hexagoxel
/
brittany
1
0
Fork 0
Code Issues 117 Pull Requests 5 Packages Projects Releases 5 Wiki Activity

Format Brittany with Brittany

pull/357/head
Taylor Fausak 2021-11-06 22:29:34 +00:00 committed by GitHub
parent ac81c5ce90
commit 4398b5880d
33 changed files with 4688 additions and 4799 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
brittany.yaml Normal file
View File

@ -0,0 +1,5 @@
conf_layout:
lconfig_cols: 79
lconfig_columnAlignMode:
tag: ColumnAlignModeDisabled
lconfig_indentPolicy: IndentPolicyLeft

10
source/library/Language/Haskell/Brittany.hs
View File

@ -16,13 +16,9 @@ module Language.Haskell.Brittany
, CForwardOptions(..) , CForwardOptions(..)
, CPreProcessorConfig(..) , CPreProcessorConfig(..)
, BrittanyError(..) , BrittanyError(..)
) ) where
where
import Language.Haskell.Brittany.Internal import Language.Haskell.Brittany.Internal
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Config import Language.Haskell.Brittany.Internal.Config
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types

205
source/library/Language/Haskell/Brittany/Internal.hs
View File

@ -12,68 +12,52 @@ module Language.Haskell.Brittany.Internal
, parseModuleFromString , parseModuleFromString
, extractCommentConfigs , extractCommentConfigs
, getTopLevelDeclNameMap , getTopLevelDeclNameMap
) ) where
where
import Control.Monad.Trans.Except
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import qualified Data.ByteString.Char8 import qualified Data.ByteString.Char8
import Data.CZipWith
import Data.Char (isSpace)
import Data.HList.HList
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Maybe import qualified Data.Maybe
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Lazy as TextL import qualified Data.Text.Lazy as TextL
import qualified GHC.OldList as List
-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 }
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers
import Control.Monad.Trans.Except
import Data.HList.HList
import qualified Data.Yaml
import Data.CZipWith
import qualified UI.Butcher.Monadic as Butcher
import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Data.Yaml
import Language.Haskell.Brittany.Internal.Types import qualified GHC hiding (parseModule)
import Language.Haskell.Brittany.Internal.Config.Types import GHC (GenLocated(L))
import Language.Haskell.Brittany.Internal.Config
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.Decl
import Language.Haskell.Brittany.Internal.Layouters.Module
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Backend
import Language.Haskell.Brittany.Internal.BackendUtils
import Language.Haskell.Brittany.Internal.ExactPrintUtils
import Language.Haskell.Brittany.Internal.Transformations.Alt
import Language.Haskell.Brittany.Internal.Transformations.Floating
import Language.Haskell.Brittany.Internal.Transformations.Par
import Language.Haskell.Brittany.Internal.Transformations.Columns
import Language.Haskell.Brittany.Internal.Transformations.Indent
import qualified GHC
hiding ( parseModule )
import GHC.Parser.Annotation ( AnnKeywordId(..) )
import GHC ( GenLocated(L)
)
import GHC.Types.SrcLoc ( SrcSpan )
import GHC.Hs
import GHC.Data.Bag import GHC.Data.Bag
import qualified GHC.Driver.Session as GHC import qualified GHC.Driver.Session as GHC
import GHC.Hs
import qualified GHC.LanguageExtensions.Type as GHC import qualified GHC.LanguageExtensions.Type as GHC
import qualified GHC.OldList as List
import Data.Char ( isSpace ) import GHC.Parser.Annotation (AnnKeywordId(..))
import GHC.Types.SrcLoc (SrcSpan)
import Language.Haskell.Brittany.Internal.Backend
import Language.Haskell.Brittany.Internal.BackendUtils
import Language.Haskell.Brittany.Internal.Config
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.ExactPrintUtils
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.Decl
import Language.Haskell.Brittany.Internal.Layouters.Module
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Transformations.Alt
import Language.Haskell.Brittany.Internal.Transformations.Columns
import Language.Haskell.Brittany.Internal.Transformations.Floating
import Language.Haskell.Brittany.Internal.Transformations.Indent
import Language.Haskell.Brittany.Internal.Transformations.Par
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified UI.Butcher.Monadic as Butcher
data InlineConfigTarget data InlineConfigTarget
= InlineConfigTargetModule = InlineConfigTargetModule
@ -102,7 +86,8 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
) )
| (k, ann) <- Map.toList anns | (k, ann) <- Map.toList anns
] ]
let configLiness = commentLiness <&> second let
configLiness = commentLiness <&> second
(Data.Maybe.mapMaybe $ \line -> do (Data.Maybe.mapMaybe $ \line -> do
l1 <- l1 <-
List.stripPrefix "-- BRITTANY" line List.stripPrefix "-- BRITTANY" line
@ -138,19 +123,22 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
] ]
parser = do -- we will (mis?)use butcher here to parse the inline config parser = do -- we will (mis?)use butcher here to parse the inline config
-- line. -- line.
let nextDecl = do let
nextDecl = do
conf <- configParser conf <- configParser
Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf) Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf)
Butcher.addCmd "-next-declaration" nextDecl Butcher.addCmd "-next-declaration" nextDecl
Butcher.addCmd "-Next-Declaration" nextDecl Butcher.addCmd "-Next-Declaration" nextDecl
Butcher.addCmd "-NEXT-DECLARATION" nextDecl Butcher.addCmd "-NEXT-DECLARATION" nextDecl
let nextBinding = do let
nextBinding = do
conf <- configParser conf <- configParser
Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf) Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf)
Butcher.addCmd "-next-binding" nextBinding Butcher.addCmd "-next-binding" nextBinding
Butcher.addCmd "-Next-Binding" nextBinding Butcher.addCmd "-Next-Binding" nextBinding
Butcher.addCmd "-NEXT-BINDING" nextBinding Butcher.addCmd "-NEXT-BINDING" nextBinding
let disableNextBinding = do let
disableNextBinding = do
Butcher.addCmdImpl Butcher.addCmdImpl
( InlineConfigTargetNextBinding ( InlineConfigTargetNextBinding
, mempty { _conf_roundtrip_exactprint_only = pure $ pure True } , mempty { _conf_roundtrip_exactprint_only = pure $ pure True }
@ -158,7 +146,8 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
Butcher.addCmd "-disable-next-binding" disableNextBinding Butcher.addCmd "-disable-next-binding" disableNextBinding
Butcher.addCmd "-Disable-Next-Binding" disableNextBinding Butcher.addCmd "-Disable-Next-Binding" disableNextBinding
Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding
let disableNextDecl = do let
disableNextDecl = do
Butcher.addCmdImpl Butcher.addCmdImpl
( InlineConfigTargetNextDecl ( InlineConfigTargetNextDecl
, mempty { _conf_roundtrip_exactprint_only = pure $ pure True } , mempty { _conf_roundtrip_exactprint_only = pure $ pure True }
@ -166,7 +155,8 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
Butcher.addCmd "-disable-next-declaration" disableNextDecl Butcher.addCmd "-disable-next-declaration" disableNextDecl
Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl
Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl
let disableFormatting = do let
disableFormatting = do
Butcher.addCmdImpl Butcher.addCmdImpl
( InlineConfigTargetModule ( InlineConfigTargetModule
, mempty { _conf_disable_formatting = pure $ pure True } , mempty { _conf_disable_formatting = pure $ pure True }
@ -188,7 +178,8 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
Right c -> Right $ c Right c -> Right $ c
pure (k, r) pure (k, r)
let perModule = foldl' let
perModule = foldl'
(<>) (<>)
mempty mempty
[ conf [ conf
@ -203,8 +194,8 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
, (target, conf) <- lineConfigs , (target, conf) <- lineConfigs
, n <- case target of , n <- case target of
InlineConfigTargetBinding s -> [s] InlineConfigTargetBinding s -> [s]
InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap -> InlineConfigTargetNextBinding
[name] | Just name <- Map.lookup k declNameMap -> [name]
_ -> [] _ -> []
] ]
let let
@ -248,20 +239,24 @@ getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) =
-- won't do. -- won't do.
parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text) parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text)
parsePrintModule configWithDebugs inputText = runExceptT $ do parsePrintModule configWithDebugs inputText = runExceptT $ do
let config = let
config =
configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig }
let ghcOptions = config & _conf_forward & _options_ghc & runIdentity let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
let config_pp = config & _conf_preprocessor let config_pp = config & _conf_preprocessor
let cppMode = config_pp & _ppconf_CPPMode & confUnpack let cppMode = config_pp & _ppconf_CPPMode & confUnpack
let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack
(anns, parsedSource, hasCPP) <- do (anns, parsedSource, hasCPP) <- do
let hackF s = if "#include" `isPrefixOf` s let
hackF s = if "#include" `isPrefixOf` s
then "-- BRITANY_INCLUDE_HACK " ++ s then "-- BRITANY_INCLUDE_HACK " ++ s
else s else s
let hackTransform = if hackAroundIncludes let
hackTransform = if hackAroundIncludes
then List.intercalate "\n" . fmap hackF . lines' then List.intercalate "\n" . fmap hackF . lines'
else id else id
let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags let
cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
then case cppMode of then case cppMode of
CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting."
CPPModeWarn -> return $ Right True CPPModeWarn -> return $ Right True
@ -285,7 +280,8 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do
return inputText return inputText
else do else do
(errsWarns, outputTextL) <- do (errsWarns, outputTextL) <- do
let omitCheck = let
omitCheck =
moduleConfig moduleConfig
& _conf_errorHandling & _conf_errorHandling
& _econf_omit_output_valid_check & _econf_omit_output_valid_check
@ -294,23 +290,26 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do
then return $ pPrintModule moduleConfig perItemConf anns parsedSource then return $ pPrintModule moduleConfig perItemConf anns parsedSource
else lift else lift
$ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource
let hackF s = fromMaybe s let
hackF s = fromMaybe s
$ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
pure $ if hackAroundIncludes pure $ if hackAroundIncludes
then then
( ews ( ews
, TextL.intercalate (TextL.pack "\n") $ hackF <$> TextL.splitOn , TextL.intercalate (TextL.pack "\n")
(TextL.pack "\n") $ hackF
outRaw <$> TextL.splitOn (TextL.pack "\n") outRaw
) )
else (ews, outRaw) else (ews, outRaw)
let customErrOrder ErrorInput{} = 4 let
customErrOrder ErrorInput{} = 4
customErrOrder LayoutWarning{} = 0 :: Int customErrOrder LayoutWarning{} = 0 :: Int
customErrOrder ErrorOutputCheck{} = 1 customErrOrder ErrorOutputCheck{} = 1
customErrOrder ErrorUnusedComment{} = 2 customErrOrder ErrorUnusedComment{} = 2
customErrOrder ErrorUnknownNode{} = 3 customErrOrder ErrorUnknownNode{} = 3
customErrOrder ErrorMacroConfig{} = 5 customErrOrder ErrorMacroConfig{} = 5
let hasErrors = let
hasErrors =
if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack
then not $ null errsWarns then not $ null errsWarns
else 0 < maximum (-1 : fmap customErrOrder errsWarns) else 0 < maximum (-1 : fmap customErrOrder errsWarns)
@ -331,7 +330,8 @@ pPrintModule
-> GHC.ParsedSource -> GHC.ParsedSource
-> ([BrittanyError], TextL.Text) -> ([BrittanyError], TextL.Text)
pPrintModule conf inlineConf anns parsedModule = pPrintModule conf inlineConf anns parsedModule =
let ((out, errs), debugStrings) = let
((out, errs), debugStrings) =
runIdentity runIdentity
$ MultiRWSS.runMultiRWSTNil $ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiWriterAW
@ -367,11 +367,13 @@ pPrintModuleAndCheck
pPrintModuleAndCheck conf inlineConf anns parsedModule = do pPrintModuleAndCheck conf inlineConf anns parsedModule = do
let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity
let (errs, output) = pPrintModule conf inlineConf anns parsedModule let (errs, output) = pPrintModule conf inlineConf anns parsedModule
parseResult <- parseModuleFromString ghcOptions parseResult <- parseModuleFromString
ghcOptions
"output" "output"
(\_ -> return $ Right ()) (\_ -> return $ Right ())
(TextL.unpack output) (TextL.unpack output)
let errs' = errs ++ case parseResult of let
errs' = errs ++ case parseResult of
Left{} -> [ErrorOutputCheck] Left{} -> [ErrorOutputCheck]
Right{} -> [] Right{} -> []
return (errs', output) return (errs', output)
@ -384,14 +386,18 @@ parsePrintModuleTests conf filename input = do
let inputStr = Text.unpack input let inputStr = Text.unpack input
parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr
case parseResult of case parseResult of
Left err -> return $ Left $ "parsing error: " ++ show (bagToList (show <$> err)) Left err ->
return $ Left $ "parsing error: " ++ show (bagToList (show <$> err))
Right (anns, parsedModule) -> runExceptT $ do Right (anns, parsedModule) -> runExceptT $ do
(inlineConf, perItemConf) <- (inlineConf, perItemConf) <-
case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of case
extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule)
of
Left err -> throwE $ "error in inline config: " ++ show err Left err -> throwE $ "error in inline config: " ++ show err
Right x -> pure x Right x -> pure x
let moduleConf = cZipWith fromOptionIdentity conf inlineConf let moduleConf = cZipWith fromOptionIdentity conf inlineConf
let omitCheck = let
omitCheck =
conf conf
& _conf_errorHandling & _conf_errorHandling
.> _econf_omit_output_valid_check .> _econf_omit_output_valid_check
@ -468,23 +474,26 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
let declBindingNames = getDeclBindingNames decl let declBindingNames = getDeclBindingNames decl
inlineConf <- mAsk inlineConf <- mAsk
let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf
let mBindingConfs = let
mBindingConfs =
declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf
filteredAnns <- mAsk filteredAnns <- mAsk <&> \annMap ->
<&> \annMap -> Map.union (Map.findWithDefault Map.empty annKey annMap)
Map.union (Map.findWithDefault Map.empty annKey annMap) $ $ Map.findWithDefault Map.empty declAnnKey annMap
Map.findWithDefault Map.empty declAnnKey annMap
traceIfDumpConf "bridoc annotations filtered/transformed" traceIfDumpConf
"bridoc annotations filtered/transformed"
_dconf_dump_annotations _dconf_dump_annotations
$ annsDoc filteredAnns $ annsDoc filteredAnns
config <- mAsk config <- mAsk
let config' = cZipWith fromOptionIdentity config let
config' = cZipWith fromOptionIdentity config
$ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf]))
let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack let
exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack
toLocal config' filteredAnns $ do toLocal config' filteredAnns $ do
bd <- if exactprintOnly bd <- if exactprintOnly
then briDocMToPPM $ briDocByExactNoComment decl then briDocMToPPM $ briDocByExactNoComment decl
@ -497,7 +506,8 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
else briDocMToPPM $ briDocByExactNoComment decl else briDocMToPPM $ briDocByExactNoComment decl
layoutBriDoc bd layoutBriDoc bd
let finalComments = filter let
finalComments = filter
(fst .> \case (fst .> \case
ExactPrint.AnnComment{} -> True ExactPrint.AnnComment{} -> True
_ -> False _ -> False
@ -508,10 +518,10 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
ppmMoveToExactLoc l ppmMoveToExactLoc l
mTell $ Text.Builder.fromString cmStr mTell $ Text.Builder.fromString cmStr
(ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> (ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) ->
let folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of let
ExactPrint.AnnComment cm folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of
| span <- ExactPrint.commentIdentifier cm ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm ->
-> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span
, x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span
) )
_ -> (acc + y, x) _ -> (acc + y, x)
@ -540,7 +550,8 @@ ppPreamble lmod@(L loc m@HsModule{}) = do
-- attached annotations that come after the module's where -- attached annotations that come after the module's where
-- from the module node -- from the module node
config <- mAsk config <- mAsk
let shouldReformatPreamble = let
shouldReformatPreamble =
config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack
let let
@ -564,9 +575,9 @@ ppPreamble lmod@(L loc m@HsModule{}) = do
mAnn' = mAnn { ExactPrint.annsDP = pre } mAnn' = mAnn { ExactPrint.annsDP = pre }
filteredAnns'' = filteredAnns'' =
Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns
in in (filteredAnns'', post')
(filteredAnns'', post') traceIfDumpConf
traceIfDumpConf "bridoc annotations filtered/transformed" "bridoc annotations filtered/transformed"
_dconf_dump_annotations _dconf_dump_annotations
$ annsDoc filteredAnns' $ annsDoc filteredAnns'
@ -612,7 +623,8 @@ layoutBriDoc briDoc = do
mGet >>= transformSimplifyFloating .> mSet mGet >>= transformSimplifyFloating .> mSet
mGet mGet
>>= briDocToDoc >>= briDocToDoc
.> traceIfDumpConf "bridoc post-floating" .> traceIfDumpConf
"bridoc post-floating"
_dconf_dump_bridoc_simpl_floating _dconf_dump_bridoc_simpl_floating
-- bridoc transformation: par removal -- bridoc transformation: par removal
mGet >>= transformSimplifyPar .> mSet mGet >>= transformSimplifyPar .> mSet
@ -638,7 +650,9 @@ layoutBriDoc briDoc = do
anns :: ExactPrint.Anns <- mAsk anns :: ExactPrint.Anns <- mAsk
let state = LayoutState { _lstate_baseYs = [0] let
state = LayoutState
{ _lstate_baseYs = [0]
, _lstate_curYOrAddNewline = Right 0 -- important that we dont use left , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left
-- here because moveToAnn stuff -- here because moveToAnn stuff
-- of the first node needs to do -- of the first node needs to do
@ -653,7 +667,8 @@ layoutBriDoc briDoc = do
state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
let remainingComments = let
remainingComments =
[ c [ c
| (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList
(_lstate_comments state') (_lstate_comments state')

140
source/library/Language/Haskell/Brittany/Internal/Backend.hs
View File

@ -6,10 +6,6 @@
module Language.Haskell.Brittany.Internal.Backend where module Language.Haskell.Brittany.Internal.Backend where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Control.Monad.Trans.State.Strict as StateS import qualified Control.Monad.Trans.State.Strict as StateS
import qualified Data.Either as Either import qualified Data.Either as Either
import qualified Data.Foldable as Foldable import qualified Data.Foldable as Foldable
@ -21,22 +17,18 @@ import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified GHC.OldList as List import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.BackendUtils
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.BackendUtils
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types
import qualified Data.Text.Lazy.Builder as Text.Builder
type ColIndex = Int type ColIndex = Int
data ColumnSpacing data ColumnSpacing
@ -45,8 +37,12 @@ data ColumnSpacing
type ColumnBlock a = [a] type ColumnBlock a = [a]
type ColumnBlocks a = Seq [a] type ColumnBlocks a = Seq [a]
type ColMap1 = IntMapL.IntMap {- ColIndex -} (Bool, ColumnBlocks ColumnSpacing) type ColMap1
type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int) = IntMapL.IntMap {- ColIndex -}
(Bool, ColumnBlocks ColumnSpacing)
type ColMap2
= IntMapL.IntMap {- ColIndex -}
(Float, ColumnBlock Int, ColumnBlocks Int)
-- (ratio of hasSpace, maximum, raw) -- (ratio of hasSpace, maximum, raw)
data ColInfo data ColInfo
@ -56,15 +52,18 @@ data ColInfo
instance Show ColInfo where instance Show ColInfo where
show ColInfoStart = "ColInfoStart" show ColInfoStart = "ColInfoStart"
show (ColInfoNo bd) = "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..") show (ColInfoNo bd) =
show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..")
show (ColInfo ind sig list) =
"ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list
data ColBuildState = ColBuildState data ColBuildState = ColBuildState
{ _cbs_map :: ColMap1 { _cbs_map :: ColMap1
, _cbs_index :: ColIndex , _cbs_index :: ColIndex
} }
type LayoutConstraints m = ( MonadMultiReader Config m type LayoutConstraints m
= ( MonadMultiReader Config m
, MonadMultiReader ExactPrint.Types.Anns m , MonadMultiReader ExactPrint.Types.Anns m
, MonadMultiWriter Text.Builder.Builder m , MonadMultiWriter Text.Builder.Builder m
, MonadMultiWriter (Seq String) m , MonadMultiWriter (Seq String) m
@ -90,7 +89,8 @@ layoutBriDocM = \case
BDSeparator -> do BDSeparator -> do
layoutAddSepSpace layoutAddSepSpace
BDAddBaseY indent bd -> do BDAddBaseY indent bd -> do
let indentF = case indent of let
indentF = case indent of
BrIndentNone -> id BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i BrIndentSpecial i -> layoutWithAddBaseColN i
@ -108,7 +108,8 @@ layoutBriDocM = \case
layoutBriDocM bd layoutBriDocM bd
layoutIndentLevelPop layoutIndentLevelPop
BDEnsureIndent indent bd -> do BDEnsureIndent indent bd -> do
let indentF = case indent of let
indentF = case indent of
BrIndentNone -> id BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i BrIndentSpecial i -> layoutWithAddBaseColN i
@ -117,7 +118,8 @@ layoutBriDocM = \case
layoutBriDocM bd layoutBriDocM bd
BDPar indent sameLine indented -> do BDPar indent sameLine indented -> do
layoutBriDocM sameLine layoutBriDocM sameLine
let indentF = case indent of let
indentF = case indent of
BrIndentNone -> id BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i BrIndentSpecial i -> layoutWithAddBaseColN i
@ -131,7 +133,8 @@ layoutBriDocM = \case
BDForceSingleline bd -> layoutBriDocM bd BDForceSingleline bd -> layoutBriDocM bd
BDForwardLineMode bd -> layoutBriDocM bd BDForwardLineMode bd -> layoutBriDocM bd
BDExternal annKey subKeys shouldAddComment t -> do BDExternal annKey subKeys shouldAddComment t -> do
let tlines = Text.lines $ t <> Text.pack "\n" let
tlines = Text.lines $ t <> Text.pack "\n"
tlineCount = length tlines tlineCount = length tlines
anns :: ExactPrint.Anns <- mAsk anns :: ExactPrint.Anns <- mAsk
when shouldAddComment $ do when shouldAddComment $ do
@ -154,7 +157,8 @@ layoutBriDocM = \case
BDAnnotationPrior annKey bd -> do BDAnnotationPrior annKey bd -> do
state <- mGet state <- mGet
let m = _lstate_comments state let m = _lstate_comments state
let moveToExactLocationAction = case _lstate_curYOrAddNewline state of let
moveToExactLocationAction = case _lstate_curYOrAddNewline state of
Left{} -> pure () Left{} -> pure ()
Right{} -> moveToExactAnn annKey Right{} -> moveToExactAnn annKey
mAnn <- do mAnn <- do
@ -176,7 +180,8 @@ layoutBriDocM = \case
when (comment /= "(" && comment /= ")") $ do when (comment /= "(" && comment /= ")") $ do
let commentLines = Text.lines $ Text.pack $ comment let commentLines = Text.lines $ Text.pack $ comment
case comment of case comment of
('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) ('#' : _) ->
layoutMoveToCommentPos y (-999) (length commentLines)
-- ^ evil hack for CPP -- ^ evil hack for CPP
_ -> layoutMoveToCommentPos y x (length commentLines) _ -> layoutMoveToCommentPos y x (length commentLines)
-- fixedX <- fixMoveToLineByIsNewline x -- fixedX <- fixMoveToLineByIsNewline x
@ -192,14 +197,16 @@ layoutBriDocM = \case
state <- mGet state <- mGet
let m = _lstate_comments state let m = _lstate_comments state
let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
let mToSpan = case mAnn of let
mToSpan = case mAnn of
Just anns | Maybe.isNothing keyword -> Just anns Just anns | Maybe.isNothing keyword -> Just anns
Just ((ExactPrint.Types.G kw1, _):annR) | keyword == Just kw1 -> Just Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 ->
annR Just annR
_ -> Nothing _ -> Nothing
case mToSpan of case mToSpan of
Just anns -> do Just anns -> do
let (comments, rest) = flip spanMaybe anns $ \case let
(comments, rest) = flip spanMaybe anns $ \case
(ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp)
_ -> Nothing _ -> Nothing
mSet $ state mSet $ state
@ -213,12 +220,14 @@ layoutBriDocM = \case
case mComments of case mComments of
Nothing -> pure () Nothing -> pure ()
Just comments -> do Just comments -> do
comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> comments
`forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
when (comment /= "(" && comment /= ")") $ do when (comment /= "(" && comment /= ")") $ do
let commentLines = Text.lines $ Text.pack $ comment let commentLines = Text.lines $ Text.pack $ comment
-- evil hack for CPP: -- evil hack for CPP:
case comment of case comment of
('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) ('#' : _) ->
layoutMoveToCommentPos y (-999) (length commentLines)
_ -> layoutMoveToCommentPos y x (length commentLines) _ -> layoutMoveToCommentPos y x (length commentLines)
-- fixedX <- fixMoveToLineByIsNewline x -- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline -- replicateM_ fixedX layoutWriteNewline
@ -232,18 +241,23 @@ layoutBriDocM = \case
let m = _lstate_comments state let m = _lstate_comments state
pure $ Map.lookup annKey m pure $ Map.lookup annKey m
let mComments = nonEmpty . extractAllComments =<< annMay let mComments = nonEmpty . extractAllComments =<< annMay
let semiCount = length [ () let
semiCount = length
[ ()
| Just ann <- [annMay] | Just ann <- [annMay]
, (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann
] ]
shouldAddSemicolonNewlines <- mAsk <&> shouldAddSemicolonNewlines <-
_conf_layout .> _lconfig_experimentalSemicolonNewlines .> confUnpack mAsk
<&> _conf_layout
.> _lconfig_experimentalSemicolonNewlines
.> confUnpack
mModify $ \state -> state mModify $ \state -> state
{ _lstate_comments = Map.adjust { _lstate_comments = Map.adjust
( \ann -> ann { ExactPrint.annFollowingComments = [] (\ann -> ann
{ ExactPrint.annFollowingComments = []
, ExactPrint.annPriorComments = [] , ExactPrint.annPriorComments = []
, ExactPrint.annsDP = , ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case
flip filter (ExactPrint.annsDP ann) $ \case
(ExactPrint.Types.AnnComment{}, _) -> False (ExactPrint.Types.AnnComment{}, _) -> False
_ -> True _ -> True
} }
@ -256,7 +270,8 @@ layoutBriDocM = \case
when shouldAddSemicolonNewlines $ do when shouldAddSemicolonNewlines $ do
[1 .. semiCount] `forM_` const layoutWriteNewline [1 .. semiCount] `forM_` const layoutWriteNewline
Just comments -> do Just comments -> do
comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> comments
`forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
when (comment /= "(" && comment /= ")") $ do when (comment /= "(" && comment /= ")") $ do
let commentLines = Text.lines $ Text.pack comment let commentLines = Text.lines $ Text.pack comment
case comment of case comment of
@ -276,7 +291,9 @@ layoutBriDocM = \case
state <- mGet state <- mGet
let m = _lstate_comments state let m = _lstate_comments state
let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
let relevant = [ dp let
relevant =
[ dp
| Just ann <- [mAnn] | Just ann <- [mAnn]
, (ExactPrint.Types.G kw1, dp) <- ann , (ExactPrint.Types.G kw1, dp) <- ann
, keyword == kw1 , keyword == kw1
@ -484,13 +501,15 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
where alignMax' = max 0 alignMax where alignMax' = max 0 alignMax
processedMap :: ColMap2 processedMap :: ColMap2
processedMap = processedMap = fix $ \result ->
fix $ \result -> _cbs_map finalState <&> \(lastFlag, colSpacingss) -> _cbs_map finalState <&> \(lastFlag, colSpacingss) ->
let let
colss = colSpacingss <&> \spss -> case reverse spss of colss = colSpacingss <&> \spss -> case reverse spss of
[] -> [] [] -> []
(xN : xR) -> (xN : xR) ->
reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR reverse
$ (if lastFlag then fLast else fInit) xN
: fmap fInit xR
where where
fLast (ColumnSpacingLeaf len) = len fLast (ColumnSpacingLeaf len) = len
fLast (ColumnSpacingRef len _) = len fLast (ColumnSpacingRef len _) = len
@ -507,8 +526,7 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
else count else count
ratio = fromIntegral (foldl counter (0 :: Int) colss) ratio = fromIntegral (foldl counter (0 :: Int) colss)
/ fromIntegral (length colss) / fromIntegral (length colss)
in in (ratio, maxCols, colss)
(ratio, maxCols, colss)
mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo] mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo]
mergeBriDocs bds = mergeBriDocsW ColInfoStart bds mergeBriDocs bds = mergeBriDocsW ColInfoStart bds
@ -545,8 +563,7 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
-- personal preference to not break alignment for those, even if -- personal preference to not break alignment for those, even if
-- multiline. Really, this should be configurable.. (TODO) -- multiline. Really, this should be configurable.. (TODO)
shouldBreakAfter :: BriDoc -> Bool shouldBreakAfter :: BriDoc -> Bool
shouldBreakAfter bd = alignBreak && shouldBreakAfter bd = alignBreak && briDocIsMultiLine bd && case bd of
briDocIsMultiLine bd && case bd of
(BDCols ColTyOpPrefix _) -> False (BDCols ColTyOpPrefix _) -> False
(BDCols ColPatternsFuncPrefix _) -> True (BDCols ColPatternsFuncPrefix _) -> True
(BDCols ColPatternsFuncInfix _) -> True (BDCols ColPatternsFuncInfix _) -> True
@ -578,8 +595,7 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) = mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) =
\case \case
brdc@(BDCols colSig subDocs) brdc@(BDCols colSig subDocs)
| infoSig == colSig && length subLengthsInfos == length subDocs | infoSig == colSig && length subLengthsInfos == length subDocs -> do
-> do
let let
isLastList = if lastFlag isLastList = if lastFlag
then (== length subDocs) <$> [1 ..] then (== length subDocs) <$> [1 ..]
@ -599,14 +615,14 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
m m
} }
return $ ColInfo infoInd colSig (zip curLengths infos) return $ ColInfo infoInd colSig (zip curLengths infos)
| otherwise | otherwise -> briDocToColInfo lastFlag brdc
-> briDocToColInfo lastFlag brdc
brdc -> return $ ColInfoNo brdc brdc -> return $ ColInfoNo brdc
briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo
briDocToColInfo lastFlag = \case briDocToColInfo lastFlag = \case
BDCols sig list -> withAlloc lastFlag $ \ind -> do BDCols sig list -> withAlloc lastFlag $ \ind -> do
let isLastList = let
isLastList =
if lastFlag then (== length list) <$> [1 ..] else repeat False if lastFlag then (== length list) <$> [1 ..] else repeat False
subInfos <- zip isLastList list `forM` uncurry briDocToColInfo subInfos <- zip isLastList list `forM` uncurry briDocToColInfo
let lengthInfos = zip (briDocLineLength <$> list) subInfos let lengthInfos = zip (briDocLineLength <$> list) subInfos
@ -641,7 +657,8 @@ processInfo maxSpace m = \case
ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $ ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $
do do
colMaxConf <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack colMaxConf <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack
alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack alignMode <-
mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack
curX <- do curX <- do
state <- mGet state <- mGet
-- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state))) -- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state)))
@ -654,7 +671,8 @@ processInfo maxSpace m = \case
let colMax = min colMaxConf (curX + maxSpace) let colMax = min colMaxConf (curX + maxSpace)
-- tellDebugMess $ show curX -- tellDebugMess $ show curX
let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m
let maxCols2 = list <&> \case let
maxCols2 = list <&> \case
(_, ColInfo i _ _) -> (_, ColInfo i _ _) ->
let Just (_, ms, _) = IntMapS.lookup i m in sum ms let Just (_, ms, _) = IntMapS.lookup i m in sum ms
(l, _) -> l (l, _) -> l
@ -668,7 +686,8 @@ processInfo maxSpace m = \case
-- sizes in such a way that it works _if_ we have sizes (*factor) -- sizes in such a way that it works _if_ we have sizes (*factor)
-- in each column. but in that line, in the last column, we will be -- in each column. but in that line, in the last column, we will be
-- forced to occupy the full vertical space, not reduced by any factor. -- forced to occupy the full vertical space, not reduced by any factor.
let fixedPosXs = case alignMode of let
fixedPosXs = case alignMode of
ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+ curX) ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+ curX)
where where
factor :: Float = factor :: Float =
@ -679,15 +698,16 @@ processInfo maxSpace m = \case
offsets = (subtract curX) <$> posXs offsets = (subtract curX) <$> posXs
fixed = offsets <&> fromIntegral .> (* factor) .> truncate fixed = offsets <&> fromIntegral .> (* factor) .> truncate
_ -> posXs _ -> posXs
let spacings = zipWith (-) let
(List.tail fixedPosXs ++ [min maxX colMax]) spacings =
fixedPosXs zipWith (-) (List.tail fixedPosXs ++ [min maxX colMax]) fixedPosXs
-- tellDebugMess $ "ind = " ++ show ind -- tellDebugMess $ "ind = " ++ show ind
-- tellDebugMess $ "maxCols = " ++ show maxCols -- tellDebugMess $ "maxCols = " ++ show maxCols
-- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs -- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs
-- tellDebugMess $ "list = " ++ show list -- tellDebugMess $ "list = " ++ show list
-- tellDebugMess $ "maxSpace = " ++ show maxSpace -- tellDebugMess $ "maxSpace = " ++ show maxSpace
let alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do let
alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do
layoutWriteEnsureAbsoluteN destX layoutWriteEnsureAbsoluteN destX
processInfo s m (snd x) processInfo s m (snd x)
noAlignAct = list `forM_` (snd .> processInfoIgnore) noAlignAct = list `forM_` (snd .> processInfoIgnore)

196
source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs
View File

@ -3,42 +3,29 @@
module Language.Haskell.Brittany.Internal.BackendUtils where module Language.Haskell.Brittany.Internal.BackendUtils where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Data import qualified Data.Data
import qualified Data.Either import qualified Data.Either
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Maybe import qualified Data.Maybe
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.GHC.ExactPrint.Types ( AnnKey
, Annotation
)
import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import Language.Haskell.Brittany.Internal.Utils
import GHC (Located) import GHC (Located)
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
traceLocal :: (MonadMultiState LayoutState m) => a -> m ()
traceLocal
:: (MonadMultiState LayoutState m)
=> a
-> m ()
traceLocal _ = return () traceLocal _ = return ()
layoutWriteAppend layoutWriteAppend
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> Text => Text
-> m () -> m ()
layoutWriteAppend t = do layoutWriteAppend t = do
@ -60,9 +47,7 @@ layoutWriteAppend t = do
} }
layoutWriteAppendSpaces layoutWriteAppendSpaces
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> Int => Int
-> m () -> m ()
layoutWriteAppendSpaces i = do layoutWriteAppendSpaces i = do
@ -74,9 +59,7 @@ layoutWriteAppendSpaces i = do
} }
layoutWriteAppendMultiline layoutWriteAppendMultiline
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> [Text] => [Text]
-> m () -> m ()
layoutWriteAppendMultiline ts = do layoutWriteAppendMultiline ts = do
@ -91,14 +74,13 @@ layoutWriteAppendMultiline ts = do
-- adds a newline and adds spaces to reach the base column. -- adds a newline and adds spaces to reach the base column.
layoutWriteNewlineBlock layoutWriteNewlineBlock
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> m () => m ()
layoutWriteNewlineBlock = do layoutWriteNewlineBlock = do
traceLocal ("layoutWriteNewlineBlock") traceLocal ("layoutWriteNewlineBlock")
state <- mGet state <- mGet
mSet $ state { _lstate_curYOrAddNewline = Right 1 mSet $ state
{ _lstate_curYOrAddNewline = Right 1
, _lstate_addSepSpace = Just $ lstate_baseY state , _lstate_addSepSpace = Just $ lstate_baseY state
} }
@ -116,11 +98,11 @@ layoutWriteNewlineBlock = do
-- else _lstate_indLevelLinger state + i - _lstate_curY state -- else _lstate_indLevelLinger state + i - _lstate_curY state
-- } -- }
layoutSetCommentCol layoutSetCommentCol :: (MonadMultiState LayoutState m) => m ()
:: (MonadMultiState LayoutState m) => m ()
layoutSetCommentCol = do layoutSetCommentCol = do
state <- mGet state <- mGet
let col = case _lstate_curYOrAddNewline state of let
col = case _lstate_curYOrAddNewline state of
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Right{} -> lstate_baseY state Right{} -> lstate_baseY state
traceLocal ("layoutSetCommentCol", col) traceLocal ("layoutSetCommentCol", col)
@ -130,9 +112,7 @@ layoutSetCommentCol = do
-- This is also used to move to non-comments in a couple of places. Seems -- This is also used to move to non-comments in a couple of places. Seems
-- to be harmless so far.. -- to be harmless so far..
layoutMoveToCommentPos layoutMoveToCommentPos
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> Int => Int
-> Int -> Int
-> Int -> Int
@ -150,8 +130,7 @@ layoutMoveToCommentPos y x commentLines = do
Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x
Right{} -> _lstate_indLevelLinger state + x Right{} -> _lstate_indLevelLinger state + x
else if y == 0 then x else _lstate_indLevelLinger state + x else if y == 0 then x else _lstate_indLevelLinger state + x
, _lstate_commentCol = , _lstate_commentCol = Just $ case _lstate_commentCol state of
Just $ case _lstate_commentCol state of
Just existing -> existing Just existing -> existing
Nothing -> case _lstate_curYOrAddNewline state of Nothing -> case _lstate_curYOrAddNewline state of
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
@ -162,9 +141,7 @@ layoutMoveToCommentPos y x commentLines = do
-- | does _not_ add spaces to again reach the current base column. -- | does _not_ add spaces to again reach the current base column.
layoutWriteNewline layoutWriteNewline
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> m () => m ()
layoutWriteNewline = do layoutWriteNewline = do
traceLocal ("layoutWriteNewline") traceLocal ("layoutWriteNewline")
@ -181,9 +158,7 @@ _layoutResetCommentNewlines = do
mModify $ \state -> state { _lstate_commentNewlines = 0 } mModify $ \state -> state { _lstate_commentNewlines = 0 }
layoutWriteEnsureNewlineBlock layoutWriteEnsureNewlineBlock
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> m () => m ()
layoutWriteEnsureNewlineBlock = do layoutWriteEnsureNewlineBlock = do
traceLocal ("layoutWriteEnsureNewlineBlock") traceLocal ("layoutWriteEnsureNewlineBlock")
@ -197,61 +172,53 @@ layoutWriteEnsureNewlineBlock = do
} }
layoutWriteEnsureAbsoluteN layoutWriteEnsureAbsoluteN
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> Int => Int
-> m () -> m ()
layoutWriteEnsureAbsoluteN n = do layoutWriteEnsureAbsoluteN n = do
state <- mGet state <- mGet
let diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of let
diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of
(Just c, _) -> n - c (Just c, _) -> n - c
(Nothing, Left i) -> n - i (Nothing, Left i) -> n - i
(Nothing, Right{}) -> n (Nothing, Right{}) -> n
traceLocal ("layoutWriteEnsureAbsoluteN", n, diff) traceLocal ("layoutWriteEnsureAbsoluteN", n, diff)
when (diff > 0) $ do when (diff > 0) $ do
mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to mSet $ state { _lstate_addSepSpace = Just diff } -- this always sets to
-- at least (Just 1), so we won't -- at least (Just 1), so we won't
-- overwrite any old value in any -- overwrite any old value in any
-- bad way. -- bad way.
}
layoutBaseYPushInternal layoutBaseYPushInternal :: (MonadMultiState LayoutState m) => Int -> m ()
:: (MonadMultiState LayoutState m)
=> Int
-> m ()
layoutBaseYPushInternal i = do layoutBaseYPushInternal i = do
traceLocal ("layoutBaseYPushInternal", i) traceLocal ("layoutBaseYPushInternal", i)
mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s } mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s }
layoutBaseYPopInternal layoutBaseYPopInternal :: (MonadMultiState LayoutState m) => m ()
:: (MonadMultiState LayoutState m) => m ()
layoutBaseYPopInternal = do layoutBaseYPopInternal = do
traceLocal ("layoutBaseYPopInternal") traceLocal ("layoutBaseYPopInternal")
mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s } mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s }
layoutIndentLevelPushInternal layoutIndentLevelPushInternal
:: (MonadMultiState LayoutState m) :: (MonadMultiState LayoutState m) => Int -> m ()
=> Int
-> m ()
layoutIndentLevelPushInternal i = do layoutIndentLevelPushInternal i = do
traceLocal ("layoutIndentLevelPushInternal", i) traceLocal ("layoutIndentLevelPushInternal", i)
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s mModify $ \s -> s
{ _lstate_indLevelLinger = lstate_indLevel s
, _lstate_indLevels = i : _lstate_indLevels s , _lstate_indLevels = i : _lstate_indLevels s
} }
layoutIndentLevelPopInternal layoutIndentLevelPopInternal :: (MonadMultiState LayoutState m) => m ()
:: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPopInternal = do layoutIndentLevelPopInternal = do
traceLocal ("layoutIndentLevelPopInternal") traceLocal ("layoutIndentLevelPopInternal")
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s mModify $ \s -> s
{ _lstate_indLevelLinger = lstate_indLevel s
, _lstate_indLevels = List.tail $ _lstate_indLevels s , _lstate_indLevels = List.tail $ _lstate_indLevels s
} }
layoutRemoveIndentLevelLinger :: (MonadMultiState LayoutState m) => m () layoutRemoveIndentLevelLinger :: (MonadMultiState LayoutState m) => m ()
layoutRemoveIndentLevelLinger = do layoutRemoveIndentLevelLinger = do
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s }
}
layoutWithAddBaseCol layoutWithAddBaseCol
:: ( MonadMultiWriter Text.Builder.Builder m :: ( MonadMultiWriter Text.Builder.Builder m
@ -283,9 +250,7 @@ layoutWithAddBaseColBlock m = do
layoutBaseYPopInternal layoutBaseYPopInternal
layoutWithAddBaseColNBlock layoutWithAddBaseColNBlock
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> Int => Int
-> m () -> m ()
-> m () -> m ()
@ -298,9 +263,7 @@ layoutWithAddBaseColNBlock amount m = do
layoutBaseYPopInternal layoutBaseYPopInternal
layoutWriteEnsureBlock layoutWriteEnsureBlock
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> m () => m ()
layoutWriteEnsureBlock = do layoutWriteEnsureBlock = do
traceLocal ("layoutWriteEnsureBlock") traceLocal ("layoutWriteEnsureBlock")
@ -316,9 +279,7 @@ layoutWriteEnsureBlock = do
mSet $ state { _lstate_addSepSpace = Just $ diff } mSet $ state { _lstate_addSepSpace = Just $ diff }
layoutWithAddBaseColN layoutWithAddBaseColN
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> Int => Int
-> m () -> m ()
-> m () -> m ()
@ -328,8 +289,7 @@ layoutWithAddBaseColN amount m = do
m m
layoutBaseYPopInternal layoutBaseYPopInternal
layoutBaseYPushCur layoutBaseYPushCur :: (MonadMultiState LayoutState m) => m ()
:: (MonadMultiState LayoutState m) => m ()
layoutBaseYPushCur = do layoutBaseYPushCur = do
traceLocal ("layoutBaseYPushCur") traceLocal ("layoutBaseYPushCur")
state <- mGet state <- mGet
@ -341,26 +301,24 @@ layoutBaseYPushCur = do
(Right{}, _) -> layoutBaseYPushInternal $ lstate_baseY state (Right{}, _) -> layoutBaseYPushInternal $ lstate_baseY state
Just cCol -> layoutBaseYPushInternal cCol Just cCol -> layoutBaseYPushInternal cCol
layoutBaseYPop layoutBaseYPop :: (MonadMultiState LayoutState m) => m ()
:: (MonadMultiState LayoutState m) => m ()
layoutBaseYPop = do layoutBaseYPop = do
traceLocal ("layoutBaseYPop") traceLocal ("layoutBaseYPop")
layoutBaseYPopInternal layoutBaseYPopInternal
layoutIndentLevelPushCur layoutIndentLevelPushCur :: (MonadMultiState LayoutState m) => m ()
:: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPushCur = do layoutIndentLevelPushCur = do
traceLocal ("layoutIndentLevelPushCur") traceLocal ("layoutIndentLevelPushCur")
state <- mGet state <- mGet
let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of let
y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i, Just j) -> i + j (Left i, Just j) -> i + j
(Left i, Nothing) -> i (Left i, Nothing) -> i
(Right{}, Just j) -> j (Right{}, Just j) -> j
(Right{}, Nothing) -> 0 (Right{}, Nothing) -> 0
layoutIndentLevelPushInternal y layoutIndentLevelPushInternal y
layoutIndentLevelPop layoutIndentLevelPop :: (MonadMultiState LayoutState m) => m ()
:: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPop = do layoutIndentLevelPop = do
traceLocal ("layoutIndentLevelPop") traceLocal ("layoutIndentLevelPop")
layoutIndentLevelPopInternal layoutIndentLevelPopInternal
@ -370,12 +328,12 @@ layoutIndentLevelPop = do
-- make sense. -- make sense.
layoutRemoveIndentLevelLinger layoutRemoveIndentLevelLinger
layoutAddSepSpace :: (MonadMultiState LayoutState m) layoutAddSepSpace :: (MonadMultiState LayoutState m) => m ()
=> m ()
layoutAddSepSpace = do layoutAddSepSpace = do
state <- mGet state <- mGet
mSet $ state mSet $ state
{ _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state } { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state
}
-- TODO: when refactoring is complete, the other version of this method -- TODO: when refactoring is complete, the other version of this method
-- can probably be removed. -- can probably be removed.
@ -399,16 +357,16 @@ moveToExactAnn annKey = do
moveToY :: MonadMultiState LayoutState m => Int -> m () moveToY :: MonadMultiState LayoutState m => Int -> m ()
moveToY y = mModify $ \state -> moveToY y = mModify $ \state ->
let upd = case _lstate_curYOrAddNewline state of let
upd = case _lstate_curYOrAddNewline state of
Left i -> if y == 0 then Left i else Right y Left i -> if y == 0 then Left i else Right y
Right i -> Right $ max y i Right i -> Right $ max y i
in state in
state
{ _lstate_curYOrAddNewline = upd { _lstate_curYOrAddNewline = upd
, _lstate_addSepSpace = if Data.Either.isRight upd , _lstate_addSepSpace = if Data.Either.isRight upd
then then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just
_lstate_commentCol state (lstate_baseY state)
<|> _lstate_addSepSpace state
<|> Just (lstate_baseY state)
else Nothing else Nothing
, _lstate_commentCol = Nothing , _lstate_commentCol = Nothing
} }
@ -421,9 +379,7 @@ moveToY y = mModify $ \state ->
-- else x -- else x
ppmMoveToExactLoc ppmMoveToExactLoc
:: MonadMultiWriter Text.Builder.Builder m :: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m ()
=> ExactPrint.DeltaPos
-> m ()
ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do
replicateM_ x $ mTell $ Text.Builder.fromString "\n" replicateM_ x $ mTell $ Text.Builder.fromString "\n"
replicateM_ y $ mTell $ Text.Builder.fromString " " replicateM_ y $ mTell $ Text.Builder.fromString " "
@ -443,17 +399,18 @@ layoutWritePriorComments ast = do
let anns = _lstate_comments state let anns = _lstate_comments state
let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns
mSet $ state mSet $ state
{ _lstate_comments = { _lstate_comments = Map.adjust
Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) key anns (\ann -> ann { ExactPrint.annPriorComments = [] })
key
anns
} }
return mAnn return mAnn
case mAnn of case mAnn of
Nothing -> return () Nothing -> return ()
Just priors -> do Just priors -> do
unless (null priors) $ layoutSetCommentCol unless (null priors) $ layoutSetCommentCol
priors `forM_` \( ExactPrint.Comment comment _ _ priors
, ExactPrint.DP (x, y) `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> do
) -> do
replicateM_ x layoutWriteNewline replicateM_ x layoutWriteNewline
layoutWriteAppendSpaces y layoutWriteAppendSpaces y
layoutWriteAppendMultiline $ Text.lines $ Text.pack comment layoutWriteAppendMultiline $ Text.lines $ Text.pack comment
@ -462,10 +419,13 @@ layoutWritePriorComments ast = do
-- this currently only extracs from the `annsDP` field of Annotations. -- this currently only extracs from the `annsDP` field of Annotations.
-- per documentation, this seems sufficient, as the -- per documentation, this seems sufficient, as the
-- "..`annFollowingComments` are only added by AST transformations ..". -- "..`annFollowingComments` are only added by AST transformations ..".
layoutWritePostComments :: (Data.Data.Data ast, layoutWritePostComments
MonadMultiWriter Text.Builder.Builder m, :: ( Data.Data.Data ast
MonadMultiState LayoutState m) , MonadMultiWriter Text.Builder.Builder m
=> Located ast -> m () , MonadMultiState LayoutState m
)
=> Located ast
-> m ()
layoutWritePostComments ast = do layoutWritePostComments ast = do
mAnn <- do mAnn <- do
state <- mGet state <- mGet
@ -473,8 +433,8 @@ layoutWritePostComments ast = do
let anns = _lstate_comments state let anns = _lstate_comments state
let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns
mSet $ state mSet $ state
{ _lstate_comments = { _lstate_comments = Map.adjust
Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = [] }) (\ann -> ann { ExactPrint.annFollowingComments = [] })
key key
anns anns
} }
@ -483,30 +443,28 @@ layoutWritePostComments ast = do
Nothing -> return () Nothing -> return ()
Just posts -> do Just posts -> do
unless (null posts) $ layoutSetCommentCol unless (null posts) $ layoutSetCommentCol
posts `forM_` \( ExactPrint.Comment comment _ _ posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
, ExactPrint.DP (x, y) do
) -> do
replicateM_ x layoutWriteNewline replicateM_ x layoutWriteNewline
layoutWriteAppend $ Text.pack $ replicate y ' ' layoutWriteAppend $ Text.pack $ replicate y ' '
mModify $ \s -> s { _lstate_addSepSpace = Nothing } mModify $ \s -> s { _lstate_addSepSpace = Nothing }
layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment
layoutIndentRestorePostComment layoutIndentRestorePostComment
:: ( MonadMultiState LayoutState m :: (MonadMultiState LayoutState m, MonadMultiWriter Text.Builder.Builder m)
, MonadMultiWriter Text.Builder.Builder m
)
=> m () => m ()
layoutIndentRestorePostComment = do layoutIndentRestorePostComment = do
state <- mGet state <- mGet
let mCommentCol = _lstate_commentCol state let mCommentCol = _lstate_commentCol state
let eCurYAddNL = _lstate_curYOrAddNewline state let eCurYAddNL = _lstate_curYOrAddNewline state
mModify $ \s -> s { _lstate_commentCol = Nothing mModify
, _lstate_commentNewlines = 0 $ \s -> s { _lstate_commentCol = Nothing, _lstate_commentNewlines = 0 }
}
case (mCommentCol, eCurYAddNL) of case (mCommentCol, eCurYAddNL) of
(Just commentCol, Left{}) -> do (Just commentCol, Left{}) -> do
layoutWriteEnsureNewlineBlock layoutWriteEnsureNewlineBlock
layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe 0 (_lstate_addSepSpace state) layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe
0
(_lstate_addSepSpace state)
_ -> return () _ -> return ()
-- layoutWritePriorCommentsRestore :: (Data.Data.Data ast, -- layoutWritePriorCommentsRestore :: (Data.Data.Data ast,

43
source/library/Language/Haskell/Brittany/Internal/Config.hs
View File

@ -3,38 +3,27 @@
module Language.Haskell.Brittany.Internal.Config where module Language.Haskell.Brittany.Internal.Config where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Bool as Bool import qualified Data.Bool as Bool
import qualified Data.ByteString as ByteString import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Char8 import qualified Data.ByteString.Char8
import qualified Data.Semigroup as Semigroup
import qualified GHC.OldList as List
import qualified System.Directory
import qualified System.IO
import qualified Data.Yaml
import Data.CZipWith import Data.CZipWith
import Data.Coerce (coerce)
import UI.Butcher.Monadic import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Semigroup as Semigroup
import qualified System.Console.CmdArgs.Explicit import qualified Data.Yaml
as CmdArgs import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Config.Types.Instances () import Language.Haskell.Brittany.Internal.Config.Types.Instances ()
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Utils
import qualified System.Console.CmdArgs.Explicit as CmdArgs
import Data.Coerce ( coerce import qualified System.Directory
)
import qualified Data.List.NonEmpty as NonEmpty
import qualified System.Directory as Directory import qualified System.Directory as Directory
import qualified System.FilePath.Posix as FilePath import qualified System.FilePath.Posix as FilePath
import qualified System.IO
import UI.Butcher.Monadic
-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft }
staticDefaultConfig :: Config staticDefaultConfig :: Config
staticDefaultConfig = Config staticDefaultConfig = Config
{ _conf_version = coerce (1 :: Int) { _conf_version = coerce (1 :: Int)
@ -105,7 +94,7 @@ forwardOptionsSyntaxExtsEnabled = ForwardOptions
] ]
} }
-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 200 } -- brittany-next-binding --columns 200
cmdlineConfigParser :: CmdParser Identity out (CConfig Maybe) cmdlineConfigParser :: CmdParser Identity out (CConfig Maybe)
cmdlineConfigParser = do cmdlineConfigParser = do
-- TODO: why does the default not trigger; ind never should be []!! -- TODO: why does the default not trigger; ind never should be []!!
@ -245,7 +234,8 @@ userConfigPath = do
userBritPathSimple <- Directory.getAppUserDataDirectory "brittany" userBritPathSimple <- Directory.getAppUserDataDirectory "brittany"
userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany"
let searchDirs = [userBritPathSimple, userBritPathXdg] let searchDirs = [userBritPathSimple, userBritPathXdg]
globalConfig <- Directory.findFileWith Directory.doesFileExist globalConfig <- Directory.findFileWith
Directory.doesFileExist
searchDirs searchDirs
"config.yaml" "config.yaml"
maybe (writeUserConfig userBritPathXdg) pure globalConfig maybe (writeUserConfig userBritPathXdg) pure globalConfig
@ -271,8 +261,9 @@ readConfigs
-> MaybeT IO Config -> MaybeT IO Config
readConfigs cmdlineConfig configPaths = do readConfigs cmdlineConfig configPaths = do
configs <- readConfig `mapM` configPaths configs <- readConfig `mapM` configPaths
let merged = Semigroup.sconcat let
$ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) merged =
Semigroup.sconcat $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs)
return $ cZipWith fromOptionIdentity staticDefaultConfig merged return $ cZipWith fromOptionIdentity staticDefaultConfig merged
-- | Reads provided configs -- | Reads provided configs

36
source/library/Language/Haskell/Brittany/Internal/Config/Types.hs
View File

@ -7,24 +7,15 @@
module Language.Haskell.Brittany.Internal.Config.Types where module Language.Haskell.Brittany.Internal.Config.Types where
import Data.CZipWith
import Data.Coerce (Coercible, coerce)
import Data.Data (Data)
import qualified Data.Semigroup as Semigroup
import Data.Semigroup (Last)
import Data.Semigroup.Generic
import GHC.Generics
import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils () import Language.Haskell.Brittany.Internal.PreludeUtils ()
import qualified Data.Semigroup as Semigroup
import GHC.Generics
import Data.Data ( Data )
import Data.Coerce ( Coercible, coerce )
import Data.Semigroup.Generic
import Data.Semigroup ( Last )
import Data.CZipWith
confUnpack :: Coercible a b => Identity a -> b confUnpack :: Coercible a b => Identity a -> b
confUnpack (Identity x) = coerce x confUnpack (Identity x) = coerce x
@ -43,7 +34,7 @@ data CDebugConfig f = DebugConfig
, _dconf_dump_bridoc_final :: f (Semigroup.Last Bool) , _dconf_dump_bridoc_final :: f (Semigroup.Last Bool)
, _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) , _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool)
} }
deriving (Generic) deriving Generic
data CLayoutConfig f = LayoutConfig data CLayoutConfig f = LayoutConfig
{ _lconfig_cols :: f (Last Int) -- the thing that has default 80. { _lconfig_cols :: f (Last Int) -- the thing that has default 80.
@ -148,12 +139,12 @@ data CLayoutConfig f = LayoutConfig
-- -- > , y :: Double -- -- > , y :: Double
-- -- > } -- -- > }
} }
deriving (Generic) deriving Generic
data CForwardOptions f = ForwardOptions data CForwardOptions f = ForwardOptions
{ _options_ghc :: f [String] { _options_ghc :: f [String]
} }
deriving (Generic) deriving Generic
data CErrorHandlingConfig f = ErrorHandlingConfig data CErrorHandlingConfig f = ErrorHandlingConfig
{ _econf_produceOutputOnErrors :: f (Semigroup.Last Bool) { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool)
@ -168,13 +159,13 @@ data CErrorHandlingConfig f = ErrorHandlingConfig
-- has different semantics than the code pre-transformation. -- has different semantics than the code pre-transformation.
, _econf_omit_output_valid_check :: f (Semigroup.Last Bool) , _econf_omit_output_valid_check :: f (Semigroup.Last Bool)
} }
deriving (Generic) deriving Generic
data CPreProcessorConfig f = PreProcessorConfig data CPreProcessorConfig f = PreProcessorConfig
{ _ppconf_CPPMode :: f (Semigroup.Last CPPMode) { _ppconf_CPPMode :: f (Semigroup.Last CPPMode)
, _ppconf_hackAroundIncludes :: f (Semigroup.Last Bool) , _ppconf_hackAroundIncludes :: f (Semigroup.Last Bool)
} }
deriving (Generic) deriving Generic
data CConfig f = Config data CConfig f = Config
{ _conf_version :: f (Semigroup.Last Int) { _conf_version :: f (Semigroup.Last Int)
@ -194,9 +185,8 @@ data CConfig f = Config
-- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something -- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something
-- in that direction). -- in that direction).
, _conf_obfuscate :: f (Semigroup.Last Bool) , _conf_obfuscate :: f (Semigroup.Last Bool)
} }
deriving (Generic) deriving Generic
type DebugConfig = CDebugConfig Identity type DebugConfig = CDebugConfig Identity
type LayoutConfig = CLayoutConfig Identity type LayoutConfig = CLayoutConfig Identity

31
source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs
View File

@ -18,17 +18,11 @@
module Language.Haskell.Brittany.Internal.Config.Types.Instances where module Language.Haskell.Brittany.Internal.Config.Types.Instances where
import Language.Haskell.Brittany.Internal.Prelude
import Data.Yaml
import qualified Data.Aeson.Key as Key import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.Types as Aeson import qualified Data.Aeson.Types as Aeson
import Data.Yaml
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
aesonDecodeOptionsBrittany :: Aeson.Options aesonDecodeOptionsBrittany :: Aeson.Options
aesonDecodeOptionsBrittany = Aeson.defaultOptions aesonDecodeOptionsBrittany = Aeson.defaultOptions
@ -108,16 +102,17 @@ instance ToJSON (CConfig Maybe) where
-- leafs, but for nodes of the config as well. This way e.g. "{}" is valid -- leafs, but for nodes of the config as well. This way e.g. "{}" is valid
-- config file content. -- config file content.
instance FromJSON (CConfig Maybe) where instance FromJSON (CConfig Maybe) where
parseJSON (Object v) = Config parseJSON (Object v) =
<$> v .:? Key.fromString "conf_version" Config
<*> v .:?= Key.fromString "conf_debug" <$> (v .:? Key.fromString "conf_version")
<*> v .:?= Key.fromString "conf_layout" <*> (v .:?= Key.fromString "conf_debug")
<*> v .:?= Key.fromString "conf_errorHandling" <*> (v .:?= Key.fromString "conf_layout")
<*> v .:?= Key.fromString "conf_forward" <*> (v .:?= Key.fromString "conf_errorHandling")
<*> v .:?= Key.fromString "conf_preprocessor" <*> (v .:?= Key.fromString "conf_forward")
<*> v .:? Key.fromString "conf_roundtrip_exactprint_only" <*> (v .:?= Key.fromString "conf_preprocessor")
<*> v .:? Key.fromString "conf_disable_formatting" <*> (v .:? Key.fromString "conf_roundtrip_exactprint_only")
<*> v .:? Key.fromString "conf_obfuscate" <*> (v .:? Key.fromString "conf_disable_formatting")
<*> (v .:? Key.fromString "conf_obfuscate")
parseJSON invalid = Aeson.typeMismatch "Config" invalid parseJSON invalid = Aeson.typeMismatch "Config" invalid
-- Pretends that the value is {} when the key is not present. -- Pretends that the value is {} when the key is not present.

80
source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
View File

@ -7,47 +7,34 @@
module Language.Haskell.Brittany.Internal.ExactPrintUtils where module Language.Haskell.Brittany.Internal.ExactPrintUtils where
import Control.Exception
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Control.Monad.State.Class as State.Class import qualified Control.Monad.State.Class as State.Class
import qualified Control.Monad.Trans.Except as ExceptT import qualified Control.Monad.Trans.Except as ExceptT
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import Data.Data
import qualified Data.Foldable as Foldable import qualified Data.Foldable as Foldable
import qualified Data.Generics as SYB
import Data.HList.HList
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Maybe import qualified Data.Maybe
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified System.IO
import Language.Haskell.Brittany.Internal.Config.Types
import Data.Data
import Data.HList.HList
import GHC (GenLocated(L)) import GHC (GenLocated(L))
import qualified GHC.Driver.Session as GHC
import qualified GHC hiding (parseModule) import qualified GHC hiding (parseModule)
import qualified GHC.Types.SrcLoc as GHC
import qualified GHC.Driver.CmdLine as GHC
import GHC.Hs
import GHC.Data.Bag import GHC.Data.Bag
import qualified GHC.Driver.CmdLine as GHC
import GHC.Types.SrcLoc ( SrcSpan, Located ) import qualified GHC.Driver.Session as GHC
import GHC.Hs
import qualified GHC.Types.SrcLoc as GHC
import GHC.Types.SrcLoc (Located, SrcSpan)
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint
import qualified Data.Generics as SYB import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified System.IO
import Control.Exception
-- import Data.Generics.Schemes
parseModule parseModule
:: [String] :: [String]
@ -88,7 +75,10 @@ parseModuleWithCpp cpp opts args fp dynCheck =
++ show (warnings <&> warnExtractorCompat) ++ show (warnings <&> warnExtractorCompat)
x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2 x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2
res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp
either (\err -> ExceptT.throwE $ "transform error: " ++ show (bagToList (show <$> err))) either
(\err -> ExceptT.throwE $ "transform error: " ++ show
(bagToList (show <$> err))
)
(\(a, m) -> pure (a, m, x)) (\(a, m) -> pure (a, m, x))
$ ExactPrint.postParseTransform res opts $ ExactPrint.postParseTransform res opts
@ -121,19 +111,23 @@ parseModuleFromString args fp dynCheck str =
dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1 dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1
let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str
case res of case res of
Left err -> ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err)) Left err ->
ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err))
Right (a, m) -> pure (a, m, dynCheckRes) Right (a, m) -> pure (a, m, dynCheckRes)
commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform () commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform ()
commentAnnFixTransformGlob ast = do commentAnnFixTransformGlob ast = do
let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey) let
extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $
const Seq.empty const Seq.empty
`SYB.ext1Q` `SYB.ext1Q` (\l@(L span _) ->
(\l@(L span _) -> Seq.singleton (span, ExactPrint.mkAnnKey l)) Seq.singleton (span, ExactPrint.mkAnnKey l)
)
let nodes = SYB.everything (<>) extract ast let nodes = SYB.everything (<>) extract ast
let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey let
annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey
annsMap = Map.fromListWith annsMap = Map.fromListWith
(const id) (const id)
[ (GHC.realSrcSpanEnd span, annKey) [ (GHC.realSrcSpanEnd span, annKey)
@ -144,7 +138,8 @@ commentAnnFixTransformGlob ast = do
processComs annsMap annKey1 = do processComs annsMap annKey1 = do
mAnn <- State.Class.gets fst <&> Map.lookup annKey1 mAnn <- State.Class.gets fst <&> Map.lookup annKey1
mAnn `forM_` \ann1 -> do mAnn `forM_` \ann1 -> do
let priors = ExactPrint.annPriorComments ann1 let
priors = ExactPrint.annPriorComments ann1
follows = ExactPrint.annFollowingComments ann1 follows = ExactPrint.annFollowingComments ann1
assocs = ExactPrint.annsDP ann1 assocs = ExactPrint.annsDP ann1
let let
@ -171,15 +166,16 @@ commentAnnFixTransformGlob ast = do
{ ExactPrint.annFollowingComments = { ExactPrint.annFollowingComments =
ExactPrint.annFollowingComments ann2 ++ [comPair] ExactPrint.annFollowingComments ann2 ++ [comPair]
} }
in in Map.insert annKey2 ann2' anns
Map.insert annKey2 ann2' anns
_ -> return True -- retain comment at current node. _ -> return True -- retain comment at current node.
priors' <- filterM processCom priors priors' <- filterM processCom priors
follows' <- filterM processCom follows follows' <- filterM processCom follows
assocs' <- flip filterM assocs $ \case assocs' <- flip filterM assocs $ \case
(ExactPrint.AnnComment com, dp) -> processCom (com, dp) (ExactPrint.AnnComment com, dp) -> processCom (com, dp)
_ -> return True _ -> return True
let ann1' = ann1 { ExactPrint.annPriorComments = priors' let
ann1' = ann1
{ ExactPrint.annPriorComments = priors'
, ExactPrint.annFollowingComments = follows' , ExactPrint.annFollowingComments = follows'
, ExactPrint.annsDP = assocs' , ExactPrint.annsDP = assocs'
} }
@ -274,7 +270,8 @@ extractToplevelAnns lmod anns = output
output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns
groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a) groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a)
groupMap f = Map.foldlWithKey' (\m k a -> Map.alter (insert k a) (f k a) m) groupMap f = Map.foldlWithKey'
(\m k a -> Map.alter (insert k a) (f k a) m)
Map.empty Map.empty
where where
insert k a Nothing = Just (Map.singleton k a) insert k a Nothing = Just (Map.singleton k a)
@ -289,10 +286,10 @@ foldedAnnKeys ast = SYB.everything
[ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x [ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x
| locTyCon == SYB.typeRepTyCon (SYB.typeOf x) | locTyCon == SYB.typeRepTyCon (SYB.typeOf x)
, l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x
]
-- for some reason, ghc-8.8 has forgotten how to infer the type of l, -- for some reason, ghc-8.8 has forgotten how to infer the type of l,
-- even though it is passed to mkAnnKey above, which only accepts -- even though it is passed to mkAnnKey above, which only accepts
-- SrcSpan. -- SrcSpan.
]
) )
ast ast
where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ())) where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ()))
@ -312,7 +309,8 @@ withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case
pure x pure x
where where
f anns = f anns =
let ((), (annsBalanced, _), _) = let
((), (annsBalanced, _), _) =
ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) ExactPrint.runTransform anns (commentAnnFixTransformGlob ast)
in annsBalanced in annsBalanced

110
source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
View File

@ -6,49 +6,36 @@
module Language.Haskell.Brittany.Internal.LayouterBasics where module Language.Haskell.Brittany.Internal.LayouterBasics where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import qualified Control.Monad.Writer.Strict as Writer
import qualified Data.Char as Char
import Data.Data
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as Text.Builder
import DataTreePrint
import GHC (GenLocated(L), Located, moduleName, moduleNameString)
import qualified GHC.OldList as List import qualified GHC.OldList as List
import GHC.Parser.Annotation (AnnKeywordId(..))
import qualified Control.Monad.Writer.Strict as Writer import GHC.Types.Name (getOccString)
import GHC.Types.Name.Occurrence (occNameString)
import GHC.Types.Name.Reader (RdrName(..))
import qualified GHC.Types.SrcLoc as GHC
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.ExactPrintUtils
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation) import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
import qualified Data.Text.Lazy.Builder as Text.Builder
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.ExactPrintUtils
import GHC.Types.Name.Reader ( RdrName(..) )
import GHC ( Located, GenLocated(L), moduleName, moduleNameString )
import qualified GHC.Types.SrcLoc as GHC
import GHC.Types.Name.Occurrence ( occNameString )
import GHC.Types.Name ( getOccString )
import GHC.Parser.Annotation ( AnnKeywordId(..) )
import Data.Data
import qualified Data.Char as Char
import DataTreePrint
processDefault processDefault
:: ( ExactPrint.Annotate.Annotate ast :: ( ExactPrint.Annotate.Annotate ast
@ -79,7 +66,8 @@ briDocByExact
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
briDocByExact ast = do briDocByExact ast = do
anns <- mAsk anns <- mAsk
traceIfDumpConf "ast" traceIfDumpConf
"ast"
_dconf_dump_ast_unknown _dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast) (printTreeWithCustom 100 (customLayouterF anns) ast)
docExt ast anns True docExt ast anns True
@ -95,7 +83,8 @@ briDocByExactNoComment
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
briDocByExactNoComment ast = do briDocByExactNoComment ast = do
anns <- mAsk anns <- mAsk
traceIfDumpConf "ast" traceIfDumpConf
"ast"
_dconf_dump_ast_unknown _dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast) (printTreeWithCustom 100 (customLayouterF anns) ast)
docExt ast anns False docExt ast anns False
@ -110,21 +99,23 @@ briDocByExactInlineOnly
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
briDocByExactInlineOnly infoStr ast = do briDocByExactInlineOnly infoStr ast = do
anns <- mAsk anns <- mAsk
traceIfDumpConf "ast" traceIfDumpConf
"ast"
_dconf_dump_ast_unknown _dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast) (printTreeWithCustom 100 (customLayouterF anns) ast)
let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns
fallbackMode <- fallbackMode <-
mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack
let exactPrintNode t = allocateNode $ BDFExternal let
exactPrintNode t = allocateNode $ BDFExternal
(ExactPrint.Types.mkAnnKey ast) (ExactPrint.Types.mkAnnKey ast)
(foldedAnnKeys ast) (foldedAnnKeys ast)
False False
t t
let errorAction = do let
errorAction = do
mTell [ErrorUnknownNode infoStr ast] mTell [ErrorUnknownNode infoStr ast]
docLit docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"
$ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"
case (fallbackMode, Text.lines exactPrinted) of case (fallbackMode, Text.lines exactPrinted) of
(ExactPrintFallbackModeNever, _) -> errorAction (ExactPrintFallbackModeNever, _) -> errorAction
(_, [t]) -> exactPrintNode (_, [t]) -> exactPrintNode
@ -152,7 +143,8 @@ lrdrNameToTextAnnGen
lrdrNameToTextAnnGen f ast@(L _ n) = do lrdrNameToTextAnnGen f ast@(L _ n) = do
anns <- mAsk anns <- mAsk
let t = f $ rdrNameToText n let t = f $ rdrNameToText n
let hasUni x (ExactPrint.Types.G y, _) = x == y let
hasUni x (ExactPrint.Types.G y, _) = x == y
hasUni _ _ = False hasUni _ _ = False
-- TODO: in general: we should _always_ process all annotaiton stuff here. -- TODO: in general: we should _always_ process all annotaiton stuff here.
-- whatever we don't probably should have had some effect on the -- whatever we don't probably should have had some effect on the
@ -178,7 +170,8 @@ lrdrNameToTextAnnTypeEqualityIsSpecial
=> Located RdrName => Located RdrName
-> m Text -> m Text
lrdrNameToTextAnnTypeEqualityIsSpecial ast = do lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
let f x = if x == Text.pack "Data.Type.Equality~" let
f x = if x == Text.pack "Data.Type.Equality~"
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
else x else x
lrdrNameToTextAnnGen f ast lrdrNameToTextAnnGen f ast
@ -199,7 +192,8 @@ lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick
lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do
hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote
x <- lrdrNameToTextAnn ast2 x <- lrdrNameToTextAnn ast2
let lit = if x == Text.pack "Data.Type.Equality~" let
lit = if x == Text.pack "Data.Type.Equality~"
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
else x else x
return $ if hasQuote then Text.cons '\'' lit else lit return $ if hasQuote then Text.cons '\'' lit else lit
@ -223,8 +217,7 @@ extractRestComments ann =
) )
filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns
filterAnns ast = filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast)
Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast)
-- | True if there are any comments that are -- | True if there are any comments that are
-- a) connected to any node below (in AST sense) the given node AND -- a) connected to any node below (in AST sense) the given node AND
@ -242,7 +235,8 @@ hasCommentsBetween
-> ToBriDocM Bool -> ToBriDocM Bool
hasCommentsBetween ast leftKey rightKey = do hasCommentsBetween ast leftKey rightKey = do
mAnn <- astAnn ast mAnn <- astAnn ast
let go1 [] = False let
go1 [] = False
go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest
go1 (_ : rest) = go1 rest go1 (_ : rest) = go1 rest
go2 [] = False go2 [] = False
@ -260,7 +254,8 @@ hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast
-- | True if there are any regular comments connected to any node below (in AST -- | True if there are any regular comments connected to any node below (in AST
-- sense) the given node -- sense) the given node
hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool hasAnyRegularCommentsConnected
:: Data ast => GHC.Located ast -> ToBriDocM Bool
hasAnyRegularCommentsConnected ast = hasAnyRegularCommentsConnected ast =
any isRegularComment <$> astConnectedComments ast any isRegularComment <$> astConnectedComments ast
@ -460,12 +455,10 @@ newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a)
deriving (Functor, Applicative, Monad) deriving (Functor, Applicative, Monad)
addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM () addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM ()
addAlternativeCond cond doc = addAlternativeCond cond doc = when cond (addAlternative doc)
when cond (addAlternative doc)
addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM () addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM ()
addAlternative = addAlternative = CollectAltM . Writer.tell . (: [])
CollectAltM . Writer.tell . (: [])
runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered
runFilteredAlternative (CollectAltM action) = runFilteredAlternative (CollectAltM action) =
@ -482,7 +475,8 @@ docLines l = allocateNode . BDFLines =<< sequence l
docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
docCols sig l = allocateNode . BDFCols sig =<< sequence l docCols sig l = allocateNode . BDFCols sig =<< sequence l
docAddBaseY :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docAddBaseY
:: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm
docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
@ -517,7 +511,8 @@ docAnnotationKW
-> Maybe AnnKeywordId -> Maybe AnnKeywordId
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm docAnnotationKW annKey kw bdm =
allocateNode . BDFAnnotationKW annKey kw =<< bdm
docMoveToKWDP docMoveToKWDP
:: AnnKey :: AnnKey
@ -631,17 +626,11 @@ instance DocWrapable (ToBriDocM BriDocNumbered) where
docWrapNodePrior ast bdm = do docWrapNodePrior ast bdm = do
bd <- bdm bd <- bdm
i1 <- allocNodeIndex i1 <- allocNodeIndex
return return $ (,) i1 $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ bd
$ (,) i1
$ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
$ bd
docWrapNodeRest ast bdm = do docWrapNodeRest ast bdm = do
bd <- bdm bd <- bdm
i2 <- allocNodeIndex i2 <- allocNodeIndex
return return $ (,) i2 $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd
$ (,) i2
$ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast)
$ bd
instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where
docWrapNode ast bdms = case bdms of docWrapNode ast bdms = case bdms of
@ -778,7 +767,8 @@ briDocMToPPM m = do
briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String) briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String)
briDocMToPPMInner m = do briDocMToPPMInner m = do
readers <- MultiRWSS.mGetRawR readers <- MultiRWSS.mGetRawR
let ((x, errs), debugs) = let
((x, errs), debugs) =
runIdentity runIdentity
$ MultiRWSS.runMultiRWSTNil $ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiStateA (NodeAllocIndex 1) $ MultiRWSS.withMultiStateA (NodeAllocIndex 1)

136
source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs
View File

@ -3,26 +3,19 @@
module Language.Haskell.Brittany.Internal.Layouters.DataDecl where module Language.Haskell.Brittany.Internal.Layouters.DataDecl where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Data import qualified Data.Data
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified GHC.OldList as List import GHC (GenLocated(L), Located)
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Config.Types
import GHC ( Located, GenLocated(L) )
import qualified GHC import qualified GHC
import GHC.Hs import GHC.Hs
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.Type import Language.Haskell.Brittany.Internal.Layouters.Type
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
layoutDataDecl layoutDataDecl
:: Located (TyClDecl GhcPs) :: Located (TyClDecl GhcPs)
@ -32,9 +25,10 @@ layoutDataDecl
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
-- newtype MyType a b = MyType .. -- newtype MyType a b = MyType ..
HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs ->
(L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) -> case cons of
docWrapNode ltycl $ do (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc))
-> docWrapNode ltycl $ do
nameStr <- lrdrNameToTextAnn name nameStr <- lrdrNameToTextAnn name
consNameStr <- lrdrNameToTextAnn consName consNameStr <- lrdrNameToTextAnn consName
tyVarLine <- return <$> createBndrDoc bndrs tyVarLine <- return <$> createBndrDoc bndrs
@ -74,8 +68,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
-- data MyData = MyData { .. } -- data MyData = MyData { .. }
HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs ->
case cons of case cons of
(L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) -> (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc))
docWrapNode ltycl $ do -> docWrapNode ltycl $ do
lhsContextDoc <- docSharedWrapper createContextDoc lhsContext lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
nameStr <- lrdrNameToTextAnn name nameStr <- lrdrNameToTextAnn name
consNameStr <- lrdrNameToTextAnn consName consNameStr <- lrdrNameToTextAnn consName
@ -87,19 +81,23 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
Nothing -> pure Nothing Nothing -> pure Nothing
Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt
rhsDoc <- return <$> createDetailsDoc consNameStr details rhsDoc <- return <$> createDetailsDoc consNameStr details
consDoc <- fmap pure consDoc <-
fmap pure
$ docNonBottomSpacing $ docNonBottomSpacing
$ case (forallDocMay, rhsContextDocMay) of $ case (forallDocMay, rhsContextDocMay) of
(Just forallDoc, Just rhsContextDoc) -> docLines (Just forallDoc, Just rhsContextDoc) -> docLines
[ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] [ docSeq
[docLitS "=", docSeparator, docForceSingleline forallDoc]
, docSeq , docSeq
[ docLitS "." [ docLitS "."
, docSeparator , docSeparator
, docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] , docSetBaseY
$ docLines [rhsContextDoc, docSetBaseY rhsDoc]
] ]
] ]
(Just forallDoc, Nothing) -> docLines (Just forallDoc, Nothing) -> docLines
[ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] [ docSeq
[docLitS "=", docSeparator, docForceSingleline forallDoc]
, docSeq [docLitS ".", docSeparator, rhsDoc] , docSeq [docLitS ".", docSeparator, rhsDoc]
] ]
(Nothing, Just rhsContextDoc) -> docSeq (Nothing, Just rhsContextDoc) -> docSeq
@ -107,12 +105,12 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
, docSeparator , docSeparator
, docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc]
] ]
(Nothing, Nothing) -> docSeq [docLitS "=", docSeparator, rhsDoc] (Nothing, Nothing) ->
docSeq [docLitS "=", docSeparator, rhsDoc]
createDerivingPar mDerivs $ docAlt createDerivingPar mDerivs $ docAlt
[ -- data D = forall a . Show a => D a [ -- data D = forall a . Show a => D a
docSeq docSeq
[ docNodeAnnKW ltycl (Just GHC.AnnData) [ docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq
$ docSeq
[ appSep $ docLitS "data" [ appSep $ docLitS "data"
, docForceSingleline $ lhsContextDoc , docForceSingleline $ lhsContextDoc
, appSep $ docLit nameStr , appSep $ docLit nameStr
@ -124,7 +122,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
, docSetIndentLevel $ docSeq , docSetIndentLevel $ docSeq
[ case forallDocMay of [ case forallDocMay of
Nothing -> docEmpty Nothing -> docEmpty
Just forallDoc -> docSeq Just forallDoc ->
docSeq
[ docForceSingleline forallDoc [ docForceSingleline forallDoc
, docSeparator , docSeparator
, docLitS "." , docLitS "."
@ -137,8 +136,7 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
, -- data D , -- data D
-- = forall a . Show a => D a -- = forall a . Show a => D a
docAddBaseY BrIndentRegular $ docPar docAddBaseY BrIndentRegular $ docPar
( docNodeAnnKW ltycl (Just GHC.AnnData) (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq
$ docSeq
[ appSep $ docLitS "data" [ appSep $ docLitS "data"
, docForceSingleline lhsContextDoc , docForceSingleline lhsContextDoc
, appSep $ docLit nameStr , appSep $ docLit nameStr
@ -151,7 +149,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
, docSetIndentLevel $ docSeq , docSetIndentLevel $ docSeq
[ case forallDocMay of [ case forallDocMay of
Nothing -> docEmpty Nothing -> docEmpty
Just forallDoc -> docSeq Just forallDoc ->
docSeq
[ docForceSingleline forallDoc [ docForceSingleline forallDoc
, docSeparator , docSeparator
, docLitS "." , docLitS "."
@ -167,8 +166,7 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
-- . Show a => -- . Show a =>
-- D a -- D a
docAddBaseY BrIndentRegular $ docPar docAddBaseY BrIndentRegular $ docPar
( docNodeAnnKW ltycl (Just GHC.AnnData) (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq
$ docSeq
[ appSep $ docLitS "data" [ appSep $ docLitS "data"
, docForceSingleline lhsContextDoc , docForceSingleline lhsContextDoc
, appSep $ docLit nameStr , appSep $ docLit nameStr
@ -192,10 +190,7 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
(docLines (docLines
[ lhsContextDoc [ lhsContextDoc
, docNodeAnnKW ltycl (Just GHC.AnnData) , docNodeAnnKW ltycl (Just GHC.AnnData)
$ docSeq $ docSeq [appSep $ docLit nameStr, tyVarLine]
[ appSep $ docLit nameStr
, tyVarLine
]
, consDoc , consDoc
] ]
) )
@ -214,15 +209,15 @@ createContextDoc (t1 : tR) = do
docAlt docAlt
[ docSeq [ docSeq
[ docLitS "(" [ docLitS "("
, docForceSingleline $ docSeq $ List.intersperse docCommaSep , docForceSingleline $ docSeq $ List.intersperse
docCommaSep
(t1Doc : tRDocs) (t1Doc : tRDocs)
, docLitS ") =>" , docLitS ") =>"
, docSeparator , docSeparator
] ]
, docLines $ join , docLines $ join
[ [docSeq [docLitS "(", docSeparator, t1Doc]] [ [docSeq [docLitS "(", docSeparator, t1Doc]]
, tRDocs , tRDocs <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc]
<&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc]
, [docLitS ") =>", docSeparator] , [docLitS ") =>", docSeparator]
] ]
] ]
@ -234,10 +229,8 @@ createBndrDoc bs = do
(L _ (KindedTyVar _ _ext lrdrName kind)) -> do (L _ (KindedTyVar _ _ext lrdrName kind)) -> do
d <- docSharedWrapper layoutType kind d <- docSharedWrapper layoutType kind
return $ (lrdrNameToText lrdrName, Just $ d) return $ (lrdrNameToText lrdrName, Just $ d)
docSeq docSeq $ List.intersperse docSeparator $ tyVarDocs <&> \(vname, mKind) ->
$ List.intersperse docSeparator case mKind of
$ tyVarDocs
<&> \(vname, mKind) -> case mKind of
Nothing -> docLit vname Nothing -> docLit vname
Just kind -> docSeq Just kind -> docSeq
[ docLitS "(" [ docLitS "("
@ -263,16 +256,17 @@ createDerivingPar derivs mainDoc = do
<$> types <$> types
derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered
derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) =
case types of
(L _ []) -> docSeq [] (L _ []) -> docSeq []
(L _ ts) -> (L _ ts) ->
let let
tsLength = length ts tsLength = length ts
whenMoreThan1Type val = whenMoreThan1Type val =
if tsLength > 1 then docLitS val else docLitS "" if tsLength > 1 then docLitS val else docLitS ""
(lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy (lhsStrategy, rhsStrategy) =
in maybe (docEmpty, docEmpty) strategyLeftRight mStrategy
docSeq in docSeq
[ docDeriving [ docDeriving
, docWrapNodePrior types $ lhsStrategy , docWrapNodePrior types $ lhsStrategy
, docSeparator , docSeparator
@ -280,7 +274,8 @@ derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of
, docWrapNodeRest types , docWrapNodeRest types
$ docSeq $ docSeq
$ List.intersperse docCommaSep $ List.intersperse docCommaSep
$ ts <&> \case $ ts
<&> \case
HsIB _ t -> layoutType t HsIB _ t -> layoutType t
, whenMoreThan1Type ")" , whenMoreThan1Type ")"
, rhsStrategy , rhsStrategy
@ -294,10 +289,7 @@ derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of
( docEmpty ( docEmpty
, case viaTypes of , case viaTypes of
HsIB _ext t -> docSeq HsIB _ext t -> docSeq
[ docWrapNode lVia $ docLitS " via" [docWrapNode lVia $ docLitS " via", docSeparator, layoutType t]
, docSeparator
, layoutType t
]
) )
docDeriving :: ToBriDocM BriDocNumbered docDeriving :: ToBriDocM BriDocNumbered
@ -307,7 +299,8 @@ createDetailsDoc
:: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered) :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered)
createDetailsDoc consNameStr details = case details of createDetailsDoc consNameStr details = case details of
PrefixCon args -> do PrefixCon args -> do
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack indentPolicy <-
mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
let let
singleLine = docSeq singleLine = docSeq
[ docLit consNameStr [ docLit consNameStr
@ -315,13 +308,16 @@ createDetailsDoc consNameStr details = case details of
, docForceSingleline , docForceSingleline
$ docSeq $ docSeq
$ List.intersperse docSeparator $ List.intersperse docSeparator
$ fmap hsScaledThing args <&> layoutType $ fmap hsScaledThing args
<&> layoutType
] ]
leftIndented = docSetParSpacing leftIndented =
docSetParSpacing
. docAddBaseY BrIndentRegular . docAddBaseY BrIndentRegular
. docPar (docLit consNameStr) . docPar (docLit consNameStr)
. docLines . docLines
$ layoutType <$> fmap hsScaledThing args $ layoutType
<$> fmap hsScaledThing args
multiAppended = docSeq multiAppended = docSeq
[ docLit consNameStr [ docLit consNameStr
, docSeparator , docSeparator
@ -335,14 +331,13 @@ createDetailsDoc consNameStr details = case details of
IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented] IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented]
IndentPolicyFree -> IndentPolicyFree ->
docAlt [singleLine, multiAppended, multiIndented, leftIndented] docAlt [singleLine, multiAppended, multiIndented, leftIndented]
RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] RecCon (L _ []) ->
docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"]
RecCon lRec@(L _ fields@(_ : _)) -> do RecCon lRec@(L _ fields@(_ : _)) -> do
let ((fName1, fType1) : fDocR) = mkFieldDocs fields let ((fName1, fType1) : fDocR) = mkFieldDocs fields
-- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack
let allowSingleline = False let allowSingleline = False
docAddBaseY BrIndentRegular docAddBaseY BrIndentRegular $ runFilteredAlternative $ do
$ runFilteredAlternative
$ do
-- single-line: { i :: Int, b :: Bool } -- single-line: { i :: Int, b :: Bool }
addAlternativeCond allowSingleline $ docSeq addAlternativeCond allowSingleline $ docSeq
[ docLit consNameStr [ docLit consNameStr
@ -371,7 +366,8 @@ createDetailsDoc consNameStr details = case details of
(docLit consNameStr) (docLit consNameStr)
(docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines
[ docAlt [ docAlt
[ docCols ColRecDecl [ docCols
ColRecDecl
[ appSep (docLitS "{") [ appSep (docLitS "{")
, appSep $ docForceSingleline fName1 , appSep $ docForceSingleline fName1
, docSeq [docLitS "::", docSeparator] , docSeq [docLitS "::", docSeparator]
@ -387,7 +383,8 @@ createDetailsDoc consNameStr details = case details of
] ]
, docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) -> , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) ->
docAlt docAlt
[ docCols ColRecDecl [ docCols
ColRecDecl
[ docCommaSep [ docCommaSep
, appSep $ docForceSingleline fName , appSep $ docForceSingleline fName
, docSeq [docLitS "::", docSeparator] , docSeq [docLitS "::", docSeparator]
@ -418,10 +415,11 @@ createDetailsDoc consNameStr details = case details of
mkFieldDocs = fmap $ \lField -> case lField of mkFieldDocs = fmap $ \lField -> case lField of
L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t
createForallDoc :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered) createForallDoc
:: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered)
createForallDoc [] = Nothing createForallDoc [] = Nothing
createForallDoc lhsTyVarBndrs = Just $ docSeq createForallDoc lhsTyVarBndrs =
[docLitS "forall ", createBndrDoc lhsTyVarBndrs] Just $ docSeq [docLitS "forall ", createBndrDoc lhsTyVarBndrs]
createNamesAndTypeDoc createNamesAndTypeDoc
:: Data.Data.Data ast :: Data.Data.Data ast
@ -431,12 +429,8 @@ createNamesAndTypeDoc
-> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered) -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)
createNamesAndTypeDoc lField names t = createNamesAndTypeDoc lField names t =
( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq ( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq
[ docSeq [ docSeq $ List.intersperse docCommaSep $ names <&> \case
$ List.intersperse docCommaSep L _ (FieldOcc _ fieldName) -> docLit =<< lrdrNameToTextAnn fieldName
$ names
<&> \case
L _ (FieldOcc _ fieldName) ->
docLit =<< lrdrNameToTextAnn fieldName
] ]
, docWrapNodeRest lField $ layoutType t , docWrapNodeRest lField $ layoutType t
) )

252
source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
View File

@ -5,48 +5,38 @@
module Language.Haskell.Brittany.Internal.Layouters.Decl where module Language.Haskell.Brittany.Internal.Layouters.Decl where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Data import qualified Data.Data
import qualified Data.Foldable import qualified Data.Foldable
import qualified Data.Maybe import qualified Data.Maybe
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified GHC.OldList as List import GHC (AnnKeywordId(..), GenLocated(L))
import GHC.Data.Bag (bagToList, emptyBag)
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Layouters.Type
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint
import Language.Haskell.Brittany.Internal.ExactPrintUtils
import GHC ( GenLocated(L)
, AnnKeywordId(..)
)
import GHC.Types.SrcLoc ( SrcSpan, Located , getLoc, unLoc )
import qualified GHC.Data.FastString as FastString import qualified GHC.Data.FastString as FastString
import GHC.Hs import GHC.Hs
import GHC.Types.Basic ( InlinePragma(..) import qualified GHC.OldList as List
, Activation(..) import GHC.Types.Basic
( Activation(..)
, InlinePragma(..)
, InlineSpec(..) , InlineSpec(..)
, RuleMatchInfo(..)
, LexicalFixity(..) , LexicalFixity(..)
, RuleMatchInfo(..)
) )
import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) import GHC.Types.SrcLoc (Located, SrcSpan, getLoc, unLoc)
import Language.Haskell.Brittany.Internal.Config.Types
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr import Language.Haskell.Brittany.Internal.ExactPrintUtils
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.Pattern
import Language.Haskell.Brittany.Internal.Layouters.DataDecl import Language.Haskell.Brittany.Internal.Layouters.DataDecl
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
import GHC.Data.Bag ( bagToList, emptyBag ) import Language.Haskell.Brittany.Internal.Layouters.Pattern
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt
import Language.Haskell.Brittany.Internal.Layouters.Type
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import Language.Haskell.GHC.ExactPrint.Types (mkAnnKey)
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint
layoutDecl :: ToBriDoc HsDecl layoutDecl :: ToBriDoc HsDecl
layoutDecl d@(L loc decl) = case decl of layoutDecl d@(L loc decl) = case decl of
@ -67,44 +57,53 @@ layoutDecl d@(L loc decl) = case decl of
layoutSig :: ToBriDoc Sig layoutSig :: ToBriDoc Sig
layoutSig lsig@(L _loc sig) = case sig of layoutSig lsig@(L _loc sig) = case sig of
TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ TypeSig _ names (HsWC _ (HsIB _ typ)) ->
layoutNamesAndType Nothing names typ
InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) -> InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) ->
docWrapNode lsig $ do docWrapNode lsig $ do
nameStr <- lrdrNameToTextAnn name nameStr <- lrdrNameToTextAnn name
specStr <- specStringCompat lsig spec specStr <- specStringCompat lsig spec
let phaseStr = case phaseAct of let
phaseStr = case phaseAct of
NeverActive -> "" -- not [] - for NOINLINE NeverActive is NeverActive -> "" -- not [] - for NOINLINE NeverActive is
-- in fact the default -- in fact the default
AlwaysActive -> "" AlwaysActive -> ""
ActiveBefore _ i -> "[~" ++ show i ++ "] " ActiveBefore _ i -> "[~" ++ show i ++ "] "
ActiveAfter _ i -> "[" ++ show i ++ "] " ActiveAfter _ i -> "[" ++ show i ++ "] "
FinalActive -> error "brittany internal error: FinalActive" FinalActive -> error "brittany internal error: FinalActive"
let conlikeStr = case conlike of let
conlikeStr = case conlike of
FunLike -> "" FunLike -> ""
ConLike -> "CONLIKE " ConLike -> "CONLIKE "
docLit docLit
$ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr)
<> nameStr <> nameStr
<> Text.pack " #-}" <> Text.pack " #-}"
ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ ClassOpSig _ False names (HsIB _ typ) ->
PatSynSig _ names (HsIB _ typ) -> layoutNamesAndType (Just "pattern") names typ layoutNamesAndType Nothing names typ
PatSynSig _ names (HsIB _ typ) ->
layoutNamesAndType (Just "pattern") names typ
_ -> briDocByExactNoComment lsig -- TODO _ -> briDocByExactNoComment lsig -- TODO
where where
layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do
let keyDoc = case mKeyword of let
keyDoc = case mKeyword of
Just key -> [appSep . docLit $ Text.pack key] Just key -> [appSep . docLit $ Text.pack key]
Nothing -> [] Nothing -> []
nameStrs <- names `forM` lrdrNameToTextAnn nameStrs <- names `forM` lrdrNameToTextAnn
let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs
typeDoc <- docSharedWrapper layoutType typ typeDoc <- docSharedWrapper layoutType typ
hasComments <- hasAnyCommentsBelow lsig hasComments <- hasAnyCommentsBelow lsig
shouldBeHanging <- mAsk shouldBeHanging <-
<&> _conf_layout mAsk <&> _conf_layout .> _lconfig_hangingTypeSignature .> confUnpack
.> _lconfig_hangingTypeSignature
.> confUnpack
if shouldBeHanging if shouldBeHanging
then docSeq $ then
[ appSep $ docWrapNodeRest lsig $ docSeq $ keyDoc <> [docLit nameStr] docSeq
$ [ appSep
$ docWrapNodeRest lsig
$ docSeq
$ keyDoc
<> [docLit nameStr]
, docSetBaseY $ docLines , docSetBaseY $ docLines
[ docCols [ docCols
ColTyOpPrefix ColTyOpPrefix
@ -133,7 +132,8 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
BindStmt _ lPat expr -> do BindStmt _ lPat expr -> do
patDoc <- docSharedWrapper layoutPat lPat patDoc <- docSharedWrapper layoutPat lPat
expDoc <- docSharedWrapper layoutExpr expr expDoc <- docSharedWrapper layoutExpr expr
docCols ColBindStmt docCols
ColBindStmt
[ appSep $ colsWrapPat =<< patDoc [ appSep $ colsWrapPat =<< patDoc
, docSeq [appSep $ docLit $ Text.pack "<-", expDoc] , docSeq [appSep $ docLit $ Text.pack "<-", expDoc]
] ]
@ -145,9 +145,7 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
layoutBind layoutBind
:: ToBriDocC :: ToBriDocC (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered)
(HsBindLR GhcPs GhcPs)
(Either [BriDocNumbered] BriDocNumbered)
layoutBind lbind@(L _ bind) = case bind of layoutBind lbind@(L _ bind) = case bind of
FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do
idStr <- lrdrNameToTextAnn fId idStr <- lrdrNameToTextAnn fId
@ -165,17 +163,15 @@ layoutBind lbind@(L _ bind) = case bind of
let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey? let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey?
binderDoc <- docLit $ Text.pack "=" binderDoc <- docLit $ Text.pack "="
hasComments <- hasAnyCommentsBelow lbind hasComments <- hasAnyCommentsBelow lbind
fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing fmap Right $ docWrapNode lbind $ layoutPatternBindFinal
Nothing
binderDoc binderDoc
(Just patDocs) (Just patDocs)
clauseDocs clauseDocs
mWhereArg mWhereArg
hasComments hasComments
PatSynBind _ (PSB _ patID lpat rpat dir) -> do PatSynBind _ (PSB _ patID lpat rpat dir) -> do
fmap Right $ docWrapNode lbind $ layoutPatSynBind patID fmap Right $ docWrapNode lbind $ layoutPatSynBind patID lpat dir rpat
lpat
dir
rpat
_ -> Right <$> unknownNodeError "" lbind _ -> Right <$> unknownNodeError "" lbind
layoutIPBind :: ToBriDoc IPBind layoutIPBind :: ToBriDoc IPBind
layoutIPBind lipbind@(L _ bind) = case bind of layoutIPBind lipbind@(L _ bind) = case bind of
@ -185,7 +181,13 @@ layoutIPBind lipbind@(L _ bind) = case bind of
binderDoc <- docLit $ Text.pack "=" binderDoc <- docLit $ Text.pack "="
exprDoc <- layoutExpr expr exprDoc <- layoutExpr expr
hasComments <- hasAnyCommentsBelow lipbind hasComments <- hasAnyCommentsBelow lipbind
layoutPatternBindFinal Nothing binderDoc (Just ipName) [([], exprDoc, expr)] Nothing hasComments layoutPatternBindFinal
Nothing
binderDoc
(Just ipName)
[([], exprDoc, expr)]
Nothing
hasComments
data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs)
@ -203,7 +205,8 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of
-- x@(HsValBinds (ValBindsIn{})) -> -- x@(HsValBinds (ValBindsIn{})) ->
-- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x -- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x
HsValBinds _ (ValBinds _ bindlrs sigs) -> do HsValBinds _ (ValBinds _ bindlrs sigs) -> do
let unordered = let
unordered =
[ BagBind b | b <- Data.Foldable.toList bindlrs ] [ BagBind b | b <- Data.Foldable.toList bindlrs ]
++ [ BagSig s | s <- sigs ] ++ [ BagSig s | s <- sigs ]
ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered
@ -213,8 +216,7 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of
return $ Just $ docs return $ Just $ docs
-- x@(HsValBinds (ValBindsOut _binds _lsigs)) -> -- x@(HsValBinds (ValBindsOut _binds _lsigs)) ->
HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR" HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR"
HsIPBinds _ (IPBinds _ bb) -> HsIPBinds _ (IPBinds _ bb) -> Just <$> mapM layoutIPBind bb
Just <$> mapM layoutIPBind bb
EmptyLocalBinds{} -> return $ Nothing EmptyLocalBinds{} -> return $ Nothing
-- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is -- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is
@ -243,15 +245,16 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do
let mIdStr' = fixPatternBindIdentifier match <$> mIdStr let mIdStr' = fixPatternBindIdentifier match <$> mIdStr
patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of
(Just idStr, p1 : p2 : pr) | isInfix -> if null pr (Just idStr, p1 : p2 : pr) | isInfix -> if null pr
then then docCols
docCols ColPatternsFuncInfix ColPatternsFuncInfix
[ appSep $ docForceSingleline p1 [ appSep $ docForceSingleline p1
, appSep $ docLit $ idStr , appSep $ docLit $ idStr
, docForceSingleline p2 , docForceSingleline p2
] ]
else else docCols
docCols ColPatternsFuncInfix ColPatternsFuncInfix
( [docCols ColPatterns ([ docCols
ColPatterns
[ docParenL [ docParenL
, appSep $ docForceSingleline p1 , appSep $ docForceSingleline p1
, appSep $ docLit $ idStr , appSep $ docLit $ idStr
@ -274,15 +277,15 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do
let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch) let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch)
let alignmentToken = if null pats then Nothing else funId let alignmentToken = if null pats then Nothing else funId
hasComments <- hasAnyCommentsBelow lmatch hasComments <- hasAnyCommentsBelow lmatch
layoutPatternBindFinal alignmentToken layoutPatternBindFinal
alignmentToken
binderDoc binderDoc
(Just patDoc) (Just patDoc)
clauseDocs clauseDocs
mWhereArg mWhereArg
hasComments hasComments
fixPatternBindIdentifier fixPatternBindIdentifier :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text
:: Match GhcPs (LHsExpr GhcPs) -> Text -> Text
fixPatternBindIdentifier match idStr = go $ m_ctxt match fixPatternBindIdentifier match idStr = go $ m_ctxt match
where where
go = \case go = \case
@ -308,22 +311,20 @@ layoutPatternBindFinal
-- ^ AnnKey for the node that contains the AnnWhere position annotation -- ^ AnnKey for the node that contains the AnnWhere position annotation
-> Bool -> Bool
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments = do layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments
let patPartInline = case mPatDoc of = do
let
patPartInline = case mPatDoc of
Nothing -> [] Nothing -> []
Just patDoc -> [appSep $ docForceSingleline $ return patDoc] Just patDoc -> [appSep $ docForceSingleline $ return patDoc]
patPartParWrap = case mPatDoc of patPartParWrap = case mPatDoc of
Nothing -> id Nothing -> id
Just patDoc -> docPar (return patDoc) Just patDoc -> docPar (return patDoc)
whereIndent <- do whereIndent <- do
shouldSpecial <- mAsk shouldSpecial <-
<&> _conf_layout mAsk <&> _conf_layout .> _lconfig_indentWhereSpecial .> confUnpack
.> _lconfig_indentWhereSpecial regularIndentAmount <-
.> confUnpack mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
regularIndentAmount <- mAsk
<&> _conf_layout
.> _lconfig_indentAmount
.> confUnpack
pure $ if shouldSpecial pure $ if shouldSpecial
then BrIndentSpecial (max 1 (regularIndentAmount `div` 2)) then BrIndentSpecial (max 1 (regularIndentAmount `div` 2))
else BrIndentRegular else BrIndentRegular
@ -332,8 +333,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of
Nothing -> return $ [] Nothing -> return $ []
Just (annKeyWhere, [w]) -> pure . pure <$> docAlt Just (annKeyWhere, [w]) -> pure . pure <$> docAlt
[ docEnsureIndent BrIndentRegular [ docEnsureIndent BrIndentRegular $ docSeq
$ docSeq
[ docLit $ Text.pack "where" [ docLit $ Text.pack "where"
, docSeparator , docSeparator
, docForceSingleline $ return w , docForceSingleline $ return w
@ -361,13 +361,16 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
$ return $ return
<$> ws <$> ws
] ]
let singleLineGuardsDoc guards = appSep $ case guards of let
singleLineGuardsDoc guards = appSep $ case guards of
[] -> docEmpty [] -> docEmpty
[g] -> docSeq [g] -> docSeq
[appSep $ docLit $ Text.pack "|", docForceSingleline $ return g] [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g]
gs -> docSeq gs ->
docSeq
$ [appSep $ docLit $ Text.pack "|"] $ [appSep $ docLit $ Text.pack "|"]
++ (List.intersperse docCommaSep ++ (List.intersperse
docCommaSep
(docForceSingleline . return <$> gs) (docForceSingleline . return <$> gs)
) )
wherePart = case mWhereDocs of wherePart = case mWhereDocs of
@ -379,10 +382,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
] ]
_ -> Nothing _ -> Nothing
indentPolicy <- mAsk indentPolicy <-
<&> _conf_layout mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
.> _lconfig_indentPolicy
.> confUnpack
runFilteredAlternative $ do runFilteredAlternative $ do
@ -408,7 +409,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
[ docSeq (patPartInline ++ [guardPart]) [ docSeq (patPartInline ++ [guardPart])
, docSeq , docSeq
[ appSep $ return binderDoc [ appSep $ return binderDoc
, docForceParSpacing $ docAddBaseY BrIndentRegular $ return body , docForceParSpacing $ docAddBaseY BrIndentRegular $ return
body
] ]
] ]
] ]
@ -418,7 +420,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
$ docLines $ docLines
$ [ docForceSingleline $ [ docForceSingleline
$ docSeq (patPartInline ++ [guardPart, return binderDoc]) $ docSeq (patPartInline ++ [guardPart, return binderDoc])
, docEnsureIndent BrIndentRegular $ docForceSingleline $ return body , docEnsureIndent BrIndentRegular $ docForceSingleline $ return
body
] ]
++ wherePartMultiLine ++ wherePartMultiLine
-- pattern and exactly one clause in single line, body as par; -- pattern and exactly one clause in single line, body as par;
@ -430,7 +433,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
[ docSeq (patPartInline ++ [guardPart]) [ docSeq (patPartInline ++ [guardPart])
, docSeq , docSeq
[ appSep $ return binderDoc [ appSep $ return binderDoc
, docForceParSpacing $ docAddBaseY BrIndentRegular $ return body , docForceParSpacing $ docAddBaseY BrIndentRegular $ return
body
] ]
] ]
] ]
@ -522,8 +526,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
$ (case guardDocs of $ (case guardDocs of
[] -> [] [] -> []
[g] -> [g] ->
[ docForceSingleline [ docForceSingleline $ docSeq
$ docSeq [appSep $ docLit $ Text.pack "|", return g] [appSep $ docLit $ Text.pack "|", return g]
] ]
gs -> gs ->
[ docForceSingleline [ docForceSingleline
@ -556,8 +560,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
(case guardDocs of (case guardDocs of
[] -> [] [] -> []
[g] -> [g] ->
[ docForceSingleline [ docForceSingleline $ docSeq
$ docSeq [appSep $ docLit $ Text.pack "|", return g] [appSep $ docLit $ Text.pack "|", return g]
] ]
gs -> gs ->
[ docForceSingleline [ docForceSingleline
@ -592,8 +596,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
(g1 : gr) -> (g1 : gr) ->
(docSeq [appSep $ docLit $ Text.pack "|", return g1] (docSeq [appSep $ docLit $ Text.pack "|", return g1]
: (gr : (gr
<&> \g -> <&> \g -> docSeq
docSeq
[appSep $ docLit $ Text.pack ",", return g] [appSep $ docLit $ Text.pack ",", return g]
) )
) )
@ -615,43 +618,50 @@ layoutPatSynBind
-> LPat GhcPs -> LPat GhcPs
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
layoutPatSynBind name patSynDetails patDir rpat = do layoutPatSynBind name patSynDetails patDir rpat = do
let patDoc = docLit $ Text.pack "pattern" let
patDoc = docLit $ Text.pack "pattern"
binderDoc = case patDir of binderDoc = case patDir of
ImplicitBidirectional -> docLit $ Text.pack "=" ImplicitBidirectional -> docLit $ Text.pack "="
_ -> docLit $ Text.pack "<-" _ -> docLit $ Text.pack "<-"
body = colsWrapPat =<< layoutPat rpat body = colsWrapPat =<< layoutPat rpat
whereDoc = docLit $ Text.pack "where" whereDoc = docLit $ Text.pack "where"
mWhereDocs <- layoutPatSynWhere patDir mWhereDocs <- layoutPatSynWhere patDir
headDoc <- fmap pure $ docSeq $ headDoc <-
[ patDoc fmap pure
$ docSeq
$ [ patDoc
, docSeparator , docSeparator
, layoutLPatSyn name patSynDetails , layoutLPatSyn name patSynDetails
, docSeparator , docSeparator
, binderDoc , binderDoc
] ]
runFilteredAlternative $ do runFilteredAlternative $ do
addAlternative $ addAlternative
$
-- pattern .. where -- pattern .. where
-- .. -- ..
-- .. -- ..
docAddBaseY BrIndentRegular $ docSeq docAddBaseY BrIndentRegular
( [headDoc, docSeparator, body] $ docSeq
++ case mWhereDocs of ([headDoc, docSeparator, body] ++ case mWhereDocs of
Just ds -> [docSeparator, docPar whereDoc (docLines ds)] Just ds -> [docSeparator, docPar whereDoc (docLines ds)]
Nothing -> [] Nothing -> []
) )
addAlternative $ addAlternative
$
-- pattern .. = -- pattern .. =
-- .. -- ..
-- pattern .. <- -- pattern .. <-
-- .. where -- .. where
-- .. -- ..
-- .. -- ..
docAddBaseY BrIndentRegular $ docPar docAddBaseY BrIndentRegular
$ docPar
headDoc headDoc
(case mWhereDocs of (case mWhereDocs of
Nothing -> body Nothing -> body
Just ds -> docLines ([ docSeq [body, docSeparator, whereDoc] ] ++ ds) Just ds ->
docLines ([docSeq [body, docSeparator, whereDoc]] ++ ds)
) )
-- | Helper method for the left hand side of a pattern synonym -- | Helper method for the left hand side of a pattern synonym
@ -671,18 +681,21 @@ layoutLPatSyn name (InfixCon left right) = do
layoutLPatSyn name (RecCon recArgs) = do layoutLPatSyn name (RecCon recArgs) = do
docName <- lrdrNameToTextAnn name docName <- lrdrNameToTextAnn name
args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs
docSeq . fmap docLit docSeq
. fmap docLit
$ [docName, Text.pack " { "] $ [docName, Text.pack " { "]
<> intersperse (Text.pack ", ") args <> intersperse (Text.pack ", ") args
<> [Text.pack " }"] <> [Text.pack " }"]
-- | Helper method to get the where clause from of explicitly bidirectional -- | Helper method to get the where clause from of explicitly bidirectional
-- pattern synonyms -- pattern synonyms
layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered]) layoutPatSynWhere
:: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered])
layoutPatSynWhere hs = case hs of layoutPatSynWhere hs = case hs of
ExplicitBidirectional (MG _ (L _ lbinds) _) -> do ExplicitBidirectional (MG _ (L _ lbinds) _) -> do
binderDoc <- docLit $ Text.pack "=" binderDoc <- docLit $ Text.pack "="
Just <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds Just
<$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds
_ -> pure Nothing _ -> pure Nothing
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -692,7 +705,8 @@ layoutPatSynWhere hs = case hs of
layoutTyCl :: ToBriDoc TyClDecl layoutTyCl :: ToBriDoc TyClDecl
layoutTyCl ltycl@(L _loc tycl) = case tycl of layoutTyCl ltycl@(L _loc tycl) = case tycl of
SynDecl _ name vars fixity typ -> do SynDecl _ name vars fixity typ -> do
let isInfix = case fixity of let
isInfix = case fixity of
Prefix -> False Prefix -> False
Infix -> True Infix -> True
-- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP
@ -723,9 +737,7 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do
-- This isn't quite right, but does give syntactically valid results -- This isn't quite right, but does give syntactically valid results
let needsParens = not (null rest) || hasOwnParens let needsParens = not (null rest) || hasOwnParens
docSeq docSeq
$ [ docLit $ Text.pack "type" $ [docLit $ Text.pack "type", docSeparator]
, docSeparator
]
++ [ docParenL | needsParens ] ++ [ docParenL | needsParens ]
++ [ layoutTyVarBndr False a ++ [ layoutTyVarBndr False a
, docSeparator , docSeparator
@ -807,14 +819,16 @@ layoutTyFamInstDecl inClass outerNode tfid = do
++ [appSep $ docWrapNode name $ docLit nameStr] ++ [appSep $ docWrapNode name $ docLit nameStr]
++ intersperse docSeparator (layoutHsTyPats pats) ++ intersperse docSeparator (layoutHsTyPats pats)
++ [ docParenR | needsParens ] ++ [ docParenR | needsParens ]
hasComments <- (||) hasComments <-
(||)
<$> hasAnyRegularCommentsConnected outerNode <$> hasAnyRegularCommentsConnected outerNode
<*> hasAnyRegularCommentsRest innerNode <*> hasAnyRegularCommentsRest innerNode
typeDoc <- docSharedWrapper layoutType typ typeDoc <- docSharedWrapper layoutType typ
layoutLhsAndType hasComments lhs "=" typeDoc layoutLhsAndType hasComments lhs "=" typeDoc
layoutHsTyPats :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered] layoutHsTyPats
:: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered]
layoutHsTyPats pats = pats <&> \case layoutHsTyPats pats = pats <&> \case
HsValArg tm -> layoutType tm HsValArg tm -> layoutType tm
HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty] HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty]
@ -864,7 +878,11 @@ layoutClsInst lcid@(L _ cid) = docLines
docSortedLines docSortedLines
:: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered :: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered
docSortedLines l = docSortedLines l =
allocateNode . BDFLines . fmap unLoc . List.sortOn (ExactPrint.rs . getLoc) =<< sequence l allocateNode
. BDFLines
. fmap unLoc
. List.sortOn (ExactPrint.rs . getLoc)
=<< sequence l
layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered) layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered)
layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig
@ -945,7 +963,8 @@ layoutClsInst lcid@(L _ cid) = docLines
where where
go [] = [] go [] = []
go (line1 : lineR) = case Text.stripStart line1 of go (line1 : lineR) = case Text.stripStart line1 of
st | isTypeOrData st -> st : lineR st
| isTypeOrData st -> st : lineR
| otherwise -> st : go lineR | otherwise -> st : go lineR
isTypeOrData t' = isTypeOrData t' =
(Text.pack "type" `Text.isPrefixOf` t') (Text.pack "type" `Text.isPrefixOf` t')
@ -969,7 +988,12 @@ layoutLhsAndType hasComments lhs sep typeDoc = do
-- lhs = type -- lhs = type
-- lhs :: type -- lhs :: type
addAlternativeCond (not hasComments) $ docSeq addAlternativeCond (not hasComments) $ docSeq
[lhs, docSeparator, docLitS sep, docSeparator, docForceSingleline typeDoc] [ lhs
, docSeparator
, docLitS sep
, docSeparator
, docForceSingleline typeDoc
]
-- lhs -- lhs
-- :: typeA -- :: typeA
-- -> typeB -- -> typeB

595
source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
View File

File diff suppressed because it is too large Load Diff

11
source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot
View File

@ -2,20 +2,11 @@
module Language.Haskell.Brittany.Internal.Layouters.Expr where module Language.Haskell.Brittany.Internal.Layouters.Expr where
import GHC.Hs
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import GHC.Hs
layoutExpr :: ToBriDoc HsExpr layoutExpr :: ToBriDoc HsExpr
-- layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
litBriDoc :: HsLit GhcPs -> BriDocFInt litBriDoc :: HsLit GhcPs -> BriDocFInt
overLitValBriDoc :: OverLitVal -> BriDocFInt overLitValBriDoc :: OverLitVal -> BriDocFInt

59
source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs
View File

@ -4,27 +4,23 @@
module Language.Haskell.Brittany.Internal.Layouters.IE where module Language.Haskell.Brittany.Internal.Layouters.IE where
import Language.Haskell.Brittany.Internal.Prelude
import qualified Data.List.Extra import qualified Data.List.Extra
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified GHC.OldList as List import GHC
( AnnKeywordId(..)
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import GHC ( unLoc
, GenLocated(L) , GenLocated(L)
, moduleNameString
, AnnKeywordId(..)
, Located , Located
, ModuleName , ModuleName
, moduleNameString
, unLoc
) )
import GHC.Hs import GHC.Hs
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Utils
prepareName :: LIEWrappedName name -> Located name prepareName :: LIEWrappedName name -> Located name
prepareName = ieLWrappedName prepareName = ieLWrappedName
@ -51,22 +47,27 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
addAlternative addAlternative
$ docWrapNodeRest lie $ docWrapNodeRest lie
$ docAddBaseY BrIndentRegular $ docAddBaseY BrIndentRegular
$ docPar $ docPar (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs))
(layoutWrapped lie x)
(layoutItems (splitFirstLast sortedNs))
where where
nameDoc = docLit <=< lrdrNameToTextAnn . prepareName nameDoc = docLit <=< lrdrNameToTextAnn . prepareName
layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n]
layoutItems FirstLastEmpty = docSetBaseY $ docLines layoutItems FirstLastEmpty = docSetBaseY $ docLines
[docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty], docParenR] [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty]
, docParenR
]
layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines
[docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n], docParenR] [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n]
, docParenR
]
layoutItems (FirstLast n1 nMs nN) = layoutItems (FirstLast n1 nMs nN) =
docSetBaseY docSetBaseY
$ docLines $ docLines
$ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]]
++ map layoutItem nMs ++ map layoutItem nMs
++ [docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN], docParenR] ++ [ docSeq
[docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN]
, docParenR
]
IEModuleContents _ n -> docSeq IEModuleContents _ n -> docSeq
[ docLit $ Text.pack "module" [ docLit $ Text.pack "module"
, docSeparator , docSeparator
@ -92,16 +93,19 @@ data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted
-- handling of the resulting list. Adding parens is -- handling of the resulting list. Adding parens is
-- left to the caller since that is context sensitive -- left to the caller since that is context sensitive
layoutAnnAndSepLLIEs layoutAnnAndSepLLIEs
:: SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered] :: SortItemsFlag
-> Located [LIE GhcPs]
-> ToBriDocM [ToBriDocM BriDocNumbered]
layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
let makeIENode ie = docSeq [docCommaSep, ie] let makeIENode ie = docSeq [docCommaSep, ie]
let sortedLies = let
sortedLies =
[ items [ items
| group <- Data.List.Extra.groupOn lieToText | group <- Data.List.Extra.groupOn lieToText $ List.sortOn lieToText lies
$ List.sortOn lieToText lies
, items <- mergeGroup group , items <- mergeGroup group
] ]
let ieDocs = fmap layoutIE $ case shouldSort of let
ieDocs = fmap layoutIE $ case shouldSort of
ShouldSortItems -> sortedLies ShouldSortItems -> sortedLies
KeepItemsUnsorted -> lies KeepItemsUnsorted -> lies
ieCommaDocs <- ieCommaDocs <-
@ -141,7 +145,8 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2)) thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2))
= L = L
l l
(IEThingWith x (IEThingWith
x
wn wn
NoIEWildcard NoIEWildcard
(consItems1 ++ consItems2) (consItems1 ++ consItems2)
@ -164,7 +169,8 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
-- () -- no comments -- () -- no comments
-- ( -- a comment -- ( -- a comment
-- ) -- )
layoutLLIEs :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered layoutLLIEs
:: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered
layoutLLIEs enableSingleline shouldSort llies = do layoutLLIEs enableSingleline shouldSort llies = do
ieDs <- layoutAnnAndSepLLIEs shouldSort llies ieDs <- layoutAnnAndSepLLIEs shouldSort llies
hasComments <- hasAnyCommentsBelow llies hasComments <- hasAnyCommentsBelow llies
@ -213,4 +219,5 @@ lieToText = \case
L _ IEDocNamed{} -> Text.pack "@IEDocNamed" L _ IEDocNamed{} -> Text.pack "@IEDocNamed"
where where
moduleNameToText :: Located ModuleName -> Text moduleNameToText :: Located ModuleName -> Text
moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name) moduleNameToText (L _ name) =
Text.pack ("@IEModuleContents" ++ moduleNameString name)

105
source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs
View File

@ -2,26 +2,18 @@
module Language.Haskell.Brittany.Internal.Layouters.Import where module Language.Haskell.Brittany.Internal.Layouters.Import where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text import qualified Data.Text as Text
import GHC (GenLocated(L), Located, moduleNameString, unLoc)
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.IE
import Language.Haskell.Brittany.Internal.Config.Types
import GHC ( unLoc
, GenLocated(L)
, moduleNameString
, Located
)
import GHC.Hs import GHC.Hs
import GHC.Types.Basic import GHC.Types.Basic
import GHC.Unit.Types (IsBootInterface(..)) import GHC.Unit.Types (IsBootInterface(..))
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.IE
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
prepPkg :: SourceText -> String prepPkg :: SourceText -> String
prepPkg rawN = case rawN of prepPkg rawN = case rawN of
@ -36,8 +28,10 @@ layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered
layoutImport importD = case importD of layoutImport importD = case importD of
ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do
importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack
importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack importAsCol <-
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack
indentPolicy <-
mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
let let
compact = indentPolicy /= IndentPolicyFree compact = indentPolicy /= IndentPolicyFree
modNameT = Text.pack $ moduleNameString modName modNameT = Text.pack $ moduleNameString modName
@ -46,10 +40,13 @@ layoutImport importD = case importD of
hiding = maybe False fst mllies hiding = maybe False fst mllies
minQLength = length "import qualified " minQLength = length "import qualified "
qLengthReal = qLengthReal =
let qualifiedPart = if q /= NotQualified then length "qualified " else 0 let
qualifiedPart = if q /= NotQualified then length "qualified " else 0
safePart = if safe then length "safe " else 0 safePart = if safe then length "safe " else 0
pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT
srcPart = case src of { IsBoot -> length "{-# SOURCE #-} "; NotBoot -> 0 } srcPart = case src of
IsBoot -> length "{-# SOURCE #-} "
NotBoot -> 0
in length "import " + srcPart + safePart + qualifiedPart + pkgPart in length "import " + srcPart + safePart + qualifiedPart + pkgPart
qLength = max minQLength qLengthReal qLength = max minQLength qLengthReal
-- Cost in columns of importColumn -- Cost in columns of importColumn
@ -58,20 +55,23 @@ layoutImport importD = case importD of
nameCost = Text.length modNameT + qLength nameCost = Text.length modNameT + qLength
importQualifiers = docSeq importQualifiers = docSeq
[ appSep $ docLit $ Text.pack "import" [ appSep $ docLit $ Text.pack "import"
, case src of { IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}"; NotBoot -> docEmpty } , case src of
IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}"
NotBoot -> docEmpty
, if safe then appSep $ docLit $ Text.pack "safe" else docEmpty , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty
, if q /= NotQualified then appSep $ docLit $ Text.pack "qualified" else docEmpty , if q /= NotQualified
then appSep $ docLit $ Text.pack "qualified"
else docEmpty
, maybe docEmpty (appSep . docLit) pkgNameT , maybe docEmpty (appSep . docLit) pkgNameT
] ]
indentName = indentName =
if compact then id else docEnsureIndent (BrIndentSpecial qLength) if compact then id else docEnsureIndent (BrIndentSpecial qLength)
modNameD = modNameD = indentName $ appSep $ docLit modNameT
indentName $ appSep $ docLit modNameT hidDocCol =
hidDocCol = if hiding then importCol - hidingParenCost else importCol - 2 if hiding then importCol - hidingParenCost else importCol - 2
hidDocColDiff = importCol - 2 - hidDocCol hidDocColDiff = importCol - 2 - hidDocCol
hidDoc = if hiding hidDoc =
then appSep $ docLit $ Text.pack "hiding" if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty
else docEmpty
importHead = docSeq [importQualifiers, modNameD] importHead = docSeq [importQualifiers, modNameD]
bindingsD = case mllies of bindingsD = case mllies of
Nothing -> docEmpty Nothing -> docEmpty
@ -79,8 +79,12 @@ layoutImport importD = case importD of
hasComments <- hasAnyCommentsBelow llies hasComments <- hasAnyCommentsBelow llies
if compact if compact
then docAlt then docAlt
[ docSeq [hidDoc, docForceSingleline $ layoutLLIEs True ShouldSortItems llies] [ docSeq
, let makeParIfHiding = if hiding [ hidDoc
, docForceSingleline $ layoutLLIEs True ShouldSortItems llies
]
, let
makeParIfHiding = if hiding
then docAddBaseY BrIndentRegular . docPar hidDoc then docAddBaseY BrIndentRegular . docPar hidDoc
else id else id
in makeParIfHiding (layoutLLIEs True ShouldSortItems llies) in makeParIfHiding (layoutLLIEs True ShouldSortItems llies)
@ -93,9 +97,15 @@ layoutImport importD = case importD of
-- ..[hiding].( ) -- ..[hiding].( )
[] -> if hasComments [] -> if hasComments
then docPar then docPar
(docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) (docSeq
(docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) [hidDoc, docParenLSep, docWrapNode llies docEmpty]
else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] )
(docEnsureIndent
(BrIndentSpecial hidDocColDiff)
docParenR
)
else docSeq
[hidDoc, docParenLSep, docSeparator, docParenR]
-- ..[hiding].( b ) -- ..[hiding].( b )
[ieD] -> runFilteredAlternative $ do [ieD] -> runFilteredAlternative $ do
addAlternativeCond (not hasComments) addAlternativeCond (not hasComments)
@ -107,14 +117,19 @@ layoutImport importD = case importD of
, docParenR , docParenR
] ]
addAlternative $ docPar addAlternative $ docPar
(docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]
(docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) )
(docEnsureIndent
(BrIndentSpecial hidDocColDiff)
docParenR
)
-- ..[hiding].( b -- ..[hiding].( b
-- , b' -- , b'
-- ) -- )
(ieD:ieDs') -> (ieD : ieDs') -> docPar
docPar (docSeq
(docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]
)
(docEnsureIndent (BrIndentSpecial hidDocColDiff) (docEnsureIndent (BrIndentSpecial hidDocColDiff)
$ docLines $ docLines
$ ieDs' $ ieDs'
@ -125,21 +140,19 @@ layoutImport importD = case importD of
if compact if compact
then then
let asDoc = maybe docEmpty makeAsDoc masT let asDoc = maybe docEmpty makeAsDoc masT
in docAlt in
docAlt
[ docForceSingleline $ docSeq [importHead, asDoc, bindingsD] [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD]
, docAddBaseY BrIndentRegular $ , docAddBaseY BrIndentRegular
docPar (docSeq [importHead, asDoc]) bindingsD $ docPar (docSeq [importHead, asDoc]) bindingsD
] ]
else else case masT of
case masT of
Just n -> if enoughRoom Just n -> if enoughRoom
then docLines then docLines [docSeq [importHead, asDoc], bindingsD]
[ docSeq [importHead, asDoc], bindingsD]
else docLines [importHead, asDoc, bindingsD] else docLines [importHead, asDoc, bindingsD]
where where
enoughRoom = nameCost < importAsCol - asCost enoughRoom = nameCost < importAsCol - asCost
asDoc = asDoc = docEnsureIndent (BrIndentSpecial (importAsCol - asCost))
docEnsureIndent (BrIndentSpecial (importAsCol - asCost))
$ makeAsDoc n $ makeAsDoc n
Nothing -> if enoughRoom Nothing -> if enoughRoom
then docSeq [importHead, bindingsD] then docSeq [importHead, bindingsD]

60
source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs
View File

@ -3,29 +3,22 @@
module Language.Haskell.Brittany.Internal.Layouters.Module where module Language.Haskell.Brittany.Internal.Layouters.Module where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Maybe import qualified Data.Maybe
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text import qualified Data.Text as Text
import GHC (AnnKeywordId(..), GenLocated(L), moduleNameString, unLoc)
import GHC.Hs
import qualified GHC.OldList as List import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.IE import Language.Haskell.Brittany.Internal.Layouters.IE
import Language.Haskell.Brittany.Internal.Layouters.Import import Language.Haskell.Brittany.Internal.Layouters.Import
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import GHC (unLoc, GenLocated(L), moduleNameString, AnnKeywordId(..)) import Language.Haskell.Brittany.Internal.Types
import GHC.Hs
import Language.Haskell.GHC.ExactPrint as ExactPrint import Language.Haskell.GHC.ExactPrint as ExactPrint
import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Types
( DeltaPos(..) (DeltaPos(..), commentContents, deltaRow)
, deltaRow
, commentContents
)
layoutModule :: ToBriDoc' HsModule layoutModule :: ToBriDoc' HsModule
layoutModule lmod@(L _ mod') = case mod' of layoutModule lmod@(L _ mod') = case mod' of
@ -41,22 +34,19 @@ layoutModule lmod@(L _ mod') = case mod' of
-- groupify commentedImports `forM_` tellDebugMessShow -- groupify commentedImports `forM_` tellDebugMessShow
-- sortedImports <- sortImports imports -- sortedImports <- sortImports imports
let tn = Text.pack $ moduleNameString $ unLoc n let tn = Text.pack $ moduleNameString $ unLoc n
allowSingleLineExportList <- mAsk allowSingleLineExportList <-
<&> _conf_layout mAsk <&> _conf_layout .> _lconfig_allowSingleLineExportList .> confUnpack
.> _lconfig_allowSingleLineExportList
.> confUnpack
-- the config should not prevent single-line layout when there is no -- the config should not prevent single-line layout when there is no
-- export list -- export list
let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les let
allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les
docLines docLines
$ docSeq $ docSeq
[ docNodeAnnKW lmod Nothing docEmpty [ docNodeAnnKW lmod Nothing docEmpty
-- A pseudo node that serves merely to force documentation -- A pseudo node that serves merely to force documentation
-- before the node -- before the node
, docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do , docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do
addAlternativeCond allowSingleLine $ addAlternativeCond allowSingleLine $ docForceSingleline $ docSeq
docForceSingleline
$ docSeq
[ appSep $ docLit $ Text.pack "module" [ appSep $ docLit $ Text.pack "module"
, appSep $ docLit tn , appSep $ docLit tn
, docWrapNode lmod $ appSep $ case les of , docWrapNode lmod $ appSep $ case les of
@ -65,13 +55,11 @@ layoutModule lmod@(L _ mod') = case mod' of
, docSeparator , docSeparator
, docLit $ Text.pack "where" , docLit $ Text.pack "where"
] ]
addAlternative addAlternative $ docLines
$ docLines
[ docAddBaseY BrIndentRegular $ docPar [ docAddBaseY BrIndentRegular $ docPar
(docSeq [appSep $ docLit $ Text.pack "module", docLit tn] (docSeq [appSep $ docLit $ Text.pack "module", docLit tn])
) (docSeq
(docSeq [ [ docWrapNode lmod $ case les of
docWrapNode lmod $ case les of
Nothing -> docEmpty Nothing -> docEmpty
Just x -> layoutLLIEs False KeepItemsUnsorted x Just x -> layoutLLIEs False KeepItemsUnsorted x
, docSeparator , docSeparator
@ -102,7 +90,8 @@ data ImportStatementRecord = ImportStatementRecord
} }
instance Show ImportStatementRecord where instance Show ImportStatementRecord where
show r = "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show show r =
"ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
(length $ commentsAfter r) (length $ commentsAfter r)
transformToCommentedImport transformToCommentedImport
@ -121,7 +110,8 @@ transformToCommentedImport is = do
accumF accConnectedComm (annMay, decl) = case annMay of accumF accConnectedComm (annMay, decl) = case annMay of
Nothing -> Nothing ->
( [] ( []
, [ ImportStatement ImportStatementRecord { commentsBefore = [] , [ ImportStatement ImportStatementRecord
{ commentsBefore = []
, commentsAfter = [] , commentsAfter = []
, importStatement = decl , importStatement = decl
} }
@ -200,10 +190,8 @@ commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered
commentedImportsToDoc = \case commentedImportsToDoc = \case
EmptyLine -> docLitS "" EmptyLine -> docLitS ""
IndependentComment c -> commentToDoc c IndependentComment c -> commentToDoc c
ImportStatement r -> ImportStatement r -> docSeq
docSeq (layoutImport (importStatement r) : map commentToDoc (commentsAfter r))
( layoutImport (importStatement r)
: map commentToDoc (commentsAfter r)
)
where where
commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c) commentToDoc (c, DP (_y, x)) =
docLitS (replicate x ' ' ++ commentContents c)

57
source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
View File

@ -3,28 +3,19 @@
module Language.Haskell.Brittany.Internal.Layouters.Pattern where module Language.Haskell.Brittany.Internal.Layouters.Pattern where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Foldable as Foldable import qualified Data.Foldable as Foldable
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified GHC.OldList as List import GHC (GenLocated(L), ol_val)
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import GHC ( GenLocated(L)
, ol_val
)
import GHC.Hs import GHC.Hs
import qualified GHC.OldList as List
import GHC.Types.Basic import GHC.Types.Basic
import Language.Haskell.Brittany.Internal.LayouterBasics
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
import Language.Haskell.Brittany.Internal.Layouters.Type import Language.Haskell.Brittany.Internal.Layouters.Type
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
-- | layouts patterns (inside function bindings, case alternatives, let -- | layouts patterns (inside function bindings, case alternatives, let
-- bindings or do notation). E.g. for input -- bindings or do notation). E.g. for input
@ -40,11 +31,9 @@ layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered)
layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_"
-- _ -> expr -- _ -> expr
VarPat _ n -> VarPat _ n -> fmap Seq.singleton $ docLit $ lrdrNameToText n
fmap Seq.singleton $ docLit $ lrdrNameToText n
-- abc -> expr -- abc -> expr
LitPat _ lit -> LitPat _ lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit
fmap Seq.singleton $ allocateNode $ litBriDoc lit
-- 0 -> expr -- 0 -> expr
ParPat _ inner -> do ParPat _ inner -> do
-- (nestedpat) -> expr -- (nestedpat) -> expr
@ -74,10 +63,9 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
then return <$> docLit nameDoc then return <$> docLit nameDoc
else do else do
x1 <- appSep (docLit nameDoc) x1 <- appSep (docLit nameDoc)
xR <- fmap Seq.fromList xR <- fmap Seq.fromList $ sequence $ spacifyDocs $ fmap
$ sequence colsWrapPat
$ spacifyDocs argDocs
$ fmap colsWrapPat argDocs
return $ x1 Seq.<| xR return $ x1 Seq.<| xR
ConPat _ lname (InfixCon left right) -> do ConPat _ lname (InfixCon left right) -> do
-- a :< b -> expr -- a :< b -> expr
@ -103,8 +91,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
Seq.singleton <$> docSeq Seq.singleton <$> docSeq
[ appSep $ docLit t [ appSep $ docLit t
, appSep $ docLit $ Text.pack "{" , appSep $ docLit $ Text.pack "{"
, docSeq $ List.intersperse docCommaSep , docSeq $ List.intersperse docCommaSep $ fds <&> \case
$ fds <&> \case
(fieldName, Just fieldDoc) -> docSeq (fieldName, Just fieldDoc) -> docSeq
[ appSep $ docLit fieldName [ appSep $ docLit fieldName
, appSep $ docLit $ Text.pack "=" , appSep $ docLit $ Text.pack "="
@ -117,11 +104,9 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
ConPat _ lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do ConPat _ lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do
-- Abc { .. } -> expr -- Abc { .. } -> expr
let t = lrdrNameToText lname let t = lrdrNameToText lname
Seq.singleton <$> docSeq Seq.singleton <$> docSeq [appSep $ docLit t, docLit $ Text.pack "{..}"]
[ appSep $ docLit t ConPat _ lname (RecCon (HsRecFields fs@(_ : _) (Just (L _ dotdoti))))
, docLit $ Text.pack "{..}" | dotdoti == length fs -> do
]
ConPat _ lname (RecCon (HsRecFields fs@(_:_) (Just (L _ dotdoti)))) | dotdoti == length fs -> do
-- Abc { a = locA, .. } -- Abc { a = locA, .. }
let t = lrdrNameToText lname let t = lrdrNameToText lname
fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do
@ -184,7 +169,8 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
wrapPatPrepend pat1 (docLit $ Text.pack "~") wrapPatPrepend pat1 (docLit $ Text.pack "~")
NPat _ llit@(L _ ol) mNegative _ -> do NPat _ llit@(L _ ol) mNegative _ -> do
-- -13 -> expr -- -13 -> expr
litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val
ol
negDoc <- docLit $ Text.pack "-" negDoc <- docLit $ Text.pack "-"
pure $ case mNegative of pure $ case mNegative of
Just{} -> Seq.fromList [negDoc, litDoc] Just{} -> Seq.fromList [negDoc, litDoc]
@ -196,9 +182,7 @@ colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered
colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList
wrapPatPrepend wrapPatPrepend
:: LPat GhcPs :: LPat GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM (Seq BriDocNumbered)
-> ToBriDocM BriDocNumbered
-> ToBriDocM (Seq BriDocNumbered)
wrapPatPrepend pat prepElem = do wrapPatPrepend pat prepElem = do
patDocs <- layoutPat pat patDocs <- layoutPat pat
case Seq.viewl patDocs of case Seq.viewl patDocs of
@ -220,8 +204,5 @@ wrapPatListy elems both start end = do
x1 Seq.:< rest -> do x1 Seq.:< rest -> do
sDoc <- start sDoc <- start
eDoc <- end eDoc <- end
rest' <- rest `forM` \bd -> docSeq rest' <- rest `forM` \bd -> docSeq [docCommaSep, return bd]
[ docCommaSep
, return bd
]
return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc

30
source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs
View File

@ -4,26 +4,19 @@
module Language.Haskell.Brittany.Internal.Layouters.Stmt where module Language.Haskell.Brittany.Internal.Layouters.Stmt where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text import qualified Data.Text as Text
import GHC (GenLocated(L))
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Config.Types
import GHC ( GenLocated(L)
)
import GHC.Hs import GHC.Hs
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Layouters.Pattern
import Language.Haskell.Brittany.Internal.Layouters.Decl import Language.Haskell.Brittany.Internal.Layouters.Decl
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
import Language.Haskell.Brittany.Internal.Layouters.Pattern
layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
layoutStmt lstmt@(L _ stmt) = do layoutStmt lstmt@(L _ stmt) = do
@ -68,7 +61,8 @@ layoutStmt lstmt@(L _ stmt) = do
f = case indentPolicy of f = case indentPolicy of
IndentPolicyFree -> docSetBaseAndIndent IndentPolicyFree -> docSetBaseAndIndent
IndentPolicyLeft -> docForceSingleline IndentPolicyLeft -> docForceSingleline
IndentPolicyMultiple | indentFourPlus -> docSetBaseAndIndent IndentPolicyMultiple
| indentFourPlus -> docSetBaseAndIndent
| otherwise -> docForceSingleline | otherwise -> docForceSingleline
in f $ return bindDoc in f $ return bindDoc
] ]
@ -84,7 +78,8 @@ layoutStmt lstmt@(L _ stmt) = do
-- ccc = exprc -- ccc = exprc
addAlternativeCond (isFree || indentFourPlus) $ docSeq addAlternativeCond (isFree || indentFourPlus) $ docSeq
[ appSep $ docLit $ Text.pack "let" [ appSep $ docLit $ Text.pack "let"
, let f = if indentFourPlus , let
f = if indentFourPlus
then docEnsureIndent BrIndentRegular then docEnsureIndent BrIndentRegular
else docSetBaseAndIndent else docSetBaseAndIndent
in f $ docLines $ return <$> bindDocs in f $ docLines $ return <$> bindDocs
@ -95,7 +90,8 @@ layoutStmt lstmt@(L _ stmt) = do
-- ccc = exprc -- ccc = exprc
addAlternativeCond (not indentFourPlus) addAlternativeCond (not indentFourPlus)
$ docAddBaseY BrIndentRegular $ docAddBaseY BrIndentRegular
$ docPar (docLit $ Text.pack "let") $ docPar
(docLit $ Text.pack "let")
(docSetBaseAndIndent $ docLines $ return <$> bindDocs) (docSetBaseAndIndent $ docLines $ return <$> bindDocs)
RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do
-- rec stmt1 -- rec stmt1

9
source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot
View File

@ -2,14 +2,7 @@
module Language.Haskell.Brittany.Internal.Layouters.Stmt where module Language.Haskell.Brittany.Internal.Layouters.Stmt where
import GHC.Hs
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import GHC.Hs
layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))

252
source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs
View File

@ -3,28 +3,18 @@
module Language.Haskell.Brittany.Internal.Layouters.Type where module Language.Haskell.Brittany.Internal.Layouters.Type where
import qualified Data.Text as Text
import GHC (AnnKeywordId(..), GenLocated(L))
import GHC.Hs
import qualified GHC.OldList as List
import GHC.Types.Basic
import GHC.Utils.Outputable (ftext, showSDocUnsafe)
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Text as Text
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Utils
( splitFirstLast (FirstLastView(..), splitFirstLast)
, FirstLastView(..)
)
import GHC ( GenLocated(L)
, AnnKeywordId (..)
)
import GHC.Hs
import GHC.Utils.Outputable ( ftext, showSDocUnsafe )
import GHC.Types.Basic
layoutType :: ToBriDoc HsType layoutType :: ToBriDoc HsType
layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
@ -32,43 +22,33 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsTyVar _ promoted name -> do HsTyVar _ promoted name -> do
t <- lrdrNameToTextAnnTypeEqualityIsSpecial name t <- lrdrNameToTextAnnTypeEqualityIsSpecial name
case promoted of case promoted of
IsPromoted -> docSeq IsPromoted ->
[ docSeparator docSeq [docSeparator, docTick, docWrapNode name $ docLit t]
, docTick
, docWrapNode name $ docLit t
]
NotPromoted -> docWrapNode name $ docLit t NotPromoted -> docWrapNode name $ docLit t
HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do
let bndrs = getBinders hsf let bndrs = getBinders hsf
typeDoc <- docSharedWrapper layoutType typ2 typeDoc <- docSharedWrapper layoutType typ2
tyVarDocs <- layoutTyVarBndrs bndrs tyVarDocs <- layoutTyVarBndrs bndrs
cntxtDocs <- cntxts `forM` docSharedWrapper layoutType cntxtDocs <- cntxts `forM` docSharedWrapper layoutType
let maybeForceML = case typ2 of let
maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline (L _ HsFunTy{}) -> docForceMultiline
_ -> id _ -> id
let let
tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs
forallDoc = docAlt forallDoc = docAlt
[ let [ let open = docLit $ Text.pack "forall"
open = docLit $ Text.pack "forall"
in docSeq ([open] ++ tyVarDocLineList) in docSeq ([open] ++ tyVarDocLineList)
, docPar , docPar
(docLit (Text.pack "forall")) (docLit (Text.pack "forall"))
(docLines (docLines $ tyVarDocs <&> \case
$ tyVarDocs <&> \case
(tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname
(tname, Just doc) -> docEnsureIndent BrIndentRegular (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines
$ docLines [ docCols ColTyOpPrefix [docParenLSep, docLit tname]
[ docCols ColTyOpPrefix , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc]
[ docParenLSep
, docLit tname
]
, docCols ColTyOpPrefix
[ docLit $ Text.pack ":: "
, doc
]
, docLit $ Text.pack ")" , docLit $ Text.pack ")"
]) ]
)
] ]
contextDoc = case cntxtDocs of contextDoc = case cntxtDocs of
[] -> docLit $ Text.pack "()" [] -> docLit $ Text.pack "()"
@ -77,20 +57,19 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
[ let [ let
open = docLit $ Text.pack "(" open = docLit $ Text.pack "("
close = docLit $ Text.pack ")" close = docLit $ Text.pack ")"
list = List.intersperse docCommaSep list =
$ docForceSingleline <$> cntxtDocs List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs
in docSeq ([open] ++ list ++ [close]) in docSeq ([open] ++ list ++ [close])
, let , let
open = docCols ColTyOpPrefix open = docCols
ColTyOpPrefix
[ docParenLSep [ docParenLSep
, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs , docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs
] ]
close = docLit $ Text.pack ")" close = docLit $ Text.pack ")"
list = List.tail cntxtDocs <&> \cntxtDoc -> list = List.tail cntxtDocs <&> \cntxtDoc -> docCols
docCols ColTyOpPrefix ColTyOpPrefix
[ docCommaSep [docCommaSep, docAddBaseY (BrIndentSpecial 2) cntxtDoc]
, docAddBaseY (BrIndentSpecial 2) cntxtDoc
]
in docPar open $ docLines $ list ++ [close] in docPar open $ docLines $ list ++ [close]
] ]
docAlt docAlt
@ -98,7 +77,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
[ docSeq [ docSeq
[ if null bndrs [ if null bndrs
then docEmpty then docEmpty
else let else
let
open = docLit $ Text.pack "forall" open = docLit $ Text.pack "forall"
close = docLit $ Text.pack " . " close = docLit $ Text.pack " . "
in docSeq ([open, docSeparator] ++ tyVarDocLineList ++ [close]) in docSeq ([open, docSeparator] ++ tyVarDocLineList ++ [close])
@ -113,12 +93,13 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docPar , docPar
forallDoc forallDoc
(docLines (docLines
[ docCols ColTyOpPrefix [ docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . " [ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, docAddBaseY (BrIndentSpecial 3) , docAddBaseY (BrIndentSpecial 3) $ contextDoc
$ contextDoc
] ]
, docCols ColTyOpPrefix , docCols
ColTyOpPrefix
[ docLit $ Text.pack "=> " [ docLit $ Text.pack "=> "
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc , docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc
] ]
@ -129,7 +110,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
let bndrs = getBinders hsf let bndrs = getBinders hsf
typeDoc <- layoutType typ2 typeDoc <- layoutType typ2
tyVarDocs <- layoutTyVarBndrs bndrs tyVarDocs <- layoutTyVarBndrs bndrs
let maybeForceML = case typ2 of let
maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline (L _ HsFunTy{}) -> docForceMultiline
_ -> id _ -> id
let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs
@ -138,7 +120,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
[ docSeq [ docSeq
[ if null bndrs [ if null bndrs
then docEmpty then docEmpty
else let else
let
open = docLit $ Text.pack "forall" open = docLit $ Text.pack "forall"
close = docLit $ Text.pack " . " close = docLit $ Text.pack " . "
in docSeq ([open] ++ tyVarDocLineList ++ [close]) in docSeq ([open] ++ tyVarDocLineList ++ [close])
@ -148,7 +131,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-- . x -- . x
, docPar , docPar
(docSeq $ docLit (Text.pack "forall") : tyVarDocLineList) (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList)
( docCols ColTyOpPrefix (docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . " [ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, maybeForceML $ return typeDoc , maybeForceML $ return typeDoc
] ]
@ -160,21 +144,16 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
(docLit (Text.pack "forall")) (docLit (Text.pack "forall"))
(docLines (docLines
$ (tyVarDocs <&> \case $ (tyVarDocs <&> \case
(tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname (tname, Nothing) ->
(tname, Just doc) -> docEnsureIndent BrIndentRegular docEnsureIndent BrIndentRegular $ docLit tname
$ docLines (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines
[ docCols ColTyOpPrefix [ docCols ColTyOpPrefix [docParenLSep, docLit tname]
[ docParenLSep , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc]
, docLit tname
]
, docCols ColTyOpPrefix
[ docLit $ Text.pack ":: "
, doc
]
, docLit $ Text.pack ")" , docLit $ Text.pack ")"
] ]
) )
++[ docCols ColTyOpPrefix ++ [ docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . " [ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, maybeForceML $ return typeDoc , maybeForceML $ return typeDoc
] ]
@ -192,25 +171,23 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
[ let [ let
open = docLit $ Text.pack "(" open = docLit $ Text.pack "("
close = docLit $ Text.pack ")" close = docLit $ Text.pack ")"
list = List.intersperse docCommaSep list =
$ docForceSingleline <$> cntxtDocs List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs
in docSeq ([open] ++ list ++ [close]) in docSeq ([open] ++ list ++ [close])
, let , let
open = docCols ColTyOpPrefix open = docCols
ColTyOpPrefix
[ docParenLSep [ docParenLSep
, docAddBaseY (BrIndentSpecial 2) , docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs
$ head cntxtDocs
] ]
close = docLit $ Text.pack ")" close = docLit $ Text.pack ")"
list = List.tail cntxtDocs <&> \cntxtDoc -> list = List.tail cntxtDocs <&> \cntxtDoc -> docCols
docCols ColTyOpPrefix ColTyOpPrefix
[ docCommaSep [docCommaSep, docAddBaseY (BrIndentSpecial 2) $ cntxtDoc]
, docAddBaseY (BrIndentSpecial 2)
$ cntxtDoc
]
in docPar open $ docLines $ list ++ [close] in docPar open $ docLines $ list ++ [close]
] ]
let maybeForceML = case typ1 of let
maybeForceML = case typ1 of
(L _ HsFunTy{}) -> docForceMultiline (L _ HsFunTy{}) -> docForceMultiline
_ -> id _ -> id
docAlt docAlt
@ -225,7 +202,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-- -> c -- -> c
, docPar , docPar
(docForceSingleline contextDoc) (docForceSingleline contextDoc)
( docCols ColTyOpPrefix (docCols
ColTyOpPrefix
[ docLit $ Text.pack "=> " [ docLit $ Text.pack "=> "
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc
] ]
@ -234,24 +212,25 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsFunTy _ _ typ1 typ2 -> do HsFunTy _ _ typ1 typ2 -> do
typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 <- docSharedWrapper layoutType typ1
typeDoc2 <- docSharedWrapper layoutType typ2 typeDoc2 <- docSharedWrapper layoutType typ2
let maybeForceML = case typ2 of let
maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline (L _ HsFunTy{}) -> docForceMultiline
_ -> id _ -> id
hasComments <- hasAnyCommentsBelow ltype hasComments <- hasAnyCommentsBelow ltype
docAlt $ docAlt
[ docSeq $ [ docSeq
[ appSep $ docForceSingleline typeDoc1 [ appSep $ docForceSingleline typeDoc1
, appSep $ docLit $ Text.pack "->" , appSep $ docLit $ Text.pack "->"
, docForceSingleline typeDoc2 , docForceSingleline typeDoc2
] ]
| not hasComments | not hasComments
] ++ ]
[ docPar ++ [ docPar
(docNodeAnnKW ltype Nothing typeDoc1) (docNodeAnnKW ltype Nothing typeDoc1)
( docCols ColTyOpPrefix (docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->" [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->"
, docAddBaseY (BrIndentSpecial 3) , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc2
$ maybeForceML typeDoc2
] ]
) )
] ]
@ -264,14 +243,18 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docLit $ Text.pack ")" , docLit $ Text.pack ")"
] ]
, docPar , docPar
( docCols ColTyOpPrefix (docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docParenLSep [ docWrapNodeRest ltype $ docParenLSep
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1 , docAddBaseY (BrIndentSpecial 2) $ typeDoc1
]) ]
)
(docLit $ Text.pack ")") (docLit $ Text.pack ")")
] ]
HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do
let gather :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) let
gather
:: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs])
gather list = \case gather list = \case
L _ (HsAppTy _ ty1 ty2) -> gather (ty2 : list) ty1 L _ (HsAppTy _ ty1 ty2) -> gather (ty2 : list) ty1
final -> (final, list) final -> (final, list)
@ -280,8 +263,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
docRest <- docSharedWrapper layoutType `mapM` typRest docRest <- docSharedWrapper layoutType `mapM` typRest
docAlt docAlt
[ docSeq [ docSeq
$ docForceSingleline docHead : (docRest >>= \d -> $ docForceSingleline docHead
[ docSeparator, docForceSingleline d ]) : (docRest >>= \d -> [docSeparator, docForceSingleline d])
, docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)
] ]
HsAppTy _ typ1 typ2 -> do HsAppTy _ typ1 typ2 -> do
@ -293,9 +276,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docSeparator , docSeparator
, docForceSingleline typeDoc2 , docForceSingleline typeDoc2
] ]
, docPar , docPar typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2)
typeDoc1
(docEnsureIndent BrIndentRegular typeDoc2)
] ]
HsListTy _ typ1 -> do HsListTy _ typ1 -> do
typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 <- docSharedWrapper layoutType typ1
@ -306,10 +287,12 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docLit $ Text.pack "]" , docLit $ Text.pack "]"
] ]
, docPar , docPar
( docCols ColTyOpPrefix (docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack "[ " [ docWrapNodeRest ltype $ docLit $ Text.pack "[ "
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1 , docAddBaseY (BrIndentSpecial 2) $ typeDoc1
]) ]
)
(docLit $ Text.pack "]") (docLit $ Text.pack "]")
] ]
HsTupleTy _ tupleSort typs -> case tupleSort of HsTupleTy _ tupleSort typs -> case tupleSort of
@ -318,38 +301,46 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsConstraintTuple -> simple HsConstraintTuple -> simple
HsBoxedOrConstraintTuple -> simple HsBoxedOrConstraintTuple -> simple
where where
unboxed = if null typs then error "brittany internal error: unboxed unit" unboxed = if null typs
then error "brittany internal error: unboxed unit"
else unboxedL else unboxedL
simple = if null typs then unitL else simpleL simple = if null typs then unitL else simpleL
unitL = docLit $ Text.pack "()" unitL = docLit $ Text.pack "()"
simpleL = do simpleL = do
docs <- docSharedWrapper layoutType `mapM` typs docs <- docSharedWrapper layoutType `mapM` typs
let end = docLit $ Text.pack ")" let
lines = List.tail docs <&> \d -> end = docLit $ Text.pack ")"
docAddBaseY (BrIndentSpecial 2) lines =
List.tail docs
<&> \d -> docAddBaseY (BrIndentSpecial 2)
$ docCols ColTyOpPrefix [docCommaSep, d] $ docCols ColTyOpPrefix [docCommaSep, d]
commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs)
docAlt docAlt
[ docSeq $ [docLit $ Text.pack "("] [ docSeq
$ [docLit $ Text.pack "("]
++ docWrapNodeRest ltype commaDocs ++ docWrapNodeRest ltype commaDocs
++ [end] ++ [end]
, let line1 = docCols ColTyOpPrefix [docParenLSep, head docs] , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs]
in docPar in
docPar
(docAddBaseY (BrIndentSpecial 2) $ line1) (docAddBaseY (BrIndentSpecial 2) $ line1)
(docLines $ docWrapNodeRest ltype lines ++ [end]) (docLines $ docWrapNodeRest ltype lines ++ [end])
] ]
unboxedL = do unboxedL = do
docs <- docSharedWrapper layoutType `mapM` typs docs <- docSharedWrapper layoutType `mapM` typs
let start = docParenHashLSep let
start = docParenHashLSep
end = docParenHashRSep end = docParenHashRSep
docAlt docAlt
[ docSeq $ [start] [ docSeq
$ [start]
++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs)
++ [end] ++ [end]
, let , let
line1 = docCols ColTyOpPrefix [start, head docs] line1 = docCols ColTyOpPrefix [start, head docs]
lines = List.tail docs <&> \d -> lines =
docAddBaseY (BrIndentSpecial 2) List.tail docs
<&> \d -> docAddBaseY (BrIndentSpecial 2)
$ docCols ColTyOpPrefix [docCommaSep, d] $ docCols ColTyOpPrefix [docCommaSep, d]
in docPar in docPar
(docAddBaseY (BrIndentSpecial 2) line1) (docAddBaseY (BrIndentSpecial 2) line1)
@ -419,20 +410,18 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 <- docSharedWrapper layoutType typ1
docAlt docAlt
[ docSeq [ docSeq
[ docWrapNodeRest ltype [ docWrapNodeRest ltype $ docLit $ Text.pack
$ docLit ("?" ++ showSDocUnsafe (ftext ipName) ++ "::")
$ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::")
, docForceSingleline typeDoc1 , docForceSingleline typeDoc1
] ]
, docPar , docPar
( docLit (docLit $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)))
$ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)) (docCols
) ColTyOpPrefix
(docCols ColTyOpPrefix [ docWrapNodeRest ltype $ docLit $ Text.pack ":: "
[ docWrapNodeRest ltype
$ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 2) typeDoc1 , docAddBaseY (BrIndentSpecial 2) typeDoc1
]) ]
)
] ]
-- TODO: test KindSig -- TODO: test KindSig
HsKindSig _ typ1 kind1 -> do HsKindSig _ typ1 kind1 -> do
@ -571,15 +560,19 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
addAlternativeCond (not hasComments) addAlternativeCond (not hasComments)
$ docSeq $ docSeq
$ [docLit $ Text.pack "'["] $ [docLit $ Text.pack "'["]
++ List.intersperse specialCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])) ++ List.intersperse
specialCommaSep
(docForceSingleline
<$> (e1 : ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])
)
++ [docLit $ Text.pack " ]"] ++ [docLit $ Text.pack " ]"]
addAlternative $ addAlternative
let $ let
start = docCols ColList start = docCols ColList [appSep $ docLit $ Text.pack "'[", e1]
[appSep $ docLit $ Text.pack "'[", e1] linesM = ems <&> \d -> docCols ColList [specialCommaSep, d]
linesM = ems <&> \d -> lineN = docCols
docCols ColList [specialCommaSep, d] ColList
lineN = docCols ColList [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN] [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN]
end = docLit $ Text.pack " ]" end = docLit $ Text.pack " ]"
in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]
] ]
@ -592,8 +585,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext
HsStrTy NoSourceText _ -> HsStrTy NoSourceText _ ->
error "overLitValBriDoc: literal with no SourceText" error "overLitValBriDoc: literal with no SourceText"
HsWildCardTy _ -> HsWildCardTy _ -> docLit $ Text.pack "_"
docLit $ Text.pack "_"
HsSumTy{} -> -- TODO HsSumTy{} -> -- TODO
briDocByExactInlineOnly "HsSumTy{}" ltype briDocByExactInlineOnly "HsSumTy{}" ltype
HsStarTy _ isUnicode -> do HsStarTy _ isUnicode -> do
@ -611,9 +603,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docLit $ Text.pack "@" , docLit $ Text.pack "@"
, docForceSingleline k , docForceSingleline k
] ]
, docPar , docPar t (docSeq [docLit $ Text.pack "@", k])
t
(docSeq [docLit $ Text.pack "@", k ])
] ]
layoutTyVarBndrs layoutTyVarBndrs

14
source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs
View File

@ -2,26 +2,22 @@
module Language.Haskell.Brittany.Internal.Obfuscation where module Language.Haskell.Brittany.Internal.Obfuscation where
import Data.Char
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified GHC.OldList as List import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Prelude
import Data.Char import Language.Haskell.Brittany.Internal.PreludeUtils
import System.Random import System.Random
obfuscate :: Text -> IO Text obfuscate :: Text -> IO Text
obfuscate input = do obfuscate input = do
let predi x = isAlphaNum x || x `elem` "_'" let predi x = isAlphaNum x || x `elem` "_'"
let groups = List.groupBy (\a b -> predi a && predi b) (Text.unpack input) let groups = List.groupBy (\a b -> predi a && predi b) (Text.unpack input)
let idents = Set.toList $ Set.fromList $ filter (all predi) groups let idents = Set.toList $ Set.fromList $ filter (all predi) groups
let exceptionFilter x | x `elem` keywords = False let
exceptionFilter x | x `elem` keywords = False
exceptionFilter x | x `elem` extraKWs = False exceptionFilter x | x `elem` extraKWs = False
exceptionFilter x = not $ null $ drop 1 x exceptionFilter x = not $ null $ drop 1 x
let filtered = filter exceptionFilter idents let filtered = filter exceptionFilter idents

503
source/library/Language/Haskell/Brittany/Internal/Prelude.hs
View File

@ -1,346 +1,195 @@
module Language.Haskell.Brittany.Internal.Prelude ( module E ) where module Language.Haskell.Brittany.Internal.Prelude
( module E
) where
-- rather project-specific stuff:
---------------------------------
import GHC.Hs.Extension as E (GhcPs) import GHC.Hs.Extension as E (GhcPs)
import GHC.Types.Name.Reader as E (RdrName) import GHC.Types.Name.Reader as E (RdrName)
import Control.Applicative as E (Alternative(..), Applicative(..))
-- more general: import Control.Arrow as E ((&&&), (***), (<<<), (>>>), first, second)
---------------- import Control.Concurrent as E (forkIO, forkOS, threadDelay)
import Data.Functor.Identity as E ( Identity(..) )
import Control.Concurrent.Chan as E (Chan) import Control.Concurrent.Chan as E (Chan)
import Control.Concurrent.MVar as E ( MVar import Control.Concurrent.MVar as E
, newEmptyMVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, swapMVar, takeMVar)
, newMVar import Control.Exception as E (assert, bracket, evaluate)
, putMVar import Control.Monad as E
, readMVar ( (<$!>)
, takeMVar , (<=<)
, swapMVar
)
import Data.Int as E ( Int )
import Data.Word as E ( Word
, Word32
)
import Prelude as E ( Integer
, Float
, Double
, undefined
, Eq (..)
, Ord (..)
, Enum (..)
, Bounded (..)
, (<$>)
, (.)
, ($)
, ($!)
, Num (..)
, Integral (..)
, Fractional (..)
, Floating (..)
, RealFrac (..)
, RealFloat (..)
, fromIntegral
, error
, foldr
, foldl
, foldr1
, id
, map
, subtract
, putStrLn
, putStr
, Show (..)
, print
, fst
, snd
, (++)
, not
, (&&)
, (||)
, curry
, uncurry
, flip
, const
, seq
, reverse
, otherwise
, traverse
, realToFrac
, or
, and
, head
, any
, (^)
, Foldable
, Traversable
)
import Control.Monad.ST as E ( ST )
import Data.Bool as E ( Bool(..) )
import Data.Char as E ( Char
, ord
, chr
)
import Data.Either as E ( Either(..)
, either
)
import Data.IORef as E ( IORef )
import Data.Maybe as E ( Maybe(..)
, fromMaybe
, maybe
, listToMaybe
, maybeToList
, catMaybes
)
import Data.Monoid as E ( Endo(..)
, All(..)
, Any(..)
, Sum(..)
, Product(..)
, Alt(..)
, mconcat
, Monoid (..)
)
import Data.Ord as E ( Ordering(..)
, Down(..)
, comparing
)
import Data.Ratio as E ( Ratio
, Rational
, (%)
, numerator
, denominator
)
import Data.String as E ( String )
import Data.Void as E ( Void )
import System.IO as E ( IO
, hFlush
, stdout
)
import Data.Proxy as E ( Proxy(..) )
import Data.Sequence as E ( Seq )
import Data.Map as E ( Map )
import Data.Set as E ( Set )
import Data.Text as E ( Text )
import Data.Function as E ( fix
, (&)
)
import Data.Foldable as E ( foldl'
, foldr'
, fold
, asum
)
import Data.List as E ( partition
, null
, elem
, notElem
, minimum
, maximum
, length
, all
, take
, drop
, find
, sum
, zip
, zip3
, zipWith
, repeat
, replicate
, iterate
, nub
, filter
, intersperse
, intercalate
, isSuffixOf
, isPrefixOf
, dropWhile
, takeWhile
, unzip
, break
, transpose
, sortBy
, mapAccumL
, mapAccumR
, uncons
)
import Data.List.NonEmpty as E ( NonEmpty(..)
, nonEmpty
)
import Data.Tuple as E ( swap
)
import Text.Read as E ( readMaybe
)
import Control.Monad as E ( Functor (..)
, Monad (..)
, MonadPlus (..)
, mapM
, mapM_
, forM
, forM_
, sequence
, sequence_
, (=<<) , (=<<)
, (>=>) , (>=>)
, (<=<) , Functor(..)
, Monad(..)
, MonadPlus(..)
, filterM
, forM
, forM_
, forever , forever
, void
, join
, replicateM
, replicateM_
, guard , guard
, when , join
, unless
, liftM , liftM
, liftM2 , liftM2
, liftM3 , liftM3
, liftM4 , liftM4
, liftM5 , liftM5
, filterM , mapM
, (<$!>) , mapM_
, replicateM
, replicateM_
, sequence
, sequence_
, unless
, void
, when
) )
import Control.Monad.Extra as E
import Control.Applicative as E ( Applicative (..) (allM, andM, anyM, ifM, notM, orM, unlessM, whenM)
, Alternative (..) import Control.Monad.IO.Class as E (MonadIO(..))
import Control.Monad.ST as E (ST)
import Control.Monad.Trans.Class as E (lift)
import Control.Monad.Trans.Maybe as E (MaybeT(..))
import Control.Monad.Trans.MultiRWS as E
(MonadMultiReader(..), MonadMultiState(..), MonadMultiWriter(..), mGet)
import Data.Bifunctor as E (bimap)
import Data.Bool as E (Bool(..))
import Data.Char as E (Char, chr, ord)
import Data.Data as E (toConstr)
import Data.Either as E (Either(..), either)
import Data.Foldable as E (asum, fold, foldl', foldr')
import Data.Function as E ((&), fix)
import Data.Functor as E (($>))
import Data.Functor.Identity as E (Identity(..))
import Data.IORef as E (IORef)
import Data.Int as E (Int)
import Data.List as E
( all
, break
, drop
, dropWhile
, elem
, filter
, find
, intercalate
, intersperse
, isPrefixOf
, isSuffixOf
, iterate
, length
, mapAccumL
, mapAccumR
, maximum
, minimum
, notElem
, nub
, null
, partition
, repeat
, replicate
, sortBy
, sum
, take
, takeWhile
, transpose
, uncons
, unzip
, zip
, zip3
, zipWith
) )
import Data.List.Extra as E (nubOrd, stripSuffix)
import Data.List.NonEmpty as E (NonEmpty(..), nonEmpty)
import Data.Map as E (Map)
import Data.Maybe as E
(Maybe(..), catMaybes, fromMaybe, listToMaybe, maybe, maybeToList)
import Data.Monoid as E
( All(..)
, Alt(..)
, Any(..)
, Endo(..)
, Monoid(..)
, Product(..)
, Sum(..)
, mconcat
)
import Data.Ord as E (Down(..), Ordering(..), comparing)
import Data.Proxy as E (Proxy(..))
import Data.Ratio as E ((%), Ratio, Rational, denominator, numerator)
import Data.Semigroup as E ((<>), Semigroup(..))
import Data.Sequence as E (Seq)
import Data.Set as E (Set)
import Data.String as E (String)
import Data.Text as E (Text)
import Data.Tree as E (Tree(..))
import Data.Tuple as E (swap)
import Data.Typeable as E (Typeable)
import Data.Version as E (showVersion)
import Data.Void as E (Void)
import Data.Word as E (Word, Word32)
import Debug.Trace as E
( trace
, traceIO
, traceId
, traceM
, traceShow
, traceShowId
, traceShowM
, traceStack
)
import Foreign.ForeignPtr as E (ForeignPtr)
import Foreign.Storable as E (Storable) import Foreign.Storable as E (Storable)
import GHC.Exts as E (Constraint) import GHC.Exts as E (Constraint)
import Prelude as E
import Control.Concurrent as E ( threadDelay ( ($)
, forkIO , ($!)
, forkOS , (&&)
) , (++)
, (.)
import Control.Exception as E ( evaluate , (<$>)
, bracket , Bounded(..)
, assert , Double
) , Enum(..)
, Eq(..)
import Debug.Trace as E ( trace , Float
, traceId , Floating(..)
, traceShowId , Foldable
, traceShow , Fractional(..)
, traceStack , Integer
, traceShowId , Integral(..)
, traceIO , Num(..)
, traceM , Ord(..)
, traceShowM , RealFloat(..)
) , RealFrac(..)
, Show(..)
import Foreign.ForeignPtr as E ( ForeignPtr , Traversable
) , (^)
, and
import Data.Bifunctor as E ( bimap ) , any
import Data.Functor as E ( ($>) ) , const
import Data.Semigroup as E ( (<>) , curry
, Semigroup(..) , error
) , flip
, foldl
import Data.Typeable as E ( Typeable , foldr
) , foldr1
, fromIntegral
import Control.Arrow as E ( first , fst
, second , head
, (***) , id
, (&&&) , map
, (>>>) , not
, (<<<) , or
) , otherwise
, print
import Data.Version as E ( showVersion , putStr
) , putStrLn
, realToFrac
import Data.List.Extra as E ( nubOrd , reverse
, stripSuffix , seq
) , snd
import Control.Monad.Extra as E ( whenM , subtract
, unlessM , traverse
, ifM , uncurry
, notM , undefined
, orM , (||)
, andM
, anyM
, allM
)
import Data.Tree as E ( Tree(..)
)
import Control.Monad.Trans.MultiRWS as E ( -- MultiRWST (..)
-- , MultiRWSTNull
-- , MultiRWS
-- ,
MonadMultiReader(..)
, MonadMultiWriter(..)
, MonadMultiState(..)
, mGet
-- , runMultiRWST
-- , runMultiRWSTASW
-- , runMultiRWSTW
-- , runMultiRWSTAW
-- , runMultiRWSTSW
-- , runMultiRWSTNil
-- , runMultiRWSTNil_
-- , withMultiReader
-- , withMultiReader_
-- , withMultiReaders
-- , withMultiReaders_
-- , withMultiWriter
-- , withMultiWriterAW
-- , withMultiWriterWA
-- , withMultiWriterW
-- , withMultiWriters
-- , withMultiWritersAW
-- , withMultiWritersWA
-- , withMultiWritersW
-- , withMultiState
-- , withMultiStateAS
-- , withMultiStateSA
-- , withMultiStateA
-- , withMultiStateS
-- , withMultiState_
-- , withMultiStates
-- , withMultiStatesAS
-- , withMultiStatesSA
-- , withMultiStatesA
-- , withMultiStatesS
-- , withMultiStates_
-- , inflateReader
-- , inflateMultiReader
-- , inflateWriter
-- , inflateMultiWriter
-- , inflateState
-- , inflateMultiState
-- , mapMultiRWST
-- , mGetRawR
-- , mGetRawW
-- , mGetRawS
-- , mPutRawR
-- , mPutRawW
-- , mPutRawS
)
import Control.Monad.IO.Class as E ( MonadIO (..)
)
import Control.Monad.Trans.Class as E ( lift
)
import Control.Monad.Trans.Maybe as E ( MaybeT (..)
)
import Data.Data as E ( toConstr
) )
import System.IO as E (IO, hFlush, stdout)
import Text.Read as E (readMaybe)

24
source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs
View File

@ -1,20 +1,14 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.Brittany.Internal.PreludeUtils where module Language.Haskell.Brittany.Internal.PreludeUtils where
import Control.Applicative
import Prelude
import qualified Data.Strict.Maybe as Strict
import Debug.Trace
import Control.Monad
import System.IO
import Control.DeepSeq (NFData, force) import Control.DeepSeq (NFData, force)
import Control.Exception.Base (evaluate) import Control.Exception.Base (evaluate)
import Control.Monad
import Control.Applicative import qualified Data.Strict.Maybe as Strict
import Debug.Trace
import Prelude
import System.IO
instance Applicative Strict.Maybe where instance Applicative Strict.Maybe where
pure = Strict.Just pure = Strict.Just
@ -30,12 +24,12 @@ instance Alternative Strict.Maybe where
x <|> Strict.Nothing = x x <|> Strict.Nothing = x
_ <|> x = x _ <|> x = x
traceFunctionWith :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b) traceFunctionWith
:: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b)
traceFunctionWith name s1 s2 f x = trace traceStr y traceFunctionWith name s1 s2 f x = trace traceStr y
where where
y = f x y = f x
traceStr = traceStr = name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y
name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y
(<&!>) :: Monad m => m a -> (a -> b) -> m b (<&!>) :: Monad m => m a -> (a -> b) -> m b
(<&!>) = flip (<$!>) (<&!>) = flip (<$!>)

373
source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs
View File

@ -9,25 +9,18 @@
module Language.Haskell.Brittany.Internal.Transformations.Alt where module Language.Haskell.Brittany.Internal.Transformations.Alt where
import qualified Control.Monad.Memo as Memo
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import Data.HList.ContainsType
import qualified Data.List.Extra import qualified Data.List.Extra
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified GHC.OldList as List import qualified GHC.OldList as List
import Data.HList.ContainsType
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import qualified Control.Monad.Memo as Memo
data AltCurPos = AltCurPos data AltCurPos = AltCurPos
{ _acp_line :: Int -- chars in the current line { _acp_line :: Int -- chars in the current line
@ -35,7 +28,7 @@ data AltCurPos = AltCurPos
, _acp_indentPrep :: Int -- indentChange affecting the next Par , _acp_indentPrep :: Int -- indentChange affecting the next Par
, _acp_forceMLFlag :: AltLineModeState , _acp_forceMLFlag :: AltLineModeState
} }
deriving (Show) deriving Show
data AltLineModeState data AltLineModeState
= AltLineModeStateNone = AltLineModeStateNone
@ -49,11 +42,13 @@ altLineModeRefresh :: AltLineModeState -> AltLineModeState
altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone
altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False
altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL
altLineModeRefresh AltLineModeStateContradiction = AltLineModeStateContradiction altLineModeRefresh AltLineModeStateContradiction =
AltLineModeStateContradiction
altLineModeDecay :: AltLineModeState -> AltLineModeState altLineModeDecay :: AltLineModeState -> AltLineModeState
altLineModeDecay AltLineModeStateNone = AltLineModeStateNone altLineModeDecay AltLineModeStateNone = AltLineModeStateNone
altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True altLineModeDecay (AltLineModeStateForceML False) =
AltLineModeStateForceML True
altLineModeDecay (AltLineModeStateForceML True) = AltLineModeStateNone altLineModeDecay (AltLineModeStateForceML True) = AltLineModeStateNone
altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL
altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction
@ -119,7 +114,13 @@ transformAlts =
rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] (MultiRWSS.MultiRWS r w (AltCurPos ': s)) BriDocNumbered rec
:: BriDocNumbered
-> Memo.MemoT
Int
[VerticalSpacing]
(MultiRWSS.MultiRWS r w (AltCurPos ': s))
BriDocNumbered
rec bdX@(brDcId, brDc) = do rec bdX@(brDcId, brDc) = do
let reWrap = (,) brDcId let reWrap = (,) brDcId
-- debugAcp :: AltCurPos <- mGet -- debugAcp :: AltCurPos <- mGet
@ -130,10 +131,8 @@ transformAlts =
-- BDWrapAnnKey annKey <$> rec bd -- BDWrapAnnKey annKey <$> rec bd
BDFEmpty{} -> processSpacingSimple bdX $> bdX BDFEmpty{} -> processSpacingSimple bdX $> bdX
BDFLit{} -> processSpacingSimple bdX $> bdX BDFLit{} -> processSpacingSimple bdX $> bdX
BDFSeq list -> BDFSeq list -> reWrap . BDFSeq <$> list `forM` rec
reWrap . BDFSeq <$> list `forM` rec BDFCols sig list -> reWrap . BDFCols sig <$> list `forM` rec
BDFCols sig list ->
reWrap . BDFCols sig <$> list `forM` rec
BDFSeparator -> processSpacingSimple bdX $> bdX BDFSeparator -> processSpacingSimple bdX $> bdX
BDFAddBaseY indent bd -> do BDFAddBaseY indent bd -> do
acp <- mGet acp <- mGet
@ -162,22 +161,18 @@ transformAlts =
BDFIndentLevelPop bd -> do BDFIndentLevelPop bd -> do
reWrap . BDFIndentLevelPop <$> rec bd reWrap . BDFIndentLevelPop <$> rec bd
BDFPar indent sameLine indented -> do BDFPar indent sameLine indented -> do
indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack indAmount <-
let indAdd = case indent of mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
let
indAdd = case indent of
BrIndentNone -> 0 BrIndentNone -> 0
BrIndentRegular -> indAmount BrIndentRegular -> indAmount
BrIndentSpecial i -> i BrIndentSpecial i -> i
acp <- mGet acp <- mGet
let ind = _acp_indent acp + _acp_indentPrep acp + indAdd let ind = _acp_indent acp + _acp_indentPrep acp + indAdd
mSet $ acp mSet $ acp { _acp_indent = ind, _acp_indentPrep = 0 }
{ _acp_indent = ind
, _acp_indentPrep = 0
}
sameLine' <- rec sameLine sameLine' <- rec sameLine
mModify $ \acp' -> acp' mModify $ \acp' -> acp' { _acp_line = ind, _acp_indent = ind }
{ _acp_line = ind
, _acp_indent = ind
}
indented' <- rec indented indented' <- rec indented
return $ reWrap $ BDFPar indent sameLine' indented' return $ reWrap $ BDFPar indent sameLine' indented'
BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a
@ -185,14 +180,16 @@ transformAlts =
-- fail-early approach; BDEmpty does not -- fail-early approach; BDEmpty does not
-- make sense semantically for Alt[]. -- make sense semantically for Alt[].
BDFAlt alts -> do BDFAlt alts -> do
altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack altChooser <-
mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack
case altChooser of case altChooser of
AltChooserSimpleQuick -> do AltChooserSimpleQuick -> do
rec $ head alts rec $ head alts
AltChooserShallowBest -> do AltChooserShallowBest -> do
spacings <- alts `forM` getSpacing spacings <- alts `forM` getSpacing
acp <- mGet acp <- mGet
let lineCheck LineModeInvalid = False let
lineCheck LineModeInvalid = False
lineCheck (LineModeValid (VerticalSpacing _ p _)) = lineCheck (LineModeValid (VerticalSpacing _ p _)) =
case _acp_forceMLFlag acp of case _acp_forceMLFlag acp of
AltLineModeStateNone -> True AltLineModeStateNone -> True
@ -202,35 +199,41 @@ transformAlts =
-- TODO: use COMPLETE pragma instead? -- TODO: use COMPLETE pragma instead?
lineCheck _ = error "ghc exhaustive check is insufficient" lineCheck _ = error "ghc exhaustive check is insufficient"
lconf <- _conf_layout <$> mAsk lconf <- _conf_layout <$> mAsk
let options = -- trace ("considering options:" ++ show (length alts, acp)) $ let
options = -- trace ("considering options:" ++ show (length alts, acp)) $
(zip spacings alts (zip spacings alts
<&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs))
( hasSpace1 lconf acp vs && lineCheck vs, bd)) (hasSpace1 lconf acp vs && lineCheck vs, bd)
)
rec rec
$ fromMaybe (-- trace ("choosing last") $ $ fromMaybe (-- trace ("choosing last") $
List.last alts) List.last alts)
$ Data.List.Extra.firstJust (\(_i::Int, (b,x)) -> $ Data.List.Extra.firstJust
(\(_i :: Int, (b, x)) ->
[ -- traceShow ("choosing option " ++ show i) $ [ -- traceShow ("choosing option " ++ show i) $
x x
| b | b
]) ]
)
$ zip [1 ..] options $ zip [1 ..] options
AltChooserBoundedSearch limit -> do AltChooserBoundedSearch limit -> do
spacings <- alts `forM` getSpacings limit spacings <- alts `forM` getSpacings limit
acp <- mGet acp <- mGet
let lineCheck (VerticalSpacing _ p _) = let
case _acp_forceMLFlag acp of lineCheck (VerticalSpacing _ p _) = case _acp_forceMLFlag acp of
AltLineModeStateNone -> True AltLineModeStateNone -> True
AltLineModeStateForceSL{} -> p == VerticalSpacingParNone AltLineModeStateForceSL{} -> p == VerticalSpacingParNone
AltLineModeStateForceML{} -> p /= VerticalSpacingParNone AltLineModeStateForceML{} -> p /= VerticalSpacingParNone
AltLineModeStateContradiction -> False AltLineModeStateContradiction -> False
lconf <- _conf_layout <$> mAsk lconf <- _conf_layout <$> mAsk
let options = -- trace ("considering options:" ++ show (length alts, acp)) $ let
options = -- trace ("considering options:" ++ show (length alts, acp)) $
(zip spacings alts (zip spacings alts
<&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs))
( any (hasSpace2 lconf acp) vs (any (hasSpace2 lconf acp) vs && any lineCheck vs, bd)
&& any lineCheck vs, bd)) )
let checkedOptions :: [Maybe (Int, BriDocNumbered)] = let
checkedOptions :: [Maybe (Int, BriDocNumbered)] =
zip [1 ..] options <&> (\(i, (b, x)) -> [ (i, x) | b ]) zip [1 ..] options <&> (\(i, (b, x)) -> [ (i, x) | b ])
rec rec
$ fromMaybe (-- trace ("choosing last") $ $ fromMaybe (-- trace ("choosing last") $
@ -255,7 +258,9 @@ transformAlts =
BDFForwardLineMode bd -> do BDFForwardLineMode bd -> do
acp <- mGet acp <- mGet
x <- do x <- do
mSet $ acp { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp } mSet $ acp
{ _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp
}
rec bd rec bd
acp' <- mGet acp' <- mGet
mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp }
@ -264,7 +269,9 @@ transformAlts =
BDFPlain{} -> processSpacingSimple bdX $> bdX BDFPlain{} -> processSpacingSimple bdX $> bdX
BDFAnnotationPrior annKey bd -> do BDFAnnotationPrior annKey bd -> do
acp <- mGet acp <- mGet
mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp } mSet $ acp
{ _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp
}
bd' <- rec bd bd' <- rec bd
return $ reWrap $ BDFAnnotationPrior annKey bd' return $ reWrap $ BDFAnnotationPrior annKey bd'
BDFAnnotationRest annKey bd -> BDFAnnotationRest annKey bd ->
@ -278,10 +285,7 @@ transformAlts =
ind <- _acp_indent <$> mGet ind <- _acp_indent <$> mGet
l' <- rec l l' <- rec l
lr' <- lr `forM` \x -> do lr' <- lr `forM` \x -> do
mModify $ \acp -> acp mModify $ \acp -> acp { _acp_line = ind, _acp_indent = ind }
{ _acp_line = ind
, _acp_indent = ind
}
rec x rec x
return $ reWrap $ BDFLines (l' : lr') return $ reWrap $ BDFLines (l' : lr')
BDFEnsureIndent indent bd -> do BDFEnsureIndent indent bd -> do
@ -302,14 +306,21 @@ transformAlts =
mSet $ acp' { _acp_indent = _acp_indent acp } mSet $ acp' { _acp_indent = _acp_indent acp }
return $ case indent of return $ case indent of
BrIndentNone -> r BrIndentNone -> r
BrIndentRegular -> reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r BrIndentRegular ->
reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r
BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r
BDFNonBottomSpacing _ bd -> rec bd BDFNonBottomSpacing _ bd -> rec bd
BDFSetParSpacing bd -> rec bd BDFSetParSpacing bd -> rec bd
BDFForceParSpacing bd -> rec bd BDFForceParSpacing bd -> rec bd
BDFDebug s bd -> do BDFDebug s bd -> do
acp :: AltCurPos <- mGet acp :: AltCurPos <- mGet
tellDebugMess $ "transformAlts: BDFDEBUG " ++ s ++ " (node-id=" ++ show brDcId ++ "): acp=" ++ show acp tellDebugMess
$ "transformAlts: BDFDEBUG "
++ s
++ " (node-id="
++ show brDcId
++ "): acp="
++ show acp
reWrap . BDFDebug s <$> rec bd reWrap . BDFDebug s <$> rec bd
processSpacingSimple processSpacingSimple
:: ( MonadMultiReader Config m :: ( MonadMultiReader Config m
@ -325,7 +336,8 @@ transformAlts =
mSet $ acp { _acp_line = _acp_line acp + i } mSet $ acp { _acp_line = _acp_line acp + i }
LineModeValid VerticalSpacing{} -> error "processSpacingSimple par" LineModeValid VerticalSpacing{} -> error "processSpacingSimple par"
_ -> error "ghc exhaustive check is insufficient" _ -> error "ghc exhaustive check is insufficient"
hasSpace1 :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool hasSpace1
:: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool
hasSpace1 _ _ LineModeInvalid = False hasSpace1 _ _ LineModeInvalid = False
hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs
hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient"
@ -333,8 +345,13 @@ transformAlts =
hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _) hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _)
= line + sameLine <= confUnpack (_lconfig_cols lconf) = line + sameLine <= confUnpack (_lconfig_cols lconf)
hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _) hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _)
= line + sameLine <= confUnpack (_lconfig_cols lconf) = line
&& indent + indentPrep + par <= confUnpack (_lconfig_cols lconf) + sameLine
<= confUnpack (_lconfig_cols lconf)
&& indent
+ indentPrep
+ par
<= confUnpack (_lconfig_cols lconf)
hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _) hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _)
= line + sameLine <= confUnpack (_lconfig_cols lconf) = line + sameLine <= confUnpack (_lconfig_cols lconf)
@ -353,10 +370,11 @@ getSpacing !bridoc = rec bridoc
-- BDWrapAnnKey _annKey bd -> rec bd -- BDWrapAnnKey _annKey bd -> rec bd
BDFEmpty -> BDFEmpty ->
return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False
BDFLit t -> BDFLit t -> return $ LineModeValid $ VerticalSpacing
return $ LineModeValid $ VerticalSpacing (Text.length t) VerticalSpacingParNone False (Text.length t)
BDFSeq list -> VerticalSpacingParNone
sumVs <$> rec `mapM` list False
BDFSeq list -> sumVs <$> rec `mapM` list
BDFCols _sig list -> sumVs <$> rec `mapM` list BDFCols _sig list -> sumVs <$> rec `mapM` list
BDFSeparator -> BDFSeparator ->
return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False
@ -365,17 +383,23 @@ getSpacing !bridoc = rec bridoc
return $ mVs <&> \vs -> vs return $ mVs <&> \vs -> vs
{ _vs_paragraph = case _vs_paragraph vs of { _vs_paragraph = case _vs_paragraph vs of
VerticalSpacingParNone -> VerticalSpacingParNone VerticalSpacingParNone -> VerticalSpacingParNone
VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of VerticalSpacingParAlways i ->
VerticalSpacingParAlways $ case indent of
BrIndentNone -> i BrIndentNone -> i
BrIndentRegular -> i + ( confUnpack BrIndentRegular ->
i
+ (confUnpack
$ _lconfig_indentAmount $ _lconfig_indentAmount
$ _conf_layout $ _conf_layout
$ config $ config
) )
BrIndentSpecial j -> i + j BrIndentSpecial j -> i + j
VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of VerticalSpacingParSome i ->
VerticalSpacingParSome $ case indent of
BrIndentNone -> i BrIndentNone -> i
BrIndentRegular -> i + ( confUnpack BrIndentRegular ->
i
+ (confUnpack
$ _lconfig_indentAmount $ _lconfig_indentAmount
$ _conf_layout $ _conf_layout
$ config $ config
@ -390,11 +414,13 @@ getSpacing !bridoc = rec bridoc
-- the reason is that we really want to _keep_ it Just if it is -- the reason is that we really want to _keep_ it Just if it is
-- just so we properly communicate the is-multiline fact. -- just so we properly communicate the is-multiline fact.
-- An alternative would be setting to (Just 0). -- An alternative would be setting to (Just 0).
{ _vs_sameLine = max (_vs_sameLine vs) { _vs_sameLine = max
(_vs_sameLine vs)
(case _vs_paragraph vs of (case _vs_paragraph vs of
VerticalSpacingParNone -> 0 VerticalSpacingParNone -> 0
VerticalSpacingParSome i -> i VerticalSpacingParSome i -> i
VerticalSpacingParAlways i -> min colMax i) VerticalSpacingParAlways i -> min colMax i
)
, _vs_paragraph = VerticalSpacingParSome 0 , _vs_paragraph = VerticalSpacingParSome 0
} }
BDFBaseYPop bd -> rec bd BDFBaseYPop bd -> rec bd
@ -408,12 +434,19 @@ getSpacing !bridoc = rec bridoc
| VerticalSpacing lsp mPsp _ <- mVs | VerticalSpacing lsp mPsp _ <- mVs
, indSp <- mIndSp , indSp <- mIndSp
, lineMax <- getMaxVS $ mIndSp , lineMax <- getMaxVS $ mIndSp
, let pspResult = case mPsp of , let
VerticalSpacingParSome psp -> VerticalSpacingParSome $ max psp lineMax pspResult = case mPsp of
VerticalSpacingParSome psp ->
VerticalSpacingParSome $ max psp lineMax
VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax
VerticalSpacingParAlways psp -> VerticalSpacingParAlways $ max psp lineMax VerticalSpacingParAlways psp ->
, let parFlagResult = mPsp == VerticalSpacingParNone VerticalSpacingParAlways $ max psp lineMax
&& _vs_paragraph indSp == VerticalSpacingParNone , let
parFlagResult =
mPsp
== VerticalSpacingParNone
&& _vs_paragraph indSp
== VerticalSpacingParNone
&& _vs_parFlag indSp && _vs_parFlag indSp
] ]
BDFPar{} -> error "BDPar with indent in getSpacing" BDFPar{} -> error "BDPar with indent in getSpacing"
@ -440,35 +473,33 @@ getSpacing !bridoc = rec bridoc
BDFAnnotationKW _annKey _kw bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd
BDFAnnotationRest _annKey bd -> rec bd BDFAnnotationRest _annKey bd -> rec bd
BDFMoveToKWDP _annKey _kw _b bd -> rec bd BDFMoveToKWDP _annKey _kw _b bd -> rec bd
BDFLines [] -> return BDFLines [] ->
$ LineModeValid return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False
$ VerticalSpacing 0 VerticalSpacingParNone False
BDFLines ls@(_ : _) -> do BDFLines ls@(_ : _) -> do
lSps <- rec `mapM` ls lSps <- rec `mapM` ls
let (mVs : _) = lSps -- separated into let to avoid MonadFail let (mVs : _) = lSps -- separated into let to avoid MonadFail
return $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False return
$ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False
| VerticalSpacing lsp _ _ <- mVs | VerticalSpacing lsp _ _ <- mVs
, lineMax <- getMaxVS $ maxVs $ lSps , lineMax <- getMaxVS $ maxVs $ lSps
] ]
BDFEnsureIndent indent bd -> do BDFEnsureIndent indent bd -> do
mVs <- rec bd mVs <- rec bd
let addInd = case indent of let
addInd = case indent of
BrIndentNone -> 0 BrIndentNone -> 0
BrIndentRegular -> confUnpack BrIndentRegular ->
$ _lconfig_indentAmount confUnpack $ _lconfig_indentAmount $ _conf_layout $ config
$ _conf_layout
$ config
BrIndentSpecial i -> i BrIndentSpecial i -> i
return $ mVs <&> \(VerticalSpacing lsp psp pf) -> return $ mVs <&> \(VerticalSpacing lsp psp pf) ->
VerticalSpacing (lsp + addInd) psp pf VerticalSpacing (lsp + addInd) psp pf
BDFNonBottomSpacing b bd -> do BDFNonBottomSpacing b bd -> do
mVs <- rec bd mVs <- rec bd
return return $ mVs <|> LineModeValid
$ mVs
<|> LineModeValid
(VerticalSpacing (VerticalSpacing
0 0
(if b then VerticalSpacingParSome 0 (if b
then VerticalSpacingParSome 0
else VerticalSpacingParAlways colMax else VerticalSpacingParAlways colMax
) )
False False
@ -478,16 +509,29 @@ getSpacing !bridoc = rec bridoc
return $ mVs <&> \vs -> vs { _vs_parFlag = True } return $ mVs <&> \vs -> vs { _vs_parFlag = True }
BDFForceParSpacing bd -> do BDFForceParSpacing bd -> do
mVs <- rec bd mVs <- rec bd
return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] return
$ [ vs
| vs <- mVs
, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone
]
BDFDebug s bd -> do BDFDebug s bd -> do
r <- rec bd r <- rec bd
tellDebugMess $ "getSpacing: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): mVs=" ++ show r tellDebugMess
$ "getSpacing: BDFDebug "
++ show s
++ " (node-id="
++ show brDcId
++ "): mVs="
++ show r
return r return r
return result return result
maxVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing maxVs
:: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing
maxVs = foldl' maxVs = foldl'
(liftM2 (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> (liftM2
VerticalSpacing (max x1 y1) (case (x2, y2) of (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing
(max x1 y1)
(case (x2, y2) of
(x, VerticalSpacingParNone) -> x (x, VerticalSpacingParNone) -> x
(VerticalSpacingParNone, x) -> x (VerticalSpacingParNone, x) -> x
(VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> (VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->
@ -497,9 +541,14 @@ getSpacing !bridoc = rec bridoc
(VerticalSpacingParSome j, VerticalSpacingParAlways i) -> (VerticalSpacingParSome j, VerticalSpacingParAlways i) ->
VerticalSpacingParAlways $ max i j VerticalSpacingParAlways $ max i j
(VerticalSpacingParSome x, VerticalSpacingParSome y) -> (VerticalSpacingParSome x, VerticalSpacingParSome y) ->
VerticalSpacingParSome $ max x y) False)) VerticalSpacingParSome $ max x y
)
False
)
)
(LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False) (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False)
sumVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing sumVs
:: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing
sumVs sps = foldl' (liftM2 go) initial sps sumVs sps = foldl' (liftM2 go) initial sps
where where
go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing
@ -514,7 +563,8 @@ getSpacing !bridoc = rec bridoc
(VerticalSpacingParSome i, VerticalSpacingParAlways j) -> (VerticalSpacingParSome i, VerticalSpacingParAlways j) ->
VerticalSpacingParAlways $ i + j VerticalSpacingParAlways $ i + j
(VerticalSpacingParSome x, VerticalSpacingParSome y) -> (VerticalSpacingParSome x, VerticalSpacingParSome y) ->
VerticalSpacingParSome $ x + y) VerticalSpacingParSome $ x + y
)
x3 x3
singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone
singleline _ = False singleline _ = False
@ -549,16 +599,19 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
preFilterLimit = take (3 * limit) preFilterLimit = take (3 * limit)
memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v
memoWithKey k v = Memo.memo (const v) k memoWithKey k v = Memo.memo (const v) k
rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] rec
:: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing]
rec (brDcId, brdc) = memoWithKey brDcId $ do rec (brDcId, brdc) = memoWithKey brDcId $ do
config <- mAsk config <- mAsk
let colMax = config & _conf_layout & _lconfig_cols & confUnpack let colMax = config & _conf_layout & _lconfig_cols & confUnpack
let hasOkColCount (VerticalSpacing lsp psp _) = let
hasOkColCount (VerticalSpacing lsp psp _) =
lsp <= colMax && case psp of lsp <= colMax && case psp of
VerticalSpacingParNone -> True VerticalSpacingParNone -> True
VerticalSpacingParSome i -> i <= colMax VerticalSpacingParSome i -> i <= colMax
VerticalSpacingParAlways{} -> True VerticalSpacingParAlways{} -> True
let specialCompare vs1 vs2 = let
specialCompare vs1 vs2 =
if ((_vs_sameLine vs1 == _vs_sameLine vs2) if ((_vs_sameLine vs1 == _vs_sameLine vs2)
&& (_vs_parFlag vs1 == _vs_parFlag vs2) && (_vs_parFlag vs1 == _vs_parFlag vs2)
) )
@ -567,11 +620,9 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
if i1 < i2 then Smaller else Bigger if i1 < i2 then Smaller else Bigger
(p1, p2) -> if p1 == p2 then Smaller else Unequal (p1, p2) -> if p1 == p2 then Smaller else Unequal
else Unequal else Unequal
let allowHangingQuasiQuotes = let
config allowHangingQuasiQuotes =
& _conf_layout config & _conf_layout & _lconfig_allowHangingQuasiQuotes & confUnpack
& _lconfig_allowHangingQuasiQuotes
& confUnpack
let -- this is like List.nub, with one difference: if two elements let -- this is like List.nub, with one difference: if two elements
-- are unequal only in _vs_paragraph, with both ParAlways, we -- are unequal only in _vs_paragraph, with both ParAlways, we
-- treat them like equals and replace the first occurence with the -- treat them like equals and replace the first occurence with the
@ -591,7 +642,8 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- applied whenever in a parent the combination of spacings from -- applied whenever in a parent the combination of spacings from
-- its children might cause excess of the upper bound. -- its children might cause excess of the upper bound.
filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing] filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing]
filterAndLimit = take limit filterAndLimit =
take limit
-- prune so we always consider a constant -- prune so we always consider a constant
-- amount of spacings per node of the BriDoc. -- amount of spacings per node of the BriDoc.
. specialNub . specialNub
@ -623,12 +675,11 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
. preFilterLimit . preFilterLimit
result <- case brdc of result <- case brdc of
-- BDWrapAnnKey _annKey bd -> rec bd -- BDWrapAnnKey _annKey bd -> rec bd
BDFEmpty -> BDFEmpty -> return $ [VerticalSpacing 0 VerticalSpacingParNone False]
return $ [VerticalSpacing 0 VerticalSpacingParNone False]
BDFLit t -> BDFLit t ->
return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] return
BDFSeq list -> $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False]
fmap sumVs . mapM filterAndLimit <$> rec `mapM` list BDFSeq list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list
BDFCols _sig list -> BDFCols _sig list ->
fmap sumVs . mapM filterAndLimit <$> rec `mapM` list fmap sumVs . mapM filterAndLimit <$> rec `mapM` list
BDFSeparator -> BDFSeparator ->
@ -638,17 +689,23 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
return $ mVs <&> \vs -> vs return $ mVs <&> \vs -> vs
{ _vs_paragraph = case _vs_paragraph vs of { _vs_paragraph = case _vs_paragraph vs of
VerticalSpacingParNone -> VerticalSpacingParNone VerticalSpacingParNone -> VerticalSpacingParNone
VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of VerticalSpacingParAlways i ->
VerticalSpacingParAlways $ case indent of
BrIndentNone -> i BrIndentNone -> i
BrIndentRegular -> i + ( confUnpack BrIndentRegular ->
i
+ (confUnpack
$ _lconfig_indentAmount $ _lconfig_indentAmount
$ _conf_layout $ _conf_layout
$ config $ config
) )
BrIndentSpecial j -> i + j BrIndentSpecial j -> i + j
VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of VerticalSpacingParSome i ->
VerticalSpacingParSome $ case indent of
BrIndentNone -> i BrIndentNone -> i
BrIndentRegular -> i + ( confUnpack BrIndentRegular ->
i
+ (confUnpack
$ _lconfig_indentAmount $ _lconfig_indentAmount
$ _conf_layout $ _conf_layout
$ config $ config
@ -663,11 +720,13 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- the reason is that we really want to _keep_ it Just if it is -- the reason is that we really want to _keep_ it Just if it is
-- just so we properly communicate the is-multiline fact. -- just so we properly communicate the is-multiline fact.
-- An alternative would be setting to (Just 0). -- An alternative would be setting to (Just 0).
{ _vs_sameLine = max (_vs_sameLine vs) { _vs_sameLine = max
(_vs_sameLine vs)
(case _vs_paragraph vs of (case _vs_paragraph vs of
VerticalSpacingParNone -> 0 VerticalSpacingParNone -> 0
VerticalSpacingParSome i -> i VerticalSpacingParSome i -> i
VerticalSpacingParAlways i -> min colMax i) VerticalSpacingParAlways i -> min colMax i
)
, _vs_paragraph = case _vs_paragraph vs of , _vs_paragraph = case _vs_paragraph vs of
VerticalSpacingParNone -> VerticalSpacingParNone VerticalSpacingParNone -> VerticalSpacingParNone
VerticalSpacingParSome i -> VerticalSpacingParSome i VerticalSpacingParSome i -> VerticalSpacingParSome i
@ -679,13 +738,8 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
BDFPar BrIndentNone sameLine indented -> do BDFPar BrIndentNone sameLine indented -> do
mVss <- filterAndLimit <$> rec sameLine mVss <- filterAndLimit <$> rec sameLine
indSps <- filterAndLimit <$> rec indented indSps <- filterAndLimit <$> rec indented
let mVsIndSp = take limit let mVsIndSp = take limit $ [ (x, y) | x <- mVss, y <- indSps ]
$ [ (x,y) return $ mVsIndSp <&> \(VerticalSpacing lsp mPsp _, indSp) ->
| x<-mVss
, y<-indSps
]
return $ mVsIndSp <&>
\(VerticalSpacing lsp mPsp _, indSp) ->
VerticalSpacing VerticalSpacing
lsp lsp
(case mPsp of (case mPsp of
@ -693,9 +747,12 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO
VerticalSpacingParNone -> spMakePar indSp VerticalSpacingParNone -> spMakePar indSp
VerticalSpacingParAlways psp -> VerticalSpacingParAlways psp ->
VerticalSpacingParAlways $ max psp $ getMaxVS indSp) VerticalSpacingParAlways $ max psp $ getMaxVS indSp
( mPsp == VerticalSpacingParNone )
&& _vs_paragraph indSp == VerticalSpacingParNone (mPsp
== VerticalSpacingParNone
&& _vs_paragraph indSp
== VerticalSpacingParNone
&& _vs_parFlag indSp && _vs_parFlag indSp
) )
@ -713,17 +770,15 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
return $ filter ((== VerticalSpacingParNone) . _vs_paragraph) mVs return $ filter ((== VerticalSpacingParNone) . _vs_paragraph) mVs
BDFForwardLineMode bd -> rec bd BDFForwardLineMode bd -> rec bd
BDFExternal _ _ _ txt | [t] <- Text.lines txt -> BDFExternal _ _ _ txt | [t] <- Text.lines txt ->
return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] return
BDFExternal{} -> $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False]
return $ [] -- yes, we just assume that we cannot properly layout BDFExternal{} -> return $ [] -- yes, we just assume that we cannot properly layout
-- this. -- this.
BDFPlain t -> return BDFPlain t -> return
[ case Text.lines t of [ case Text.lines t of
[] -> VerticalSpacing 0 VerticalSpacingParNone False [] -> VerticalSpacing 0 VerticalSpacingParNone False
[t1 ] -> VerticalSpacing [t1] ->
(Text.length t1) VerticalSpacing (Text.length t1) VerticalSpacingParNone False
VerticalSpacingParNone
False
(t1 : _) -> VerticalSpacing (t1 : _) -> VerticalSpacing
(Text.length t1) (Text.length t1)
(VerticalSpacingParAlways 0) (VerticalSpacingParAlways 0)
@ -734,7 +789,8 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
BDFAnnotationKW _annKey _kw bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd
BDFAnnotationRest _annKey bd -> rec bd BDFAnnotationRest _annKey bd -> rec bd
BDFMoveToKWDP _annKey _kw _b bd -> rec bd BDFMoveToKWDP _annKey _kw _b bd -> rec bd
BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] BDFLines [] ->
return $ [VerticalSpacing 0 VerticalSpacingParNone False]
BDFLines ls@(_ : _) -> do BDFLines ls@(_ : _) -> do
-- we simply assume that lines is only used "properly", i.e. in -- we simply assume that lines is only used "properly", i.e. in
-- such a way that the first line can be treated "as a part of the -- such a way that the first line can be treated "as a part of the
@ -742,14 +798,13 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- be inserted anywhere but at the start of the line. A -- be inserted anywhere but at the start of the line. A
-- counterexample would be anything like Seq[Lit "foo", Lines]. -- counterexample would be anything like Seq[Lit "foo", Lines].
lSpss <- map filterAndLimit <$> rec `mapM` ls lSpss <- map filterAndLimit <$> rec `mapM` ls
let worbled = fmap reverse let
$ sequence worbled = fmap reverse $ sequence $ reverse $ lSpss
$ reverse sumF lSps@(lSp1 : _) =
$ lSpss VerticalSpacing (_vs_sameLine lSp1) (spMakePar $ maxVs lSps) False
sumF lSps@(lSp1:_) = VerticalSpacing (_vs_sameLine lSp1) sumF [] =
(spMakePar $ maxVs lSps) error
False $ "should not happen. if my logic does not fail"
sumF [] = error $ "should not happen. if my logic does not fail"
++ "me, this follows from not (null ls)." ++ "me, this follows from not (null ls)."
return $ sumF <$> worbled return $ sumF <$> worbled
-- lSpss@(mVs:_) <- rec `mapM` ls -- lSpss@(mVs:_) <- rec `mapM` ls
@ -765,12 +820,11 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps -- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps
BDFEnsureIndent indent bd -> do BDFEnsureIndent indent bd -> do
mVs <- rec bd mVs <- rec bd
let addInd = case indent of let
addInd = case indent of
BrIndentNone -> 0 BrIndentNone -> 0
BrIndentRegular -> confUnpack BrIndentRegular ->
$ _lconfig_indentAmount confUnpack $ _lconfig_indentAmount $ _conf_layout $ config
$ _conf_layout
$ config
BrIndentSpecial i -> i BrIndentSpecial i -> i
return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> return $ mVs <&> \(VerticalSpacing lsp psp parFlag) ->
VerticalSpacing (lsp + addInd) psp parFlag VerticalSpacing (lsp + addInd) psp parFlag
@ -781,9 +835,11 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- problem but breaks certain other cases. -- problem but breaks certain other cases.
mVs <- rec bd mVs <- rec bd
return $ if null mVs return $ if null mVs
then [VerticalSpacing then
[ VerticalSpacing
0 0
(if b then VerticalSpacingParSome 0 (if b
then VerticalSpacingParSome 0
else VerticalSpacingParAlways colMax else VerticalSpacingParAlways colMax
) )
False False
@ -832,16 +888,25 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
return $ mVs <&> \vs -> vs { _vs_parFlag = True } return $ mVs <&> \vs -> vs { _vs_parFlag = True }
BDFForceParSpacing bd -> do BDFForceParSpacing bd -> do
mVs <- preFilterLimit <$> rec bd mVs <- preFilterLimit <$> rec bd
return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ] return
$ [ vs
| vs <- mVs
, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone
]
BDFDebug s bd -> do BDFDebug s bd -> do
r <- rec bd r <- rec bd
tellDebugMess $ "getSpacings: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): vs=" ++ show (take 9 r) tellDebugMess
$ "getSpacings: BDFDebug "
++ show s
++ " (node-id="
++ show brDcId
++ "): vs="
++ show (take 9 r)
return r return r
return result return result
maxVs :: [VerticalSpacing] -> VerticalSpacing maxVs :: [VerticalSpacing] -> VerticalSpacing
maxVs = foldl' maxVs = foldl'
(\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing
VerticalSpacing
(max x1 y1) (max x1 y1)
(case (x2, y2) of (case (x2, y2) of
(x, VerticalSpacingParNone) -> x (x, VerticalSpacingParNone) -> x
@ -853,8 +918,10 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
(VerticalSpacingParSome i, VerticalSpacingParAlways j) -> (VerticalSpacingParSome i, VerticalSpacingParAlways j) ->
VerticalSpacingParAlways $ max i j VerticalSpacingParAlways $ max i j
(VerticalSpacingParSome x, VerticalSpacingParSome y) -> (VerticalSpacingParSome x, VerticalSpacingParSome y) ->
VerticalSpacingParSome $ max x y) VerticalSpacingParSome $ max x y
False) )
False
)
(VerticalSpacing 0 VerticalSpacingParNone False) (VerticalSpacing 0 VerticalSpacingParNone False)
sumVs :: [VerticalSpacing] -> VerticalSpacing sumVs :: [VerticalSpacing] -> VerticalSpacing
sumVs sps = foldl' go initial sps sumVs sps = foldl' go initial sps
@ -870,7 +937,9 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
VerticalSpacingParAlways $ i + j VerticalSpacingParAlways $ i + j
(VerticalSpacingParSome i, VerticalSpacingParAlways j) -> (VerticalSpacingParSome i, VerticalSpacingParAlways j) ->
VerticalSpacingParAlways $ i + j VerticalSpacingParAlways $ i + j
(VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ x + y) (VerticalSpacingParSome x, VerticalSpacingParSome y) ->
VerticalSpacingParSome $ x + y
)
x3 x3
singleline x = _vs_paragraph x == VerticalSpacingParNone singleline x = _vs_paragraph x == VerticalSpacingParNone
isPar x = _vs_parFlag x isPar x = _vs_parFlag x
@ -893,7 +962,8 @@ fixIndentationForMultiple
:: (MonadMultiReader (CConfig Identity) m) => AltCurPos -> BrIndent -> m Int :: (MonadMultiReader (CConfig Identity) m) => AltCurPos -> BrIndent -> m Int
fixIndentationForMultiple acp indent = do fixIndentationForMultiple acp indent = do
indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
let indAddRaw = case indent of let
indAddRaw = case indent of
BrIndentNone -> 0 BrIndentNone -> 0
BrIndentRegular -> indAmount BrIndentRegular -> indAmount
BrIndentSpecial i -> i BrIndentSpecial i -> i
@ -903,7 +973,8 @@ fixIndentationForMultiple acp indent = do
indPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack indPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
pure $ if indPolicy == IndentPolicyMultiple pure $ if indPolicy == IndentPolicyMultiple
then then
let indAddMultiple1 = let
indAddMultiple1 =
indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount) indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount)
indAddMultiple2 = if indAddMultiple1 <= 0 indAddMultiple2 = if indAddMultiple1 <= 0
then indAddMultiple1 + indAmount then indAddMultiple1 + indAmount

114
source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs
View File

@ -3,16 +3,10 @@
module Language.Haskell.Brittany.Internal.Transformations.Columns where module Language.Haskell.Brittany.Internal.Transformations.Columns where
import Language.Haskell.Brittany.Internal.Prelude
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Types
import qualified Data.Generics.Uniplate.Direct as Uniplate import qualified Data.Generics.Uniplate.Direct as Uniplate
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types
transformSimplifyColumns :: BriDoc -> BriDoc transformSimplifyColumns :: BriDoc -> BriDoc
transformSimplifyColumns = Uniplate.rewrite $ \case transformSimplifyColumns = Uniplate.rewrite $ \case
@ -20,19 +14,35 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
-- BDWrapAnnKey annKey $ transformSimplify bd -- BDWrapAnnKey annKey $ transformSimplify bd
BDEmpty -> Nothing BDEmpty -> Nothing
BDLit{} -> Nothing BDLit{} -> Nothing
BDSeq list | any (\case BDSeq{} -> True BDSeq list
| any
(\case
BDSeq{} -> True
BDEmpty{} -> True BDEmpty{} -> True
_ -> False) list -> Just $ BDSeq $ list >>= \case _ -> False
)
list
-> Just $ BDSeq $ list >>= \case
BDEmpty -> [] BDEmpty -> []
BDSeq l -> l BDSeq l -> l
x -> [x] x -> [x]
BDSeq (BDCols sig1 cols1@(_ : _) : rest) BDSeq (BDCols sig1 cols1@(_ : _) : rest)
| all (\case BDSeparator -> True; _ -> False) rest -> | all
Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)]) (\case
BDLines lines | any (\case BDLines{} -> True BDSeparator -> True
_ -> False
)
rest
-> Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1 : rest)])
BDLines lines
| any
(\case
BDLines{} -> True
BDEmpty{} -> True BDEmpty{} -> True
_ -> False) lines -> _ -> False
Just $ BDLines $ filter isNotEmpty $ lines >>= \case )
lines
-> Just $ BDLines $ filter isNotEmpty $ lines >>= \case
BDLines l -> l BDLines l -> l
x -> [x] x -> [x]
-- prior floating in -- prior floating in
@ -44,17 +54,35 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr) Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr)
-- post floating in -- post floating in
BDAnnotationRest annKey1 (BDSeq list) -> BDAnnotationRest annKey1 (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] Just
$ BDSeq
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDLines list) -> BDAnnotationRest annKey1 (BDLines list) ->
Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] Just
$ BDLines
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDCols sig cols) -> BDAnnotationRest annKey1 (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] Just
$ BDCols sig
$ List.init cols
++ [BDAnnotationRest annKey1 $ List.last cols]
BDAnnotationKW annKey1 kw (BDSeq list) -> BDAnnotationKW annKey1 kw (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] Just
$ BDSeq
$ List.init list
++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDLines list) -> BDAnnotationKW annKey1 kw (BDLines list) ->
Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] Just
$ BDLines
$ List.init list
++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDCols sig cols) -> BDAnnotationKW annKey1 kw (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] Just
$ BDCols sig
$ List.init cols
++ [BDAnnotationKW annKey1 kw $ List.last cols]
-- ensureIndent float-in -- ensureIndent float-in
-- not sure if the following rule is necessary; tests currently are -- not sure if the following rule is necessary; tests currently are
-- unaffected. -- unaffected.
@ -64,48 +92,46 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
BDCols sig1 cols1@(_ : _) BDCols sig1 cols1@(_ : _)
| BDLines lines@(_ : _ : _) <- List.last cols1 | BDLines lines@(_ : _ : _) <- List.last cols1
, BDCols sig2 cols2 <- List.last lines , BDCols sig2 cols2 <- List.last lines
, sig1==sig2 -> , sig1 == sig2
Just $ BDLines -> Just $ BDLines
[ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines]
, BDCols sig2 cols2 , BDCols sig2 cols2
] ]
BDCols sig1 cols1@(_ : _) BDCols sig1 cols1@(_ : _)
| BDLines lines@(_ : _ : _) <- List.last cols1 | BDLines lines@(_ : _ : _) <- List.last cols1
, BDEnsureIndent _ (BDCols sig2 cols2) <- List.last lines , BDEnsureIndent _ (BDCols sig2 cols2) <- List.last lines
, sig1==sig2 -> , sig1 == sig2
Just $ BDLines -> Just $ BDLines
[ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines]
, BDCols sig2 cols2 , BDCols sig2 cols2
] ]
BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1 == sig2 -> BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1 == sig2 ->
Just $ BDAddBaseY ind (BDLines [col1, col2]) Just $ BDAddBaseY ind (BDLines [col1, col2])
BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _) : rest)) BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _) : rest))
| sig1==sig2 -> | sig1 == sig2 -> Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest)
Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest)
BDPar ind (BDLines lines1) col2@(BDCols sig2 _) BDPar ind (BDLines lines1) col2@(BDCols sig2 _)
| BDCols sig1 _ <- List.last lines1 | BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just
, sig1==sig2 -> $ BDAddBaseY ind (BDLines $ lines1 ++ [col2])
Just $ BDAddBaseY ind (BDLines $ lines1 ++ [col2])
BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _) : rest)) BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _) : rest))
| BDCols sig1 _ <- List.last lines1 | BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just
, sig1==sig2 -> $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest)
Just $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest)
-- BDPar ind1 (BDCols sig1 cols1) (BDPar ind2 line (BDCols sig2 cols2)) -- BDPar ind1 (BDCols sig1 cols1) (BDPar ind2 line (BDCols sig2 cols2))
-- | sig1==sig2 -> -- | sig1==sig2 ->
-- Just $ BDPar -- Just $ BDPar
-- ind1 -- ind1
-- (BDLines [BDCols sig1 cols1, BDCols sig]) -- (BDLines [BDCols sig1 cols1, BDCols sig])
BDCols sig1 cols | BDPar _ind line (BDCols sig2 cols2) <- List.last cols BDCols sig1 cols
, sig1==sig2 -> | BDPar _ind line (BDCols sig2 cols2) <- List.last cols, sig1 == sig2
Just $ BDLines -> Just
[ BDCols sig1 (List.init cols ++ [line]) $ BDLines [BDCols sig1 (List.init cols ++ [line]), BDCols sig2 cols2]
, BDCols sig2 cols2 BDCols sig1 cols
] | BDPar ind line (BDLines lines) <- List.last cols
BDCols sig1 cols | BDPar ind line (BDLines lines) <- List.last cols
, BDCols sig2 cols2 <- List.last lines , BDCols sig2 cols2 <- List.last lines
, sig1==sig2 -> , sig1 == sig2
Just $ BDLines -> Just $ BDLines
[ BDCols sig1 $ List.init cols ++ [BDPar ind line (BDLines $ List.init lines)] [ BDCols sig1
$ List.init cols
++ [BDPar ind line (BDLines $ List.init lines)]
, BDCols sig2 cols2 , BDCols sig2 cols2
] ]
BDLines [x] -> Just $ x BDLines [x] -> Just $ x

104
source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs
View File

@ -3,24 +3,19 @@
module Language.Haskell.Brittany.Internal.Transformations.Floating where module Language.Haskell.Brittany.Internal.Transformations.Floating where
import qualified Data.Generics.Uniplate.Direct as Uniplate
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import qualified Data.Generics.Uniplate.Direct as Uniplate
-- note that this is not total, and cannot be with that exact signature. -- note that this is not total, and cannot be with that exact signature.
mergeIndents :: BrIndent -> BrIndent -> BrIndent mergeIndents :: BrIndent -> BrIndent -> BrIndent
mergeIndents BrIndentNone x = x mergeIndents BrIndentNone x = x
mergeIndents x BrIndentNone = x mergeIndents x BrIndentNone = x
mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j) mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) =
BrIndentSpecial (max i j)
mergeIndents _ _ = error "mergeIndents" mergeIndents _ _ = error "mergeIndents"
@ -52,11 +47,20 @@ transformSimplifyFloating = stepBO .> stepFull
BDAnnotationRest annKey1 (BDPar ind line indented) -> BDAnnotationRest annKey1 (BDPar ind line indented) ->
Just $ BDPar ind line $ BDAnnotationRest annKey1 indented Just $ BDPar ind line $ BDAnnotationRest annKey1 indented
BDAnnotationRest annKey1 (BDSeq list) -> BDAnnotationRest annKey1 (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] Just
$ BDSeq
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDLines list) -> BDAnnotationRest annKey1 (BDLines list) ->
Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] Just
$ BDLines
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDCols sig cols) -> BDAnnotationRest annKey1 (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] Just
$ BDCols sig
$ List.init cols
++ [BDAnnotationRest annKey1 $ List.last cols]
BDAnnotationRest annKey1 (BDAddBaseY indent x) -> BDAnnotationRest annKey1 (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x
BDAnnotationRest annKey1 (BDDebug s x) -> BDAnnotationRest annKey1 (BDDebug s x) ->
@ -67,11 +71,20 @@ transformSimplifyFloating = stepBO .> stepFull
BDAnnotationKW annKey1 kw (BDPar ind line indented) -> BDAnnotationKW annKey1 kw (BDPar ind line indented) ->
Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented
BDAnnotationKW annKey1 kw (BDSeq list) -> BDAnnotationKW annKey1 kw (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] Just
$ BDSeq
$ List.init list
++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDLines list) -> BDAnnotationKW annKey1 kw (BDLines list) ->
Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] Just
$ BDLines
$ List.init list
++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDCols sig cols) -> BDAnnotationKW annKey1 kw (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] Just
$ BDCols sig
$ List.init cols
++ [BDAnnotationKW annKey1 kw $ List.last cols]
BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> BDAnnotationKW annKey1 kw (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x
BDAnnotationKW annKey1 kw (BDDebug s x) -> BDAnnotationKW annKey1 kw (BDDebug s x) ->
@ -80,36 +93,35 @@ transformSimplifyFloating = stepBO .> stepFull
descendBYPush = transformDownMay $ \case descendBYPush = transformDownMay $ \case
BDBaseYPushCur (BDCols sig cols@(_ : _)) -> BDBaseYPushCur (BDCols sig cols@(_ : _)) ->
Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols)
BDBaseYPushCur (BDDebug s x) -> BDBaseYPushCur (BDDebug s x) -> Just $ BDDebug s (BDBaseYPushCur x)
Just $ BDDebug s (BDBaseYPushCur x)
_ -> Nothing _ -> Nothing
descendBYPop = transformDownMay $ \case descendBYPop = transformDownMay $ \case
BDBaseYPop (BDCols sig cols@(_ : _)) -> BDBaseYPop (BDCols sig cols@(_ : _)) ->
Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)])
BDBaseYPop (BDDebug s x) -> BDBaseYPop (BDDebug s x) -> Just $ BDDebug s (BDBaseYPop x)
Just $ BDDebug s (BDBaseYPop x)
_ -> Nothing _ -> Nothing
descendILPush = transformDownMay $ \case descendILPush = transformDownMay $ \case
BDIndentLevelPushCur (BDCols sig cols@(_:_)) -> BDIndentLevelPushCur (BDCols sig cols@(_ : _)) -> Just
Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols)
BDIndentLevelPushCur (BDDebug s x) -> BDIndentLevelPushCur (BDDebug s x) ->
Just $ BDDebug s (BDIndentLevelPushCur x) Just $ BDDebug s (BDIndentLevelPushCur x)
_ -> Nothing _ -> Nothing
descendILPop = transformDownMay $ \case descendILPop = transformDownMay $ \case
BDIndentLevelPop (BDCols sig cols@(_ : _)) -> BDIndentLevelPop (BDCols sig cols@(_ : _)) ->
Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)])
BDIndentLevelPop (BDDebug s x) -> BDIndentLevelPop (BDDebug s x) -> Just $ BDDebug s (BDIndentLevelPop x)
Just $ BDDebug s (BDIndentLevelPop x)
_ -> Nothing _ -> Nothing
descendAddB = transformDownMay $ \case descendAddB = transformDownMay $ \case
BDAddBaseY BrIndentNone x -> BDAddBaseY BrIndentNone x -> Just x
Just x
-- AddIndent floats into Lines. -- AddIndent floats into Lines.
BDAddBaseY indent (BDLines lines) -> BDAddBaseY indent (BDLines lines) ->
Just $ BDLines $ BDAddBaseY indent <$> lines Just $ BDLines $ BDAddBaseY indent <$> lines
-- AddIndent floats into last column -- AddIndent floats into last column
BDAddBaseY indent (BDCols sig cols) -> BDAddBaseY indent (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] Just
$ BDCols sig
$ List.init cols
++ [BDAddBaseY indent $ List.last cols]
-- merge AddIndent and Par -- merge AddIndent and Par
BDAddBaseY ind1 (BDPar ind2 line indented) -> BDAddBaseY ind1 (BDPar ind2 line indented) ->
Just $ BDPar (mergeIndents ind1 ind2) line indented Just $ BDPar (mergeIndents ind1 ind2) line indented
@ -121,14 +133,11 @@ transformSimplifyFloating = stepBO .> stepFull
Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x)
BDAddBaseY ind (BDSeq list) -> BDAddBaseY ind (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]
BDAddBaseY _ lit@BDLit{} -> BDAddBaseY _ lit@BDLit{} -> Just $ lit
Just $ lit
BDAddBaseY ind (BDBaseYPushCur x) -> BDAddBaseY ind (BDBaseYPushCur x) ->
Just $ BDBaseYPushCur (BDAddBaseY ind x) Just $ BDBaseYPushCur (BDAddBaseY ind x)
BDAddBaseY ind (BDBaseYPop x) -> BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x)
Just $ BDBaseYPop (BDAddBaseY ind x) BDAddBaseY ind (BDDebug s x) -> Just $ BDDebug s (BDAddBaseY ind x)
BDAddBaseY ind (BDDebug s x) ->
Just $ BDDebug s (BDAddBaseY ind x)
BDAddBaseY ind (BDIndentLevelPop x) -> BDAddBaseY ind (BDIndentLevelPop x) ->
Just $ BDIndentLevelPop (BDAddBaseY ind x) Just $ BDIndentLevelPop (BDAddBaseY ind x)
BDAddBaseY ind (BDIndentLevelPushCur x) -> BDAddBaseY ind (BDIndentLevelPushCur x) ->
@ -152,25 +161,25 @@ transformSimplifyFloating = stepBO .> stepFull
x -> x x -> x
stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $
Uniplate.rewrite $ \case Uniplate.rewrite $ \case
BDAddBaseY BrIndentNone x -> BDAddBaseY BrIndentNone x -> Just $ x
Just $ x
-- AddIndent floats into Lines. -- AddIndent floats into Lines.
BDAddBaseY indent (BDLines lines) -> BDAddBaseY indent (BDLines lines) ->
Just $ BDLines $ BDAddBaseY indent <$> lines Just $ BDLines $ BDAddBaseY indent <$> lines
-- AddIndent floats into last column -- AddIndent floats into last column
BDAddBaseY indent (BDCols sig cols) -> BDAddBaseY indent (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] Just
$ BDCols sig
$ List.init cols
++ [BDAddBaseY indent $ List.last cols]
BDAddBaseY ind (BDSeq list) -> BDAddBaseY ind (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]
-- merge AddIndent and Par -- merge AddIndent and Par
BDAddBaseY ind1 (BDPar ind2 line indented) -> BDAddBaseY ind1 (BDPar ind2 line indented) ->
Just $ BDPar (mergeIndents ind1 ind2) line indented Just $ BDPar (mergeIndents ind1 ind2) line indented
BDAddBaseY _ lit@BDLit{} -> BDAddBaseY _ lit@BDLit{} -> Just $ lit
Just $ lit
BDAddBaseY ind (BDBaseYPushCur x) -> BDAddBaseY ind (BDBaseYPushCur x) ->
Just $ BDBaseYPushCur (BDAddBaseY ind x) Just $ BDBaseYPushCur (BDAddBaseY ind x)
BDAddBaseY ind (BDBaseYPop x) -> BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x)
Just $ BDBaseYPop (BDAddBaseY ind x)
-- prior floating in -- prior floating in
BDAnnotationPrior annKey1 (BDPar ind line indented) -> BDAnnotationPrior annKey1 (BDPar ind line indented) ->
Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented
@ -191,9 +200,18 @@ transformSimplifyFloating = stepBO .> stepFull
BDAnnotationRest annKey1 (BDPar ind line indented) -> BDAnnotationRest annKey1 (BDPar ind line indented) ->
Just $ BDPar ind line $ BDAnnotationRest annKey1 indented Just $ BDPar ind line $ BDAnnotationRest annKey1 indented
BDAnnotationRest annKey1 (BDSeq list) -> BDAnnotationRest annKey1 (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] Just
$ BDSeq
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDLines list) -> BDAnnotationRest annKey1 (BDLines list) ->
Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] Just
$ BDLines
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDCols sig cols) -> BDAnnotationRest annKey1 (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] Just
$ BDCols sig
$ List.init cols
++ [BDAnnotationRest annKey1 $ List.last cols]
_ -> Nothing _ -> Nothing

20
source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs
View File

@ -3,16 +3,10 @@
module Language.Haskell.Brittany.Internal.Transformations.Indent where module Language.Haskell.Brittany.Internal.Transformations.Indent where
import Language.Haskell.Brittany.Internal.Prelude
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Types
import qualified Data.Generics.Uniplate.Direct as Uniplate import qualified Data.Generics.Uniplate.Direct as Uniplate
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types
-- prepare layouting by translating BDPar's, replacing them with Indents and -- prepare layouting by translating BDPar's, replacing them with Indents and
-- floating those in. This gives a more clear picture of what exactly is -- floating those in. This gives a more clear picture of what exactly is
@ -31,13 +25,15 @@ transformSimplifyIndent = Uniplate.rewrite $ \case
-- [ BDAddBaseY ind x -- [ BDAddBaseY ind x
-- , BDEnsureIndent ind indented -- , BDEnsureIndent ind indented
-- ] -- ]
BDLines lines | any ( \case BDLines lines
| any
(\case
BDLines{} -> True BDLines{} -> True
BDEmpty{} -> True BDEmpty{} -> True
_ -> False _ -> False
) )
lines -> lines
Just $ BDLines $ filter isNotEmpty $ lines >>= \case -> Just $ BDLines $ filter isNotEmpty $ lines >>= \case
BDLines l -> l BDLines l -> l
x -> [x] x -> [x]
BDLines [l] -> Just l BDLines [l] -> Just l

14
source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs
View File

@ -3,14 +3,9 @@
module Language.Haskell.Brittany.Internal.Transformations.Par where module Language.Haskell.Brittany.Internal.Transformations.Par where
import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
transformSimplifyPar :: BriDoc -> BriDoc transformSimplifyPar :: BriDoc -> BriDoc
transformSimplifyPar = transformUp $ \case transformSimplifyPar = transformUp $ \case
@ -24,12 +19,15 @@ transformSimplifyPar = transformUp $ \case
BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds)) BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds))
BDPar ind1 (BDPar ind2 line p1) p2 -> BDPar ind1 (BDPar ind2 line p1) p2 ->
BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2]) BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2])
BDLines lines | any ( \case BDLines lines
| any
(\case
BDLines{} -> True BDLines{} -> True
BDEmpty{} -> True BDEmpty{} -> True
_ -> False _ -> False
) )
lines -> case go lines of lines
-> case go lines of
[] -> BDEmpty [] -> BDEmpty
[x] -> x [x] -> x
xs -> BDLines xs xs -> BDLines xs

82
source/library/Language/Haskell/Brittany/Internal/Types.hs
View File

@ -12,31 +12,20 @@
module Language.Haskell.Brittany.Internal.Types where module Language.Haskell.Brittany.Internal.Types where
import Language.Haskell.Brittany.Internal.Prelude
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import qualified Data.Data import qualified Data.Data
import qualified Data.Strict.Maybe as Strict
import qualified Safe
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Data.Text.Lazy.Builder as Text.Builder
import GHC ( Located, GenLocated, AnnKeywordId, SrcSpan )
import Language.Haskell.GHC.ExactPrint ( AnnKey )
import Language.Haskell.GHC.ExactPrint.Types ( Anns )
import Language.Haskell.Brittany.Internal.Config.Types
import Data.Generics.Uniplate.Direct as Uniplate import Data.Generics.Uniplate.Direct as Uniplate
import qualified Data.Kind as Kind import qualified Data.Kind as Kind
import qualified Data.Strict.Maybe as Strict
import qualified Data.Text.Lazy.Builder as Text.Builder
import GHC (AnnKeywordId, GenLocated, Located, SrcSpan)
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import Language.Haskell.GHC.ExactPrint (AnnKey)
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Types (Anns)
import qualified Safe
data PerItemConfig = PerItemConfig data PerItemConfig = PerItemConfig
{ _icd_perBinding :: Map String (CConfig Maybe) { _icd_perBinding :: Map String (CConfig Maybe)
@ -44,12 +33,18 @@ data PerItemConfig = PerItemConfig
} }
deriving Data.Data.Data deriving Data.Data.Data
type PPM = MultiRWSS.MultiRWS type PPM
'[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns] = MultiRWSS.MultiRWS
'[ Map ExactPrint.AnnKey ExactPrint.Anns
, PerItemConfig
, Config
, ExactPrint.Anns
]
'[Text.Builder.Builder , [BrittanyError] , Seq String] '[Text.Builder.Builder , [BrittanyError] , Seq String]
'[] '[]
type PPMLocal = MultiRWSS.MultiRWS type PPMLocal
= MultiRWSS.MultiRWS
'[Config , ExactPrint.Anns] '[Config , ExactPrint.Anns]
'[Text.Builder.Builder , [BrittanyError] , Seq String] '[Text.Builder.Builder , [BrittanyError] , Seq String]
'[] '[]
@ -115,13 +110,20 @@ lstate_indLevel = Safe.headNote "lstate_baseY" . _lstate_indLevels
instance Show LayoutState where instance Show LayoutState where
show state = show state =
"LayoutState" "LayoutState"
++ "{baseYs=" ++ show (_lstate_baseYs state) ++ "{baseYs="
++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state) ++ show (_lstate_baseYs state)
++ ",indLevels=" ++ show (_lstate_indLevels state) ++ ",curYOrAddNewline="
++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state) ++ show (_lstate_curYOrAddNewline state)
++ ",commentCol=" ++ show (_lstate_commentCol state) ++ ",indLevels="
++ ",addSepSpace=" ++ show (_lstate_addSepSpace state) ++ show (_lstate_indLevels state)
++ ",commentNewlines=" ++ show (_lstate_commentNewlines state) ++ ",indLevelLinger="
++ show (_lstate_indLevelLinger state)
++ ",commentCol="
++ show (_lstate_commentCol state)
++ ",addSepSpace="
++ show (_lstate_addSepSpace state)
++ ",commentNewlines="
++ show (_lstate_commentNewlines state)
++ "}" ++ "}"
-- data NewLineState = NewLineStateInit -- initial state. we do not know if in a -- data NewLineState = NewLineStateInit -- initial state. we do not know if in a
@ -223,12 +225,14 @@ data BrIndent = BrIndentNone
| BrIndentSpecial Int | BrIndentSpecial Int
deriving (Eq, Ord, Data.Data.Data, Show) deriving (Eq, Ord, Data.Data.Data, Show)
type ToBriDocM = MultiRWSS.MultiRWS type ToBriDocM
= MultiRWSS.MultiRWS
'[Config , Anns] -- reader '[Config , Anns] -- reader
'[[BrittanyError] , Seq String] -- writer '[[BrittanyError] , Seq String] -- writer
'[NodeAllocIndex] -- state '[NodeAllocIndex] -- state
type ToBriDoc (sym :: Kind.Type -> Kind.Type) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered type ToBriDoc (sym :: Kind.Type -> Kind.Type)
= Located (sym GhcPs) -> ToBriDocM BriDocNumbered
type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered
type ToBriDocC sym c = Located sym -> ToBriDocM c type ToBriDocC sym c = Located sym -> ToBriDocM c
@ -421,7 +425,8 @@ briDocSeqSpine = \case
BDBaseYPop bd -> briDocSeqSpine bd BDBaseYPop bd -> briDocSeqSpine bd
BDIndentLevelPushCur bd -> briDocSeqSpine bd BDIndentLevelPushCur bd -> briDocSeqSpine bd
BDIndentLevelPop bd -> briDocSeqSpine bd BDIndentLevelPop bd -> briDocSeqSpine bd
BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented BDPar _ind line indented ->
briDocSeqSpine line `seq` briDocSeqSpine indented
BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts
BDForwardLineMode bd -> briDocSeqSpine bd BDForwardLineMode bd -> briDocSeqSpine bd
BDExternal{} -> () BDExternal{} -> ()
@ -456,8 +461,7 @@ data VerticalSpacingPar
-- product like (Normal|Always, None|Some Int). -- product like (Normal|Always, None|Some Int).
deriving (Eq, Show) deriving (Eq, Show)
data VerticalSpacing data VerticalSpacing = VerticalSpacing
= VerticalSpacing
{ _vs_sameLine :: !Int { _vs_sameLine :: !Int
, _vs_paragraph :: !VerticalSpacingPar , _vs_paragraph :: !VerticalSpacingPar
, _vs_parFlag :: !Bool , _vs_parFlag :: !Bool
@ -468,6 +472,8 @@ newtype LineModeValidity a = LineModeValidity (Strict.Maybe a)
deriving (Functor, Applicative, Monad, Show, Alternative) deriving (Functor, Applicative, Monad, Show, Alternative)
pattern LineModeValid :: forall t . t -> LineModeValidity t pattern LineModeValid :: forall t . t -> LineModeValidity t
pattern LineModeValid x = LineModeValidity (Strict.Just x) :: LineModeValidity t pattern LineModeValid x =
LineModeValidity (Strict.Just x) :: LineModeValidity t
pattern LineModeInvalid :: forall t . LineModeValidity t pattern LineModeInvalid :: forall t . LineModeValidity t
pattern LineModeInvalid = LineModeValidity Strict.Nothing :: LineModeValidity t pattern LineModeInvalid =
LineModeValidity Strict.Nothing :: LineModeValidity t

83
source/library/Language/Haskell/Brittany/Internal/Utils.hs
View File

@ -7,39 +7,28 @@
module Language.Haskell.Brittany.Internal.Utils where module Language.Haskell.Brittany.Internal.Utils where
import qualified Data.ByteString as B
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Coerce import qualified Data.Coerce
import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq
import qualified GHC.OldList as List
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
import Data.Data import Data.Data
import Data.Generics.Aliases import Data.Generics.Aliases
import qualified Text.PrettyPrint as PP
import qualified GHC.Utils.Outputable as GHC
import qualified GHC.Driver.Session as GHC
import qualified GHC.Data.FastString as GHC
import qualified GHC.Types.SrcLoc as GHC
import GHC.Types.Name.Occurrence as OccName ( occNameString )
import qualified Data.ByteString as B
import DataTreePrint
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types
import qualified Data.Generics.Uniplate.Direct as Uniplate import qualified Data.Generics.Uniplate.Direct as Uniplate
import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq
import DataTreePrint
import qualified GHC.Data.FastString as GHC
import qualified GHC.Driver.Session as GHC
import qualified GHC.Hs.Extension as HsExtension import qualified GHC.Hs.Extension as HsExtension
import qualified GHC.OldList as List
import GHC.Types.Name.Occurrence as OccName (occNameString)
import qualified GHC.Types.SrcLoc as GHC
import qualified GHC.Utils.Outputable as GHC
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
import qualified Text.PrettyPrint as PP
parDoc :: String -> PP.Doc parDoc :: String -> PP.Doc
parDoc = PP.fsep . fmap PP.text . List.words parDoc = PP.fsep . fmap PP.text . List.words
@ -55,7 +44,8 @@ showOutputable :: (GHC.Outputable a) => a -> String
showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags
fromMaybeIdentity :: Identity a -> Maybe a -> Identity a fromMaybeIdentity :: Identity a -> Maybe a -> Identity a
fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y fromMaybeIdentity x y =
Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y
fromOptionIdentity :: Identity a -> Maybe a -> Identity a fromOptionIdentity :: Identity a -> Maybe a -> Identity a
fromOptionIdentity x y = fromOptionIdentity x y =
@ -75,9 +65,11 @@ instance (Num a, Ord a) => Monoid (Max a) where
newtype ShowIsId = ShowIsId String deriving Data newtype ShowIsId = ShowIsId String deriving Data
instance Show ShowIsId where show (ShowIsId x) = x instance Show ShowIsId where
show (ShowIsId x) = x
data A x = A ShowIsId x deriving Data data A x = A ShowIsId x
deriving Data
customLayouterF :: ExactPrint.Types.Anns -> LayouterF customLayouterF :: ExactPrint.Types.Anns -> LayouterF
customLayouterF anns layoutF = customLayouterF anns layoutF =
@ -102,11 +94,15 @@ customLayouterF anns layoutF =
simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString
-> NodeLayouter -> NodeLayouter
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString occName =
simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString
srcSpan :: GHC.SrcSpan -> NodeLayouter srcSpan :: GHC.SrcSpan -> NodeLayouter
srcSpan ss = simpleLayouter srcSpan ss =
simpleLayouter
-- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}" -- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}"
$ "{" ++ showOutputable ss ++ "}" $ "{"
++ showOutputable ss
++ "}"
located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter
located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a
where where
@ -138,7 +134,8 @@ customLayouterNoAnnsF layoutF =
simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString
-> NodeLayouter -> NodeLayouter
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString occName =
simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString
srcSpan :: GHC.SrcSpan -> NodeLayouter srcSpan :: GHC.SrcSpan -> NodeLayouter
srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}" srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}"
located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter
@ -202,12 +199,11 @@ traceIfDumpConf s accessor val = do
whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do
trace ("---- " ++ s ++ " ----\n" ++ show val) $ return () trace ("---- " ++ s ++ " ----\n" ++ show val) $ return ()
tellDebugMess :: MonadMultiWriter tellDebugMess :: MonadMultiWriter (Seq String) m => String -> m ()
(Seq String) m => String -> m ()
tellDebugMess s = mTell $ Seq.singleton s tellDebugMess s = mTell $ Seq.singleton s
tellDebugMessShow :: forall a m . (MonadMultiWriter tellDebugMessShow
(Seq String) m, Show a) => a -> m () :: forall a m . (MonadMultiWriter (Seq String) m, Show a) => a -> m ()
tellDebugMessShow = tellDebugMess . show tellDebugMessShow = tellDebugMess . show
-- i should really put that into multistate.. -- i should really put that into multistate..
@ -230,20 +226,19 @@ briDocToDocWithAnns :: BriDoc -> PP.Doc
briDocToDocWithAnns = astToDoc briDocToDocWithAnns = astToDoc
annsDoc :: ExactPrint.Types.Anns -> PP.Doc annsDoc :: ExactPrint.Types.Anns -> PP.Doc
annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) annsDoc =
printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show)
breakEither :: (a -> Either b c) -> [a] -> ([b], [c]) breakEither :: (a -> Either b c) -> [a] -> ([b], [c])
breakEither _ [] = ([], []) breakEither _ [] = ([], [])
breakEither fn (a1 : aR) = case fn a1 of breakEither fn (a1 : aR) = case fn a1 of
Left b -> (b : bs, cs) Left b -> (b : bs, cs)
Right c -> (bs, c : cs) Right c -> (bs, c : cs)
where where (bs, cs) = breakEither fn aR
(bs, cs) = breakEither fn aR
spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])
spanMaybe f (x1 : xR) | Just y <- f x1 = (y : ys, xs) spanMaybe f (x1 : xR) | Just y <- f x1 = (y : ys, xs)
where where (ys, xs) = spanMaybe f xR
(ys, xs) = spanMaybe f xR
spanMaybe _ xs = ([], xs) spanMaybe _ xs = ([], xs)
data FirstLastView a data FirstLastView a

124
source/library/Language/Haskell/Brittany/Main.hs
View File

@ -4,58 +4,41 @@
module Language.Haskell.Brittany.Main where module Language.Haskell.Brittany.Main where
import Control.Monad (zipWithM)
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Control.Monad.Trans.Except as ExceptT import qualified Control.Monad.Trans.Except as ExceptT
import Data.CZipWith
import qualified Data.Either import qualified Data.Either
import qualified Data.List.Extra import qualified Data.List.Extra
import qualified Data.Monoid
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO import qualified Data.Text.IO as Text.IO
import qualified Data.Text.Lazy as TextL import qualified Data.Text.Lazy as TextL
import qualified GHC.OldList as List import DataTreePrint
import qualified System.IO
-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 }
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Data.Monoid
import GHC (GenLocated(L)) import GHC (GenLocated(L))
import GHC.Utils.Outputable ( Outputable(..) import qualified GHC.Driver.Session as GHC
, showSDocUnsafe import qualified GHC.LanguageExtensions.Type as GHC
) import qualified GHC.OldList as List
import GHC.Utils.Outputable (Outputable(..), showSDocUnsafe)
import Text.Read ( Read(..) )
import qualified Text.ParserCombinators.ReadP as ReadP
import qualified Text.ParserCombinators.ReadPrec as ReadPrec
import Control.Monad ( zipWithM )
import Data.CZipWith
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal import Language.Haskell.Brittany.Internal
import Language.Haskell.Brittany.Internal.Config import Language.Haskell.Brittany.Internal.Config
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Obfuscation import Language.Haskell.Brittany.Internal.Obfuscation
import Language.Haskell.Brittany.Internal.Prelude
import qualified Text.PrettyPrint as PP import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import DataTreePrint import Language.Haskell.Brittany.Internal.Utils
import UI.Butcher.Monadic import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified System.Exit
import qualified System.Directory as Directory
import qualified System.FilePath.Posix as FilePath
import qualified GHC.Driver.Session as GHC
import qualified GHC.LanguageExtensions.Type as GHC
import Paths_brittany import Paths_brittany
import qualified System.Directory as Directory
import qualified System.Exit
import qualified System.FilePath.Posix as FilePath
import qualified System.IO
import qualified Text.ParserCombinators.ReadP as ReadP
import qualified Text.ParserCombinators.ReadPrec as ReadPrec
import qualified Text.PrettyPrint as PP
import Text.Read (Read(..))
import UI.Butcher.Monadic
data WriteMode = Display | Inplace data WriteMode = Display | Inplace
@ -151,7 +134,8 @@ mainCmdParser helpDesc = do
printVersion <- addSimpleBoolFlag "" ["version"] mempty printVersion <- addSimpleBoolFlag "" ["version"] mempty
printLicense <- addSimpleBoolFlag "" ["license"] mempty printLicense <- addSimpleBoolFlag "" ["license"] mempty
noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty
configPaths <- addFlagStringParams "" configPaths <- addFlagStringParams
""
["config-file"] ["config-file"]
"PATH" "PATH"
(flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?
@ -211,9 +195,11 @@ mainCmdParser helpDesc = do
$ ppHelpShallow helpDesc $ ppHelpShallow helpDesc
System.Exit.exitSuccess System.Exit.exitSuccess
let inputPaths = let
inputPaths =
if null inputParams then [Nothing] else map Just inputParams if null inputParams then [Nothing] else map Just inputParams
let outputPaths = case writeMode of let
outputPaths = case writeMode of
Display -> repeat Nothing Display -> repeat Nothing
Inplace -> inputPaths Inplace -> inputPaths
@ -235,7 +221,8 @@ mainCmdParser helpDesc = do
$ trace (showConfigYaml config) $ trace (showConfigYaml config)
$ return () $ return ()
results <- zipWithM (coreIO putStrErrLn config suppressOutput checkMode) results <- zipWithM
(coreIO putStrErrLn config suppressOutput checkMode)
inputPaths inputPaths
outputPaths outputPaths
@ -266,7 +253,8 @@ coreIO
-> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status. -> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status.
coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
ExceptT.runExceptT $ do ExceptT.runExceptT $ do
let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () let
putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO ()
let ghcOptions = config & _conf_forward & _options_ghc & runIdentity let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
-- there is a good of code duplication between the following code and the -- there is a good of code duplication between the following code and the
-- `pureModuleTransform` function. Unfortunately, there are also a good -- `pureModuleTransform` function. Unfortunately, there are also a good
@ -280,15 +268,18 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
-- string from the transformation output. -- string from the transformation output.
-- The flag is intentionally misspelled to prevent clashing with -- The flag is intentionally misspelled to prevent clashing with
-- inline-config stuff. -- inline-config stuff.
let hackAroundIncludes = let
hackAroundIncludes =
config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack
let exactprintOnly = viaGlobal || viaDebug let
exactprintOnly = viaGlobal || viaDebug
where where
viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack
viaDebug = viaDebug =
config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack
let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags let
cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
then case cppMode of then case cppMode of
CPPModeAbort -> do CPPModeAbort -> do
return $ Left "Encountered -XCPP. Aborting." return $ Left "Encountered -XCPP. Aborting."
@ -304,14 +295,17 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
(parseResult, originalContents) <- case inputPathM of (parseResult, originalContents) <- case inputPathM of
Nothing -> do Nothing -> do
-- TODO: refactor this hack to not be mixed into parsing logic -- TODO: refactor this hack to not be mixed into parsing logic
let hackF s = if "#include" `isPrefixOf` s let
hackF s = if "#include" `isPrefixOf` s
then "-- BRITANY_INCLUDE_HACK " ++ s then "-- BRITANY_INCLUDE_HACK " ++ s
else s else s
let hackTransform = if hackAroundIncludes && not exactprintOnly let
hackTransform = if hackAroundIncludes && not exactprintOnly
then List.intercalate "\n" . fmap hackF . lines' then List.intercalate "\n" . fmap hackF . lines'
else id else id
inputString <- liftIO System.IO.getContents inputString <- liftIO System.IO.getContents
parseRes <- liftIO $ parseModuleFromString ghcOptions parseRes <- liftIO $ parseModuleFromString
ghcOptions
"stdin" "stdin"
cppCheckFunc cppCheckFunc
(hackTransform inputString) (hackTransform inputString)
@ -346,9 +340,11 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
pure c pure c
let moduleConf = cZipWith fromOptionIdentity config inlineConf let moduleConf = cZipWith fromOptionIdentity config inlineConf
when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do
let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource let
val = printTreeWithCustom 100 (customLayouterF anns) parsedSource
trace ("---- ast ----\n" ++ show val) $ return () trace ("---- ast ----\n" ++ show val) $ return ()
let disableFormatting = let
disableFormatting =
moduleConf & _conf_disable_formatting & confUnpack moduleConf & _conf_disable_formatting & confUnpack
(errsWarns, outSText, hasChanges) <- do (errsWarns, outSText, hasChanges) <- do
if if
@ -358,7 +354,8 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
let r = Text.pack $ ExactPrint.exactPrint parsedSource anns let r = Text.pack $ ExactPrint.exactPrint parsedSource anns
pure ([], r, r /= originalContents) pure ([], r, r /= originalContents)
| otherwise -> do | otherwise -> do
let omitCheck = let
omitCheck =
moduleConf moduleConf
& _conf_errorHandling & _conf_errorHandling
.> _econf_omit_output_valid_check .> _econf_omit_output_valid_check
@ -366,14 +363,17 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
(ews, outRaw) <- if hasCPP || omitCheck (ews, outRaw) <- if hasCPP || omitCheck
then return then return
$ pPrintModule moduleConf perItemConf anns parsedSource $ pPrintModule moduleConf perItemConf anns parsedSource
else liftIO $ pPrintModuleAndCheck moduleConf else liftIO $ pPrintModuleAndCheck
moduleConf
perItemConf perItemConf
anns anns
parsedSource parsedSource
let hackF s = fromMaybe s $ TextL.stripPrefix let
hackF s = fromMaybe s $ TextL.stripPrefix
(TextL.pack "-- BRITANY_INCLUDE_HACK ") (TextL.pack "-- BRITANY_INCLUDE_HACK ")
s s
let out = TextL.toStrict $ if hackAroundIncludes let
out = TextL.toStrict $ if hackAroundIncludes
then then
TextL.intercalate (TextL.pack "\n") TextL.intercalate (TextL.pack "\n")
$ hackF $ hackF
@ -383,14 +383,16 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
then lift $ obfuscate out then lift $ obfuscate out
else pure out else pure out
pure $ (ews, out', out' /= originalContents) pure $ (ews, out', out' /= originalContents)
let customErrOrder ErrorInput{} = 4 let
customErrOrder ErrorInput{} = 4
customErrOrder LayoutWarning{} = -1 :: Int customErrOrder LayoutWarning{} = -1 :: Int
customErrOrder ErrorOutputCheck{} = 1 customErrOrder ErrorOutputCheck{} = 1
customErrOrder ErrorUnusedComment{} = 2 customErrOrder ErrorUnusedComment{} = 2
customErrOrder ErrorUnknownNode{} = -2 :: Int customErrOrder ErrorUnknownNode{} = -2 :: Int
customErrOrder ErrorMacroConfig{} = 5 customErrOrder ErrorMacroConfig{} = 5
unless (null errsWarns) $ do unless (null errsWarns) $ do
let groupedErrsWarns = let
groupedErrsWarns =
Data.List.Extra.groupOn customErrOrder Data.List.Extra.groupOn customErrOrder
$ List.sortOn customErrOrder $ List.sortOn customErrOrder
$ errsWarns $ errsWarns
@ -406,7 +408,8 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
$ "WARNING: encountered unknown syntactical constructs:" $ "WARNING: encountered unknown syntactical constructs:"
uns `forM_` \case uns `forM_` \case
ErrorUnknownNode str ast@(L loc _) -> do ErrorUnknownNode str ast@(L loc _) -> do
putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc) putErrorLn $ " " <> str <> " at " <> showSDocUnsafe
(ppr loc)
when when
(config (config
& _conf_debug & _conf_debug
@ -460,7 +463,8 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
$ case outputPathM of $ case outputPathM of
Nothing -> liftIO $ Text.IO.putStr $ outSText Nothing -> liftIO $ Text.IO.putStr $ outSText
Just p -> liftIO $ do Just p -> liftIO $ do
let isIdentical = case inputPathM of let
isIdentical = case inputPathM of
Nothing -> False Nothing -> False
Just _ -> not hasChanges Just _ -> not hasChanges
unless isIdentical $ Text.IO.writeFile p $ outSText unless isIdentical $ Text.IO.writeFile p $ outSText

54
source/test-suite/Main.hs
View File

@ -2,36 +2,25 @@
{-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
import Language.Haskell.Brittany.Internal.Prelude import Data.Coerce (coerce)
import Data.List (groupBy)
import qualified Data.Maybe import qualified Data.Maybe
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import qualified GHC.OldList as List import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal
import Language.Haskell.Brittany.Internal.Config
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified System.Directory import qualified System.Directory
import System.FilePath ((</>))
import System.Timeout (timeout)
import Test.Hspec import Test.Hspec
import qualified Text.Parsec as Parsec import qualified Text.Parsec as Parsec
import Text.Parsec.Text (Parser) import Text.Parsec.Text (Parser)
import Data.List ( groupBy )
import Language.Haskell.Brittany.Internal
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Config
import Data.Coerce ( coerce )
import qualified Data.Text.IO as Text.IO
import System.FilePath ( (</>) )
import System.Timeout ( timeout )
import Language.Haskell.Brittany.Internal.PreludeUtils
hush :: Either a b -> Maybe b hush :: Either a b -> Maybe b
hush = either (const Nothing) Just hush = either (const Nothing) Just
@ -47,8 +36,7 @@ asymptoticPerfTest = do
$ roundTripEqualWithTimeout 4000000 $ roundTripEqualWithTimeout 4000000
$ (Text.pack "func = ") $ (Text.pack "func = ")
<> mconcat <> mconcat
( [1 .. 10] ([1 .. 10] <&> \(i :: Int) ->
<&> \(i :: Int) ->
(Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n") (Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n")
) )
<> Text.replicate 2000 (Text.pack " ") <> Text.replicate 2000 (Text.pack " ")
@ -64,7 +52,8 @@ roundTripEqualWithTimeout :: Int -> Text -> Expectation
roundTripEqualWithTimeout time t = roundTripEqualWithTimeout time t =
timeout time (action >>= evaluate) >>= (`shouldSatisfy` Data.Maybe.isJust) timeout time (action >>= evaluate) >>= (`shouldSatisfy` Data.Maybe.isJust)
where where
action = fmap (fmap PPTextWrapper) action = fmap
(fmap PPTextWrapper)
(parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t) (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t)
@ -85,7 +74,8 @@ data TestCase = TestCase
main :: IO () main :: IO ()
main = do main = do
files <- System.Directory.listDirectory "data/" files <- System.Directory.listDirectory "data/"
let blts = let
blts =
List.sort List.sort
$ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x)) $ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x))
$ filter (".blt" `isSuffixOf`) files $ filter (".blt" `isSuffixOf`) files
@ -99,8 +89,10 @@ main = do
it "gives properly formatted result for valid input" $ do it "gives properly formatted result for valid input" $ do
let let
input = Text.pack $ unlines input = Text.pack $ unlines
["func = [00000000000000000000000, 00000000000000000000000, 00000000000000000000000, 00000000000000000000000]"] [ "func = [00000000000000000000000, 00000000000000000000000, 00000000000000000000000, 00000000000000000000000]"
let expected = Text.pack $ unlines ]
let
expected = Text.pack $ unlines
[ "func =" [ "func ="
, " [ 00000000000000000000000" , " [ 00000000000000000000000"
, " , 00000000000000000000000" , " , 00000000000000000000000"
@ -154,13 +146,16 @@ main = do
testProcessor = \case testProcessor = \case
HeaderLine n : rest -> HeaderLine n : rest ->
let normalLines = Data.Maybe.mapMaybe extractNormal rest let normalLines = Data.Maybe.mapMaybe extractNormal rest
in TestCase in
TestCase
{ testName = n { testName = n
, isPending = any isPendingLine rest , isPending = any isPendingLine rest
, content = Text.unlines normalLines , content = Text.unlines normalLines
} }
l -> l ->
error $ "first non-empty line must start with #test footest\n" ++ show l error
$ "first non-empty line must start with #test footest\n"
++ show l
extractNormal (NormalLine l) = Just l extractNormal (NormalLine l) = Just l
extractNormal _ = Nothing extractNormal _ = Nothing
isPendingLine PendingLine{} = True isPendingLine PendingLine{} = True
@ -225,7 +220,6 @@ instance Show PPTextWrapper where
show (PPTextWrapper t) = "\n" ++ Text.unpack t show (PPTextWrapper t) = "\n" ++ Text.unpack t
-- brittany-next-binding --columns 160 -- brittany-next-binding --columns 160
-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft }
defaultTestConfig :: Config defaultTestConfig :: Config
defaultTestConfig = Config defaultTestConfig = Config
{ _conf_version = _conf_version staticDefaultConfig { _conf_version = _conf_version staticDefaultConfig