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

Revert "Format Brittany with Brittany" 

This reverts commit 4398b5880d.
pull/357/head
Taylor Fausak 2021-11-07 12:37:49 +00:00 committed by GitHub
parent 4398b5880d
commit 4079981b1d
33 changed files with 4804 additions and 4693 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
brittany.yaml
View File

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

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

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

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

@ -12,52 +12,68 @@ module Language.Haskell.Brittany.Internal
, parseModuleFromString
, extractCommentConfigs
, 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 Data.ByteString.Char8
import Data.CZipWith
import Data.Char (isSpace)
import Data.HList.HList
import qualified Data.Map as Map
import qualified Data.Maybe
import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TextL
import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Data.Yaml
import qualified GHC hiding (parseModule)
import GHC (GenLocated(L))
import GHC.Data.Bag
import qualified GHC.Driver.Session as GHC
import GHC.Hs
import qualified GHC.LanguageExtensions.Type as GHC
import qualified GHC.OldList as List
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
-- 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 qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified UI.Butcher.Monadic as Butcher
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 Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Config.Types
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 qualified GHC.Driver.Session as GHC
import qualified GHC.LanguageExtensions.Type as GHC
import Data.Char ( isSpace )
data InlineConfigTarget
= InlineConfigTargetModule
@ -75,36 +91,35 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
[ ( k
, [ x
| (ExactPrint.Comment x _ _, _) <-
(ExactPrint.annPriorComments ann
( ExactPrint.annPriorComments ann
++ ExactPrint.annFollowingComments ann
)
]
++ [ x
| (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <-
ExactPrint.annsDP ann
]
++ [ x
| (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <-
ExactPrint.annsDP ann
]
)
| (k, ann) <- Map.toList anns
]
let
configLiness = commentLiness <&> second
(Data.Maybe.mapMaybe $ \line -> do
l1 <-
List.stripPrefix "-- BRITTANY" line
<|> List.stripPrefix "--BRITTANY" line
<|> List.stripPrefix "-- brittany" line
<|> List.stripPrefix "--brittany" line
<|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}")
let l2 = dropWhile isSpace l1
guard
(("@" `isPrefixOf` l2)
|| ("-disable" `isPrefixOf` l2)
|| ("-next" `isPrefixOf` l2)
|| ("{" `isPrefixOf` l2)
|| ("--" `isPrefixOf` l2)
)
pure l2
)
let configLiness = commentLiness <&> second
(Data.Maybe.mapMaybe $ \line -> do
l1 <-
List.stripPrefix "-- BRITTANY" line
<|> List.stripPrefix "--BRITTANY" line
<|> List.stripPrefix "-- brittany" line
<|> List.stripPrefix "--brittany" line
<|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}")
let l2 = dropWhile isSpace l1
guard
( ("@" `isPrefixOf` l2)
|| ("-disable" `isPrefixOf` l2)
|| ("-next" `isPrefixOf` l2)
|| ("{" `isPrefixOf` l2)
|| ("--" `isPrefixOf` l2)
)
pure l2
)
let
configParser = Butcher.addAlternatives
[ ( "commandline-config"
@ -123,44 +138,39 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
]
parser = do -- we will (mis?)use butcher here to parse the inline config
-- line.
let
nextDecl = do
conf <- configParser
Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf)
let nextDecl = do
conf <- configParser
Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf)
Butcher.addCmd "-next-declaration" nextDecl
Butcher.addCmd "-Next-Declaration" nextDecl
Butcher.addCmd "-NEXT-DECLARATION" nextDecl
let
nextBinding = do
conf <- configParser
Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf)
let nextBinding = do
conf <- configParser
Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf)
Butcher.addCmd "-next-binding" nextBinding
Butcher.addCmd "-Next-Binding" nextBinding
Butcher.addCmd "-NEXT-BINDING" nextBinding
let
disableNextBinding = do
Butcher.addCmdImpl
( InlineConfigTargetNextBinding
, mempty { _conf_roundtrip_exactprint_only = pure $ pure True }
)
let disableNextBinding = do
Butcher.addCmdImpl
( InlineConfigTargetNextBinding
, mempty { _conf_roundtrip_exactprint_only = pure $ pure True }
)
Butcher.addCmd "-disable-next-binding" disableNextBinding
Butcher.addCmd "-Disable-Next-Binding" disableNextBinding
Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding
let
disableNextDecl = do
Butcher.addCmdImpl
( InlineConfigTargetNextDecl
, mempty { _conf_roundtrip_exactprint_only = pure $ pure True }
)
let disableNextDecl = do
Butcher.addCmdImpl
( InlineConfigTargetNextDecl
, mempty { _conf_roundtrip_exactprint_only = pure $ pure True }
)
Butcher.addCmd "-disable-next-declaration" disableNextDecl
Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl
Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl
let
disableFormatting = do
Butcher.addCmdImpl
( InlineConfigTargetModule
, mempty { _conf_disable_formatting = pure $ pure True }
)
let disableFormatting = do
Butcher.addCmdImpl
( InlineConfigTargetModule
, mempty { _conf_disable_formatting = pure $ pure True }
)
Butcher.addCmd "-disable" disableFormatting
Butcher.addCmd "@" $ do
-- Butcher.addCmd "module" $ do
@ -168,42 +178,41 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
-- Butcher.addCmdImpl (InlineConfigTargetModule, conf)
Butcher.addNullCmd $ do
bindingName <- Butcher.addParamString "BINDING" mempty
conf <- configParser
conf <- configParser
Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf)
conf <- configParser
Butcher.addCmdImpl (InlineConfigTargetModule, conf)
lineConfigss <- configLiness `forM` \(k, ss) -> do
r <- ss `forM` \s -> case Butcher.runCmdParserSimple s parser of
Left err -> Left $ (err, s)
Right c -> Right $ c
Left err -> Left $ (err, s)
Right c -> Right $ c
pure (k, r)
let
perModule = foldl'
(<>)
mempty
[ conf
| (_, lineConfigs) <- lineConfigss
, (InlineConfigTargetModule, conf) <- lineConfigs
]
let perModule = foldl'
(<>)
mempty
[ conf
| (_ , lineConfigs) <- lineConfigss
, (InlineConfigTargetModule, conf ) <- lineConfigs
]
let
perBinding = Map.fromListWith
(<>)
[ (n, conf)
| (k, lineConfigs) <- lineConfigss
, (target, conf) <- lineConfigs
, n <- case target of
| (k , lineConfigs) <- lineConfigss
, (target, conf ) <- lineConfigs
, n <- case target of
InlineConfigTargetBinding s -> [s]
InlineConfigTargetNextBinding
| Just name <- Map.lookup k declNameMap -> [name]
InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap ->
[name]
_ -> []
]
let
perKey = Map.fromListWith
(<>)
[ (k, conf)
| (k, lineConfigs) <- lineConfigss
, (target, conf) <- lineConfigs
| (k , lineConfigs) <- lineConfigss
, (target, conf ) <- lineConfigs
, case target of
InlineConfigTargetNextDecl -> True
InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap ->
@ -221,7 +230,7 @@ getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap
getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) =
TopLevelDeclNameMap $ Map.fromList
[ (ExactPrint.mkAnnKey decl, name)
| decl <- decls
| decl <- decls
, (name : _) <- [getDeclBindingNames decl]
]
@ -239,78 +248,70 @@ getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) =
-- won't do.
parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text)
parsePrintModule configWithDebugs inputText = runExceptT $ do
let
config =
configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig }
let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
let config_pp = config & _conf_preprocessor
let cppMode = config_pp & _ppconf_CPPMode & confUnpack
let config =
configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig }
let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
let config_pp = config & _conf_preprocessor
let cppMode = config_pp & _ppconf_CPPMode & confUnpack
let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack
(anns, parsedSource, hasCPP) <- do
let
hackF s = if "#include" `isPrefixOf` s
then "-- BRITANY_INCLUDE_HACK " ++ s
else s
let
hackTransform = if hackAroundIncludes
then List.intercalate "\n" . fmap hackF . lines'
else id
let
cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
then case cppMode of
CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting."
CPPModeWarn -> return $ Right True
CPPModeNowarn -> return $ Right True
else return $ Right False
let hackF s = if "#include" `isPrefixOf` s
then "-- BRITANY_INCLUDE_HACK " ++ s
else s
let hackTransform = if hackAroundIncludes
then List.intercalate "\n" . fmap hackF . lines'
else id
let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
then case cppMode of
CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting."
CPPModeWarn -> return $ Right True
CPPModeNowarn -> return $ Right True
else return $ Right False
parseResult <- lift $ parseModuleFromString
ghcOptions
"stdin"
cppCheckFunc
(hackTransform $ Text.unpack inputText)
case parseResult of
Left err -> throwE [ErrorInput err]
Right x -> pure x
Left err -> throwE [ErrorInput err]
Right x -> pure x
(inlineConf, perItemConf) <-
either (throwE . (: []) . uncurry ErrorMacroConfig) pure
$ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)
let moduleConfig = cZipWith fromOptionIdentity config inlineConf
let moduleConfig = cZipWith fromOptionIdentity config inlineConf
let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack
if disableFormatting
then do
return inputText
else do
(errsWarns, outputTextL) <- do
let
omitCheck =
moduleConfig
& _conf_errorHandling
& _econf_omit_output_valid_check
& confUnpack
let omitCheck =
moduleConfig
& _conf_errorHandling
& _econf_omit_output_valid_check
& confUnpack
(ews, outRaw) <- if hasCPP || omitCheck
then return $ pPrintModule moduleConfig perItemConf anns parsedSource
else lift
$ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource
let
hackF s = fromMaybe s
$ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
let hackF s = fromMaybe s
$ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
pure $ if hackAroundIncludes
then
( ews
, TextL.intercalate (TextL.pack "\n")
$ hackF
<$> TextL.splitOn (TextL.pack "\n") outRaw
, TextL.intercalate (TextL.pack "\n") $ hackF <$> TextL.splitOn
(TextL.pack "\n")
outRaw
)
else (ews, outRaw)
let
customErrOrder ErrorInput{} = 4
customErrOrder LayoutWarning{} = 0 :: Int
customErrOrder ErrorOutputCheck{} = 1
customErrOrder ErrorUnusedComment{} = 2
customErrOrder ErrorUnknownNode{} = 3
customErrOrder ErrorMacroConfig{} = 5
let
hasErrors =
if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack
let customErrOrder ErrorInput{} = 4
customErrOrder LayoutWarning{} = 0 :: Int
customErrOrder ErrorOutputCheck{} = 1
customErrOrder ErrorUnusedComment{} = 2
customErrOrder ErrorUnknownNode{} = 3
customErrOrder ErrorMacroConfig{} = 5
let hasErrors =
if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack
then not $ null errsWarns
else 0 < maximum (-1 : fmap customErrOrder errsWarns)
if hasErrors
@ -330,27 +331,26 @@ pPrintModule
-> GHC.ParsedSource
-> ([BrittanyError], TextL.Text)
pPrintModule conf inlineConf anns parsedModule =
let
((out, errs), debugStrings) =
runIdentity
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterW
$ MultiRWSS.withMultiReader anns
$ MultiRWSS.withMultiReader conf
$ MultiRWSS.withMultiReader inlineConf
$ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns)
$ do
traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations
$ annsDoc anns
ppModule parsedModule
tracer = if Seq.null debugStrings
then id
else
trace ("---- DEBUGMESSAGES ---- ")
. foldr (seq . join trace) id debugStrings
in tracer $ (errs, Text.Builder.toLazyText out)
let ((out, errs), debugStrings) =
runIdentity
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterW
$ MultiRWSS.withMultiReader anns
$ MultiRWSS.withMultiReader conf
$ MultiRWSS.withMultiReader inlineConf
$ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns)
$ do
traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations
$ annsDoc anns
ppModule parsedModule
tracer = if Seq.null debugStrings
then id
else
trace ("---- DEBUGMESSAGES ---- ")
. foldr (seq . join trace) id debugStrings
in tracer $ (errs, Text.Builder.toLazyText out)
-- unless () $ do
--
-- debugStrings `forM_` \s ->
@ -365,17 +365,15 @@ pPrintModuleAndCheck
-> GHC.ParsedSource
-> IO ([BrittanyError], TextL.Text)
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
parseResult <- parseModuleFromString
ghcOptions
"output"
(\_ -> return $ Right ())
(TextL.unpack output)
let
errs' = errs ++ case parseResult of
Left{} -> [ErrorOutputCheck]
Right{} -> []
parseResult <- parseModuleFromString ghcOptions
"output"
(\_ -> return $ Right ())
(TextL.unpack output)
let errs' = errs ++ case parseResult of
Left{} -> [ErrorOutputCheck]
Right{} -> []
return (errs', output)
@ -386,22 +384,18 @@ parsePrintModuleTests conf filename input = do
let inputStr = Text.unpack input
parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr
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
(inlineConf, perItemConf) <-
case
extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule)
of
Left err -> throwE $ "error in inline config: " ++ show err
Right x -> pure x
case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of
Left err -> throwE $ "error in inline config: " ++ show err
Right x -> pure x
let moduleConf = cZipWith fromOptionIdentity conf inlineConf
let
omitCheck =
conf
& _conf_errorHandling
.> _econf_omit_output_valid_check
.> confUnpack
let omitCheck =
conf
& _conf_errorHandling
.> _econf_omit_output_valid_check
.> confUnpack
(errs, ltext) <- if omitCheck
then return $ pPrintModule moduleConf perItemConf anns parsedModule
else lift
@ -411,13 +405,13 @@ parsePrintModuleTests conf filename input = do
else
let
errStrs = errs <&> \case
ErrorInput str -> str
ErrorInput str -> str
ErrorUnusedComment str -> str
LayoutWarning str -> str
LayoutWarning str -> str
ErrorUnknownNode str _ -> str
ErrorMacroConfig str _ -> "when parsing inline config: " ++ str
ErrorOutputCheck -> "Output is not syntactically valid."
in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs
ErrorOutputCheck -> "Output is not syntactically valid."
in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs
isErrorUnusedComment :: BrittanyError -> Bool
isErrorUnusedComment x = case x of
@ -470,30 +464,27 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
let annKey = ExactPrint.mkAnnKey lmod
post <- ppPreamble lmod
decls `forM_` \decl -> do
let declAnnKey = ExactPrint.mkAnnKey decl
let declAnnKey = ExactPrint.mkAnnKey decl
let declBindingNames = getDeclBindingNames decl
inlineConf <- mAsk
let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf
let
mBindingConfs =
declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf
filteredAnns <- mAsk <&> \annMap ->
Map.union (Map.findWithDefault Map.empty annKey annMap)
$ Map.findWithDefault Map.empty declAnnKey annMap
let mBindingConfs =
declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf
filteredAnns <- mAsk
<&> \annMap ->
Map.union (Map.findWithDefault Map.empty annKey annMap) $
Map.findWithDefault Map.empty declAnnKey annMap
traceIfDumpConf
"bridoc annotations filtered/transformed"
_dconf_dump_annotations
traceIfDumpConf "bridoc annotations filtered/transformed"
_dconf_dump_annotations
$ annsDoc filteredAnns
config <- mAsk
let
config' = cZipWith fromOptionIdentity config
$ mconcat (catMaybes (mBindingConfs ++ [mDeclConf]))
let config' = cZipWith fromOptionIdentity config
$ mconcat (catMaybes (mBindingConfs ++ [mDeclConf]))
let
exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack
let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack
toLocal config' filteredAnns $ do
bd <- if exactprintOnly
then briDocMToPPM $ briDocByExactNoComment decl
@ -506,34 +497,33 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
else briDocMToPPM $ briDocByExactNoComment decl
layoutBriDoc bd
let
finalComments = filter
(fst .> \case
ExactPrint.AnnComment{} -> True
_ -> False
)
post
let finalComments = filter
(fst .> \case
ExactPrint.AnnComment{} -> True
_ -> False
)
post
post `forM_` \case
(ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do
ppmMoveToExactLoc l
mTell $ Text.Builder.fromString cmStr
(ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) ->
let
folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of
ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm ->
( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span
, x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span
)
_ -> (acc + y, x)
(cmY, cmX) = foldl' folder (0, 0) finalComments
in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX)
let folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of
ExactPrint.AnnComment cm
| span <- ExactPrint.commentIdentifier cm
-> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span
, x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span
)
_ -> (acc + y, x)
(cmY, cmX) = foldl' folder (0, 0) finalComments
in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX)
_ -> return ()
getDeclBindingNames :: LHsDecl GhcPs -> [String]
getDeclBindingNames (L _ decl) = case decl of
SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n)
ValD _ (FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n]
_ -> []
_ -> []
-- Prints the information associated with the module annotation
@ -550,9 +540,8 @@ ppPreamble lmod@(L loc m@HsModule{}) = do
-- attached annotations that come after the module's where
-- from the module node
config <- mAsk
let
shouldReformatPreamble =
config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack
let shouldReformatPreamble =
config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack
let
(filteredAnns', post) =
@ -562,23 +551,23 @@ ppPreamble lmod@(L loc m@HsModule{}) = do
let
modAnnsDp = ExactPrint.annsDP mAnn
isWhere (ExactPrint.G AnnWhere) = True
isWhere _ = False
isWhere _ = False
isEof (ExactPrint.AnnEofPos) = True
isEof _ = False
whereInd = List.findIndex (isWhere . fst) modAnnsDp
eofInd = List.findIndex (isEof . fst) modAnnsDp
isEof _ = False
whereInd = List.findIndex (isWhere . fst) modAnnsDp
eofInd = List.findIndex (isEof . fst) modAnnsDp
(pre, post') = case (whereInd, eofInd) of
(Nothing, Nothing) -> ([], modAnnsDp)
(Just i, Nothing) -> List.splitAt (i + 1) modAnnsDp
(Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp
(Nothing, Just _i) -> ([], modAnnsDp)
(Just i, Just j) -> List.splitAt (min (i + 1) j) modAnnsDp
(Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp
mAnn' = mAnn { ExactPrint.annsDP = pre }
filteredAnns'' =
Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns
in (filteredAnns'', post')
traceIfDumpConf
"bridoc annotations filtered/transformed"
_dconf_dump_annotations
in
(filteredAnns'', post')
traceIfDumpConf "bridoc annotations filtered/transformed"
_dconf_dump_annotations
$ annsDoc filteredAnns'
if shouldReformatPreamble
@ -587,7 +576,7 @@ ppPreamble lmod@(L loc m@HsModule{}) = do
layoutBriDoc briDoc
else
let emptyModule = L loc m { hsmodDecls = [] }
in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule
in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule
return post
_sigHead :: Sig GhcPs -> String
@ -600,7 +589,7 @@ _bindHead :: HsBind GhcPs -> String
_bindHead = \case
FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId)
PatBind _ _pat _ ([], []) -> "PatBind smth"
_ -> "unknown bind"
_ -> "unknown bind"
@ -618,67 +607,63 @@ layoutBriDoc briDoc = do
transformAlts briDoc >>= mSet
mGet
>>= briDocToDoc
.> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt
.> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt
-- bridoc transformation: float stuff in
mGet >>= transformSimplifyFloating .> mSet
mGet
>>= briDocToDoc
.> traceIfDumpConf
"bridoc post-floating"
_dconf_dump_bridoc_simpl_floating
.> traceIfDumpConf "bridoc post-floating"
_dconf_dump_bridoc_simpl_floating
-- bridoc transformation: par removal
mGet >>= transformSimplifyPar .> mSet
mGet
>>= briDocToDoc
.> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par
.> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par
-- bridoc transformation: float stuff in
mGet >>= transformSimplifyColumns .> mSet
mGet
>>= briDocToDoc
.> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns
.> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns
-- bridoc transformation: indent
mGet >>= transformSimplifyIndent .> mSet
mGet
>>= briDocToDoc
.> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent
.> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent
mGet
>>= briDocToDoc
.> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final
.> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final
-- -- convert to Simple type
-- simpl <- mGet <&> transformToSimple
-- return simpl
anns :: ExactPrint.Anns <- mAsk
let
state = LayoutState
{ _lstate_baseYs = [0]
, _lstate_curYOrAddNewline = Right 0 -- important that we dont use left
-- here because moveToAnn stuff
-- of the first node needs to do
-- its thing properly.
, _lstate_indLevels = [0]
, _lstate_indLevelLinger = 0
, _lstate_comments = anns
, _lstate_commentCol = Nothing
, _lstate_addSepSpace = Nothing
, _lstate_commentNewlines = 0
}
let state = LayoutState { _lstate_baseYs = [0]
, _lstate_curYOrAddNewline = Right 0 -- important that we dont use left
-- here because moveToAnn stuff
-- of the first node needs to do
-- its thing properly.
, _lstate_indLevels = [0]
, _lstate_indLevelLinger = 0
, _lstate_comments = anns
, _lstate_commentCol = Nothing
, _lstate_addSepSpace = Nothing
, _lstate_commentNewlines = 0
}
state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
let
remainingComments =
[ c
| (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList
(_lstate_comments state')
-- With the new import layouter, we manually process comments
-- without relying on the backend to consume the comments out of
-- the state/map. So they will end up here, and we need to ignore
-- them.
, ExactPrint.unConName con /= "ImportDecl"
, c <- extractAllComments elemAnns
]
let remainingComments =
[ c
| (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList
(_lstate_comments state')
-- With the new import layouter, we manually process comments
-- without relying on the backend to consume the comments out of
-- the state/map. So they will end up here, and we need to ignore
-- them.
, ExactPrint.unConName con /= "ImportDecl"
, c <- extractAllComments elemAnns
]
remainingComments
`forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell)

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

@ -6,6 +6,10 @@
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 Data.Either as Either
import qualified Data.Foldable as Foldable
@ -17,32 +21,32 @@ import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as Text.Builder
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.Types as ExactPrint.Types
type ColIndex = Int
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
data ColumnSpacing
= ColumnSpacingLeaf Int
| ColumnSpacingRef Int Int
type ColumnBlock a = [a]
type ColumnBlock a = [a]
type ColumnBlocks a = Seq [a]
type ColMap1
= IntMapL.IntMap {- ColIndex -}
(Bool, ColumnBlocks ColumnSpacing)
type ColMap2
= IntMapL.IntMap {- ColIndex -}
(Float, ColumnBlock Int, ColumnBlocks Int)
type ColMap1 = IntMapL.IntMap {- ColIndex -} (Bool, ColumnBlocks ColumnSpacing)
type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int)
-- (ratio of hasSpace, maximum, raw)
data ColInfo
@ -52,23 +56,20 @@ data ColInfo
instance Show ColInfo where
show ColInfoStart = "ColInfoStart"
show (ColInfoNo bd) =
"ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..")
show (ColInfo ind sig list) =
"ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list
show (ColInfoNo bd) = "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..")
show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list
data ColBuildState = ColBuildState
{ _cbs_map :: ColMap1
, _cbs_index :: ColIndex
}
type LayoutConstraints m
= ( MonadMultiReader Config m
, MonadMultiReader ExactPrint.Types.Anns m
, MonadMultiWriter Text.Builder.Builder m
, MonadMultiWriter (Seq String) m
, MonadMultiState LayoutState m
)
type LayoutConstraints m = ( MonadMultiReader Config m
, MonadMultiReader ExactPrint.Types.Anns m
, MonadMultiWriter Text.Builder.Builder m
, MonadMultiWriter (Seq String) m
, MonadMultiState LayoutState m
)
layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m ()
layoutBriDocM = \case
@ -89,11 +90,10 @@ layoutBriDocM = \case
BDSeparator -> do
layoutAddSepSpace
BDAddBaseY indent bd -> do
let
indentF = case indent of
BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
let indentF = case indent of
BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ layoutBriDocM bd
BDBaseYPushCur bd -> do
layoutBaseYPushCur
@ -108,39 +108,36 @@ layoutBriDocM = \case
layoutBriDocM bd
layoutIndentLevelPop
BDEnsureIndent indent bd -> do
let
indentF = case indent of
BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
let indentF = case indent of
BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ do
layoutWriteEnsureBlock
layoutBriDocM bd
BDPar indent sameLine indented -> do
layoutBriDocM sameLine
let
indentF = case indent of
BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
let indentF = case indent of
BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ do
layoutWriteNewlineBlock
layoutBriDocM indented
BDLines lines -> alignColsLines lines
BDAlt [] -> error "empty BDAlt"
BDAlt (alt : _) -> layoutBriDocM alt
BDForceMultiline bd -> layoutBriDocM bd
BDForceSingleline bd -> layoutBriDocM bd
BDForwardLineMode bd -> layoutBriDocM bd
BDLines lines -> alignColsLines lines
BDAlt [] -> error "empty BDAlt"
BDAlt (alt:_) -> layoutBriDocM alt
BDForceMultiline bd -> layoutBriDocM bd
BDForceSingleline bd -> layoutBriDocM bd
BDForwardLineMode bd -> layoutBriDocM bd
BDExternal annKey subKeys shouldAddComment t -> do
let
tlines = Text.lines $ t <> Text.pack "\n"
tlineCount = length tlines
let tlines = Text.lines $ t <> Text.pack "\n"
tlineCount = length tlines
anns :: ExactPrint.Anns <- mAsk
when shouldAddComment $ do
layoutWriteAppend
$ Text.pack
$ "{-"
$ Text.pack
$ "{-"
++ show (annKey, Map.lookup annKey anns)
++ "-}"
zip [1 ..] tlines `forM_` \(i, l) -> do
@ -157,10 +154,9 @@ layoutBriDocM = \case
BDAnnotationPrior annKey bd -> do
state <- mGet
let m = _lstate_comments state
let
moveToExactLocationAction = case _lstate_curYOrAddNewline state of
Left{} -> pure ()
Right{} -> moveToExactAnn annKey
let moveToExactLocationAction = case _lstate_curYOrAddNewline state of
Left{} -> pure ()
Right{} -> moveToExactAnn annKey
mAnn <- do
let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m
mSet $ state
@ -171,8 +167,8 @@ layoutBriDocM = \case
}
return mAnn
case mAnn of
Nothing -> moveToExactLocationAction
Just [] -> moveToExactLocationAction
Nothing -> moveToExactLocationAction
Just [] -> moveToExactLocationAction
Just priors -> do
-- layoutResetSepSpace
priors
@ -180,10 +176,9 @@ layoutBriDocM = \case
when (comment /= "(" && comment /= ")") $ do
let commentLines = Text.lines $ Text.pack $ comment
case comment of
('#' : _) ->
layoutMoveToCommentPos y (-999) (length commentLines)
('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines)
-- ^ evil hack for CPP
_ -> layoutMoveToCommentPos y x (length commentLines)
_ -> layoutMoveToCommentPos y x (length commentLines)
-- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline
-- layoutMoveToIndentCol y
@ -195,20 +190,18 @@ layoutBriDocM = \case
layoutBriDocM bd
mComments <- do
state <- mGet
let m = _lstate_comments state
let m = _lstate_comments state
let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
let
mToSpan = case mAnn of
Just anns | Maybe.isNothing keyword -> Just anns
Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 ->
Just annR
_ -> Nothing
let mToSpan = case mAnn of
Just anns | Maybe.isNothing keyword -> Just anns
Just ((ExactPrint.Types.G kw1, _):annR) | keyword == Just kw1 -> Just
annR
_ -> Nothing
case mToSpan of
Just anns -> do
let
(comments, rest) = flip spanMaybe anns $ \case
(ExactPrint.Types.AnnComment x, dp) -> Just (x, dp)
_ -> Nothing
let (comments, rest) = flip spanMaybe anns $ \case
(ExactPrint.Types.AnnComment x, dp) -> Just (x, dp)
_ -> Nothing
mSet $ state
{ _lstate_comments = Map.adjust
(\ann -> ann { ExactPrint.annsDP = rest })
@ -220,19 +213,17 @@ layoutBriDocM = \case
case mComments of
Nothing -> pure ()
Just comments -> do
comments
`forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
when (comment /= "(" && comment /= ")") $ do
let commentLines = Text.lines $ Text.pack $ comment
-- evil hack for CPP:
case comment of
('#' : _) ->
layoutMoveToCommentPos y (-999) (length commentLines)
_ -> layoutMoveToCommentPos y x (length commentLines)
-- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline
-- layoutMoveToIndentCol y
layoutWriteAppendMultiline commentLines
comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
when (comment /= "(" && comment /= ")") $ do
let commentLines = Text.lines $ Text.pack $ comment
-- evil hack for CPP:
case comment of
('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines)
_ -> layoutMoveToCommentPos y x (length commentLines)
-- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline
-- layoutMoveToIndentCol y
layoutWriteAppendMultiline commentLines
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
BDAnnotationRest annKey bd -> do
layoutBriDocM bd
@ -241,26 +232,21 @@ layoutBriDocM = \case
let m = _lstate_comments state
pure $ Map.lookup annKey m
let mComments = nonEmpty . extractAllComments =<< annMay
let
semiCount = length
[ ()
| Just ann <- [annMay]
, (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann
]
shouldAddSemicolonNewlines <-
mAsk
<&> _conf_layout
.> _lconfig_experimentalSemicolonNewlines
.> confUnpack
let semiCount = length [ ()
| Just ann <- [ annMay ]
, (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann
]
shouldAddSemicolonNewlines <- mAsk <&>
_conf_layout .> _lconfig_experimentalSemicolonNewlines .> confUnpack
mModify $ \state -> state
{ _lstate_comments = Map.adjust
(\ann -> ann
{ ExactPrint.annFollowingComments = []
, ExactPrint.annPriorComments = []
, ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case
(ExactPrint.Types.AnnComment{}, _) -> False
_ -> True
}
( \ann -> ann { ExactPrint.annFollowingComments = []
, ExactPrint.annPriorComments = []
, ExactPrint.annsDP =
flip filter (ExactPrint.annsDP ann) $ \case
(ExactPrint.Types.AnnComment{}, _) -> False
_ -> True
}
)
annKey
(_lstate_comments state)
@ -268,40 +254,37 @@ layoutBriDocM = \case
case mComments of
Nothing -> do
when shouldAddSemicolonNewlines $ do
[1 .. semiCount] `forM_` const layoutWriteNewline
[1..semiCount] `forM_` const layoutWriteNewline
Just comments -> do
comments
`forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
when (comment /= "(" && comment /= ")") $ do
let commentLines = Text.lines $ Text.pack comment
case comment of
('#' : _) -> layoutMoveToCommentPos y (-999) 1
-- ^ evil hack for CPP
")" -> pure ()
-- ^ fixes the formatting of parens
-- on the lhs of type alias defs
_ -> layoutMoveToCommentPos y x (length commentLines)
-- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline
-- layoutMoveToIndentCol y
layoutWriteAppendMultiline commentLines
comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
when (comment /= "(" && comment /= ")") $ do
let commentLines = Text.lines $ Text.pack comment
case comment of
('#':_) -> layoutMoveToCommentPos y (-999) 1
-- ^ evil hack for CPP
")" -> pure ()
-- ^ fixes the formatting of parens
-- on the lhs of type alias defs
_ -> layoutMoveToCommentPos y x (length commentLines)
-- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline
-- layoutMoveToIndentCol y
layoutWriteAppendMultiline commentLines
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do
mDP <- do
state <- mGet
let m = _lstate_comments state
let m = _lstate_comments state
let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
let
relevant =
[ dp
| Just ann <- [mAnn]
, (ExactPrint.Types.G kw1, dp) <- ann
, keyword == kw1
]
let relevant = [ dp
| Just ann <- [mAnn]
, (ExactPrint.Types.G kw1, dp) <- ann
, keyword == kw1
]
-- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant]
case relevant of
[] -> pure Nothing
(ExactPrint.Types.DP (y, x) : _) -> do
(ExactPrint.Types.DP (y, x):_) -> do
mSet state { _lstate_commentNewlines = 0 }
pure $ Just (y - _lstate_commentNewlines state, x)
case mDP of
@ -312,8 +295,8 @@ layoutBriDocM = \case
layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) 1
layoutBriDocM bd
BDNonBottomSpacing _ bd -> layoutBriDocM bd
BDSetParSpacing bd -> layoutBriDocM bd
BDForceParSpacing bd -> layoutBriDocM bd
BDSetParSpacing bd -> layoutBriDocM bd
BDForceParSpacing bd -> layoutBriDocM bd
BDDebug s bd -> do
mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}"
layoutBriDocM bd
@ -324,73 +307,73 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
-- appended at the current position.
where
rec = \case
BDEmpty -> return $ 0
BDLit t -> StateS.put False $> Text.length t
BDSeq bds -> sum <$> rec `mapM` bds
BDCols _ bds -> sum <$> rec `mapM` bds
BDEmpty -> return $ 0
BDLit t -> StateS.put False $> Text.length t
BDSeq bds -> sum <$> rec `mapM` bds
BDCols _ bds -> sum <$> rec `mapM` bds
BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1
BDAddBaseY _ bd -> rec bd
BDBaseYPushCur bd -> rec bd
BDBaseYPop bd -> rec bd
BDAddBaseY _ bd -> rec bd
BDBaseYPushCur bd -> rec bd
BDBaseYPop bd -> rec bd
BDIndentLevelPushCur bd -> rec bd
BDIndentLevelPop bd -> rec bd
BDPar _ line _ -> rec line
BDAlt{} -> error "briDocLineLength BDAlt"
BDForceMultiline bd -> rec bd
BDForceSingleline bd -> rec bd
BDForwardLineMode bd -> rec bd
BDExternal _ _ _ t -> return $ Text.length t
BDPlain t -> return $ Text.length t
BDAnnotationPrior _ bd -> rec bd
BDAnnotationKW _ _ bd -> rec bd
BDAnnotationRest _ bd -> rec bd
BDMoveToKWDP _ _ _ bd -> rec bd
BDLines ls@(_ : _) -> do
BDIndentLevelPop bd -> rec bd
BDPar _ line _ -> rec line
BDAlt{} -> error "briDocLineLength BDAlt"
BDForceMultiline bd -> rec bd
BDForceSingleline bd -> rec bd
BDForwardLineMode bd -> rec bd
BDExternal _ _ _ t -> return $ Text.length t
BDPlain t -> return $ Text.length t
BDAnnotationPrior _ bd -> rec bd
BDAnnotationKW _ _ bd -> rec bd
BDAnnotationRest _ bd -> rec bd
BDMoveToKWDP _ _ _ bd -> rec bd
BDLines ls@(_ : _) -> do
x <- StateS.get
return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x
BDLines [] -> error "briDocLineLength BDLines []"
BDEnsureIndent _ bd -> rec bd
BDSetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd
BDLines [] -> error "briDocLineLength BDLines []"
BDEnsureIndent _ bd -> rec bd
BDSetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd
BDNonBottomSpacing _ bd -> rec bd
BDDebug _ bd -> rec bd
BDDebug _ bd -> rec bd
briDocIsMultiLine :: BriDoc -> Bool
briDocIsMultiLine briDoc = rec briDoc
where
rec :: BriDoc -> Bool
rec = \case
BDEmpty -> False
BDLit _ -> False
BDSeq bds -> any rec bds
BDCols _ bds -> any rec bds
BDSeparator -> False
BDAddBaseY _ bd -> rec bd
BDBaseYPushCur bd -> rec bd
BDBaseYPop bd -> rec bd
BDIndentLevelPushCur bd -> rec bd
BDIndentLevelPop bd -> rec bd
BDPar{} -> True
BDAlt{} -> error "briDocIsMultiLine BDAlt"
BDForceMultiline _ -> True
BDForceSingleline bd -> rec bd
BDForwardLineMode bd -> rec bd
BDEmpty -> False
BDLit _ -> False
BDSeq bds -> any rec bds
BDCols _ bds -> any rec bds
BDSeparator -> False
BDAddBaseY _ bd -> rec bd
BDBaseYPushCur bd -> rec bd
BDBaseYPop bd -> rec bd
BDIndentLevelPushCur bd -> rec bd
BDIndentLevelPop bd -> rec bd
BDPar{} -> True
BDAlt{} -> error "briDocIsMultiLine BDAlt"
BDForceMultiline _ -> True
BDForceSingleline bd -> rec bd
BDForwardLineMode bd -> rec bd
BDExternal _ _ _ t | [_] <- Text.lines t -> False
BDExternal{} -> True
BDPlain t | [_] <- Text.lines t -> False
BDPlain _ -> True
BDAnnotationPrior _ bd -> rec bd
BDAnnotationKW _ _ bd -> rec bd
BDAnnotationRest _ bd -> rec bd
BDMoveToKWDP _ _ _ bd -> rec bd
BDLines (_ : _ : _) -> True
BDLines [_] -> False
BDExternal{} -> True
BDPlain t | [_] <- Text.lines t -> False
BDPlain _ -> True
BDAnnotationPrior _ bd -> rec bd
BDAnnotationKW _ _ bd -> rec bd
BDAnnotationRest _ bd -> rec bd
BDMoveToKWDP _ _ _ bd -> rec bd
BDLines (_ : _ : _) -> True
BDLines [_ ] -> False
BDLines [] -> error "briDocIsMultiLine BDLines []"
BDEnsureIndent _ bd -> rec bd
BDSetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd
BDNonBottomSpacing _ bd -> rec bd
BDDebug _ bd -> rec bd
BDEnsureIndent _ bd -> rec bd
BDSetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd
BDNonBottomSpacing _ bd -> rec bd
BDDebug _ bd -> rec bd
-- In theory
-- =========
@ -475,16 +458,16 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
return $ Either.fromLeft 0 (_lstate_curYOrAddNewline state) + fromMaybe
0
(_lstate_addSepSpace state)
colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack
alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack
colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack
alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack
alignBreak <-
mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack
case () of
_ -> do
-- tellDebugMess ("processedMap: " ++ show processedMap)
sequence_
$ List.intersperse layoutWriteEnsureNewlineBlock
$ colInfos
$ List.intersperse layoutWriteEnsureNewlineBlock
$ colInfos
<&> processInfo colMax processedMap
where
(colInfos, finalState) =
@ -501,41 +484,40 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
where alignMax' = max 0 alignMax
processedMap :: ColMap2
processedMap = fix $ \result ->
_cbs_map finalState <&> \(lastFlag, colSpacingss) ->
processedMap =
fix $ \result -> _cbs_map finalState <&> \(lastFlag, colSpacingss) ->
let
colss = colSpacingss <&> \spss -> case reverse spss of
[] -> []
(xN : xR) ->
reverse
$ (if lastFlag then fLast else fInit) xN
: fmap fInit xR
(xN:xR) ->
reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR
where
fLast (ColumnSpacingLeaf len) = len
fLast (ColumnSpacingLeaf len ) = len
fLast (ColumnSpacingRef len _) = len
fInit (ColumnSpacingLeaf len) = len
fInit (ColumnSpacingRef _ i) = case IntMapL.lookup i result of
Nothing -> 0
fInit (ColumnSpacingRef _ i ) = case IntMapL.lookup i result of
Nothing -> 0
Just (_, maxs, _) -> sum maxs
maxCols = {-Foldable.foldl1 maxZipper-}
fmap colAggregation $ transpose $ Foldable.toList colss
(_, posXs) = -- trace ("colss=" ++ show colss ++ ", maxCols=" ++ show maxCols ++ " for " ++ take 100 (show $ briDocToDoc $ head bridocs)) $
mapAccumL (\acc x -> (acc + x, acc)) curX maxCols
mapAccumL (\acc x -> (acc + x, acc)) curX maxCols
counter count l = if List.last posXs + List.last l <= colMax
then count + 1
else count
ratio = fromIntegral (foldl counter (0 :: Int) colss)
/ fromIntegral (length colss)
in (ratio, maxCols, colss)
in
(ratio, maxCols, colss)
mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo]
mergeBriDocs bds = mergeBriDocsW ColInfoStart bds
mergeBriDocsW
:: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo]
mergeBriDocsW _ [] = return []
mergeBriDocsW lastInfo (bd : bdr) = do
info <- mergeInfoBriDoc True lastInfo bd
mergeBriDocsW _ [] = return []
mergeBriDocsW lastInfo (bd:bdr) = do
info <- mergeInfoBriDoc True lastInfo bd
infor <- mergeBriDocsW
-- (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info)
(if shouldBreakAfter bd then ColInfoStart else info)
@ -563,27 +545,28 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
-- personal preference to not break alignment for those, even if
-- multiline. Really, this should be configurable.. (TODO)
shouldBreakAfter :: BriDoc -> Bool
shouldBreakAfter bd = alignBreak && briDocIsMultiLine bd && case bd of
(BDCols ColTyOpPrefix _) -> False
(BDCols ColPatternsFuncPrefix _) -> True
(BDCols ColPatternsFuncInfix _) -> True
(BDCols ColPatterns _) -> True
(BDCols ColCasePattern _) -> True
(BDCols ColBindingLine{} _) -> True
(BDCols ColGuard _) -> True
(BDCols ColGuardedBody _) -> True
(BDCols ColBindStmt _) -> True
(BDCols ColDoLet _) -> True
(BDCols ColRec _) -> False
(BDCols ColRecUpdate _) -> False
(BDCols ColRecDecl _) -> False
(BDCols ColListComp _) -> False
(BDCols ColList _) -> False
(BDCols ColApp{} _) -> True
(BDCols ColTuple _) -> False
(BDCols ColTuples _) -> False
(BDCols ColOpPrefix _) -> False
_ -> True
shouldBreakAfter bd = alignBreak &&
briDocIsMultiLine bd && case bd of
(BDCols ColTyOpPrefix _) -> False
(BDCols ColPatternsFuncPrefix _) -> True
(BDCols ColPatternsFuncInfix _) -> True
(BDCols ColPatterns _) -> True
(BDCols ColCasePattern _) -> True
(BDCols ColBindingLine{} _) -> True
(BDCols ColGuard _) -> True
(BDCols ColGuardedBody _) -> True
(BDCols ColBindStmt _) -> True
(BDCols ColDoLet _) -> True
(BDCols ColRec _) -> False
(BDCols ColRecUpdate _) -> False
(BDCols ColRecDecl _) -> False
(BDCols ColListComp _) -> False
(BDCols ColList _) -> False
(BDCols ColApp{} _) -> True
(BDCols ColTuple _) -> False
(BDCols ColTuples _) -> False
(BDCols ColOpPrefix _) -> False
_ -> True
mergeInfoBriDoc
:: Bool
@ -591,22 +574,23 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
-> BriDoc
-> StateS.StateT ColBuildState Identity ColInfo
mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag
mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag
mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag
mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) =
\case
brdc@(BDCols colSig subDocs)
| infoSig == colSig && length subLengthsInfos == length subDocs -> do
| infoSig == colSig && length subLengthsInfos == length subDocs
-> do
let
isLastList = if lastFlag
then (== length subDocs) <$> [1 ..]
then (==length subDocs) <$> [1 ..]
else repeat False
infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs
`forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd
let curLengths = briDocLineLength <$> subDocs
let curLengths = briDocLineLength <$> subDocs
let trueSpacings = getTrueSpacings (zip curLengths infos)
do -- update map
s <- StateS.get
let m = _cbs_map s
let m = _cbs_map s
let (Just (_, spaces)) = IntMapS.lookup infoInd m
StateS.put s
{ _cbs_map = IntMapS.insert
@ -615,17 +599,17 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
m
}
return $ ColInfo infoInd colSig (zip curLengths infos)
| otherwise -> briDocToColInfo lastFlag brdc
| otherwise
-> briDocToColInfo lastFlag brdc
brdc -> return $ ColInfoNo brdc
briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo
briDocToColInfo lastFlag = \case
BDCols sig list -> withAlloc lastFlag $ \ind -> do
let
isLastList =
if lastFlag then (== length list) <$> [1 ..] else repeat False
let isLastList =
if lastFlag then (==length list) <$> [1 ..] else repeat False
subInfos <- zip isLastList list `forM` uncurry briDocToColInfo
let lengthInfos = zip (briDocLineLength <$> list) subInfos
let lengthInfos = zip (briDocLineLength <$> list) subInfos
let trueSpacings = getTrueSpacings lengthInfos
return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos)
bd -> return $ ColInfoNo bd
@ -633,11 +617,11 @@ briDocToColInfo lastFlag = \case
getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing]
getTrueSpacings lengthInfos = lengthInfos <&> \case
(len, ColInfo i _ _) -> ColumnSpacingRef len i
(len, _) -> ColumnSpacingLeaf len
(len, _ ) -> ColumnSpacingLeaf len
withAlloc
:: Bool
-> ( ColIndex
-> ( ColIndex
-> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo)
)
-> StateS.State ColBuildState ColInfo
@ -652,14 +636,13 @@ withAlloc lastFlag f = do
processInfo :: LayoutConstraints m => Int -> ColMap2 -> ColInfo -> m ()
processInfo maxSpace m = \case
ColInfoStart -> error "should not happen (TM)"
ColInfoNo doc -> layoutBriDocM doc
ColInfoStart -> error "should not happen (TM)"
ColInfoNo doc -> layoutBriDocM doc
ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $
do
colMaxConf <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack
alignMode <-
mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack
curX <- do
alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack
curX <- do
state <- mGet
-- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state)))
let spaceAdd = fromMaybe 0 $ _lstate_addSepSpace state
@ -671,11 +654,10 @@ processInfo maxSpace m = \case
let colMax = min colMaxConf (curX + maxSpace)
-- tellDebugMess $ show curX
let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m
let
maxCols2 = list <&> \case
(_, ColInfo i _ _) ->
let Just (_, ms, _) = IntMapS.lookup i m in sum ms
(l, _) -> l
let maxCols2 = list <&> \case
(_, ColInfo i _ _) ->
let Just (_, ms, _) = IntMapS.lookup i m in sum ms
(l, _) -> l
let maxCols = zipWith max maxCols1 maxCols2
let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols
-- handle the cases that the vertical alignment leads to more than max
@ -686,48 +668,46 @@ processInfo maxSpace m = \case
-- 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
-- forced to occupy the full vertical space, not reduced by any factor.
let
fixedPosXs = case alignMode of
ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+ curX)
where
factor :: Float =
-- 0.0001 as an offering to the floating point gods.
min
1.0001
(fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX))
offsets = (subtract curX) <$> posXs
fixed = offsets <&> fromIntegral .> (* factor) .> truncate
_ -> posXs
let
spacings =
zipWith (-) (List.tail fixedPosXs ++ [min maxX colMax]) fixedPosXs
let fixedPosXs = case alignMode of
ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+curX)
where
factor :: Float =
-- 0.0001 as an offering to the floating point gods.
min
1.0001
(fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX))
offsets = (subtract curX) <$> posXs
fixed = offsets <&> fromIntegral .> (*factor) .> truncate
_ -> posXs
let spacings = zipWith (-)
(List.tail fixedPosXs ++ [min maxX colMax])
fixedPosXs
-- tellDebugMess $ "ind = " ++ show ind
-- tellDebugMess $ "maxCols = " ++ show maxCols
-- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs
-- tellDebugMess $ "list = " ++ show list
-- tellDebugMess $ "maxSpace = " ++ show maxSpace
let
alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do
layoutWriteEnsureAbsoluteN destX
processInfo s m (snd x)
noAlignAct = list `forM_` (snd .> processInfoIgnore)
animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $
if List.last fixedPosXs + fst (List.last list) > colMax
-- per-item check if there is overflowing.
then noAlignAct
else alignAct
let alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do
layoutWriteEnsureAbsoluteN destX
processInfo s m (snd x)
noAlignAct = list `forM_` (snd .> processInfoIgnore)
animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $
if List.last fixedPosXs + fst (List.last list) > colMax
-- per-item check if there is overflowing.
then noAlignAct
else alignAct
case alignMode of
ColumnAlignModeDisabled -> noAlignAct
ColumnAlignModeUnanimously | maxX <= colMax -> alignAct
ColumnAlignModeUnanimously -> noAlignAct
ColumnAlignModeDisabled -> noAlignAct
ColumnAlignModeUnanimously | maxX <= colMax -> alignAct
ColumnAlignModeUnanimously -> noAlignAct
ColumnAlignModeMajority limit | ratio >= limit -> animousAct
ColumnAlignModeMajority{} -> noAlignAct
ColumnAlignModeAnimouslyScale{} -> animousAct
ColumnAlignModeAnimously -> animousAct
ColumnAlignModeAlways -> alignAct
ColumnAlignModeMajority{} -> noAlignAct
ColumnAlignModeAnimouslyScale{} -> animousAct
ColumnAlignModeAnimously -> animousAct
ColumnAlignModeAlways -> alignAct
processInfoIgnore :: LayoutConstraints m => ColInfo -> m ()
processInfoIgnore = \case
ColInfoStart -> error "should not happen (TM)"
ColInfoNo doc -> layoutBriDocM doc
ColInfoStart -> error "should not happen (TM)"
ColInfoNo doc -> layoutBriDocM doc
ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore)

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

@ -3,29 +3,42 @@
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.Either
import qualified Data.Map as Map
import qualified Data.Maybe
import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as Text.Builder
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 ()
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 Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import Language.Haskell.Brittany.Internal.Utils
import GHC ( Located )
traceLocal
:: (MonadMultiState LayoutState m)
=> a
-> m ()
traceLocal _ = return ()
layoutWriteAppend
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> Text
-> m ()
layoutWriteAppend t = do
@ -41,13 +54,15 @@ layoutWriteAppend t = do
mTell $ Text.Builder.fromText $ t
mModify $ \s -> s
{ _lstate_curYOrAddNewline = Left $ case _lstate_curYOrAddNewline s of
Left c -> c + Text.length t + spaces
Right{} -> Text.length t + spaces
Left c -> c + Text.length t + spaces
Right{} -> Text.length t + spaces
, _lstate_addSepSpace = Nothing
}
layoutWriteAppendSpaces
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> Int
-> m ()
layoutWriteAppendSpaces i = do
@ -55,18 +70,20 @@ layoutWriteAppendSpaces i = do
unless (i == 0) $ do
state <- mGet
mSet $ state
{ _lstate_addSepSpace = Just $ maybe i (+ i) $ _lstate_addSepSpace state
{ _lstate_addSepSpace = Just $ maybe i (+i) $ _lstate_addSepSpace state
}
layoutWriteAppendMultiline
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> [Text]
-> m ()
layoutWriteAppendMultiline ts = do
traceLocal ("layoutWriteAppendMultiline", ts)
case ts of
[] -> layoutWriteAppend (Text.pack "") -- need to write empty, too.
(l : lr) -> do
[] -> layoutWriteAppend (Text.pack "") -- need to write empty, too.
(l:lr) -> do
layoutWriteAppend l
lr `forM_` \x -> do
layoutWriteNewline
@ -74,15 +91,16 @@ layoutWriteAppendMultiline ts = do
-- adds a newline and adds spaces to reach the base column.
layoutWriteNewlineBlock
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> m ()
layoutWriteNewlineBlock = do
traceLocal ("layoutWriteNewlineBlock")
state <- mGet
mSet $ state
{ _lstate_curYOrAddNewline = Right 1
, _lstate_addSepSpace = Just $ lstate_baseY state
}
mSet $ state { _lstate_curYOrAddNewline = Right 1
, _lstate_addSepSpace = Just $ lstate_baseY state
}
-- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m
-- , MonadMultiWriter (Seq String) m) => Int -> m ()
@ -98,13 +116,13 @@ layoutWriteNewlineBlock = do
-- else _lstate_indLevelLinger state + i - _lstate_curY state
-- }
layoutSetCommentCol :: (MonadMultiState LayoutState m) => m ()
layoutSetCommentCol
:: (MonadMultiState LayoutState m) => m ()
layoutSetCommentCol = do
state <- mGet
let
col = case _lstate_curYOrAddNewline state of
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Right{} -> lstate_baseY state
let col = case _lstate_curYOrAddNewline state of
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Right{} -> lstate_baseY state
traceLocal ("layoutSetCommentCol", col)
unless (Data.Maybe.isJust $ _lstate_commentCol state)
$ mSet state { _lstate_commentCol = Just col }
@ -112,7 +130,9 @@ layoutSetCommentCol = do
-- This is also used to move to non-comments in a couple of places. Seems
-- to be harmless so far..
layoutMoveToCommentPos
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> Int
-> Int
-> Int
@ -122,35 +142,38 @@ layoutMoveToCommentPos y x commentLines = do
state <- mGet
mSet state
{ _lstate_curYOrAddNewline = 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{} -> Right y
, _lstate_addSepSpace =
, _lstate_addSepSpace =
Just $ if Data.Maybe.isJust (_lstate_commentCol state)
then case _lstate_curYOrAddNewline state of
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
else if y == 0 then x else _lstate_indLevelLinger state + x
, _lstate_commentCol = Just $ case _lstate_commentCol state of
Just existing -> existing
Nothing -> case _lstate_curYOrAddNewline state of
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Right{} -> lstate_baseY state
, _lstate_commentCol =
Just $ case _lstate_commentCol state of
Just existing -> existing
Nothing -> case _lstate_curYOrAddNewline state of
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Right{} -> lstate_baseY state
, _lstate_commentNewlines =
_lstate_commentNewlines state + y + commentLines - 1
_lstate_commentNewlines state + y + commentLines - 1
}
-- | does _not_ add spaces to again reach the current base column.
layoutWriteNewline
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> m ()
layoutWriteNewline = do
traceLocal ("layoutWriteNewline")
state <- mGet
mSet $ state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left{} -> Right 1
Left{} -> Right 1
Right i -> Right (i + 1)
, _lstate_addSepSpace = Nothing
, _lstate_addSepSpace = Nothing
}
_layoutResetCommentNewlines :: MonadMultiState LayoutState m => m ()
@ -158,67 +181,77 @@ _layoutResetCommentNewlines = do
mModify $ \state -> state { _lstate_commentNewlines = 0 }
layoutWriteEnsureNewlineBlock
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> m ()
layoutWriteEnsureNewlineBlock = do
traceLocal ("layoutWriteEnsureNewlineBlock")
state <- mGet
mSet $ state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left{} -> Right 1
Left{} -> Right 1
Right i -> Right $ max 1 i
, _lstate_addSepSpace = Just $ lstate_baseY state
, _lstate_commentCol = Nothing
, _lstate_addSepSpace = Just $ lstate_baseY state
, _lstate_commentCol = Nothing
}
layoutWriteEnsureAbsoluteN
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> Int
-> m ()
layoutWriteEnsureAbsoluteN n = do
state <- mGet
let
diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of
(Just c, _) -> n - c
(Nothing, Left i) -> n - i
(Nothing, Right{}) -> n
let diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of
(Just c , _ ) -> n - c
(Nothing, Left i ) -> n - i
(Nothing, Right{}) -> n
traceLocal ("layoutWriteEnsureAbsoluteN", n, diff)
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
-- overwrite any old value in any
-- bad way.
}
layoutBaseYPushInternal :: (MonadMultiState LayoutState m) => Int -> m ()
layoutBaseYPushInternal
:: (MonadMultiState LayoutState m)
=> Int
-> m ()
layoutBaseYPushInternal i = do
traceLocal ("layoutBaseYPushInternal", i)
mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s }
layoutBaseYPopInternal :: (MonadMultiState LayoutState m) => m ()
layoutBaseYPopInternal
:: (MonadMultiState LayoutState m) => m ()
layoutBaseYPopInternal = do
traceLocal ("layoutBaseYPopInternal")
mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s }
layoutIndentLevelPushInternal
:: (MonadMultiState LayoutState m) => Int -> m ()
:: (MonadMultiState LayoutState m)
=> Int
-> m ()
layoutIndentLevelPushInternal i = do
traceLocal ("layoutIndentLevelPushInternal", i)
mModify $ \s -> s
{ _lstate_indLevelLinger = lstate_indLevel s
, _lstate_indLevels = i : _lstate_indLevels s
}
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
, _lstate_indLevels = i : _lstate_indLevels s
}
layoutIndentLevelPopInternal :: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPopInternal
:: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPopInternal = do
traceLocal ("layoutIndentLevelPopInternal")
mModify $ \s -> s
{ _lstate_indLevelLinger = lstate_indLevel s
, _lstate_indLevels = List.tail $ _lstate_indLevels s
}
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
, _lstate_indLevels = List.tail $ _lstate_indLevels s
}
layoutRemoveIndentLevelLinger :: (MonadMultiState LayoutState m) => m ()
layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m) => m ()
layoutRemoveIndentLevelLinger = do
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s }
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
}
layoutWithAddBaseCol
:: ( MonadMultiWriter Text.Builder.Builder m
@ -250,7 +283,9 @@ layoutWithAddBaseColBlock m = do
layoutBaseYPopInternal
layoutWithAddBaseColNBlock
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> Int
-> m ()
-> m ()
@ -263,23 +298,27 @@ layoutWithAddBaseColNBlock amount m = do
layoutBaseYPopInternal
layoutWriteEnsureBlock
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> m ()
layoutWriteEnsureBlock = do
traceLocal ("layoutWriteEnsureBlock")
state <- mGet
let
diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of
(Nothing, Left i) -> lstate_baseY state - i
(Nothing, Left i ) -> lstate_baseY state - i
(Nothing, Right{}) -> lstate_baseY state
(Just sp, Left i) -> max sp (lstate_baseY state - i)
(Just sp, Left i ) -> max sp (lstate_baseY state - i)
(Just sp, Right{}) -> max sp (lstate_baseY state)
-- when (diff>0) $ layoutWriteNewlineBlock
when (diff > 0) $ do
mSet $ state { _lstate_addSepSpace = Just $ diff }
layoutWithAddBaseColN
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> Int
-> m ()
-> m ()
@ -289,36 +328,39 @@ layoutWithAddBaseColN amount m = do
m
layoutBaseYPopInternal
layoutBaseYPushCur :: (MonadMultiState LayoutState m) => m ()
layoutBaseYPushCur
:: (MonadMultiState LayoutState m) => m ()
layoutBaseYPushCur = do
traceLocal ("layoutBaseYPushCur")
state <- mGet
case _lstate_commentCol state of
Nothing ->
case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i, Just j) -> layoutBaseYPushInternal (i + j)
(Left i, Nothing) -> layoutBaseYPushInternal i
(Right{}, _) -> layoutBaseYPushInternal $ lstate_baseY state
(Left i , Just j ) -> layoutBaseYPushInternal (i + j)
(Left i , Nothing) -> layoutBaseYPushInternal i
(Right{}, _ ) -> layoutBaseYPushInternal $ lstate_baseY state
Just cCol -> layoutBaseYPushInternal cCol
layoutBaseYPop :: (MonadMultiState LayoutState m) => m ()
layoutBaseYPop
:: (MonadMultiState LayoutState m) => m ()
layoutBaseYPop = do
traceLocal ("layoutBaseYPop")
layoutBaseYPopInternal
layoutIndentLevelPushCur :: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPushCur
:: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPushCur = do
traceLocal ("layoutIndentLevelPushCur")
state <- mGet
let
y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i, Just j) -> i + j
(Left i, Nothing) -> i
(Right{}, Just j) -> j
(Right{}, Nothing) -> 0
let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i , Just j ) -> i + j
(Left i , Nothing) -> i
(Right{}, Just j ) -> j
(Right{}, Nothing) -> 0
layoutIndentLevelPushInternal y
layoutIndentLevelPop :: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPop
:: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPop = do
traceLocal ("layoutIndentLevelPop")
layoutIndentLevelPopInternal
@ -328,12 +370,12 @@ layoutIndentLevelPop = do
-- make sense.
layoutRemoveIndentLevelLinger
layoutAddSepSpace :: (MonadMultiState LayoutState m) => m ()
layoutAddSepSpace :: (MonadMultiState LayoutState m)
=> m ()
layoutAddSepSpace = do
state <- mGet
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
-- can probably be removed.
@ -348,7 +390,7 @@ moveToExactAnn annKey = do
traceLocal ("moveToExactAnn", annKey)
anns <- mAsk
case Map.lookup annKey anns of
Nothing -> return ()
Nothing -> return ()
Just ann -> do
-- curY <- mGet <&> _lstate_curY
let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann
@ -357,19 +399,19 @@ moveToExactAnn annKey = do
moveToY :: MonadMultiState LayoutState m => Int -> m ()
moveToY y = mModify $ \state ->
let
upd = case _lstate_curYOrAddNewline state of
Left i -> if y == 0 then Left i else Right y
Right i -> Right $ max y i
in
state
{ _lstate_curYOrAddNewline = upd
, _lstate_addSepSpace = if Data.Either.isRight upd
then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just
(lstate_baseY state)
else Nothing
, _lstate_commentCol = Nothing
}
let upd = case _lstate_curYOrAddNewline state of
Left i -> if y == 0 then Left i else Right y
Right i -> Right $ max y i
in state
{ _lstate_curYOrAddNewline = upd
, _lstate_addSepSpace = if Data.Either.isRight upd
then
_lstate_commentCol state
<|> _lstate_addSepSpace state
<|> Just (lstate_baseY state)
else Nothing
, _lstate_commentCol = Nothing
}
-- fixMoveToLineByIsNewline :: MonadMultiState
-- LayoutState m => Int -> m Int
-- fixMoveToLineByIsNewline x = do
@ -379,7 +421,9 @@ moveToY y = mModify $ \state ->
-- else x
ppmMoveToExactLoc
:: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m ()
:: MonadMultiWriter Text.Builder.Builder m
=> ExactPrint.DeltaPos
-> m ()
ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do
replicateM_ x $ mTell $ Text.Builder.fromString "\n"
replicateM_ y $ mTell $ Text.Builder.fromString " "
@ -395,77 +439,75 @@ layoutWritePriorComments
layoutWritePriorComments ast = do
mAnn <- do
state <- mGet
let key = ExactPrint.mkAnnKey ast
let key = ExactPrint.mkAnnKey ast
let anns = _lstate_comments state
let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns
mSet $ state
{ _lstate_comments = Map.adjust
(\ann -> ann { ExactPrint.annPriorComments = [] })
key
anns
{ _lstate_comments =
Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) key anns
}
return mAnn
case mAnn of
Nothing -> return ()
Just priors -> do
unless (null priors) $ layoutSetCommentCol
priors
`forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> do
replicateM_ x layoutWriteNewline
layoutWriteAppendSpaces y
layoutWriteAppendMultiline $ Text.lines $ Text.pack comment
priors `forM_` \( ExactPrint.Comment comment _ _
, ExactPrint.DP (x, y)
) -> do
replicateM_ x layoutWriteNewline
layoutWriteAppendSpaces y
layoutWriteAppendMultiline $ Text.lines $ Text.pack comment
-- TODO: update and use, or clean up. Currently dead code.
-- this currently only extracs from the `annsDP` field of Annotations.
-- per documentation, this seems sufficient, as the
-- "..`annFollowingComments` are only added by AST transformations ..".
layoutWritePostComments
:: ( Data.Data.Data ast
, MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> Located ast
-> m ()
layoutWritePostComments :: (Data.Data.Data ast,
MonadMultiWriter Text.Builder.Builder m,
MonadMultiState LayoutState m)
=> Located ast -> m ()
layoutWritePostComments ast = do
mAnn <- do
state <- mGet
let key = ExactPrint.mkAnnKey ast
let key = ExactPrint.mkAnnKey ast
let anns = _lstate_comments state
let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns
mSet $ state
{ _lstate_comments = Map.adjust
(\ann -> ann { ExactPrint.annFollowingComments = [] })
key
anns
{ _lstate_comments =
Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = [] })
key
anns
}
return mAnn
case mAnn of
Nothing -> return ()
Just posts -> do
unless (null posts) $ layoutSetCommentCol
posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
do
replicateM_ x layoutWriteNewline
layoutWriteAppend $ Text.pack $ replicate y ' '
mModify $ \s -> s { _lstate_addSepSpace = Nothing }
layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment
posts `forM_` \( ExactPrint.Comment comment _ _
, ExactPrint.DP (x, y)
) -> do
replicateM_ x layoutWriteNewline
layoutWriteAppend $ Text.pack $ replicate y ' '
mModify $ \s -> s { _lstate_addSepSpace = Nothing }
layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment
layoutIndentRestorePostComment
:: (MonadMultiState LayoutState m, MonadMultiWriter Text.Builder.Builder m)
:: ( MonadMultiState LayoutState m
, MonadMultiWriter Text.Builder.Builder m
)
=> m ()
layoutIndentRestorePostComment = do
state <- mGet
let mCommentCol = _lstate_commentCol state
let eCurYAddNL = _lstate_curYOrAddNewline state
mModify
$ \s -> s { _lstate_commentCol = Nothing, _lstate_commentNewlines = 0 }
let eCurYAddNL = _lstate_curYOrAddNewline state
mModify $ \s -> s { _lstate_commentCol = Nothing
, _lstate_commentNewlines = 0
}
case (mCommentCol, eCurYAddNL) of
(Just commentCol, Left{}) -> do
layoutWriteEnsureNewlineBlock
layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe
0
(_lstate_addSepSpace state)
_ -> return ()
layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe 0 (_lstate_addSepSpace state)
_ -> return ()
-- layoutWritePriorCommentsRestore :: (Data.Data.Data ast,
-- MonadMultiWriter Text.Builder.Builder m,

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

@ -3,174 +3,185 @@
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.ByteString as ByteString
import qualified Data.ByteString.Char8
import Data.CZipWith
import Data.Coerce (coerce)
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Semigroup as Semigroup
import qualified Data.Yaml
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Config.Types
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 qualified System.Console.CmdArgs.Explicit as CmdArgs
import qualified System.Directory
import qualified System.Directory as Directory
import qualified System.FilePath.Posix as FilePath
import qualified System.IO
import UI.Butcher.Monadic
import qualified Data.Yaml
import Data.CZipWith
import UI.Butcher.Monadic
import qualified System.Console.CmdArgs.Explicit
as CmdArgs
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Config.Types.Instances ()
import Language.Haskell.Brittany.Internal.Utils
import Data.Coerce ( coerce
)
import qualified Data.List.NonEmpty as NonEmpty
import qualified System.Directory as Directory
import qualified System.FilePath.Posix as FilePath
-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft }
staticDefaultConfig :: Config
staticDefaultConfig = Config
{ _conf_version = coerce (1 :: Int)
, _conf_debug = DebugConfig
{ _dconf_dump_config = coerce False
, _dconf_dump_annotations = coerce False
, _dconf_dump_ast_unknown = coerce False
, _dconf_dump_ast_full = coerce False
, _dconf_dump_bridoc_raw = coerce False
, _dconf_dump_bridoc_simpl_alt = coerce False
{ _conf_version = coerce (1 :: Int)
, _conf_debug = DebugConfig
{ _dconf_dump_config = coerce False
, _dconf_dump_annotations = coerce False
, _dconf_dump_ast_unknown = coerce False
, _dconf_dump_ast_full = coerce False
, _dconf_dump_bridoc_raw = coerce False
, _dconf_dump_bridoc_simpl_alt = coerce False
, _dconf_dump_bridoc_simpl_floating = coerce False
, _dconf_dump_bridoc_simpl_par = coerce False
, _dconf_dump_bridoc_simpl_columns = coerce False
, _dconf_dump_bridoc_simpl_indent = coerce False
, _dconf_dump_bridoc_final = coerce False
, _dconf_roundtrip_exactprint_only = coerce False
, _dconf_dump_bridoc_simpl_par = coerce False
, _dconf_dump_bridoc_simpl_columns = coerce False
, _dconf_dump_bridoc_simpl_indent = coerce False
, _dconf_dump_bridoc_final = coerce False
, _dconf_roundtrip_exactprint_only = coerce False
}
, _conf_layout = LayoutConfig
{ _lconfig_cols = coerce (80 :: Int)
, _lconfig_indentPolicy = coerce IndentPolicyFree
, _lconfig_indentAmount = coerce (2 :: Int)
, _lconfig_indentWhereSpecial = coerce True
, _lconfig_indentListSpecial = coerce True
, _lconfig_importColumn = coerce (50 :: Int)
, _lconfig_importAsColumn = coerce (50 :: Int)
, _conf_layout = LayoutConfig
{ _lconfig_cols = coerce (80 :: Int)
, _lconfig_indentPolicy = coerce IndentPolicyFree
, _lconfig_indentAmount = coerce (2 :: Int)
, _lconfig_indentWhereSpecial = coerce True
, _lconfig_indentListSpecial = coerce True
, _lconfig_importColumn = coerce (50 :: Int)
, _lconfig_importAsColumn = coerce (50 :: Int)
, _lconfig_altChooser = coerce (AltChooserBoundedSearch 3)
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
, _lconfig_alignmentLimit = coerce (30 :: Int)
, _lconfig_alignmentBreakOnMultiline = coerce True
, _lconfig_hangingTypeSignature = coerce False
, _lconfig_reformatModulePreamble = coerce True
, _lconfig_allowSingleLineExportList = coerce False
, _lconfig_allowHangingQuasiQuotes = coerce True
, _lconfig_alignmentLimit = coerce (30 :: Int)
, _lconfig_alignmentBreakOnMultiline = coerce True
, _lconfig_hangingTypeSignature = coerce False
, _lconfig_reformatModulePreamble = coerce True
, _lconfig_allowSingleLineExportList = coerce False
, _lconfig_allowHangingQuasiQuotes = coerce True
, _lconfig_experimentalSemicolonNewlines = coerce False
-- , _lconfig_allowSinglelineRecord = coerce False
}
, _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = coerce False
, _econf_Werror = coerce False
, _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline
, _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = coerce False
, _econf_Werror = coerce False
, _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline
, _econf_omit_output_valid_check = coerce False
}
, _conf_preprocessor = PreProcessorConfig
{ _ppconf_CPPMode = coerce CPPModeAbort
, _conf_preprocessor = PreProcessorConfig
{ _ppconf_CPPMode = coerce CPPModeAbort
, _ppconf_hackAroundIncludes = coerce False
}
, _conf_forward = ForwardOptions { _options_ghc = Identity [] }
, _conf_roundtrip_exactprint_only = coerce False
, _conf_disable_formatting = coerce False
, _conf_obfuscate = coerce False
, _conf_disable_formatting = coerce False
, _conf_obfuscate = coerce False
}
forwardOptionsSyntaxExtsEnabled :: ForwardOptions
forwardOptionsSyntaxExtsEnabled = ForwardOptions
{ _options_ghc = Identity
[ "-XLambdaCase"
, "-XMultiWayIf"
, "-XGADTs"
, "-XPatternGuards"
, "-XViewPatterns"
, "-XTupleSections"
, "-XExplicitForAll"
, "-XImplicitParams"
, "-XQuasiQuotes"
, "-XTemplateHaskell"
, "-XBangPatterns"
, "-XTypeApplications"
]
[ "-XLambdaCase"
, "-XMultiWayIf"
, "-XGADTs"
, "-XPatternGuards"
, "-XViewPatterns"
, "-XTupleSections"
, "-XExplicitForAll"
, "-XImplicitParams"
, "-XQuasiQuotes"
, "-XTemplateHaskell"
, "-XBangPatterns"
, "-XTypeApplications"
]
}
-- brittany-next-binding --columns 200
-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 200 }
cmdlineConfigParser :: CmdParser Identity out (CConfig Maybe)
cmdlineConfigParser = do
-- TODO: why does the default not trigger; ind never should be []!!
ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level")
cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)")
importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at")
importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at")
ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level")
cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)")
importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at")
importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at")
dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)")
dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint")
dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany")
dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast")
dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc")
dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt")
dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par")
dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)")
dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint")
dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany")
dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast")
dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc")
dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt")
dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par")
dumpBriDocFloating <- addSimpleBoolFlag "" ["dump-bridoc-floating"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating")
dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns")
dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent")
dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc")
dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns")
dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent")
dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc")
outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)")
wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors")
omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)")
outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)")
wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors")
omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)")
roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)")
roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)")
optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.")
disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.")
obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.")
optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.")
disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.")
obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.")
return $ Config
{ _conf_version = mempty
, _conf_debug = DebugConfig
{ _dconf_dump_config = wrapLast $ falseToNothing dumpConfig
, _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations
, _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST
, _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST
, _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw
, _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt
, _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar
{ _conf_version = mempty
, _conf_debug = DebugConfig
{ _dconf_dump_config = wrapLast $ falseToNothing dumpConfig
, _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations
, _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST
, _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST
, _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw
, _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt
, _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar
, _dconf_dump_bridoc_simpl_floating = wrapLast $ falseToNothing dumpBriDocFloating
, _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns
, _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent
, _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal
, _dconf_roundtrip_exactprint_only = mempty
, _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns
, _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent
, _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal
, _dconf_roundtrip_exactprint_only = mempty
}
, _conf_layout = LayoutConfig
{ _lconfig_cols = optionConcat cols
, _lconfig_indentPolicy = mempty
, _lconfig_indentAmount = optionConcat ind
, _lconfig_indentWhereSpecial = mempty -- falseToNothing _
, _lconfig_indentListSpecial = mempty -- falseToNothing _
, _lconfig_importColumn = optionConcat importCol
, _lconfig_importAsColumn = optionConcat importAsCol
, _lconfig_altChooser = mempty
, _lconfig_columnAlignMode = mempty
, _lconfig_alignmentLimit = mempty
, _lconfig_alignmentBreakOnMultiline = mempty
, _lconfig_hangingTypeSignature = mempty
, _lconfig_reformatModulePreamble = mempty
, _lconfig_allowSingleLineExportList = mempty
, _lconfig_allowHangingQuasiQuotes = mempty
, _conf_layout = LayoutConfig
{ _lconfig_cols = optionConcat cols
, _lconfig_indentPolicy = mempty
, _lconfig_indentAmount = optionConcat ind
, _lconfig_indentWhereSpecial = mempty -- falseToNothing _
, _lconfig_indentListSpecial = mempty -- falseToNothing _
, _lconfig_importColumn = optionConcat importCol
, _lconfig_importAsColumn = optionConcat importAsCol
, _lconfig_altChooser = mempty
, _lconfig_columnAlignMode = mempty
, _lconfig_alignmentLimit = mempty
, _lconfig_alignmentBreakOnMultiline = mempty
, _lconfig_hangingTypeSignature = mempty
, _lconfig_reformatModulePreamble = mempty
, _lconfig_allowSingleLineExportList = mempty
, _lconfig_allowHangingQuasiQuotes = mempty
, _lconfig_experimentalSemicolonNewlines = mempty
-- , _lconfig_allowSinglelineRecord = mempty
}
, _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors
, _econf_Werror = wrapLast $ falseToNothing wError
, _econf_ExactPrintFallback = mempty
, _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors
, _econf_Werror = wrapLast $ falseToNothing wError
, _econf_ExactPrintFallback = mempty
, _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck
}
, _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty }
, _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] }
, _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty }
, _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] }
, _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly
, _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting
, _conf_obfuscate = wrapLast $ falseToNothing obfuscate
, _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting
, _conf_obfuscate = wrapLast $ falseToNothing obfuscate
}
where
falseToNothing = Bool.bool Nothing (Just True)
@ -217,8 +228,8 @@ readConfig path = do
fileConf <- case Data.Yaml.decodeEither' contents of
Left e -> do
liftIO
$ putStrErrLn
$ "error reading in brittany config from "
$ putStrErrLn
$ "error reading in brittany config from "
++ path
++ ":"
liftIO $ putStrErrLn (Data.Yaml.prettyPrintParseException e)
@ -232,12 +243,11 @@ readConfig path = do
userConfigPath :: IO System.IO.FilePath
userConfigPath = do
userBritPathSimple <- Directory.getAppUserDataDirectory "brittany"
userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany"
userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany"
let searchDirs = [userBritPathSimple, userBritPathXdg]
globalConfig <- Directory.findFileWith
Directory.doesFileExist
searchDirs
"config.yaml"
globalConfig <- Directory.findFileWith Directory.doesFileExist
searchDirs
"config.yaml"
maybe (writeUserConfig userBritPathXdg) pure globalConfig
where
writeUserConfig dir = do
@ -249,7 +259,7 @@ userConfigPath = do
-- | Searches for a local (per-project) brittany config starting from a given directory
findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath)
findLocalConfigPath dir = do
let dirParts = FilePath.splitDirectories dir
let dirParts = FilePath.splitDirectories dir
-- when provided dir is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"]
let searchDirs = FilePath.joinPath <$> reverse (List.inits dirParts)
Directory.findFileWith Directory.doesFileExist searchDirs "brittany.yaml"
@ -261,9 +271,8 @@ readConfigs
-> MaybeT IO Config
readConfigs cmdlineConfig configPaths = do
configs <- readConfig `mapM` configPaths
let
merged =
Semigroup.sconcat $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs)
let merged = Semigroup.sconcat
$ NonEmpty.reverse (cmdlineConfig :| catMaybes configs)
return $ cZipWith fromOptionIdentity staticDefaultConfig merged
-- | Reads provided configs

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

@ -7,54 +7,63 @@
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.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 (Identity x) = coerce x
data CDebugConfig f = DebugConfig
{ _dconf_dump_config :: f (Semigroup.Last Bool)
, _dconf_dump_annotations :: f (Semigroup.Last Bool)
, _dconf_dump_ast_unknown :: f (Semigroup.Last Bool)
, _dconf_dump_ast_full :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_raw :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_simpl_alt :: f (Semigroup.Last Bool)
{ _dconf_dump_config :: f (Semigroup.Last Bool)
, _dconf_dump_annotations :: f (Semigroup.Last Bool)
, _dconf_dump_ast_unknown :: f (Semigroup.Last Bool)
, _dconf_dump_ast_full :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_raw :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_simpl_alt :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_simpl_floating :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_simpl_par :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_simpl_columns :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_simpl_indent :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_final :: f (Semigroup.Last Bool)
, _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_simpl_par :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_simpl_columns :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_simpl_indent :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_final :: f (Semigroup.Last Bool)
, _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool)
}
deriving Generic
deriving (Generic)
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.
, _lconfig_indentPolicy :: f (Last IndentPolicy)
, _lconfig_indentAmount :: f (Last Int)
, _lconfig_indentWhereSpecial :: f (Last Bool) -- indent where only 1 sometimes (TODO).
, _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for ","
, _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for ","
-- when creating zero-indentation
-- multi-line list literals.
, _lconfig_importColumn :: f (Last Int)
, _lconfig_importColumn :: f (Last Int)
-- ^ for import statement layouting, column at which to align the
-- elements to be imported from a module.
-- It is expected that importAsColumn >= importCol.
, _lconfig_importAsColumn :: f (Last Int)
, _lconfig_importAsColumn :: f (Last Int)
-- ^ for import statement layouting, column at which put the module's
-- "as" name (which also affects the positioning of the "as" keyword).
-- It is expected that importAsColumn >= importCol.
, _lconfig_altChooser :: f (Last AltChooser)
, _lconfig_altChooser :: f (Last AltChooser)
, _lconfig_columnAlignMode :: f (Last ColumnAlignMode)
, _lconfig_alignmentLimit :: f (Last Int)
, _lconfig_alignmentLimit :: f (Last Int)
-- roughly speaking, this sets an upper bound to the number of spaces
-- inserted to create horizontal alignment.
-- More specifically, if 'xs' are the widths of the columns in some
@ -139,17 +148,17 @@ data CLayoutConfig f = LayoutConfig
-- -- > , y :: Double
-- -- > }
}
deriving Generic
deriving (Generic)
data CForwardOptions f = ForwardOptions
{ _options_ghc :: f [String]
}
deriving Generic
deriving (Generic)
data CErrorHandlingConfig f = ErrorHandlingConfig
{ _econf_produceOutputOnErrors :: f (Semigroup.Last Bool)
, _econf_Werror :: f (Semigroup.Last Bool)
, _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode)
{ _econf_produceOutputOnErrors :: f (Semigroup.Last Bool)
, _econf_Werror :: f (Semigroup.Last Bool)
, _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode)
-- ^ Determines when to fall back on the exactprint'ed output when
-- syntactical constructs are encountered which are not yet handled by
-- brittany.
@ -159,21 +168,21 @@ data CErrorHandlingConfig f = ErrorHandlingConfig
-- has different semantics than the code pre-transformation.
, _econf_omit_output_valid_check :: f (Semigroup.Last Bool)
}
deriving Generic
deriving (Generic)
data CPreProcessorConfig f = PreProcessorConfig
{ _ppconf_CPPMode :: f (Semigroup.Last CPPMode)
, _ppconf_hackAroundIncludes :: f (Semigroup.Last Bool)
}
deriving Generic
deriving (Generic)
data CConfig f = Config
{ _conf_version :: f (Semigroup.Last Int)
, _conf_debug :: CDebugConfig f
, _conf_layout :: CLayoutConfig f
{ _conf_version :: f (Semigroup.Last Int)
, _conf_debug :: CDebugConfig f
, _conf_layout :: CLayoutConfig f
, _conf_errorHandling :: CErrorHandlingConfig f
, _conf_forward :: CForwardOptions f
, _conf_preprocessor :: CPreProcessorConfig f
, _conf_forward :: CForwardOptions f
, _conf_preprocessor :: CPreProcessorConfig f
, _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool)
-- ^ this field is somewhat of a duplicate of the one in DebugConfig.
-- It is used for per-declaration disabling by the inline config
@ -184,9 +193,10 @@ data CConfig f = Config
-- module. Useful for wildcard application
-- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something
-- in that direction).
, _conf_obfuscate :: f (Semigroup.Last Bool)
, _conf_obfuscate :: f (Semigroup.Last Bool)
}
deriving Generic
deriving (Generic)
type DebugConfig = CDebugConfig Identity
type LayoutConfig = CLayoutConfig Identity

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

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

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

@ -7,35 +7,48 @@
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.Trans.Except as ExceptT
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import Data.Data
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.Maybe
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import GHC (GenLocated(L))
import qualified GHC hiding (parseModule)
import GHC.Data.Bag
import qualified GHC.Driver.CmdLine as GHC
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.Delta as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified System.IO
import Language.Haskell.Brittany.Internal.Config.Types
import Data.Data
import Data.HList.HList
import GHC ( GenLocated(L) )
import qualified GHC.Driver.Session as GHC
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.Types.SrcLoc ( SrcSpan, Located )
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 Data.Generics as SYB
import Control.Exception
-- import Data.Generics.Schemes
parseModule
:: [String]
-> System.IO.FilePath
@ -54,7 +67,7 @@ parseModuleWithCpp
-> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
parseModuleWithCpp cpp opts args fp dynCheck =
ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do
dflags0 <- lift $ GHC.getSessionDynFlags
dflags0 <- lift $ GHC.getSessionDynFlags
(dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine
dflags0
(GHC.noLoc <$> ("-hide-all-packages" : args))
@ -66,20 +79,17 @@ parseModuleWithCpp cpp opts args fp dynCheck =
void $ lift $ GHC.setSessionDynFlags dflags1
dflags2 <- lift $ ExactPrint.initDynFlags fp
unless (null leftover)
$ ExceptT.throwE
$ "when parsing ghc flags: leftover flags: "
$ ExceptT.throwE
$ "when parsing ghc flags: leftover flags: "
++ show (leftover <&> \(L _ s) -> s)
unless (null warnings)
$ ExceptT.throwE
$ "when parsing ghc flags: encountered warnings: "
$ ExceptT.throwE
$ "when parsing ghc flags: encountered warnings: "
++ show (warnings <&> warnExtractorCompat)
x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2
x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2
res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp
either
(\err -> ExceptT.throwE $ "transform error: " ++ show
(bagToList (show <$> err))
)
(\(a, m) -> pure (a, m, x))
either (\err -> ExceptT.throwE $ "transform error: " ++ show (bagToList (show <$> err)))
(\(a, m) -> pure (a, m, x))
$ ExactPrint.postParseTransform res opts
parseModuleFromString
@ -97,51 +107,46 @@ parseModuleFromString args fp dynCheck str =
-- bridoc transformation stuff.
-- (reminder to update note on `parsePrintModule` if this changes.)
mask_ $ ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do
dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str
dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str
(dflags1, leftover, warnings) <- lift
$ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args)
unless (null leftover)
$ ExceptT.throwE
$ "when parsing ghc flags: leftover flags: "
$ ExceptT.throwE
$ "when parsing ghc flags: leftover flags: "
++ show (leftover <&> \(L _ s) -> s)
unless (null warnings)
$ ExceptT.throwE
$ "when parsing ghc flags: encountered warnings: "
$ ExceptT.throwE
$ "when parsing ghc flags: encountered warnings: "
++ show (warnings <&> warnExtractorCompat)
dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1
let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str
case res of
Left err ->
ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err))
Right (a, m) -> pure (a, m, dynCheckRes)
Left err -> ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err))
Right (a , m ) -> pure (a, m, dynCheckRes)
commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform ()
commentAnnFixTransformGlob ast = do
let
extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $
const Seq.empty
`SYB.ext1Q` (\l@(L span _) ->
Seq.singleton (span, ExactPrint.mkAnnKey l)
)
let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $
const Seq.empty
`SYB.ext1Q`
(\l@(L span _) -> Seq.singleton (span, ExactPrint.mkAnnKey l))
let nodes = SYB.everything (<>) extract ast
let
annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey
annsMap = Map.fromListWith
(const id)
[ (GHC.realSrcSpanEnd span, annKey)
| (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes
]
let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey
annsMap = Map.fromListWith
(const id)
[ (GHC.realSrcSpanEnd span, annKey)
| (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes
]
nodes `forM_` (snd .> processComs annsMap)
where
processComs annsMap annKey1 = do
mAnn <- State.Class.gets fst <&> Map.lookup annKey1
mAnn `forM_` \ann1 -> do
let
priors = ExactPrint.annPriorComments ann1
follows = ExactPrint.annFollowingComments ann1
assocs = ExactPrint.annsDP ann1
let priors = ExactPrint.annPriorComments ann1
follows = ExactPrint.annFollowingComments ann1
assocs = ExactPrint.annsDP ann1
let
processCom
:: (ExactPrint.Comment, ExactPrint.DeltaPos)
@ -153,32 +158,31 @@ commentAnnFixTransformGlob ast = do
(ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") ->
move $> False
(x, y) | x == y -> move $> False
_ -> return True
_ -> return True
where
ExactPrint.AnnKey annKeyLoc1 con1 = annKey1
ExactPrint.AnnKey annKeyLoc2 con2 = annKey2
loc1 = GHC.realSrcSpanStart annKeyLoc1
loc2 = GHC.realSrcSpanStart annKeyLoc2
loc1 = GHC.realSrcSpanStart annKeyLoc1
loc2 = GHC.realSrcSpanStart annKeyLoc2
move = ExactPrint.modifyAnnsT $ \anns ->
let
ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns
ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns
ann2' = ann2
{ ExactPrint.annFollowingComments =
ExactPrint.annFollowingComments ann2 ++ [comPair]
ExactPrint.annFollowingComments ann2 ++ [comPair]
}
in Map.insert annKey2 ann2' anns
in
Map.insert annKey2 ann2' anns
_ -> return True -- retain comment at current node.
priors' <- filterM processCom priors
priors' <- filterM processCom priors
follows' <- filterM processCom follows
assocs' <- flip filterM assocs $ \case
assocs' <- flip filterM assocs $ \case
(ExactPrint.AnnComment com, dp) -> processCom (com, dp)
_ -> return True
let
ann1' = ann1
{ ExactPrint.annPriorComments = priors'
, ExactPrint.annFollowingComments = follows'
, ExactPrint.annsDP = assocs'
}
_ -> return True
let ann1' = ann1 { ExactPrint.annPriorComments = priors'
, ExactPrint.annFollowingComments = follows'
, ExactPrint.annsDP = assocs'
}
ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns
@ -266,30 +270,29 @@ extractToplevelAnns lmod anns = output
| (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns
]
declMap = declMap1 `Map.union` declMap2
modKey = ExactPrint.mkAnnKey lmod
output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns
modKey = ExactPrint.mkAnnKey lmod
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 f = Map.foldlWithKey'
(\m k a -> Map.alter (insert k a) (f k a) m)
Map.empty
groupMap f = Map.foldlWithKey' (\m k a -> Map.alter (insert k a) (f k a) m)
Map.empty
where
insert k a Nothing = Just (Map.singleton k a)
insert k a Nothing = Just (Map.singleton k a)
insert k a (Just m) = Just (Map.insert k a m)
foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey
foldedAnnKeys ast = SYB.everything
Set.union
(\x -> maybe
( \x -> maybe
Set.empty
Set.singleton
[ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x
| locTyCon == SYB.typeRepTyCon (SYB.typeOf x)
, l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x
]
-- 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
-- SrcSpan.
]
)
ast
where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ()))
@ -298,8 +301,8 @@ foldedAnnKeys ast = SYB.everything
withTransformedAnns
:: Data ast
=> ast
-> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a
-> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a
-> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a
-> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a
withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case
readers@(conf :+: anns :+: HNil) -> do
-- TODO: implement `local` for MultiReader/MultiRWS
@ -309,10 +312,9 @@ withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case
pure x
where
f anns =
let
((), (annsBalanced, _), _) =
ExactPrint.runTransform anns (commentAnnFixTransformGlob ast)
in annsBalanced
let ((), (annsBalanced, _), _) =
ExactPrint.runTransform anns (commentAnnFixTransformGlob ast)
in annsBalanced
warnExtractorCompat :: GHC.Warn -> String

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

@ -6,37 +6,50 @@
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.Writer.Strict as Writer
import qualified Data.Char as Char
import Data.Data
import qualified Data.Map as Map
import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
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 GHC.Parser.Annotation (AnnKeywordId(..))
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 Control.Monad.Writer.Strict as Writer
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
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
import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation )
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
:: ( ExactPrint.Annotate.Annotate ast
, MonadMultiWriter Text.Builder.Builder m
@ -54,7 +67,7 @@ processDefault x = do
-- the module (header). This would remove the need for this hack!
case str of
"\n" -> return ()
_ -> mTell $ Text.Builder.fromString str
_ -> mTell $ Text.Builder.fromString str
-- | Use ExactPrint's output for this node; add a newly generated inline comment
-- at insertion position (meant to point out to the user that this node is
@ -66,10 +79,9 @@ briDocByExact
-> ToBriDocM BriDocNumbered
briDocByExact ast = do
anns <- mAsk
traceIfDumpConf
"ast"
_dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
traceIfDumpConf "ast"
_dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
docExt ast anns True
-- | Use ExactPrint's output for this node.
@ -83,10 +95,9 @@ briDocByExactNoComment
-> ToBriDocM BriDocNumbered
briDocByExactNoComment ast = do
anns <- mAsk
traceIfDumpConf
"ast"
_dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
traceIfDumpConf "ast"
_dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
docExt ast anns False
-- | Use ExactPrint's output for this node, presuming that this output does
@ -99,26 +110,24 @@ briDocByExactInlineOnly
-> ToBriDocM BriDocNumbered
briDocByExactInlineOnly infoStr ast = do
anns <- mAsk
traceIfDumpConf
"ast"
_dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
traceIfDumpConf "ast"
_dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns
fallbackMode <-
mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack
let
exactPrintNode t = allocateNode $ BDFExternal
(ExactPrint.Types.mkAnnKey ast)
(foldedAnnKeys ast)
False
t
let
errorAction = do
mTell [ErrorUnknownNode infoStr ast]
docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"
let exactPrintNode t = allocateNode $ BDFExternal
(ExactPrint.Types.mkAnnKey ast)
(foldedAnnKeys ast)
False
t
let errorAction = do
mTell [ErrorUnknownNode infoStr ast]
docLit
$ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"
case (fallbackMode, Text.lines exactPrinted) of
(ExactPrintFallbackModeNever, _) -> errorAction
(_, [t]) -> exactPrintNode
(ExactPrintFallbackModeNever, _ ) -> errorAction
(_ , [t]) -> exactPrintNode
(Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t)
(ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted
_ -> errorAction
@ -143,21 +152,20 @@ lrdrNameToTextAnnGen
lrdrNameToTextAnnGen f ast@(L _ n) = do
anns <- mAsk
let t = f $ rdrNameToText n
let
hasUni x (ExactPrint.Types.G y, _) = x == y
hasUni _ _ = False
let hasUni x (ExactPrint.Types.G y, _) = x == y
hasUni _ _ = False
-- TODO: in general: we should _always_ process all annotaiton stuff here.
-- whatever we don't probably should have had some effect on the
-- output. in such cases, resorting to byExact is probably the safe
-- choice.
return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of
Nothing -> t
Nothing -> t
Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of
Exact{} | t == Text.pack "()" -> t
_ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`"
Exact{} | t == Text.pack "()" -> t
_ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`"
_ | any (hasUni AnnCommaTuple) aks -> t
_ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")"
_ | otherwise -> t
_ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")"
_ | otherwise -> t
lrdrNameToTextAnn
:: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
@ -170,10 +178,9 @@ lrdrNameToTextAnnTypeEqualityIsSpecial
=> Located RdrName
-> m Text
lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
let
f x = if x == Text.pack "Data.Type.Equality~"
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
else x
let f x = if x == Text.pack "Data.Type.Equality~"
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
else x
lrdrNameToTextAnnGen f ast
-- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects
@ -191,11 +198,10 @@ lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick
-> m Text
lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do
hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote
x <- lrdrNameToTextAnn ast2
let
lit = if x == Text.pack "Data.Type.Equality~"
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
else x
x <- lrdrNameToTextAnn ast2
let lit = if x == Text.pack "Data.Type.Equality~"
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
else x
return $ if hasQuote then Text.cons '\'' lit else lit
askIndent :: (MonadMultiReader Config m) => m Int
@ -213,11 +219,12 @@ extractRestComments ann =
ExactPrint.annFollowingComments ann
++ (ExactPrint.annsDP ann >>= \case
(ExactPrint.AnnComment com, dp) -> [(com, dp)]
_ -> []
_ -> []
)
filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns
filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast)
filterAnns ast =
Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast)
-- | True if there are any comments that are
-- a) connected to any node below (in AST sense) the given node AND
@ -235,16 +242,15 @@ hasCommentsBetween
-> ToBriDocM Bool
hasCommentsBetween ast leftKey rightKey = do
mAnn <- astAnn ast
let
go1 [] = False
go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest
go1 (_ : rest) = go1 rest
go2 [] = False
go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True
go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False
go2 (_ : rest) = go2 rest
let go1 [] = False
go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest
go1 (_ : rest) = go1 rest
go2 [] = False
go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True
go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False
go2 (_ : rest) = go2 rest
case mAnn of
Nothing -> pure False
Nothing -> pure False
Just ann -> pure $ go1 $ ExactPrint.annsDP ann
-- | True if there are any comments that are connected to any node below (in AST
@ -254,8 +260,7 @@ hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast
-- | True if there are any regular comments connected to any node below (in AST
-- sense) the given node
hasAnyRegularCommentsConnected
:: Data ast => GHC.Located ast -> ToBriDocM Bool
hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool
hasAnyRegularCommentsConnected ast =
any isRegularComment <$> astConnectedComments ast
@ -292,7 +297,7 @@ hasAnyRegularCommentsRest ast = astAnn ast <&> \case
hasAnnKeywordComment
:: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool
hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case
Nothing -> False
Nothing -> False
Just ann -> any hasK (extractAllComments ann)
where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst
@ -306,7 +311,7 @@ hasAnnKeyword ast annKeyword = astAnn ast <&> \case
Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks
where
hasK (ExactPrint.Types.G x, _) = x == annKeyword
hasK _ = False
hasK _ = False
astAnn
:: (Data ast, MonadMultiReader (Map AnnKey Annotation) m)
@ -455,10 +460,12 @@ newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a)
deriving (Functor, Applicative, Monad)
addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM ()
addAlternativeCond cond doc = when cond (addAlternative doc)
addAlternativeCond cond doc =
when cond (addAlternative doc)
addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM ()
addAlternative = CollectAltM . Writer.tell . (: [])
addAlternative =
CollectAltM . Writer.tell . (: [])
runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered
runFilteredAlternative (CollectAltM action) =
@ -475,8 +482,7 @@ docLines l = allocateNode . BDFLines =<< sequence l
docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
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
docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
@ -511,8 +517,7 @@ docAnnotationKW
-> Maybe AnnKeywordId
-> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
docAnnotationKW annKey kw bdm =
allocateNode . BDFAnnotationKW annKey kw =<< bdm
docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm
docMoveToKWDP
:: AnnKey
@ -564,7 +569,7 @@ docParenR :: ToBriDocM BriDocNumbered
docParenR = docLit $ Text.pack ")"
docParenHashLSep :: ToBriDocM BriDocNumbered
docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator]
docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator]
docParenHashRSep :: ToBriDocM BriDocNumbered
docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"]
@ -626,26 +631,32 @@ instance DocWrapable (ToBriDocM BriDocNumbered) where
docWrapNodePrior ast bdm = do
bd <- bdm
i1 <- allocNodeIndex
return $ (,) i1 $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ bd
return
$ (,) i1
$ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
$ bd
docWrapNodeRest ast bdm = do
bd <- bdm
i2 <- allocNodeIndex
return $ (,) i2 $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd
return
$ (,) i2
$ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast)
$ bd
instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where
docWrapNode ast bdms = case bdms of
[] -> []
[bd] -> [docWrapNode ast bd]
(bd1 : bdR) | (bdN : bdM) <- reverse bdR ->
(bd1:bdR) | (bdN:bdM) <- reverse bdR ->
[docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN]
_ -> error "cannot happen (TM)"
docWrapNodePrior ast bdms = case bdms of
[] -> []
[bd] -> [docWrapNodePrior ast bd]
(bd1 : bdR) -> docWrapNodePrior ast bd1 : bdR
(bd1:bdR) -> docWrapNodePrior ast bd1 : bdR
docWrapNodeRest ast bdms = case reverse bdms of
[] -> []
(bdN : bdR) -> reverse $ docWrapNodeRest ast bdN : bdR
[] -> []
(bdN:bdR) -> reverse $ docWrapNodeRest ast bdN : bdR
instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where
docWrapNode ast bdsm = do
@ -655,25 +666,25 @@ instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where
[bd] -> do
bd' <- docWrapNode ast (return bd)
return [bd']
(bd1 : bdR) | (bdN : bdM) <- reverse bdR -> do
(bd1:bdR) | (bdN:bdM) <- reverse bdR -> do
bd1' <- docWrapNodePrior ast (return bd1)
bdN' <- docWrapNodeRest ast (return bdN)
bdN' <- docWrapNodeRest ast (return bdN)
return $ [bd1'] ++ reverse bdM ++ [bdN']
_ -> error "cannot happen (TM)"
docWrapNodePrior ast bdsm = do
bds <- bdsm
case bds of
[] -> return []
(bd1 : bdR) -> do
(bd1:bdR) -> do
bd1' <- docWrapNodePrior ast (return bd1)
return (bd1' : bdR)
return (bd1':bdR)
docWrapNodeRest ast bdsm = do
bds <- bdsm
case reverse bds of
[] -> return []
(bdN : bdR) -> do
(bdN:bdR) -> do
bdN' <- docWrapNodeRest ast (return bdN)
return $ reverse (bdN' : bdR)
return $ reverse (bdN':bdR)
instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where
docWrapNode ast bdsm = do
@ -686,7 +697,7 @@ instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where
return $ Seq.singleton bd1'
bdM Seq.:> bdN -> do
bd1' <- docWrapNodePrior ast (return bd1)
bdN' <- docWrapNodeRest ast (return bdN)
bdN' <- docWrapNodeRest ast (return bdN)
return $ (bd1' Seq.<| bdM) Seq.|> bdN'
docWrapNodePrior ast bdsm = do
bds <- bdsm
@ -730,7 +741,7 @@ docPar
-> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
docPar lineM indentedM = do
line <- lineM
line <- lineM
indented <- indentedM
allocateNode $ BDFPar BrIndentNone line indented
@ -767,15 +778,14 @@ briDocMToPPM m = do
briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String)
briDocMToPPMInner m = do
readers <- MultiRWSS.mGetRawR
let
((x, errs), debugs) =
runIdentity
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiStateA (NodeAllocIndex 1)
$ MultiRWSS.withMultiReaders readers
$ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterAW
$ m
let ((x, errs), debugs) =
runIdentity
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiStateA (NodeAllocIndex 1)
$ MultiRWSS.withMultiReaders readers
$ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterAW
$ m
pure (x, errs, debugs)
docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y)

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

@ -3,19 +3,26 @@
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.Semigroup as Semigroup
import qualified Data.Text as Text
import GHC (GenLocated(L), Located)
import qualified GHC
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.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
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 GHC.Hs
import Language.Haskell.Brittany.Internal.Layouters.Type
layoutDataDecl
:: Located (TyClDecl GhcPs)
@ -25,29 +32,28 @@ layoutDataDecl
-> ToBriDocM BriDocNumbered
layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
-- newtype MyType a b = MyType ..
HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs ->
case cons of
(L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc))
-> docWrapNode ltycl $ do
nameStr <- lrdrNameToTextAnn name
consNameStr <- lrdrNameToTextAnn consName
tyVarLine <- return <$> createBndrDoc bndrs
-- headDoc <- fmap return $ docSeq
-- [ appSep $ docLitS "newtype")
-- , appSep $ docLit nameStr
-- , appSep tyVarLine
-- ]
rhsDoc <- return <$> createDetailsDoc consNameStr details
createDerivingPar mDerivs $ docSeq
[ appSep $ docLitS "newtype"
, appSep $ docLit nameStr
, appSep tyVarLine
, docSeparator
, docLitS "="
, docSeparator
, rhsDoc
]
_ -> briDocByExactNoComment ltycl
HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of
(L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) ->
docWrapNode ltycl $ do
nameStr <- lrdrNameToTextAnn name
consNameStr <- lrdrNameToTextAnn consName
tyVarLine <- return <$> createBndrDoc bndrs
-- headDoc <- fmap return $ docSeq
-- [ appSep $ docLitS "newtype")
-- , appSep $ docLit nameStr
-- , appSep tyVarLine
-- ]
rhsDoc <- return <$> createDetailsDoc consNameStr details
createDerivingPar mDerivs $ docSeq
[ appSep $ docLitS "newtype"
, appSep $ docLit nameStr
, appSep tyVarLine
, docSeparator
, docLitS "="
, docSeparator
, rhsDoc
]
_ -> briDocByExactNoComment ltycl
-- data MyData a b
@ -55,8 +61,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs ->
docWrapNode ltycl $ do
lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
nameStr <- lrdrNameToTextAnn name
tyVarLine <- return <$> createBndrDoc bndrs
nameStr <- lrdrNameToTextAnn name
tyVarLine <- return <$> createBndrDoc bndrs
createDerivingPar mDerivs $ docSeq
[ appSep $ docLitS "data"
, lhsContextDoc
@ -68,36 +74,32 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
-- data MyData = MyData { .. }
HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs ->
case cons of
(L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc))
-> docWrapNode ltycl $ do
(L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) ->
docWrapNode ltycl $ do
lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
nameStr <- lrdrNameToTextAnn name
consNameStr <- lrdrNameToTextAnn consName
tyVarLine <- return <$> createBndrDoc bndrs
forallDocMay <- case createForallDoc qvars of
nameStr <- lrdrNameToTextAnn name
consNameStr <- lrdrNameToTextAnn consName
tyVarLine <- return <$> createBndrDoc bndrs
forallDocMay <- case createForallDoc qvars of
Nothing -> pure Nothing
Just x -> Just . pure <$> x
rhsContextDocMay <- case mRhsContext of
Nothing -> pure Nothing
Nothing -> pure Nothing
Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt
rhsDoc <- return <$> createDetailsDoc consNameStr details
consDoc <-
fmap pure
rhsDoc <- return <$> createDetailsDoc consNameStr details
consDoc <- fmap pure
$ docNonBottomSpacing
$ case (forallDocMay, rhsContextDocMay) of
(Just forallDoc, Just rhsContextDoc) -> docLines
[ docSeq
[docLitS "=", docSeparator, docForceSingleline forallDoc]
[ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc]
, docSeq
[ docLitS "."
, docSeparator
, docSetBaseY
$ docLines [rhsContextDoc, docSetBaseY rhsDoc]
, docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc]
]
]
(Just forallDoc, Nothing) -> docLines
[ docSeq
[docLitS "=", docSeparator, docForceSingleline forallDoc]
[ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc]
, docSeq [docLitS ".", docSeparator, rhsDoc]
]
(Nothing, Just rhsContextDoc) -> docSeq
@ -105,12 +107,12 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
, docSeparator
, docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc]
]
(Nothing, Nothing) ->
docSeq [docLitS "=", docSeparator, rhsDoc]
(Nothing, Nothing) -> docSeq [docLitS "=", docSeparator, rhsDoc]
createDerivingPar mDerivs $ docAlt
[ -- data D = forall a . Show a => D a
docSeq
[ docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq
[ docNodeAnnKW ltycl (Just GHC.AnnData)
$ docSeq
[ appSep $ docLitS "data"
, docForceSingleline $ lhsContextDoc
, appSep $ docLit nameStr
@ -122,13 +124,12 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
, docSetIndentLevel $ docSeq
[ case forallDocMay of
Nothing -> docEmpty
Just forallDoc ->
docSeq
[ docForceSingleline forallDoc
, docSeparator
, docLitS "."
, docSeparator
]
Just forallDoc -> docSeq
[ docForceSingleline forallDoc
, docSeparator
, docLitS "."
, docSeparator
]
, maybe docEmpty docForceSingleline rhsContextDocMay
, rhsDoc
]
@ -136,26 +137,26 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
, -- data D
-- = forall a . Show a => D a
docAddBaseY BrIndentRegular $ docPar
(docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq
( docNodeAnnKW ltycl (Just GHC.AnnData)
$ docSeq
[ appSep $ docLitS "data"
, docForceSingleline lhsContextDoc
, appSep $ docLit nameStr
, tyVarLine
]
)
(docSeq
( docSeq
[ docLitS "="
, docSeparator
, docSetIndentLevel $ docSeq
[ case forallDocMay of
Nothing -> docEmpty
Just forallDoc ->
docSeq
[ docForceSingleline forallDoc
, docSeparator
, docLitS "."
, docSeparator
]
Just forallDoc -> docSeq
[ docForceSingleline forallDoc
, docSeparator
, docLitS "."
, docSeparator
]
, maybe docEmpty docForceSingleline rhsContextDocMay
, rhsDoc
]
@ -166,7 +167,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
-- . Show a =>
-- D a
docAddBaseY BrIndentRegular $ docPar
(docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq
( docNodeAnnKW ltycl (Just GHC.AnnData)
$ docSeq
[ appSep $ docLitS "data"
, docForceSingleline lhsContextDoc
, appSep $ docLit nameStr
@ -187,10 +189,13 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
-- hurt.
docAddBaseY BrIndentRegular $ docPar
(docLitS "data")
(docLines
( docLines
[ lhsContextDoc
, docNodeAnnKW ltycl (Just GHC.AnnData)
$ docSeq [appSep $ docLit nameStr, tyVarLine]
$ docSeq
[ appSep $ docLit nameStr
, tyVarLine
]
, consDoc
]
)
@ -204,20 +209,20 @@ createContextDoc [] = docEmpty
createContextDoc [t] =
docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator]
createContextDoc (t1 : tR) = do
t1Doc <- docSharedWrapper layoutType t1
t1Doc <- docSharedWrapper layoutType t1
tRDocs <- tR `forM` docSharedWrapper layoutType
docAlt
[ docSeq
[ docLitS "("
, docForceSingleline $ docSeq $ List.intersperse
docCommaSep
(t1Doc : tRDocs)
, docForceSingleline $ docSeq $ List.intersperse docCommaSep
(t1Doc : tRDocs)
, docLitS ") =>"
, docSeparator
]
, docLines $ join
[ [docSeq [docLitS "(", docSeparator, t1Doc]]
, tRDocs <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc]
, tRDocs
<&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc]
, [docLitS ") =>", docSeparator]
]
]
@ -229,18 +234,20 @@ createBndrDoc bs = do
(L _ (KindedTyVar _ _ext lrdrName kind)) -> do
d <- docSharedWrapper layoutType kind
return $ (lrdrNameToText lrdrName, Just $ d)
docSeq $ List.intersperse docSeparator $ tyVarDocs <&> \(vname, mKind) ->
case mKind of
Nothing -> docLit vname
Just kind -> docSeq
[ docLitS "("
, docLit vname
, docSeparator
, docLitS "::"
, docSeparator
, kind
, docLitS ")"
]
docSeq
$ List.intersperse docSeparator
$ tyVarDocs
<&> \(vname, mKind) -> case mKind of
Nothing -> docLit vname
Just kind -> docSeq
[ docLitS "("
, docLit vname
, docSeparator
, docLitS "::"
, docSeparator
, kind
, docLitS ")"
]
createDerivingPar
:: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
@ -249,47 +256,48 @@ createDerivingPar derivs mainDoc = do
(L _ []) -> mainDoc
(L _ types) ->
docPar mainDoc
$ docEnsureIndent BrIndentRegular
$ docLines
$ docWrapNode derivs
$ derivingClauseDoc
$ docEnsureIndent BrIndentRegular
$ docLines
$ docWrapNode derivs
$ derivingClauseDoc
<$> types
derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered
derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) =
case types of
(L _ []) -> docSeq []
(L _ ts) ->
let
tsLength = length ts
whenMoreThan1Type val =
if tsLength > 1 then docLitS val else docLitS ""
(lhsStrategy, rhsStrategy) =
maybe (docEmpty, docEmpty) strategyLeftRight mStrategy
in docSeq
derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of
(L _ []) -> docSeq []
(L _ ts) ->
let
tsLength = length ts
whenMoreThan1Type val =
if tsLength > 1 then docLitS val else docLitS ""
(lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy
in
docSeq
[ docDeriving
, docWrapNodePrior types $ lhsStrategy
, docSeparator
, whenMoreThan1Type "("
, docWrapNodeRest types
$ docSeq
$ List.intersperse docCommaSep
$ ts
<&> \case
HsIB _ t -> layoutType t
$ docSeq
$ List.intersperse docCommaSep
$ ts <&> \case
HsIB _ t -> layoutType t
, whenMoreThan1Type ")"
, rhsStrategy
]
where
strategyLeftRight = \case
(L _ StockStrategy) -> (docLitS " stock", docEmpty)
(L _ AnyclassStrategy) -> (docLitS " anyclass", docEmpty)
(L _ NewtypeStrategy) -> (docLitS " newtype", docEmpty)
lVia@(L _ (ViaStrategy viaTypes)) ->
(L _ StockStrategy ) -> (docLitS " stock", docEmpty)
(L _ AnyclassStrategy ) -> (docLitS " anyclass", docEmpty)
(L _ NewtypeStrategy ) -> (docLitS " newtype", docEmpty)
lVia@(L _ (ViaStrategy viaTypes) ) ->
( docEmpty
, case viaTypes of
HsIB _ext t -> docSeq
[docWrapNode lVia $ docLitS " via", docSeparator, layoutType t]
HsIB _ext t -> docSeq
[ docWrapNode lVia $ docLitS " via"
, docSeparator
, layoutType t
]
)
docDeriving :: ToBriDocM BriDocNumbered
@ -299,25 +307,21 @@ createDetailsDoc
:: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered)
createDetailsDoc consNameStr details = case details of
PrefixCon args -> do
indentPolicy <-
mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
let
singleLine = docSeq
[ docLit consNameStr
, docSeparator
, docForceSingleline
$ docSeq
$ List.intersperse docSeparator
$ fmap hsScaledThing args
<&> layoutType
$ docSeq
$ List.intersperse docSeparator
$ fmap hsScaledThing args <&> layoutType
]
leftIndented =
docSetParSpacing
. docAddBaseY BrIndentRegular
. docPar (docLit consNameStr)
. docLines
$ layoutType
<$> fmap hsScaledThing args
leftIndented = docSetParSpacing
. docAddBaseY BrIndentRegular
. docPar (docLit consNameStr)
. docLines
$ layoutType <$> fmap hsScaledThing args
multiAppended = docSeq
[ docLit consNameStr
, docSeparator
@ -327,80 +331,79 @@ createDetailsDoc consNameStr details = case details of
(docLit consNameStr)
(docLines $ layoutType <$> fmap hsScaledThing args)
case indentPolicy of
IndentPolicyLeft -> docAlt [singleLine, leftIndented]
IndentPolicyLeft -> docAlt [singleLine, leftIndented]
IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented]
IndentPolicyFree ->
docAlt [singleLine, multiAppended, multiIndented, leftIndented]
RecCon (L _ []) ->
docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"]
RecCon lRec@(L _ fields@(_ : _)) -> do
RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"]
RecCon lRec@(L _ fields@(_:_)) -> do
let ((fName1, fType1) : fDocR) = mkFieldDocs fields
-- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack
let allowSingleline = False
docAddBaseY BrIndentRegular $ runFilteredAlternative $ do
docAddBaseY BrIndentRegular
$ runFilteredAlternative
$ do
-- single-line: { i :: Int, b :: Bool }
addAlternativeCond allowSingleline $ docSeq
[ docLit consNameStr
, docSeparator
, docWrapNodePrior lRec $ docLitS "{"
, docSeparator
, docWrapNodeRest lRec
$ docForceSingleline
$ docSeq
$ join
$ [fName1, docSeparator, docLitS "::", docSeparator, fType1]
: [ [ docLitS ","
, docSeparator
, fName
, docSeparator
, docLitS "::"
, docSeparator
, fType
]
| (fName, fType) <- fDocR
]
, docSeparator
, docLitS "}"
]
addAlternative $ docPar
(docLit consNameStr)
(docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines
[ docAlt
[ docCols
ColRecDecl
[ appSep (docLitS "{")
, appSep $ docForceSingleline fName1
, docSeq [docLitS "::", docSeparator]
, docForceSingleline $ fType1
]
, docSeq
[ docLitS "{"
, docSeparator
, docSetBaseY $ docAddBaseY BrIndentRegular $ docPar
fName1
(docSeq [docLitS "::", docSeparator, fType1])
]
]
, docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) ->
docAlt
[ docCols
ColRecDecl
[ docCommaSep
, appSep $ docForceSingleline fName
, docSeq [docLitS "::", docSeparator]
, docForceSingleline fType
addAlternativeCond allowSingleline $ docSeq
[ docLit consNameStr
, docSeparator
, docWrapNodePrior lRec $ docLitS "{"
, docSeparator
, docWrapNodeRest lRec
$ docForceSingleline
$ docSeq
$ join
$ [fName1, docSeparator, docLitS "::", docSeparator, fType1]
: [ [ docLitS ","
, docSeparator
, fName
, docSeparator
, docLitS "::"
, docSeparator
, fType
]
| (fName, fType) <- fDocR
]
, docSeq
[ docLitS ","
, docSeparator
, docSetBaseY $ docAddBaseY BrIndentRegular $ docPar
fName
(docSeq [docLitS "::", docSeparator, fType])
]
]
, docSeparator
, docLitS "}"
]
)
addAlternative $ docPar
(docLit consNameStr)
(docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines
[ docAlt
[ docCols ColRecDecl
[ appSep (docLitS "{")
, appSep $ docForceSingleline fName1
, docSeq [docLitS "::", docSeparator]
, docForceSingleline $ fType1
]
, docSeq
[ docLitS "{"
, docSeparator
, docSetBaseY $ docAddBaseY BrIndentRegular $ docPar
fName1
(docSeq [docLitS "::", docSeparator, fType1])
]
]
, docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) ->
docAlt
[ docCols ColRecDecl
[ docCommaSep
, appSep $ docForceSingleline fName
, docSeq [docLitS "::", docSeparator]
, docForceSingleline fType
]
, docSeq
[ docLitS ","
, docSeparator
, docSetBaseY $ docAddBaseY BrIndentRegular $ docPar
fName
(docSeq [docLitS "::", docSeparator, fType])
]
]
, docLitS "}"
]
)
InfixCon arg1 arg2 -> docSeq
[ layoutType $ hsScaledThing arg1
, docSeparator
@ -415,11 +418,10 @@ createDetailsDoc consNameStr details = case details of
mkFieldDocs = fmap $ \lField -> case lField of
L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t
createForallDoc
:: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered)
createForallDoc [] = Nothing
createForallDoc lhsTyVarBndrs =
Just $ docSeq [docLitS "forall ", createBndrDoc lhsTyVarBndrs]
createForallDoc :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered)
createForallDoc [] = Nothing
createForallDoc lhsTyVarBndrs = Just $ docSeq
[docLitS "forall ", createBndrDoc lhsTyVarBndrs]
createNamesAndTypeDoc
:: Data.Data.Data ast
@ -429,8 +431,12 @@ createNamesAndTypeDoc
-> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)
createNamesAndTypeDoc lField names t =
( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq
[ docSeq $ List.intersperse docCommaSep $ names <&> \case
L _ (FieldOcc _ fieldName) -> docLit =<< lrdrNameToTextAnn fieldName
[ docSeq
$ List.intersperse docCommaSep
$ names
<&> \case
L _ (FieldOcc _ fieldName) ->
docLit =<< lrdrNameToTextAnn fieldName
]
, docWrapNodeRest lField $ layoutType t
)

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

File diff suppressed because it is too large Load Diff

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

File diff suppressed because it is too large Load Diff

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

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

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

@ -4,22 +4,26 @@
module Language.Haskell.Brittany.Internal.Layouters.IE where
import Language.Haskell.Brittany.Internal.Prelude
import qualified Data.List.Extra
import qualified Data.Text as Text
import GHC
( AnnKeywordId(..)
, GenLocated(L)
, Located
, ModuleName
, moduleNameString
, unLoc
)
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.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import GHC ( unLoc
, GenLocated(L)
, moduleNameString
, AnnKeywordId(..)
, Located
, ModuleName
)
import GHC.Hs
import Language.Haskell.Brittany.Internal.Utils
prepareName :: LIEWrappedName name -> Located name
prepareName = ieLWrappedName
@ -33,41 +37,36 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]
IEThingWith _ x _ ns _ -> do
hasComments <- orM
(hasCommentsBetween lie AnnOpenP AnnCloseP
( hasCommentsBetween lie AnnOpenP AnnCloseP
: hasAnyCommentsBelow x
: map hasAnyCommentsBelow ns
)
let sortedNs = List.sortOn wrappedNameToText ns
runFilteredAlternative $ do
addAlternativeCond (not hasComments)
$ docSeq
$ [layoutWrapped lie x, docLit $ Text.pack "("]
$ docSeq
$ [layoutWrapped lie x, docLit $ Text.pack "("]
++ intersperse docCommaSep (map nameDoc sortedNs)
++ [docParenR]
addAlternative
$ docWrapNodeRest lie
$ docAddBaseY BrIndentRegular
$ docPar (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs))
$ docPar
(layoutWrapped lie x)
(layoutItems (splitFirstLast sortedNs))
where
nameDoc = docLit <=< lrdrNameToTextAnn . prepareName
layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n]
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
[ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n]
, docParenR
]
[docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n], docParenR]
layoutItems (FirstLast n1 nMs nN) =
docSetBaseY
$ docLines
$ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]]
$ docLines
$ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]]
++ map layoutItem nMs
++ [ docSeq
[docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN]
, docParenR
]
++ [docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN], docParenR]
IEModuleContents _ n -> docSeq
[ docLit $ Text.pack "module"
, docSeparator
@ -76,7 +75,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
_ -> docEmpty
where
layoutWrapped _ = \case
L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n
L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n
L _ (IEPattern n) -> do
name <- lrdrNameToTextAnn n
docLit $ Text.pack "pattern " <> name
@ -93,36 +92,33 @@ data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted
-- handling of the resulting list. Adding parens is
-- left to the caller since that is context sensitive
layoutAnnAndSepLLIEs
:: SortItemsFlag
-> Located [LIE GhcPs]
-> ToBriDocM [ToBriDocM BriDocNumbered]
:: SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered]
layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
let makeIENode ie = docSeq [docCommaSep, ie]
let
sortedLies =
[ items
| group <- Data.List.Extra.groupOn lieToText $ List.sortOn lieToText lies
, items <- mergeGroup group
]
let
ieDocs = fmap layoutIE $ case shouldSort of
ShouldSortItems -> sortedLies
KeepItemsUnsorted -> lies
let sortedLies =
[ items
| group <- Data.List.Extra.groupOn lieToText
$ List.sortOn lieToText lies
, items <- mergeGroup group
]
let ieDocs = fmap layoutIE $ case shouldSort of
ShouldSortItems -> sortedLies
KeepItemsUnsorted -> lies
ieCommaDocs <-
docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of
FirstLastEmpty -> []
FirstLastEmpty -> []
FirstLastSingleton ie -> [ie]
FirstLast ie1 ieMs ieN ->
[ie1] ++ map makeIENode ieMs ++ [makeIENode ieN]
pure $ fmap pure ieCommaDocs -- returned shared nodes
where
mergeGroup :: [LIE GhcPs] -> [LIE GhcPs]
mergeGroup [] = []
mergeGroup [] = []
mergeGroup items@[_] = items
mergeGroup items = if
mergeGroup items = if
| all isProperIEThing items -> [List.foldl1' thingFolder items]
| all isIEVar items -> [List.foldl1' thingFolder items]
| otherwise -> items
| all isIEVar items -> [List.foldl1' thingFolder items]
| otherwise -> items
-- proper means that if it is a ThingWith, it does not contain a wildcard
-- (because I don't know what a wildcard means if it is not already a
-- IEThingAll).
@ -135,22 +131,21 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
isIEVar :: LIE GhcPs -> Bool
isIEVar = \case
L _ IEVar{} -> True
_ -> False
_ -> False
thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs
thingFolder l1@(L _ IEVar{}) _ = l1
thingFolder l1@(L _ IEThingAll{}) _ = l1
thingFolder _ l2@(L _ IEThingAll{}) = l2
thingFolder l1 (L _ IEThingAbs{}) = l1
thingFolder (L _ IEThingAbs{}) l2 = l2
thingFolder l1@(L _ IEVar{} ) _ = l1
thingFolder l1@(L _ IEThingAll{}) _ = l1
thingFolder _ l2@(L _ IEThingAll{}) = l2
thingFolder l1 ( L _ IEThingAbs{}) = l1
thingFolder (L _ IEThingAbs{}) l2 = l2
thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2))
= L
l
(IEThingWith
x
wn
NoIEWildcard
(consItems1 ++ consItems2)
(fieldLbls1 ++ fieldLbls2)
(IEThingWith x
wn
NoIEWildcard
(consItems1 ++ consItems2)
(fieldLbls1 ++ fieldLbls2)
)
thingFolder _ _ =
error "thingFolder should be exhaustive because we have a guard above"
@ -169,10 +164,9 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
-- () -- no comments
-- ( -- a comment
-- )
layoutLLIEs
:: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered
layoutLLIEs :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered
layoutLLIEs enableSingleline shouldSort llies = do
ieDs <- layoutAnnAndSepLLIEs shouldSort llies
ieDs <- layoutAnnAndSepLLIEs shouldSort llies
hasComments <- hasAnyCommentsBelow llies
runFilteredAlternative $ case ieDs of
[] -> do
@ -182,14 +176,14 @@ layoutLLIEs enableSingleline shouldSort llies = do
docParenR
(ieDsH : ieDsT) -> do
addAlternativeCond (not hasComments && enableSingleline)
$ docSeq
$ [docLit (Text.pack "(")]
$ docSeq
$ [docLit (Text.pack "(")]
++ (docForceSingleline <$> ieDs)
++ [docParenR]
addAlternative
$ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH])
$ docLines
$ ieDsT
$ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH])
$ docLines
$ ieDsT
++ [docParenR]
-- | Returns a "fingerprint string", not a full text representation, nor even
@ -197,27 +191,26 @@ layoutLLIEs enableSingleline shouldSort llies = do
-- Used for sorting, not for printing the formatter's output source code.
wrappedNameToText :: LIEWrappedName RdrName -> Text
wrappedNameToText = \case
L _ (IEName n) -> lrdrNameToText n
L _ (IEName n) -> lrdrNameToText n
L _ (IEPattern n) -> lrdrNameToText n
L _ (IEType n) -> lrdrNameToText n
L _ (IEType n) -> lrdrNameToText n
-- | Returns a "fingerprint string", not a full text representation, nor even
-- a source code representation of this syntax node.
-- Used for sorting, not for printing the formatter's output source code.
lieToText :: LIE GhcPs -> Text
lieToText = \case
L _ (IEVar _ wn) -> wrappedNameToText wn
L _ (IEThingAbs _ wn) -> wrappedNameToText wn
L _ (IEThingAll _ wn) -> wrappedNameToText wn
L _ (IEVar _ wn ) -> wrappedNameToText wn
L _ (IEThingAbs _ wn ) -> wrappedNameToText wn
L _ (IEThingAll _ wn ) -> wrappedNameToText wn
L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn
-- TODO: These _may_ appear in exports!
-- Need to check, and either put them at the top (for module) or do some
-- other clever thing.
L _ (IEModuleContents _ n) -> moduleNameToText n
L _ IEGroup{} -> Text.pack "@IEGroup"
L _ IEDoc{} -> Text.pack "@IEDoc"
L _ IEDocNamed{} -> Text.pack "@IEDocNamed"
L _ IEGroup{} -> Text.pack "@IEGroup"
L _ IEDoc{} -> Text.pack "@IEDoc"
L _ IEDocNamed{} -> Text.pack "@IEDocNamed"
where
moduleNameToText :: Located ModuleName -> Text
moduleNameToText (L _ name) =
Text.pack ("@IEModuleContents" ++ moduleNameString name)
moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name)

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

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

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

@ -3,27 +3,34 @@
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.Semigroup as Semigroup
import qualified Data.Text as Text
import GHC (AnnKeywordId(..), GenLocated(L), moduleNameString, unLoc)
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.IE
import Language.Haskell.Brittany.Internal.Layouters.Import
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.GHC.ExactPrint as ExactPrint
import Language.Haskell.GHC.ExactPrint.Types
(DeltaPos(..), commentContents, deltaRow)
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.IE
import Language.Haskell.Brittany.Internal.Layouters.Import
import Language.Haskell.Brittany.Internal.Config.Types
import GHC (unLoc, GenLocated(L), moduleNameString, AnnKeywordId(..))
import GHC.Hs
import Language.Haskell.GHC.ExactPrint as ExactPrint
import Language.Haskell.GHC.ExactPrint.Types
( DeltaPos(..)
, deltaRow
, commentContents
)
layoutModule :: ToBriDoc' HsModule
layoutModule lmod@(L _ mod') = case mod' of
-- Implicit module Main
HsModule _ Nothing _ imports _ _ _ -> do
HsModule _ Nothing _ imports _ _ _ -> do
commentedImports <- transformToCommentedImport imports
-- groupify commentedImports `forM_` tellDebugMessShow
docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports)
@ -34,38 +41,43 @@ layoutModule lmod@(L _ mod') = case mod' of
-- groupify commentedImports `forM_` tellDebugMessShow
-- sortedImports <- sortImports imports
let tn = Text.pack $ moduleNameString $ unLoc n
allowSingleLineExportList <-
mAsk <&> _conf_layout .> _lconfig_allowSingleLineExportList .> confUnpack
allowSingleLineExportList <- mAsk
<&> _conf_layout
.> _lconfig_allowSingleLineExportList
.> confUnpack
-- the config should not prevent single-line layout when there is no
-- export list
let
allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les
let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les
docLines
$ docSeq
[ docNodeAnnKW lmod Nothing docEmpty
-- A pseudo node that serves merely to force documentation
-- before the node
, docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do
addAlternativeCond allowSingleLine $ docForceSingleline $ docSeq
[ appSep $ docLit $ Text.pack "module"
, appSep $ docLit tn
, docWrapNode lmod $ appSep $ case les of
Nothing -> docEmpty
Just x -> layoutLLIEs True KeepItemsUnsorted x
, docSeparator
, docLit $ Text.pack "where"
]
addAlternative $ docLines
addAlternativeCond allowSingleLine $
docForceSingleline
$ docSeq
[ appSep $ docLit $ Text.pack "module"
, appSep $ docLit tn
, docWrapNode lmod $ appSep $ case les of
Nothing -> docEmpty
Just x -> layoutLLIEs True KeepItemsUnsorted x
, docSeparator
, docLit $ Text.pack "where"
]
addAlternative
$ docLines
[ docAddBaseY BrIndentRegular $ docPar
(docSeq [appSep $ docLit $ Text.pack "module", docLit tn])
(docSeq
[ docWrapNode lmod $ case les of
Nothing -> docEmpty
Just x -> layoutLLIEs False KeepItemsUnsorted x
, docSeparator
, docLit $ Text.pack "where"
]
)
(docSeq [appSep $ docLit $ Text.pack "module", docLit tn]
)
(docSeq [
docWrapNode lmod $ case les of
Nothing -> docEmpty
Just x -> layoutLLIEs False KeepItemsUnsorted x
, docSeparator
, docLit $ Text.pack "where"
]
)
]
]
: (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports]
@ -77,7 +89,7 @@ data CommentedImport
instance Show CommentedImport where
show = \case
EmptyLine -> "EmptyLine"
EmptyLine -> "EmptyLine"
IndependentComment _ -> "IndependentComment"
ImportStatement r ->
"ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
@ -90,9 +102,8 @@ data ImportStatementRecord = ImportStatementRecord
}
instance Show ImportStatementRecord where
show r =
"ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
(length $ commentsAfter r)
show r = "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
(length $ commentsAfter r)
transformToCommentedImport
:: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport]
@ -110,11 +121,10 @@ transformToCommentedImport is = do
accumF accConnectedComm (annMay, decl) = case annMay of
Nothing ->
( []
, [ ImportStatement ImportStatementRecord
{ commentsBefore = []
, commentsAfter = []
, importStatement = decl
}
, [ ImportStatement ImportStatementRecord { commentsBefore = []
, commentsAfter = []
, importStatement = decl
}
]
)
Just ann ->
@ -126,7 +136,7 @@ transformToCommentedImport is = do
:: [(Comment, DeltaPos)]
-> [(Comment, DeltaPos)]
-> ([CommentedImport], [(Comment, DeltaPos)], Int)
go acc [] = ([], acc, 0)
go acc [] = ([], acc, 0)
go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1)
go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs
go acc ((c1, DP (y, x)) : xs) =
@ -143,8 +153,8 @@ transformToCommentedImport is = do
, convertedIndependentComments
++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine
++ [ ImportStatement ImportStatementRecord
{ commentsBefore = beforeComments
, commentsAfter = accConnectedComm
{ commentsBefore = beforeComments
, commentsAfter = accConnectedComm
, importStatement = decl
}
]
@ -158,14 +168,14 @@ sortCommentedImports =
where
unpackImports :: [CommentedImport] -> [CommentedImport]
unpackImports xs = xs >>= \case
l@EmptyLine -> [l]
l@EmptyLine -> [l]
l@IndependentComment{} -> [l]
ImportStatement r ->
map IndependentComment (commentsBefore r) ++ [ImportStatement r]
mergeGroups
:: [Either CommentedImport [ImportStatementRecord]] -> [CommentedImport]
mergeGroups xs = xs >>= \case
Left x -> [x]
Left x -> [x]
Right y -> ImportStatement <$> y
sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord]
sortGroups =
@ -175,23 +185,25 @@ sortCommentedImports =
groupify cs = go [] cs
where
go [] = \case
(l@EmptyLine : rest) -> Left l : go [] rest
(l@EmptyLine : rest) -> Left l : go [] rest
(l@IndependentComment{} : rest) -> Left l : go [] rest
(ImportStatement r : rest) -> go [r] rest
[] -> []
(ImportStatement r : rest) -> go [r] rest
[] -> []
go acc = \case
(l@EmptyLine : rest) -> Right (reverse acc) : Left l : go [] rest
(l@IndependentComment{} : rest) ->
Left l : Right (reverse acc) : go [] rest
(ImportStatement r : rest) -> go (r : acc) rest
[] -> [Right (reverse acc)]
[] -> [Right (reverse acc)]
commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered
commentedImportsToDoc = \case
EmptyLine -> docLitS ""
IndependentComment c -> commentToDoc c
ImportStatement r -> docSeq
(layoutImport (importStatement r) : map commentToDoc (commentsAfter r))
ImportStatement r ->
docSeq
( layoutImport (importStatement r)
: map commentToDoc (commentsAfter r)
)
where
commentToDoc (c, DP (_y, x)) =
docLitS (replicate x ' ' ++ commentContents c)
commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c)

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

@ -3,19 +3,28 @@
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.Sequence as Seq
import qualified Data.Text as Text
import GHC (GenLocated(L), ol_val)
import GHC.Hs
import qualified GHC.OldList as List
import GHC.Types.Basic
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import GHC ( GenLocated(L)
, ol_val
)
import GHC.Hs
import GHC.Types.Basic
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
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 Language.Haskell.Brittany.Internal.Layouters.Type
-- | layouts patterns (inside function bindings, case alternatives, let
-- bindings or do notation). E.g. for input
@ -29,15 +38,17 @@ import Language.Haskell.Brittany.Internal.Types
-- the different cases below.
layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered)
layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_"
WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_"
-- _ -> expr
VarPat _ n -> fmap Seq.singleton $ docLit $ lrdrNameToText n
VarPat _ n ->
fmap Seq.singleton $ docLit $ lrdrNameToText n
-- abc -> expr
LitPat _ lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit
LitPat _ lit ->
fmap Seq.singleton $ allocateNode $ litBriDoc lit
-- 0 -> expr
ParPat _ inner -> do
-- (nestedpat) -> expr
left <- docLit $ Text.pack "("
left <- docLit $ Text.pack "("
right <- docLit $ Text.pack ")"
innerDocs <- colsWrapPat =<< layoutPat inner
return $ Seq.empty Seq.|> left Seq.|> innerDocs Seq.|> right
@ -63,9 +74,10 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
then return <$> docLit nameDoc
else do
x1 <- appSep (docLit nameDoc)
xR <- fmap Seq.fromList $ sequence $ spacifyDocs $ fmap
colsWrapPat
argDocs
xR <- fmap Seq.fromList
$ sequence
$ spacifyDocs
$ fmap colsWrapPat argDocs
return $ x1 Seq.<| xR
ConPat _ lname (InfixCon left right) -> do
-- a :< b -> expr
@ -78,7 +90,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
-- Abc{} -> expr
let t = lrdrNameToText lname
fmap Seq.singleton $ docLit $ t <> Text.pack "{}"
ConPat _ lname (RecCon (HsRecFields fs@(_ : _) Nothing)) -> do
ConPat _ lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do
-- Abc { a = locA, b = locB, c = locC } -> expr1
-- Abc { a, b, c } -> expr2
let t = lrdrNameToText lname
@ -91,34 +103,37 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
Seq.singleton <$> docSeq
[ appSep $ docLit t
, appSep $ docLit $ Text.pack "{"
, docSeq $ List.intersperse docCommaSep $ fds <&> \case
(fieldName, Just fieldDoc) -> docSeq
[ appSep $ docLit fieldName
, appSep $ docLit $ Text.pack "="
, fieldDoc >>= colsWrapPat
]
(fieldName, Nothing) -> docLit fieldName
, docSeq $ List.intersperse docCommaSep
$ fds <&> \case
(fieldName, Just fieldDoc) -> docSeq
[ appSep $ docLit fieldName
, appSep $ docLit $ Text.pack "="
, fieldDoc >>= colsWrapPat
]
(fieldName, Nothing) -> docLit fieldName
, docSeparator
, docLit $ Text.pack "}"
]
ConPat _ lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do
-- Abc { .. } -> expr
let t = lrdrNameToText lname
Seq.singleton <$> docSeq [appSep $ docLit t, docLit $ Text.pack "{..}"]
ConPat _ lname (RecCon (HsRecFields fs@(_ : _) (Just (L _ dotdoti))))
| dotdoti == length fs -> do
Seq.singleton <$> docSeq
[ appSep $ docLit t
, docLit $ Text.pack "{..}"
]
ConPat _ lname (RecCon (HsRecFields fs@(_:_) (Just (L _ dotdoti)))) | dotdoti == length fs -> do
-- Abc { a = locA, .. }
let t = lrdrNameToText lname
fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do
let FieldOcc _ lnameF = fieldOcc
fExpDoc <- if pun
then return Nothing
else Just <$> docSharedWrapper layoutPat fPat
return (lrdrNameToText lnameF, fExpDoc)
Seq.singleton <$> docSeq
[ appSep $ docLit t
, appSep $ docLit $ Text.pack "{"
, docSeq $ fds >>= \case
let t = lrdrNameToText lname
fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do
let FieldOcc _ lnameF = fieldOcc
fExpDoc <- if pun
then return Nothing
else Just <$> docSharedWrapper layoutPat fPat
return (lrdrNameToText lnameF, fExpDoc)
Seq.singleton <$> docSeq
[ appSep $ docLit t
, appSep $ docLit $ Text.pack "{"
, docSeq $ fds >>= \case
(fieldName, Just fieldDoc) ->
[ appSep $ docLit fieldName
, appSep $ docLit $ Text.pack "="
@ -126,13 +141,13 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
, docCommaSep
]
(fieldName, Nothing) -> [docLit fieldName, docCommaSep]
, docLit $ Text.pack "..}"
]
, docLit $ Text.pack "..}"
]
TuplePat _ args boxity -> do
-- (nestedpat1, nestedpat2, nestedpat3) -> expr
-- (#nestedpat1, nestedpat2, nestedpat3#) -> expr
case boxity of
Boxed -> wrapPatListy args "()" docParenL docParenR
Boxed -> wrapPatListy args "()" docParenL docParenR
Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep
AsPat _ asName asPat -> do
-- bind@nestedpat -> expr
@ -169,11 +184,10 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
wrapPatPrepend pat1 (docLit $ Text.pack "~")
NPat _ llit@(L _ ol) mNegative _ -> do
-- -13 -> expr
litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val
ol
litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol
negDoc <- docLit $ Text.pack "-"
pure $ case mNegative of
Just{} -> Seq.fromList [negDoc, litDoc]
Just{} -> Seq.fromList [negDoc, litDoc]
Nothing -> Seq.singleton litDoc
_ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat
@ -182,7 +196,9 @@ colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered
colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList
wrapPatPrepend
:: LPat GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM (Seq BriDocNumbered)
:: LPat GhcPs
-> ToBriDocM BriDocNumbered
-> ToBriDocM (Seq BriDocNumbered)
wrapPatPrepend pat prepElem = do
patDocs <- layoutPat pat
case Seq.viewl patDocs of
@ -204,5 +220,8 @@ wrapPatListy elems both start end = do
x1 Seq.:< rest -> do
sDoc <- start
eDoc <- end
rest' <- rest `forM` \bd -> docSeq [docCommaSep, return bd]
rest' <- rest `forM` \bd -> docSeq
[ docCommaSep
, return bd
]
return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc

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

@ -4,19 +4,26 @@
module Language.Haskell.Brittany.Internal.Layouters.Stmt where
import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text
import GHC (GenLocated(L))
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 qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text
import Language.Haskell.Brittany.Internal.Layouters.Decl
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 Language.Haskell.Brittany.Internal.Layouters.Pattern
import Language.Haskell.Brittany.Internal.Layouters.Decl
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
import Language.Haskell.Brittany.Internal.Layouters.Pattern
layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
layoutStmt lstmt@(L _ stmt) = do
@ -46,12 +53,12 @@ layoutStmt lstmt@(L _ stmt) = do
]
]
LetStmt _ binds -> do
let isFree = indentPolicy == IndentPolicyFree
let isFree = indentPolicy == IndentPolicyFree
let indentFourPlus = indentAmount >= 4
layoutLocalBinds binds >>= \case
Nothing -> docLit $ Text.pack "let"
Nothing -> docLit $ Text.pack "let"
-- i just tested the above, and it is indeed allowed. heh.
Just [] -> docLit $ Text.pack "let" -- this probably never happens
Just [] -> docLit $ Text.pack "let" -- this probably never happens
Just [bindDoc] -> docAlt
[ -- let bind = expr
docCols
@ -61,10 +68,9 @@ layoutStmt lstmt@(L _ stmt) = do
f = case indentPolicy of
IndentPolicyFree -> docSetBaseAndIndent
IndentPolicyLeft -> docForceSingleline
IndentPolicyMultiple
| indentFourPlus -> docSetBaseAndIndent
| otherwise -> docForceSingleline
in f $ return bindDoc
IndentPolicyMultiple | indentFourPlus -> docSetBaseAndIndent
| otherwise -> docForceSingleline
in f $ return bindDoc
]
, -- let
-- bind = expr
@ -78,11 +84,10 @@ layoutStmt lstmt@(L _ stmt) = do
-- ccc = exprc
addAlternativeCond (isFree || indentFourPlus) $ docSeq
[ appSep $ docLit $ Text.pack "let"
, let
f = if indentFourPlus
then docEnsureIndent BrIndentRegular
else docSetBaseAndIndent
in f $ docLines $ return <$> bindDocs
, let f = if indentFourPlus
then docEnsureIndent BrIndentRegular
else docSetBaseAndIndent
in f $ docLines $ return <$> bindDocs
]
-- let
-- aaa = expra
@ -90,9 +95,8 @@ layoutStmt lstmt@(L _ stmt) = do
-- ccc = exprc
addAlternativeCond (not indentFourPlus)
$ docAddBaseY BrIndentRegular
$ docPar
(docLit $ Text.pack "let")
(docSetBaseAndIndent $ docLines $ return <$> bindDocs)
$ docPar (docLit $ Text.pack "let")
(docSetBaseAndIndent $ docLines $ return <$> bindDocs)
RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do
-- rec stmt1
-- stmt2

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

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

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

@ -3,18 +3,28 @@
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.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
(FirstLastView(..), splitFirstLast)
import qualified Data.Text as Text
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Utils
( splitFirstLast
, FirstLastView(..)
)
import GHC ( GenLocated(L)
, AnnKeywordId (..)
)
import GHC.Hs
import GHC.Utils.Outputable ( ftext, showSDocUnsafe )
import GHC.Types.Basic
layoutType :: ToBriDoc HsType
layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
@ -22,66 +32,76 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsTyVar _ promoted name -> do
t <- lrdrNameToTextAnnTypeEqualityIsSpecial name
case promoted of
IsPromoted ->
docSeq [docSeparator, docTick, docWrapNode name $ docLit t]
IsPromoted -> docSeq
[ docSeparator
, docTick
, docWrapNode name $ docLit t
]
NotPromoted -> docWrapNode name $ docLit t
HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do
let bndrs = getBinders hsf
typeDoc <- docSharedWrapper layoutType typ2
tyVarDocs <- layoutTyVarBndrs bndrs
cntxtDocs <- cntxts `forM` docSharedWrapper layoutType
let
maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline
_ -> id
let maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline
_ -> id
let
tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs
forallDoc = docAlt
[ let open = docLit $ Text.pack "forall"
in docSeq ([open] ++ tyVarDocLineList)
[ let
open = docLit $ Text.pack "forall"
in docSeq ([open]++tyVarDocLineList)
, docPar
(docLit (Text.pack "forall"))
(docLines $ tyVarDocs <&> \case
(tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname
(tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines
[ docCols ColTyOpPrefix [docParenLSep, docLit tname]
, docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc]
, docLit $ Text.pack ")"
]
)
(docLit (Text.pack "forall"))
(docLines
$ tyVarDocs <&> \case
(tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname
(tname, Just doc) -> docEnsureIndent BrIndentRegular
$ docLines
[ docCols ColTyOpPrefix
[ docParenLSep
, docLit tname
]
, docCols ColTyOpPrefix
[ docLit $ Text.pack ":: "
, doc
]
, docLit $ Text.pack ")"
])
]
contextDoc = case cntxtDocs of
[] -> docLit $ Text.pack "()"
[x] -> x
_ -> docAlt
[ let
open = docLit $ Text.pack "("
open = docLit $ Text.pack "("
close = docLit $ Text.pack ")"
list =
List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs
in docSeq ([open] ++ list ++ [close])
list = List.intersperse docCommaSep
$ docForceSingleline <$> cntxtDocs
in docSeq ([open]++list++[close])
, let
open = docCols
ColTyOpPrefix
[ docParenLSep
, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs
]
open = docCols ColTyOpPrefix
[ docParenLSep
, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs
]
close = docLit $ Text.pack ")"
list = List.tail cntxtDocs <&> \cntxtDoc -> docCols
ColTyOpPrefix
[docCommaSep, docAddBaseY (BrIndentSpecial 2) cntxtDoc]
list = List.tail cntxtDocs <&> \cntxtDoc ->
docCols ColTyOpPrefix
[ docCommaSep
, docAddBaseY (BrIndentSpecial 2) cntxtDoc
]
in docPar open $ docLines $ list ++ [close]
]
docAlt
-- :: forall a b c . (Foo a b c) => a b -> c
[ docSeq
[ if null bndrs
then docEmpty
else
let
then docEmpty
else let
open = docLit $ Text.pack "forall"
close = docLit $ Text.pack " . "
in docSeq ([open, docSeparator] ++ tyVarDocLineList ++ [close])
in docSeq ([open, docSeparator]++tyVarDocLineList++[close])
, docForceSingleline contextDoc
, docLit $ Text.pack " => "
, docForceSingleline typeDoc
@ -91,74 +111,75 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-- => a b
-- -> c
, docPar
forallDoc
(docLines
[ docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, docAddBaseY (BrIndentSpecial 3) $ contextDoc
forallDoc
( docLines
[ docCols ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, docAddBaseY (BrIndentSpecial 3)
$ contextDoc
]
, docCols ColTyOpPrefix
[ docLit $ Text.pack "=> "
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc
]
]
, docCols
ColTyOpPrefix
[ docLit $ Text.pack "=> "
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc
]
]
)
)
]
HsForAllTy _ hsf typ2 -> do
let bndrs = getBinders hsf
typeDoc <- layoutType typ2
tyVarDocs <- layoutTyVarBndrs bndrs
let
maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline
_ -> id
let maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline
_ -> id
let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs
docAlt
-- forall x . x
[ docSeq
[ if null bndrs
then docEmpty
else
let
then docEmpty
else let
open = docLit $ Text.pack "forall"
close = docLit $ Text.pack " . "
in docSeq ([open] ++ tyVarDocLineList ++ [close])
in docSeq ([open]++tyVarDocLineList++[close])
, docForceSingleline $ return $ typeDoc
]
-- :: forall x
-- . x
, docPar
(docSeq $ docLit (Text.pack "forall") : tyVarDocLineList)
(docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, maybeForceML $ return typeDoc
]
)
(docSeq $ docLit (Text.pack "forall") : tyVarDocLineList)
( docCols ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, maybeForceML $ return typeDoc
]
)
-- :: forall
-- (x :: *)
-- . x
, docPar
(docLit (Text.pack "forall"))
(docLines
$ (tyVarDocs <&> \case
(tname, Nothing) ->
docEnsureIndent BrIndentRegular $ docLit tname
(tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines
[ docCols ColTyOpPrefix [docParenLSep, docLit tname]
, docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc]
, docLit $ Text.pack ")"
(docLit (Text.pack "forall"))
(docLines
$ (tyVarDocs <&> \case
(tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname
(tname, Just doc) -> docEnsureIndent BrIndentRegular
$ docLines
[ docCols ColTyOpPrefix
[ docParenLSep
, docLit tname
]
, docCols ColTyOpPrefix
[ docLit $ Text.pack ":: "
, doc
]
, docLit $ Text.pack ")"
]
)
++[ docCols ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, maybeForceML $ return typeDoc
]
]
)
++ [ docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, maybeForceML $ return typeDoc
]
]
)
]
HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do
typeDoc <- docSharedWrapper layoutType typ1
@ -169,27 +190,29 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
[x] -> x
_ -> docAlt
[ let
open = docLit $ Text.pack "("
open = docLit $ Text.pack "("
close = docLit $ Text.pack ")"
list =
List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs
in docSeq ([open] ++ list ++ [close])
list = List.intersperse docCommaSep
$ docForceSingleline <$> cntxtDocs
in docSeq ([open]++list++[close])
, let
open = docCols
ColTyOpPrefix
[ docParenLSep
, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs
]
open = docCols ColTyOpPrefix
[ docParenLSep
, docAddBaseY (BrIndentSpecial 2)
$ head cntxtDocs
]
close = docLit $ Text.pack ")"
list = List.tail cntxtDocs <&> \cntxtDoc -> docCols
ColTyOpPrefix
[docCommaSep, docAddBaseY (BrIndentSpecial 2) $ cntxtDoc]
list = List.tail cntxtDocs <&> \cntxtDoc ->
docCols ColTyOpPrefix
[ docCommaSep
, docAddBaseY (BrIndentSpecial 2)
$ cntxtDoc
]
in docPar open $ docLines $ list ++ [close]
]
let
maybeForceML = case typ1 of
(L _ HsFunTy{}) -> docForceMultiline
_ -> id
let maybeForceML = case typ1 of
(L _ HsFunTy{}) -> docForceMultiline
_ -> id
docAlt
-- (Foo a b c) => a b -> c
[ docSeq
@ -201,39 +224,37 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-- => a b
-- -> c
, docPar
(docForceSingleline contextDoc)
(docCols
ColTyOpPrefix
[ docLit $ Text.pack "=> "
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc
]
)
(docForceSingleline contextDoc)
( docCols ColTyOpPrefix
[ docLit $ Text.pack "=> "
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc
]
)
]
HsFunTy _ _ typ1 typ2 -> do
typeDoc1 <- docSharedWrapper layoutType typ1
typeDoc2 <- docSharedWrapper layoutType typ2
let
maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline
_ -> id
let maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline
_ -> id
hasComments <- hasAnyCommentsBelow ltype
docAlt
$ [ docSeq
[ appSep $ docForceSingleline typeDoc1
, appSep $ docLit $ Text.pack "->"
, docForceSingleline typeDoc2
]
| not hasComments
docAlt $
[ docSeq
[ appSep $ docForceSingleline typeDoc1
, appSep $ docLit $ Text.pack "->"
, docForceSingleline typeDoc2
]
++ [ docPar
(docNodeAnnKW ltype Nothing typeDoc1)
(docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->"
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc2
]
)
]
| not hasComments
] ++
[ docPar
(docNodeAnnKW ltype Nothing typeDoc1)
( docCols ColTyOpPrefix
[ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->"
, docAddBaseY (BrIndentSpecial 3)
$ maybeForceML typeDoc2
]
)
]
HsParTy _ typ1 -> do
typeDoc1 <- docSharedWrapper layoutType typ1
docAlt
@ -243,28 +264,24 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docLit $ Text.pack ")"
]
, docPar
(docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docParenLSep
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1
]
)
(docLit $ Text.pack ")")
( docCols ColTyOpPrefix
[ docWrapNodeRest ltype $ docParenLSep
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1
])
(docLit $ Text.pack ")")
]
HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do
let
gather
:: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs])
gather list = \case
L _ (HsAppTy _ ty1 ty2) -> gather (ty2 : list) ty1
final -> (final, list)
let gather :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs])
gather list = \case
L _ (HsAppTy _ ty1 ty2) -> gather (ty2:list) ty1
final -> (final, list)
let (typHead, typRest) = gather [typ2] typ1
docHead <- docSharedWrapper layoutType typHead
docRest <- docSharedWrapper layoutType `mapM` typRest
docAlt
[ docSeq
$ docForceSingleline docHead
: (docRest >>= \d -> [docSeparator, docForceSingleline d])
$ docForceSingleline docHead : (docRest >>= \d ->
[ docSeparator, docForceSingleline d ])
, docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)
]
HsAppTy _ typ1 typ2 -> do
@ -276,7 +293,9 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docSeparator
, docForceSingleline typeDoc2
]
, docPar typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2)
, docPar
typeDoc1
(docEnsureIndent BrIndentRegular typeDoc2)
]
HsListTy _ typ1 -> do
typeDoc1 <- docSharedWrapper layoutType typ1
@ -287,61 +306,51 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docLit $ Text.pack "]"
]
, docPar
(docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack "[ "
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1
]
)
(docLit $ Text.pack "]")
( docCols ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack "[ "
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1
])
(docLit $ Text.pack "]")
]
HsTupleTy _ tupleSort typs -> case tupleSort of
HsUnboxedTuple -> unboxed
HsBoxedTuple -> simple
HsConstraintTuple -> simple
HsUnboxedTuple -> unboxed
HsBoxedTuple -> simple
HsConstraintTuple -> simple
HsBoxedOrConstraintTuple -> simple
where
unboxed = if null typs
then error "brittany internal error: unboxed unit"
else unboxedL
unboxed = if null typs then error "brittany internal error: unboxed unit"
else unboxedL
simple = if null typs then unitL else simpleL
unitL = docLit $ Text.pack "()"
simpleL = do
docs <- docSharedWrapper layoutType `mapM` typs
let
end = docLit $ Text.pack ")"
lines =
List.tail docs
<&> \d -> docAddBaseY (BrIndentSpecial 2)
$ docCols ColTyOpPrefix [docCommaSep, d]
commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs)
let end = docLit $ Text.pack ")"
lines = List.tail docs <&> \d ->
docAddBaseY (BrIndentSpecial 2)
$ docCols ColTyOpPrefix [docCommaSep, d]
commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs)
docAlt
[ docSeq
$ [docLit $ Text.pack "("]
++ docWrapNodeRest ltype commaDocs
++ [end]
[ docSeq $ [docLit $ Text.pack "("]
++ docWrapNodeRest ltype commaDocs
++ [end]
, let line1 = docCols ColTyOpPrefix [docParenLSep, head docs]
in
docPar
(docAddBaseY (BrIndentSpecial 2) $ line1)
(docLines $ docWrapNodeRest ltype lines ++ [end])
in docPar
(docAddBaseY (BrIndentSpecial 2) $ line1)
(docLines $ docWrapNodeRest ltype lines ++ [end])
]
unboxedL = do
docs <- docSharedWrapper layoutType `mapM` typs
let
start = docParenHashLSep
end = docParenHashRSep
let start = docParenHashLSep
end = docParenHashRSep
docAlt
[ docSeq
$ [start]
++ docWrapNodeRest ltype (List.intersperse docCommaSep docs)
++ [end]
[ docSeq $ [start]
++ docWrapNodeRest ltype (List.intersperse docCommaSep docs)
++ [end]
, let
line1 = docCols ColTyOpPrefix [start, head docs]
lines =
List.tail docs
<&> \d -> docAddBaseY (BrIndentSpecial 2)
$ docCols ColTyOpPrefix [docCommaSep, d]
lines = List.tail docs <&> \d ->
docAddBaseY (BrIndentSpecial 2)
$ docCols ColTyOpPrefix [docCommaSep, d]
in docPar
(docAddBaseY (BrIndentSpecial 2) line1)
(docLines $ lines ++ [end])
@ -410,18 +419,20 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
typeDoc1 <- docSharedWrapper layoutType typ1
docAlt
[ docSeq
[ docWrapNodeRest ltype $ docLit $ Text.pack
("?" ++ showSDocUnsafe (ftext ipName) ++ "::")
[ docWrapNodeRest ltype
$ docLit
$ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::")
, docForceSingleline typeDoc1
]
, docPar
(docLit $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)))
(docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 2) typeDoc1
]
)
( docLit
$ Text.pack ("?" ++ showSDocUnsafe (ftext ipName))
)
(docCols ColTyOpPrefix
[ docWrapNodeRest ltype
$ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 2) typeDoc1
])
]
-- TODO: test KindSig
HsKindSig _ typ1 kind1 -> do
@ -462,7 +473,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
]
else docPar
typeDoc1
(docCols
( docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 3) kindDoc1
@ -533,7 +544,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
let specialCommaSep = appSep $ docLit $ Text.pack " ,"
docAlt
[ docSeq
$ [docLit $ Text.pack "'["]
$ [docLit $ Text.pack "'["]
++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs)
++ [docLit $ Text.pack "]"]
, case splitFirstLast typDocs of
@ -558,23 +569,19 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
]
FirstLast e1 ems eN -> runFilteredAlternative $ do
addAlternativeCond (not hasComments)
$ docSeq
$ [docLit $ Text.pack "'["]
++ List.intersperse
specialCommaSep
(docForceSingleline
<$> (e1 : ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])
)
$ docSeq
$ [docLit $ Text.pack "'["]
++ List.intersperse specialCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN]))
++ [docLit $ Text.pack " ]"]
addAlternative
$ let
start = docCols ColList [appSep $ docLit $ Text.pack "'[", e1]
linesM = ems <&> \d -> docCols ColList [specialCommaSep, d]
lineN = docCols
ColList
[specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN]
end = docLit $ Text.pack " ]"
in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]
addAlternative $
let
start = docCols ColList
[appSep $ docLit $ Text.pack "'[", e1]
linesM = ems <&> \d ->
docCols ColList [specialCommaSep, d]
lineN = docCols ColList [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN]
end = docLit $ Text.pack " ]"
in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]
]
HsExplicitTupleTy{} -> -- TODO
briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype
@ -585,7 +592,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext
HsStrTy NoSourceText _ ->
error "overLitValBriDoc: literal with no SourceText"
HsWildCardTy _ -> docLit $ Text.pack "_"
HsWildCardTy _ ->
docLit $ Text.pack "_"
HsSumTy{} -> -- TODO
briDocByExactInlineOnly "HsSumTy{}" ltype
HsStarTy _ isUnicode -> do
@ -598,12 +606,14 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
k <- docSharedWrapper layoutType kind
docAlt
[ docSeq
[ docForceSingleline t
, docSeparator
, docLit $ Text.pack "@"
, docForceSingleline k
]
, docPar t (docSeq [docLit $ Text.pack "@", k])
[ docForceSingleline t
, docSeparator
, docLit $ Text.pack "@"
, docForceSingleline k
]
, docPar
t
(docSeq [docLit $ Text.pack "@", k ])
]
layoutTyVarBndrs

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

@ -2,24 +2,28 @@
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.Set as Set
import qualified Data.Text as Text
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import System.Random
import Data.Char
import System.Random
obfuscate :: Text -> IO Text
obfuscate input = do
let predi x = isAlphaNum x || x `elem` "_'"
let groups = List.groupBy (\a b -> predi a && predi b) (Text.unpack input)
let idents = Set.toList $ Set.fromList $ filter (all predi) groups
let
exceptionFilter x | x `elem` keywords = False
exceptionFilter x | x `elem` extraKWs = False
exceptionFilter x = not $ null $ drop 1 x
let exceptionFilter x | x `elem` keywords = False
exceptionFilter x | x `elem` extraKWs = False
exceptionFilter x = not $ null $ drop 1 x
let filtered = filter exceptionFilter idents
mappings <- fmap Map.fromList $ filtered `forM` \x -> do
r <- createAlias x
@ -71,14 +75,14 @@ extraKWs = ["return", "pure", "Int", "True", "False", "otherwise"]
createAlias :: String -> IO String
createAlias xs = go NoHint xs
where
go _hint "" = pure ""
go hint (c : cr) = do
go _hint "" = pure ""
go hint (c : cr) = do
c' <- case hint of
VocalHint | isUpper c -> randomFrom $ "AAAEEEOOOIIIUUU" ++ ['A' .. 'Z']
_ | isUpper c -> randomFrom ['A' .. 'Z']
_ | isUpper c -> randomFrom ['A' .. 'Z']
VocalHint | isLower c -> randomFrom $ "aaaeeeoooiiiuuu" ++ ['a' .. 'z']
_ | isLower c -> randomFrom ['a' .. 'z']
_ -> pure c
_ | isLower c -> randomFrom ['a' .. 'z']
_ -> pure c
cr' <- go (if c' `elem` "aeuioAEUIO" then NoVocalHint else VocalHint) cr
pure (c' : cr')

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

@ -1,195 +1,346 @@
module Language.Haskell.Brittany.Internal.Prelude
( module E
) where
module Language.Haskell.Brittany.Internal.Prelude ( module E ) where
import GHC.Hs.Extension as E (GhcPs)
import GHC.Types.Name.Reader as E (RdrName)
import Control.Applicative as E (Alternative(..), Applicative(..))
import Control.Arrow as E ((&&&), (***), (<<<), (>>>), first, second)
import Control.Concurrent as E (forkIO, forkOS, threadDelay)
import Control.Concurrent.Chan as E (Chan)
import Control.Concurrent.MVar as E
(MVar, newEmptyMVar, newMVar, putMVar, readMVar, swapMVar, takeMVar)
import Control.Exception as E (assert, bracket, evaluate)
import Control.Monad as E
( (<$!>)
, (<=<)
, (=<<)
, (>=>)
, Functor(..)
, Monad(..)
, MonadPlus(..)
, filterM
, forM
, forM_
, forever
, guard
, join
, liftM
, liftM2
, liftM3
, liftM4
, liftM5
, mapM
, mapM_
, replicateM
, replicateM_
, sequence
, sequence_
, unless
, void
, when
)
import Control.Monad.Extra as E
(allM, andM, anyM, ifM, notM, orM, unlessM, whenM)
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 GHC.Exts as E (Constraint)
import Prelude as E
( ($)
, ($!)
, (&&)
, (++)
, (.)
, (<$>)
, Bounded(..)
, Double
, Enum(..)
, Eq(..)
, Float
, Floating(..)
, Foldable
, Fractional(..)
, Integer
, Integral(..)
, Num(..)
, Ord(..)
, RealFloat(..)
, RealFrac(..)
, Show(..)
, Traversable
, (^)
, and
, any
, const
, curry
, error
, flip
, foldl
, foldr
, foldr1
, fromIntegral
, fst
, head
, id
, map
, not
, or
, otherwise
, print
, putStr
, putStrLn
, realToFrac
, reverse
, seq
, snd
, subtract
, traverse
, uncurry
, undefined
, (||)
)
import System.IO as E (IO, hFlush, stdout)
import Text.Read as E (readMaybe)
-- rather project-specific stuff:
---------------------------------
import GHC.Hs.Extension as E ( GhcPs )
import GHC.Types.Name.Reader as E ( RdrName )
-- more general:
----------------
import Data.Functor.Identity as E ( Identity(..) )
import Control.Concurrent.Chan as E ( Chan )
import Control.Concurrent.MVar as E ( MVar
, newEmptyMVar
, newMVar
, putMVar
, 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_
, (=<<)
, (>=>)
, (<=<)
, forever
, void
, join
, replicateM
, replicateM_
, guard
, when
, unless
, liftM
, liftM2
, liftM3
, liftM4
, liftM5
, filterM
, (<$!>)
)
import Control.Applicative as E ( Applicative (..)
, Alternative (..)
)
import Foreign.Storable as E ( Storable )
import GHC.Exts as E ( Constraint )
import Control.Concurrent as E ( threadDelay
, forkIO
, forkOS
)
import Control.Exception as E ( evaluate
, bracket
, assert
)
import Debug.Trace as E ( trace
, traceId
, traceShowId
, traceShow
, traceStack
, traceShowId
, traceIO
, traceM
, traceShowM
)
import Foreign.ForeignPtr as E ( ForeignPtr
)
import Data.Bifunctor as E ( bimap )
import Data.Functor as E ( ($>) )
import Data.Semigroup as E ( (<>)
, Semigroup(..)
)
import Data.Typeable as E ( Typeable
)
import Control.Arrow as E ( first
, second
, (***)
, (&&&)
, (>>>)
, (<<<)
)
import Data.Version as E ( showVersion
)
import Data.List.Extra as E ( nubOrd
, stripSuffix
)
import Control.Monad.Extra as E ( whenM
, unlessM
, ifM
, notM
, 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
)

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

@ -1,15 +1,21 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.Brittany.Internal.PreludeUtils where
import Control.Applicative
import Control.DeepSeq (NFData, force)
import Control.Exception.Base (evaluate)
import Control.Monad
import Prelude
import qualified Data.Strict.Maybe as Strict
import Debug.Trace
import Prelude
import Control.Monad
import System.IO
import Control.DeepSeq ( NFData, force )
import Control.Exception.Base ( evaluate )
import Control.Applicative
instance Applicative Strict.Maybe where
pure = Strict.Just
Strict.Just f <*> Strict.Just x = Strict.Just (f x)
@ -24,12 +30,12 @@ instance Alternative Strict.Maybe where
x <|> Strict.Nothing = 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
where
y = f x
traceStr = name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y
traceStr =
name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y
(<&!>) :: Monad m => m a -> (a -> b) -> m b
(<&!>) = flip (<$!>)
@ -45,10 +51,10 @@ printErr = putStrErrLn . show
errorIf :: Bool -> a -> a
errorIf False = id
errorIf True = error "errorIf"
errorIf True = error "errorIf"
errorIfNote :: Maybe String -> a -> a
errorIfNote Nothing = id
errorIfNote Nothing = id
errorIfNote (Just x) = error x
(<&>) :: Functor f => f a -> (a -> b) -> f b

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

File diff suppressed because it is too large Load Diff

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

@ -3,10 +3,16 @@
module Language.Haskell.Brittany.Internal.Transformations.Columns 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.Types
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Types
import qualified Data.Generics.Uniplate.Direct as Uniplate
transformSimplifyColumns :: BriDoc -> BriDoc
transformSimplifyColumns = Uniplate.rewrite $ \case
@ -14,150 +20,118 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
-- BDWrapAnnKey annKey $ transformSimplify bd
BDEmpty -> Nothing
BDLit{} -> Nothing
BDSeq list
| any
(\case
BDSeq{} -> True
BDEmpty{} -> True
_ -> False
)
list
-> Just $ BDSeq $ list >>= \case
BDEmpty -> []
BDSeq l -> l
x -> [x]
BDSeq (BDCols sig1 cols1@(_ : _) : rest)
| all
(\case
BDSeparator -> True
_ -> False
)
rest
-> Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1 : rest)])
BDLines lines
| any
(\case
BDLines{} -> True
BDEmpty{} -> True
_ -> False
)
lines
-> Just $ BDLines $ filter isNotEmpty $ lines >>= \case
BDSeq list | any (\case BDSeq{} -> True
BDEmpty{} -> True
_ -> False) list -> Just $ BDSeq $ list >>= \case
BDEmpty -> []
BDSeq l -> l
x -> [x]
BDSeq (BDCols sig1 cols1@(_:_):rest)
| all (\case BDSeparator -> True; _ -> False) rest ->
Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)])
BDLines lines | any (\case BDLines{} -> True
BDEmpty{} -> True
_ -> False) lines ->
Just $ BDLines $ filter isNotEmpty $ lines >>= \case
BDLines l -> l
x -> [x]
-- prior floating in
BDAnnotationPrior annKey1 (BDSeq (l : lr)) ->
Just $ BDSeq (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDLines (l : lr)) ->
Just $ BDLines (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDCols sig (l : lr)) ->
Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDSeq (l:lr)) ->
Just $ BDSeq (BDAnnotationPrior annKey1 l:lr)
BDAnnotationPrior annKey1 (BDLines (l:lr)) ->
Just $ BDLines (BDAnnotationPrior annKey1 l:lr)
BDAnnotationPrior annKey1 (BDCols sig (l:lr)) ->
Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr)
-- post floating in
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) ->
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) ->
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) ->
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) ->
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) ->
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
-- not sure if the following rule is necessary; tests currently are
-- unaffected.
-- BDEnsureIndent indent (BDLines lines) ->
-- Just $ BDLines $ BDEnsureIndent indent <$> lines
-- matching col special transformation
BDCols sig1 cols1@(_ : _)
| BDLines lines@(_ : _ : _) <- List.last cols1
BDCols sig1 cols1@(_:_)
| BDLines lines@(_:_:_) <- List.last cols1
, BDCols sig2 cols2 <- List.last lines
, sig1 == sig2
-> Just $ BDLines
[ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines]
, BDCols sig2 cols2
]
BDCols sig1 cols1@(_ : _)
| BDLines lines@(_ : _ : _) <- List.last cols1
, sig1==sig2 ->
Just $ BDLines
[ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines]
, BDCols sig2 cols2
]
BDCols sig1 cols1@(_:_)
| BDLines lines@(_:_:_) <- List.last cols1
, BDEnsureIndent _ (BDCols sig2 cols2) <- List.last lines
, sig1 == sig2
-> Just $ BDLines
[ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines]
, BDCols sig2 cols2
]
BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1 == sig2 ->
, sig1==sig2 ->
Just $ BDLines
[ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines]
, BDCols sig2 cols2
]
BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1==sig2 ->
Just $ BDAddBaseY ind (BDLines [col1, col2])
BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _) : rest))
| sig1 == sig2 -> Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest)
BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _):rest))
| sig1==sig2 ->
Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest)
BDPar ind (BDLines lines1) col2@(BDCols sig2 _)
| BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just
$ BDAddBaseY ind (BDLines $ lines1 ++ [col2])
BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _) : rest))
| BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just
$ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest)
| BDCols sig1 _ <- List.last lines1
, sig1==sig2 ->
Just $ BDAddBaseY ind (BDLines $ lines1 ++ [col2])
BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _):rest))
| BDCols sig1 _ <- List.last lines1
, sig1==sig2 ->
Just $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest)
-- BDPar ind1 (BDCols sig1 cols1) (BDPar ind2 line (BDCols sig2 cols2))
-- | sig1==sig2 ->
-- Just $ BDPar
-- ind1
-- (BDLines [BDCols sig1 cols1, BDCols sig])
BDCols sig1 cols
| BDPar _ind line (BDCols sig2 cols2) <- List.last cols, sig1 == sig2
-> Just
$ BDLines [BDCols sig1 (List.init cols ++ [line]), BDCols sig2 cols2]
BDCols sig1 cols
| BDPar ind line (BDLines lines) <- List.last cols
, BDCols sig2 cols2 <- List.last lines
, sig1 == sig2
-> Just $ BDLines
[ BDCols sig1
$ List.init cols
++ [BDPar ind line (BDLines $ List.init lines)]
BDCols sig1 cols | BDPar _ind line (BDCols sig2 cols2) <- List.last cols
, sig1==sig2 ->
Just $ BDLines
[ BDCols sig1 (List.init cols ++ [line])
, BDCols sig2 cols2
]
BDLines [x] -> Just $ x
BDLines [] -> Just $ BDEmpty
BDSeq{} -> Nothing
BDCols{} -> Nothing
BDSeparator -> Nothing
BDAddBaseY{} -> Nothing
BDBaseYPushCur{} -> Nothing
BDBaseYPop{} -> Nothing
BDCols sig1 cols | BDPar ind line (BDLines lines) <- List.last cols
, BDCols sig2 cols2 <- List.last lines
, sig1==sig2 ->
Just $ BDLines
[ BDCols sig1 $ List.init cols ++ [BDPar ind line (BDLines $ List.init lines)]
, BDCols sig2 cols2
]
BDLines [x] -> Just $ x
BDLines [] -> Just $ BDEmpty
BDSeq{} -> Nothing
BDCols{} -> Nothing
BDSeparator -> Nothing
BDAddBaseY{} -> Nothing
BDBaseYPushCur{} -> Nothing
BDBaseYPop{} -> Nothing
BDIndentLevelPushCur{} -> Nothing
BDIndentLevelPop{} -> Nothing
BDPar{} -> Nothing
BDAlt{} -> Nothing
BDForceMultiline{} -> Nothing
BDIndentLevelPop{} -> Nothing
BDPar{} -> Nothing
BDAlt{} -> Nothing
BDForceMultiline{} -> Nothing
BDForceSingleline{} -> Nothing
BDForwardLineMode{} -> Nothing
BDExternal{} -> Nothing
BDPlain{} -> Nothing
BDLines{} -> Nothing
BDExternal{} -> Nothing
BDPlain{} -> Nothing
BDLines{} -> Nothing
BDAnnotationPrior{} -> Nothing
BDAnnotationKW{} -> Nothing
BDAnnotationRest{} -> Nothing
BDMoveToKWDP{} -> Nothing
BDEnsureIndent{} -> Nothing
BDSetParSpacing{} -> Nothing
BDAnnotationKW{} -> Nothing
BDAnnotationRest{} -> Nothing
BDMoveToKWDP{} -> Nothing
BDEnsureIndent{} -> Nothing
BDSetParSpacing{} -> Nothing
BDForceParSpacing{} -> Nothing
BDDebug{} -> Nothing
BDDebug{} -> Nothing
BDNonBottomSpacing _ x -> Just x

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

@ -3,20 +3,25 @@
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.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Types
import qualified Data.Generics.Uniplate.Direct as Uniplate
-- note that this is not total, and cannot be with that exact signature.
mergeIndents :: BrIndent -> BrIndent -> BrIndent
mergeIndents BrIndentNone x = x
mergeIndents x BrIndentNone = x
mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) =
BrIndentSpecial (max i j)
mergeIndents _ _ = error "mergeIndents"
mergeIndents BrIndentNone x = x
mergeIndents x BrIndentNone = x
mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j)
mergeIndents _ _ = error "mergeIndents"
transformSimplifyFloating :: BriDoc -> BriDoc
@ -26,192 +31,169 @@ transformSimplifyFloating = stepBO .> stepFull
-- better complexity.
-- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence
-- the push/pop cases would need to be copied over
where
descendPrior = transformDownMay $ \case
-- prior floating in
BDAnnotationPrior annKey1 (BDPar ind line indented) ->
Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented
BDAnnotationPrior annKey1 (BDSeq (l : lr)) ->
Just $ BDSeq (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDLines (l : lr)) ->
Just $ BDLines (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDCols sig (l : lr)) ->
Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x
BDAnnotationPrior annKey1 (BDDebug s x) ->
Just $ BDDebug s $ BDAnnotationPrior annKey1 x
_ -> Nothing
descendRest = transformDownMay $ \case
-- post floating in
BDAnnotationRest annKey1 (BDPar ind line indented) ->
Just $ BDPar ind line $ BDAnnotationRest annKey1 indented
BDAnnotationRest annKey1 (BDSeq list) ->
Just
$ BDSeq
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDLines list) ->
Just
$ BDLines
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDCols sig cols) ->
Just
$ BDCols sig
$ List.init cols
++ [BDAnnotationRest annKey1 $ List.last cols]
BDAnnotationRest annKey1 (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x
BDAnnotationRest annKey1 (BDDebug s x) ->
Just $ BDDebug s $ BDAnnotationRest annKey1 x
_ -> Nothing
descendKW = transformDownMay $ \case
-- post floating in
BDAnnotationKW annKey1 kw (BDPar ind line indented) ->
Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented
BDAnnotationKW annKey1 kw (BDSeq list) ->
Just
$ BDSeq
$ List.init list
++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDLines list) ->
Just
$ BDLines
$ List.init list
++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDCols sig cols) ->
Just
$ BDCols sig
$ List.init cols
++ [BDAnnotationKW annKey1 kw $ List.last cols]
BDAnnotationKW annKey1 kw (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x
BDAnnotationKW annKey1 kw (BDDebug s x) ->
Just $ BDDebug s $ BDAnnotationKW annKey1 kw x
_ -> Nothing
descendBYPush = transformDownMay $ \case
BDBaseYPushCur (BDCols sig cols@(_ : _)) ->
Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols)
BDBaseYPushCur (BDDebug s x) -> Just $ BDDebug s (BDBaseYPushCur x)
_ -> Nothing
descendBYPop = transformDownMay $ \case
BDBaseYPop (BDCols sig cols@(_ : _)) ->
Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)])
BDBaseYPop (BDDebug s x) -> Just $ BDDebug s (BDBaseYPop x)
_ -> Nothing
descendILPush = transformDownMay $ \case
BDIndentLevelPushCur (BDCols sig cols@(_ : _)) -> Just
$ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols)
BDIndentLevelPushCur (BDDebug s x) ->
Just $ BDDebug s (BDIndentLevelPushCur x)
_ -> Nothing
descendILPop = transformDownMay $ \case
BDIndentLevelPop (BDCols sig cols@(_ : _)) ->
Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)])
BDIndentLevelPop (BDDebug s x) -> Just $ BDDebug s (BDIndentLevelPop x)
_ -> Nothing
descendAddB = transformDownMay $ \case
BDAddBaseY BrIndentNone x -> Just x
-- AddIndent floats into Lines.
BDAddBaseY indent (BDLines lines) ->
Just $ BDLines $ BDAddBaseY indent <$> lines
-- AddIndent floats into last column
BDAddBaseY indent (BDCols sig cols) ->
Just
$ BDCols sig
$ List.init cols
++ [BDAddBaseY indent $ List.last cols]
-- merge AddIndent and Par
BDAddBaseY ind1 (BDPar ind2 line indented) ->
Just $ BDPar (mergeIndents ind1 ind2) line indented
BDAddBaseY ind (BDAnnotationPrior annKey1 x) ->
Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x)
BDAddBaseY ind (BDAnnotationRest annKey1 x) ->
Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x)
BDAddBaseY ind (BDAnnotationKW annKey1 kw x) ->
Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x)
BDAddBaseY ind (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]
BDAddBaseY _ lit@BDLit{} -> Just $ lit
BDAddBaseY ind (BDBaseYPushCur x) ->
Just $ BDBaseYPushCur (BDAddBaseY ind x)
BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x)
BDAddBaseY ind (BDDebug s x) -> Just $ BDDebug s (BDAddBaseY ind x)
BDAddBaseY ind (BDIndentLevelPop x) ->
Just $ BDIndentLevelPop (BDAddBaseY ind x)
BDAddBaseY ind (BDIndentLevelPushCur x) ->
Just $ BDIndentLevelPushCur (BDAddBaseY ind x)
BDAddBaseY ind (BDEnsureIndent ind2 x) ->
Just $ BDEnsureIndent (mergeIndents ind ind2) x
_ -> Nothing
stepBO :: BriDoc -> BriDoc
stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $
transformUp f
where
f = \case
x@BDAnnotationPrior{} -> descendPrior x
x@BDAnnotationKW{} -> descendKW x
x@BDAnnotationRest{} -> descendRest x
x@BDAddBaseY{} -> descendAddB x
x@BDBaseYPushCur{} -> descendBYPush x
x@BDBaseYPop{} -> descendBYPop x
x@BDIndentLevelPushCur{} -> descendILPush x
x@BDIndentLevelPop{} -> descendILPop x
x -> x
stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $
Uniplate.rewrite $ \case
BDAddBaseY BrIndentNone x -> Just $ x
-- AddIndent floats into Lines.
BDAddBaseY indent (BDLines lines) ->
Just $ BDLines $ BDAddBaseY indent <$> lines
-- AddIndent floats into last column
BDAddBaseY indent (BDCols sig cols) ->
Just
$ BDCols sig
$ List.init cols
++ [BDAddBaseY indent $ List.last cols]
BDAddBaseY ind (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]
-- merge AddIndent and Par
BDAddBaseY ind1 (BDPar ind2 line indented) ->
Just $ BDPar (mergeIndents ind1 ind2) line indented
BDAddBaseY _ lit@BDLit{} -> Just $ lit
BDAddBaseY ind (BDBaseYPushCur x) ->
Just $ BDBaseYPushCur (BDAddBaseY ind x)
BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x)
-- prior floating in
BDAnnotationPrior annKey1 (BDPar ind line indented) ->
Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented
BDAnnotationPrior annKey1 (BDSeq (l : lr)) ->
Just $ BDSeq ((BDAnnotationPrior annKey1 l) : lr)
BDAnnotationPrior annKey1 (BDLines (l : lr)) ->
Just $ BDLines ((BDAnnotationPrior annKey1 l) : lr)
BDAnnotationPrior annKey1 (BDCols sig (l : lr)) ->
Just $ BDCols sig ((BDAnnotationPrior annKey1 l) : lr)
-- EnsureIndent float-in
-- BDEnsureIndent indent (BDCols sig (col:colr)) ->
-- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr))
-- not sure if the following rule is necessary; tests currently are
-- unaffected.
-- BDEnsureIndent indent (BDLines lines) ->
-- Just $ BDLines $ BDEnsureIndent indent <$> lines
-- post floating in
BDAnnotationRest annKey1 (BDPar ind line indented) ->
Just $ BDPar ind line $ BDAnnotationRest annKey1 indented
BDAnnotationRest annKey1 (BDSeq list) ->
Just
$ BDSeq
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDLines list) ->
Just
$ BDLines
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDCols sig cols) ->
Just
$ BDCols sig
$ List.init cols
++ [BDAnnotationRest annKey1 $ List.last cols]
_ -> Nothing
where
descendPrior = transformDownMay $ \case
-- prior floating in
BDAnnotationPrior annKey1 (BDPar ind line indented) ->
Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented
BDAnnotationPrior annKey1 (BDSeq (l:lr)) ->
Just $ BDSeq (BDAnnotationPrior annKey1 l:lr)
BDAnnotationPrior annKey1 (BDLines (l:lr)) ->
Just $ BDLines (BDAnnotationPrior annKey1 l:lr)
BDAnnotationPrior annKey1 (BDCols sig (l:lr)) ->
Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr)
BDAnnotationPrior annKey1 (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x
BDAnnotationPrior annKey1 (BDDebug s x) ->
Just $ BDDebug s $ BDAnnotationPrior annKey1 x
_ -> Nothing
descendRest = transformDownMay $ \case
-- post floating in
BDAnnotationRest annKey1 (BDPar ind line indented) ->
Just $ BDPar ind line $ BDAnnotationRest annKey1 indented
BDAnnotationRest annKey1 (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDLines list) ->
Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols]
BDAnnotationRest annKey1 (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x
BDAnnotationRest annKey1 (BDDebug s x) ->
Just $ BDDebug s $ BDAnnotationRest annKey1 x
_ -> Nothing
descendKW = transformDownMay $ \case
-- post floating in
BDAnnotationKW annKey1 kw (BDPar ind line indented) ->
Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented
BDAnnotationKW annKey1 kw (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDLines list) ->
Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols]
BDAnnotationKW annKey1 kw (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x
BDAnnotationKW annKey1 kw (BDDebug s x) ->
Just $ BDDebug s $ BDAnnotationKW annKey1 kw x
_ -> Nothing
descendBYPush = transformDownMay $ \case
BDBaseYPushCur (BDCols sig cols@(_:_)) ->
Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols)
BDBaseYPushCur (BDDebug s x) ->
Just $ BDDebug s (BDBaseYPushCur x)
_ -> Nothing
descendBYPop = transformDownMay $ \case
BDBaseYPop (BDCols sig cols@(_:_)) ->
Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)])
BDBaseYPop (BDDebug s x) ->
Just $ BDDebug s (BDBaseYPop x)
_ -> Nothing
descendILPush = transformDownMay $ \case
BDIndentLevelPushCur (BDCols sig cols@(_:_)) ->
Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols)
BDIndentLevelPushCur (BDDebug s x) ->
Just $ BDDebug s (BDIndentLevelPushCur x)
_ -> Nothing
descendILPop = transformDownMay $ \case
BDIndentLevelPop (BDCols sig cols@(_:_)) ->
Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)])
BDIndentLevelPop (BDDebug s x) ->
Just $ BDDebug s (BDIndentLevelPop x)
_ -> Nothing
descendAddB = transformDownMay $ \case
BDAddBaseY BrIndentNone x ->
Just x
-- AddIndent floats into Lines.
BDAddBaseY indent (BDLines lines) ->
Just $ BDLines $ BDAddBaseY indent <$> lines
-- AddIndent floats into last column
BDAddBaseY indent (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols]
-- merge AddIndent and Par
BDAddBaseY ind1 (BDPar ind2 line indented) ->
Just $ BDPar (mergeIndents ind1 ind2) line indented
BDAddBaseY ind (BDAnnotationPrior annKey1 x) ->
Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x)
BDAddBaseY ind (BDAnnotationRest annKey1 x) ->
Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x)
BDAddBaseY ind (BDAnnotationKW annKey1 kw x) ->
Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x)
BDAddBaseY ind (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]
BDAddBaseY _ lit@BDLit{} ->
Just $ lit
BDAddBaseY ind (BDBaseYPushCur x) ->
Just $ BDBaseYPushCur (BDAddBaseY ind x)
BDAddBaseY ind (BDBaseYPop x) ->
Just $ BDBaseYPop (BDAddBaseY ind x)
BDAddBaseY ind (BDDebug s x) ->
Just $ BDDebug s (BDAddBaseY ind x)
BDAddBaseY ind (BDIndentLevelPop x) ->
Just $ BDIndentLevelPop (BDAddBaseY ind x)
BDAddBaseY ind (BDIndentLevelPushCur x) ->
Just $ BDIndentLevelPushCur (BDAddBaseY ind x)
BDAddBaseY ind (BDEnsureIndent ind2 x) ->
Just $ BDEnsureIndent (mergeIndents ind ind2) x
_ -> Nothing
stepBO :: BriDoc -> BriDoc
stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $
transformUp f
where
f = \case
x@BDAnnotationPrior{} -> descendPrior x
x@BDAnnotationKW{} -> descendKW x
x@BDAnnotationRest{} -> descendRest x
x@BDAddBaseY{} -> descendAddB x
x@BDBaseYPushCur{} -> descendBYPush x
x@BDBaseYPop{} -> descendBYPop x
x@BDIndentLevelPushCur{} -> descendILPush x
x@BDIndentLevelPop{} -> descendILPop x
x -> x
stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $
Uniplate.rewrite $ \case
BDAddBaseY BrIndentNone x ->
Just $ x
-- AddIndent floats into Lines.
BDAddBaseY indent (BDLines lines) ->
Just $ BDLines $ BDAddBaseY indent <$> lines
-- AddIndent floats into last column
BDAddBaseY indent (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols]
BDAddBaseY ind (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]
-- merge AddIndent and Par
BDAddBaseY ind1 (BDPar ind2 line indented) ->
Just $ BDPar (mergeIndents ind1 ind2) line indented
BDAddBaseY _ lit@BDLit{} ->
Just $ lit
BDAddBaseY ind (BDBaseYPushCur x) ->
Just $ BDBaseYPushCur (BDAddBaseY ind x)
BDAddBaseY ind (BDBaseYPop x) ->
Just $ BDBaseYPop (BDAddBaseY ind x)
-- prior floating in
BDAnnotationPrior annKey1 (BDPar ind line indented) ->
Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented
BDAnnotationPrior annKey1 (BDSeq (l:lr)) ->
Just $ BDSeq ((BDAnnotationPrior annKey1 l):lr)
BDAnnotationPrior annKey1 (BDLines (l:lr)) ->
Just $ BDLines ((BDAnnotationPrior annKey1 l):lr)
BDAnnotationPrior annKey1 (BDCols sig (l:lr)) ->
Just $ BDCols sig ((BDAnnotationPrior annKey1 l):lr)
-- EnsureIndent float-in
-- BDEnsureIndent indent (BDCols sig (col:colr)) ->
-- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr))
-- not sure if the following rule is necessary; tests currently are
-- unaffected.
-- BDEnsureIndent indent (BDLines lines) ->
-- Just $ BDLines $ BDEnsureIndent indent <$> lines
-- post floating in
BDAnnotationRest annKey1 (BDPar ind line indented) ->
Just $ BDPar ind line $ BDAnnotationRest annKey1 indented
BDAnnotationRest annKey1 (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDLines list) ->
Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols]
_ -> Nothing

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

@ -3,10 +3,16 @@
module Language.Haskell.Brittany.Internal.Transformations.Indent 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.Types
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Types
import qualified Data.Generics.Uniplate.Direct as Uniplate
-- prepare layouting by translating BDPar's, replacing them with Indents and
-- floating those in. This gives a more clear picture of what exactly is
@ -25,17 +31,15 @@ transformSimplifyIndent = Uniplate.rewrite $ \case
-- [ BDAddBaseY ind x
-- , BDEnsureIndent ind indented
-- ]
BDLines lines
| any
(\case
BDLines{} -> True
BDEmpty{} -> True
_ -> False
)
lines
-> Just $ BDLines $ filter isNotEmpty $ lines >>= \case
BDLines lines | any ( \case
BDLines{} -> True
BDEmpty{} -> True
_ -> False
)
lines ->
Just $ BDLines $ filter isNotEmpty $ lines >>= \case
BDLines l -> l
x -> [x]
x -> [x]
BDLines [l] -> Just l
BDAddBaseY i (BDAnnotationPrior k x) ->
Just $ BDAnnotationPrior k (BDAddBaseY i x)
@ -49,4 +53,4 @@ transformSimplifyIndent = Uniplate.rewrite $ \case
Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l]
BDAddBaseY _ lit@BDLit{} -> Just lit
_ -> Nothing
_ -> Nothing

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

@ -3,9 +3,14 @@
module Language.Haskell.Brittany.Internal.Transformations.Par where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Types
transformSimplifyPar :: BriDoc -> BriDoc
transformSimplifyPar = transformUp $ \case
@ -19,28 +24,25 @@ transformSimplifyPar = transformUp $ \case
BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds))
BDPar ind1 (BDPar ind2 line p1) p2 ->
BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2])
BDLines lines
| any
(\case
BDLines{} -> True
BDEmpty{} -> True
_ -> False
)
lines
-> case go lines of
[] -> BDEmpty
[x] -> x
xs -> BDLines xs
BDLines lines | any ( \case
BDLines{} -> True
BDEmpty{} -> True
_ -> False
)
lines -> case go lines of
[] -> BDEmpty
[x] -> x
xs -> BDLines xs
where
go = (=<<) $ \case
BDLines l -> go l
BDEmpty -> []
x -> [x]
BDLines [] -> BDEmpty
BDLines [x] -> x
BDEmpty -> []
x -> [x]
BDLines [] -> BDEmpty
BDLines [x] -> x
-- BDCols sig cols | BDPar ind line indented <- List.last cols ->
-- Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented
-- BDPar BrIndentNone line indented ->
-- Just $ BDLines [line, indented]
BDEnsureIndent BrIndentNone x -> x
x -> x
x -> x

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

@ -12,47 +12,52 @@
module Language.Haskell.Brittany.Internal.Types where
import Language.Haskell.Brittany.Internal.Prelude
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import qualified Data.Data
import Data.Generics.Uniplate.Direct as Uniplate
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
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 qualified Data.Kind as Kind
data PerItemConfig = PerItemConfig
{ _icd_perBinding :: Map String (CConfig Maybe)
, _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Maybe)
}
deriving Data.Data.Data
type PPM
= MultiRWSS.MultiRWS
'[ Map ExactPrint.AnnKey ExactPrint.Anns
, PerItemConfig
, Config
, ExactPrint.Anns
]
'[Text.Builder.Builder , [BrittanyError] , Seq String]
'[]
type PPM = MultiRWSS.MultiRWS
'[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns]
'[Text.Builder.Builder, [BrittanyError], Seq String]
'[]
type PPMLocal
= MultiRWSS.MultiRWS
'[Config , ExactPrint.Anns]
'[Text.Builder.Builder , [BrittanyError] , Seq String]
'[]
type PPMLocal = MultiRWSS.MultiRWS
'[Config, ExactPrint.Anns]
'[Text.Builder.Builder, [BrittanyError], Seq String]
'[]
newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String)
data LayoutState = LayoutState
{ _lstate_baseYs :: [Int]
{ _lstate_baseYs :: [Int]
-- ^ stack of number of current indentation columns
-- (not number of indentations).
, _lstate_curYOrAddNewline :: Either Int Int
@ -60,7 +65,7 @@ data LayoutState = LayoutState
-- 1) number of chars in the current line.
-- 2) number of newlines to be inserted before inserting any
-- non-space elements.
, _lstate_indLevels :: [Int]
, _lstate_indLevels :: [Int]
-- ^ stack of current indentation levels. set for
-- any layout-affected elements such as
-- let/do/case/where elements.
@ -73,14 +78,14 @@ data LayoutState = LayoutState
-- on the first indented element have an
-- annotation offset relative to the last
-- non-indented element, which is confusing.
, _lstate_comments :: Anns
, _lstate_commentCol :: Maybe Int -- this communicates two things:
, _lstate_comments :: Anns
, _lstate_commentCol :: Maybe Int -- this communicates two things:
-- firstly, that cursor is currently
-- at the end of a comment (so needs
-- newline before any actual content).
-- secondly, the column at which
-- insertion of comments started.
, _lstate_addSepSpace :: Maybe Int -- number of spaces to insert if anyone
, _lstate_addSepSpace :: Maybe Int -- number of spaces to insert if anyone
-- writes (any non-spaces) in the
-- current line.
-- , _lstate_isNewline :: NewLineState
@ -110,21 +115,14 @@ lstate_indLevel = Safe.headNote "lstate_baseY" . _lstate_indLevels
instance Show LayoutState where
show state =
"LayoutState"
++ "{baseYs="
++ show (_lstate_baseYs state)
++ ",curYOrAddNewline="
++ show (_lstate_curYOrAddNewline state)
++ ",indLevels="
++ show (_lstate_indLevels state)
++ ",indLevelLinger="
++ show (_lstate_indLevelLinger state)
++ ",commentCol="
++ show (_lstate_commentCol state)
++ ",addSepSpace="
++ show (_lstate_addSepSpace state)
++ ",commentNewlines="
++ show (_lstate_commentNewlines state)
++ "}"
++ "{baseYs=" ++ show (_lstate_baseYs state)
++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state)
++ ",indLevels=" ++ show (_lstate_indLevels 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
-- -- newline, really. by special-casing
@ -225,16 +223,14 @@ data BrIndent = BrIndentNone
| BrIndentSpecial Int
deriving (Eq, Ord, Data.Data.Data, Show)
type ToBriDocM
= MultiRWSS.MultiRWS
'[Config , Anns] -- reader
'[[BrittanyError] , Seq String] -- writer
'[NodeAllocIndex] -- state
type ToBriDocM = MultiRWSS.MultiRWS
'[Config, Anns] -- reader
'[[BrittanyError], Seq String] -- writer
'[NodeAllocIndex] -- state
type ToBriDoc (sym :: Kind.Type -> Kind.Type)
= Located (sym GhcPs) -> ToBriDocM BriDocNumbered
type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered
type ToBriDocC sym c = Located sym -> ToBriDocM c
type ToBriDoc (sym :: Kind.Type -> Kind.Type) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered
type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered
type ToBriDocC sym c = Located sym -> ToBriDocM c
data DocMultiLine
= MultiLineNo
@ -342,21 +338,21 @@ type BriDocFInt = BriDocF ((,) Int)
type BriDocNumbered = (Int, BriDocFInt)
instance Uniplate.Uniplate BriDoc where
uniplate x@BDEmpty{} = plate x
uniplate x@BDLit{} = plate x
uniplate (BDSeq list) = plate BDSeq ||* list
uniplate (BDCols sig list) = plate BDCols |- sig ||* list
uniplate x@BDSeparator = plate x
uniplate (BDAddBaseY ind bd) = plate BDAddBaseY |- ind |* bd
uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd
uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd
uniplate x@BDEmpty{} = plate x
uniplate x@BDLit{} = plate x
uniplate (BDSeq list ) = plate BDSeq ||* list
uniplate (BDCols sig list) = plate BDCols |- sig ||* list
uniplate x@BDSeparator = plate x
uniplate (BDAddBaseY ind bd ) = plate BDAddBaseY |- ind |* bd
uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd
uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd
uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd
uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd
uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd
uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented
uniplate (BDAlt alts) = plate BDAlt ||* alts
uniplate (BDForwardLineMode bd) = plate BDForwardLineMode |* bd
uniplate x@BDExternal{} = plate x
uniplate x@BDPlain{} = plate x
uniplate (BDAlt alts ) = plate BDAlt ||* alts
uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd
uniplate x@BDExternal{} = plate x
uniplate x@BDPlain{} = plate x
uniplate (BDAnnotationPrior annKey bd) =
plate BDAnnotationPrior |- annKey |* bd
uniplate (BDAnnotationKW annKey kw bd) =
@ -365,84 +361,83 @@ instance Uniplate.Uniplate BriDoc where
plate BDAnnotationRest |- annKey |* bd
uniplate (BDMoveToKWDP annKey kw b bd) =
plate BDMoveToKWDP |- annKey |- kw |- b |* bd
uniplate (BDLines lines) = plate BDLines ||* lines
uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd
uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd
uniplate (BDForceSingleline bd) = plate BDForceSingleline |* bd
uniplate (BDLines lines ) = plate BDLines ||* lines
uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd
uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd
uniplate (BDForceSingleline bd ) = plate BDForceSingleline |* bd
uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd
uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd
uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd
uniplate (BDDebug s bd) = plate BDDebug |- s |* bd
uniplate (BDSetParSpacing bd ) = plate BDSetParSpacing |* bd
uniplate (BDForceParSpacing bd ) = plate BDForceParSpacing |* bd
uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd
newtype NodeAllocIndex = NodeAllocIndex Int
-- TODO: rename to "dropLabels" ?
unwrapBriDocNumbered :: BriDocNumbered -> BriDoc
unwrapBriDocNumbered tpl = case snd tpl of
BDFEmpty -> BDEmpty
BDFLit t -> BDLit t
BDFSeq list -> BDSeq $ rec <$> list
BDFCols sig list -> BDCols sig $ rec <$> list
BDFSeparator -> BDSeparator
BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd
BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd
BDFBaseYPop bd -> BDBaseYPop $ rec bd
BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd
BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd
BDFPar ind line indented -> BDPar ind (rec line) (rec indented)
BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen
BDFForwardLineMode bd -> BDForwardLineMode $ rec bd
BDFExternal k ks c t -> BDExternal k ks c t
BDFPlain t -> BDPlain t
BDFEmpty -> BDEmpty
BDFLit t -> BDLit t
BDFSeq list -> BDSeq $ rec <$> list
BDFCols sig list -> BDCols sig $ rec <$> list
BDFSeparator -> BDSeparator
BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd
BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd
BDFBaseYPop bd -> BDBaseYPop $ rec bd
BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd
BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd
BDFPar ind line indented -> BDPar ind (rec line) (rec indented)
BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen
BDFForwardLineMode bd -> BDForwardLineMode $ rec bd
BDFExternal k ks c t -> BDExternal k ks c t
BDFPlain t -> BDPlain t
BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd
BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd
BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd
BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd
BDFMoveToKWDP annKey kw b bd -> BDMoveToKWDP annKey kw b $ rec bd
BDFLines lines -> BDLines $ rec <$> lines
BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd
BDFForceMultiline bd -> BDForceMultiline $ rec bd
BDFForceSingleline bd -> BDForceSingleline $ rec bd
BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd
BDFSetParSpacing bd -> BDSetParSpacing $ rec bd
BDFForceParSpacing bd -> BDForceParSpacing $ rec bd
BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd
BDFLines lines -> BDLines $ rec <$> lines
BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd
BDFForceMultiline bd -> BDForceMultiline $ rec bd
BDFForceSingleline bd -> BDForceSingleline $ rec bd
BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd
BDFSetParSpacing bd -> BDSetParSpacing $ rec bd
BDFForceParSpacing bd -> BDForceParSpacing $ rec bd
BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd
where rec = unwrapBriDocNumbered
isNotEmpty :: BriDoc -> Bool
isNotEmpty BDEmpty = False
isNotEmpty _ = True
isNotEmpty _ = True
-- this might not work. is not used anywhere either.
briDocSeqSpine :: BriDoc -> ()
briDocSeqSpine = \case
BDEmpty -> ()
BDLit _t -> ()
BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list
BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list
BDSeparator -> ()
BDAddBaseY _ind bd -> briDocSeqSpine bd
BDBaseYPushCur bd -> briDocSeqSpine bd
BDBaseYPop bd -> briDocSeqSpine bd
BDIndentLevelPushCur bd -> briDocSeqSpine bd
BDIndentLevelPop bd -> briDocSeqSpine bd
BDPar _ind line indented ->
briDocSeqSpine line `seq` briDocSeqSpine indented
BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts
BDForwardLineMode bd -> briDocSeqSpine bd
BDExternal{} -> ()
BDPlain{} -> ()
BDAnnotationPrior _annKey bd -> briDocSeqSpine bd
BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd
BDAnnotationRest _annKey bd -> briDocSeqSpine bd
BDEmpty -> ()
BDLit _t -> ()
BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list
BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list
BDSeparator -> ()
BDAddBaseY _ind bd -> briDocSeqSpine bd
BDBaseYPushCur bd -> briDocSeqSpine bd
BDBaseYPop bd -> briDocSeqSpine bd
BDIndentLevelPushCur bd -> briDocSeqSpine bd
BDIndentLevelPop bd -> briDocSeqSpine bd
BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented
BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts
BDForwardLineMode bd -> briDocSeqSpine bd
BDExternal{} -> ()
BDPlain{} -> ()
BDAnnotationPrior _annKey bd -> briDocSeqSpine bd
BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd
BDAnnotationRest _annKey bd -> briDocSeqSpine bd
BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd
BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines
BDEnsureIndent _ind bd -> briDocSeqSpine bd
BDForceMultiline bd -> briDocSeqSpine bd
BDForceSingleline bd -> briDocSeqSpine bd
BDNonBottomSpacing _ bd -> briDocSeqSpine bd
BDSetParSpacing bd -> briDocSeqSpine bd
BDForceParSpacing bd -> briDocSeqSpine bd
BDDebug _s bd -> briDocSeqSpine bd
BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines
BDEnsureIndent _ind bd -> briDocSeqSpine bd
BDForceMultiline bd -> briDocSeqSpine bd
BDForceSingleline bd -> briDocSeqSpine bd
BDNonBottomSpacing _ bd -> briDocSeqSpine bd
BDSetParSpacing bd -> briDocSeqSpine bd
BDForceParSpacing bd -> briDocSeqSpine bd
BDDebug _s bd -> briDocSeqSpine bd
briDocForceSpine :: BriDoc -> BriDoc
briDocForceSpine bd = briDocSeqSpine bd `seq` bd
@ -461,19 +456,18 @@ data VerticalSpacingPar
-- product like (Normal|Always, None|Some Int).
deriving (Eq, Show)
data VerticalSpacing = VerticalSpacing
{ _vs_sameLine :: !Int
, _vs_paragraph :: !VerticalSpacingPar
, _vs_parFlag :: !Bool
}
data VerticalSpacing
= VerticalSpacing
{ _vs_sameLine :: !Int
, _vs_paragraph :: !VerticalSpacingPar
, _vs_parFlag :: !Bool
}
deriving (Eq, Show)
newtype LineModeValidity a = LineModeValidity (Strict.Maybe a)
deriving (Functor, Applicative, Monad, Show, Alternative)
pattern LineModeValid :: forall t . t -> LineModeValidity t
pattern LineModeValid x =
LineModeValidity (Strict.Just x) :: LineModeValidity t
pattern LineModeInvalid :: forall t . LineModeValidity t
pattern LineModeInvalid =
LineModeValidity Strict.Nothing :: LineModeValidity t
pattern LineModeValid :: forall t. t -> LineModeValidity t
pattern LineModeValid x = LineModeValidity (Strict.Just x) :: LineModeValidity t
pattern LineModeInvalid :: forall t. LineModeValidity t
pattern LineModeInvalid = LineModeValidity Strict.Nothing :: LineModeValidity t

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

@ -7,29 +7,40 @@
module Language.Haskell.Brittany.Internal.Utils where
import qualified Data.ByteString as B
import qualified Data.Coerce
import Data.Data
import Data.Generics.Aliases
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.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 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.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 GHC.Hs.Extension as HsExtension
parDoc :: String -> PP.Doc
parDoc = PP.fsep . fmap PP.text . List.words
@ -44,8 +55,7 @@ showOutputable :: (GHC.Outputable a) => a -> String
showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags
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 x y =
@ -60,26 +70,24 @@ instance (Num a, Ord a) => Semigroup (Max a) where
(<>) = Data.Coerce.coerce (max :: a -> a -> a)
instance (Num a, Ord a) => Monoid (Max a) where
mempty = Max 0
mempty = Max 0
mappend = (<>)
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 anns layoutF =
DataToLayouter
$ f
`extQ` showIsId
`extQ` fastString
`extQ` bytestring
`extQ` occName
`extQ` srcSpan
$ f
`extQ` showIsId
`extQ` fastString
`extQ` bytestring
`extQ` occName
`extQ` srcSpan
`ext2Q` located
where
DataToLayouter f = defaultLayouterF layoutF
@ -87,22 +95,18 @@ customLayouterF anns layoutF =
simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)
showIsId :: ShowIsId -> NodeLayouter
showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case
Left True -> PP.parens $ PP.text s
Left False -> PP.text s
Right _ -> PP.text s
Left True -> PP.parens $ PP.text s
Left False -> PP.text s
Right _ -> PP.text s
fastString =
simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString
simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString
-> NodeLayouter
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
occName =
simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString
srcSpan :: GHC.SrcSpan -> NodeLayouter
srcSpan ss =
simpleLayouter
srcSpan ss = simpleLayouter
-- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}"
$ "{"
++ showOutputable ss
++ "}"
$ "{" ++ showOutputable ss ++ "}"
located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter
located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a
where
@ -114,12 +118,12 @@ customLayouterF anns layoutF =
customLayouterNoAnnsF :: LayouterF
customLayouterNoAnnsF layoutF =
DataToLayouter
$ f
`extQ` showIsId
`extQ` fastString
`extQ` bytestring
`extQ` occName
`extQ` srcSpan
$ f
`extQ` showIsId
`extQ` fastString
`extQ` bytestring
`extQ` occName
`extQ` srcSpan
`ext2Q` located
where
DataToLayouter f = defaultLayouterF layoutF
@ -127,15 +131,14 @@ customLayouterNoAnnsF layoutF =
simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)
showIsId :: ShowIsId -> NodeLayouter
showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case
Left True -> PP.parens $ PP.text s
Left False -> PP.text s
Right _ -> PP.text s
Left True -> PP.parens $ PP.text s
Left False -> PP.text s
Right _ -> PP.text s
fastString =
simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString
simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString
-> NodeLayouter
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
occName =
simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString
srcSpan :: GHC.SrcSpan -> NodeLayouter
srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}"
located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter
@ -199,11 +202,12 @@ traceIfDumpConf s accessor val = do
whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do
trace ("---- " ++ s ++ " ----\n" ++ show val) $ return ()
tellDebugMess :: MonadMultiWriter (Seq String) m => String -> m ()
tellDebugMess :: MonadMultiWriter
(Seq String) m => String -> m ()
tellDebugMess s = mTell $ Seq.singleton s
tellDebugMessShow
:: forall a m . (MonadMultiWriter (Seq String) m, Show a) => a -> m ()
tellDebugMessShow :: forall a m . (MonadMultiWriter
(Seq String) m, Show a) => a -> m ()
tellDebugMessShow = tellDebugMess . show
-- i should really put that into multistate..
@ -218,28 +222,29 @@ briDocToDoc = astToDoc . removeAnnotations
where
removeAnnotations = Uniplate.transform $ \case
BDAnnotationPrior _ x -> x
BDAnnotationKW _ _ x -> x
BDAnnotationRest _ x -> x
x -> x
BDAnnotationKW _ _ x -> x
BDAnnotationRest _ x -> x
x -> x
briDocToDocWithAnns :: BriDoc -> PP.Doc
briDocToDocWithAnns = astToDoc
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 _ [] = ([], [])
breakEither fn (a1 : aR) = case fn a1 of
Left b -> (b : bs, cs)
breakEither _ [] = ([], [])
breakEither fn (a1:aR) = case fn a1 of
Left b -> (b : bs, cs)
Right c -> (bs, c : cs)
where (bs, cs) = breakEither fn aR
where
(bs, cs) = breakEither fn aR
spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])
spanMaybe f (x1 : xR) | Just y <- f x1 = (y : ys, xs)
where (ys, xs) = spanMaybe f xR
spanMaybe _ xs = ([], xs)
spanMaybe f (x1:xR) | Just y <- f x1 = (y : ys, xs)
where
(ys, xs) = spanMaybe f xR
spanMaybe _ xs = ([], xs)
data FirstLastView a
= FirstLastEmpty
@ -249,7 +254,7 @@ data FirstLastView a
splitFirstLast :: [a] -> FirstLastView a
splitFirstLast [] = FirstLastEmpty
splitFirstLast [x] = FirstLastSingleton x
splitFirstLast (x1 : xr) = FirstLast x1 (List.init xr) (List.last xr)
splitFirstLast (x1:xr) = FirstLast x1 (List.init xr) (List.last xr)
-- TODO: move to uniplate upstream?
-- aka `transform`
@ -268,7 +273,7 @@ lines' :: String -> [String]
lines' s = case break (== '\n') s of
(s1, []) -> [s1]
(s1, [_]) -> [s1, ""]
(s1, (_ : r)) -> s1 : lines' r
(s1, (_:r)) -> s1 : lines' r
absurdExt :: HsExtension.NoExtCon -> a
absurdExt = HsExtension.noExtCon

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

@ -4,41 +4,58 @@
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 Data.CZipWith
import qualified Data.Either
import qualified Data.List.Extra
import qualified Data.Monoid
import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import qualified Data.Text.Lazy as TextL
import DataTreePrint
import GHC (GenLocated(L))
import qualified GHC.Driver.Session as GHC
import qualified GHC.LanguageExtensions.Type as GHC
import qualified GHC.OldList as List
import GHC.Utils.Outputable (Outputable(..), showSDocUnsafe)
import Language.Haskell.Brittany.Internal
import Language.Haskell.Brittany.Internal.Config
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Obfuscation
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 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
-- 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.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.Config
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Obfuscation
import qualified Text.PrettyPrint as PP
import DataTreePrint
import UI.Butcher.Monadic
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
data WriteMode = Display | Inplace
@ -93,7 +110,7 @@ helpDoc = PP.vcat $ List.intersperse
]
, parDoc $ "See https://github.com/lspitzner/brittany"
, parDoc
$ "Please report bugs at"
$ "Please report bugs at"
++ " https://github.com/lspitzner/brittany/issues"
]
@ -130,16 +147,15 @@ mainCmdParser helpDesc = do
addCmd "license" $ addCmdImpl $ print $ licenseDoc
-- addButcherDebugCommand
reorderStart
printHelp <- addSimpleBoolFlag "h" ["help"] mempty
printHelp <- addSimpleBoolFlag "h" ["help"] mempty
printVersion <- addSimpleBoolFlag "" ["version"] mempty
printLicense <- addSimpleBoolFlag "" ["license"] mempty
noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty
configPaths <- addFlagStringParams
""
["config-file"]
"PATH"
(flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?
cmdlineConfig <- cmdlineConfigParser
configPaths <- addFlagStringParams ""
["config-file"]
"PATH"
(flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?
cmdlineConfig <- cmdlineConfigParser
suppressOutput <- addSimpleBoolFlag
""
["suppress-output"]
@ -165,7 +181,7 @@ mainCmdParser helpDesc = do
""
["write-mode"]
"(display|inplace)"
(flagHelp
( flagHelp
(PP.vcat
[ PP.text "display: output for any input(s) goes to stdout"
, PP.text "inplace: override respective input file (without backup!)"
@ -195,13 +211,11 @@ mainCmdParser helpDesc = do
$ ppHelpShallow helpDesc
System.Exit.exitSuccess
let
inputPaths =
if null inputParams then [Nothing] else map Just inputParams
let
outputPaths = case writeMode of
Display -> repeat Nothing
Inplace -> inputPaths
let inputPaths =
if null inputParams then [Nothing] else map Just inputParams
let outputPaths = case writeMode of
Display -> repeat Nothing
Inplace -> inputPaths
configsToLoad <- liftIO $ if null configPaths
then
@ -216,15 +230,14 @@ mainCmdParser helpDesc = do
)
>>= \case
Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53)
Just x -> return x
Just x -> return x
when (config & _conf_debug & _dconf_dump_config & confUnpack)
$ trace (showConfigYaml config)
$ return ()
results <- zipWithM
(coreIO putStrErrLn config suppressOutput checkMode)
inputPaths
outputPaths
results <- zipWithM (coreIO putStrErrLn config suppressOutput checkMode)
inputPaths
outputPaths
if checkMode
then when (Changes `elem` (Data.Either.rights results))
@ -253,65 +266,58 @@ coreIO
-> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status.
coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
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
-- there is a good of code duplication between the following code and the
-- `pureModuleTransform` function. Unfortunately, there are also a good
-- amount of slight differences: This module is a bit more verbose, and
-- it tries to use the full-blown `parseModule` function which supports
-- CPP (but requires the input to be a file..).
let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack
let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack
-- the flag will do the following: insert a marker string
-- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with
-- "#include" before processing (parsing) input; and remove that marker
-- string from the transformation output.
-- The flag is intentionally misspelled to prevent clashing with
-- inline-config stuff.
let
hackAroundIncludes =
config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack
let
exactprintOnly = viaGlobal || viaDebug
where
viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack
viaDebug =
config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack
let hackAroundIncludes =
config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack
let exactprintOnly = viaGlobal || viaDebug
where
viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack
viaDebug =
config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack
let
cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
then case cppMode of
CPPModeAbort -> do
return $ Left "Encountered -XCPP. Aborting."
CPPModeWarn -> do
putErrorLnIO
$ "Warning: Encountered -XCPP."
++ " Be warned that -XCPP is not supported and that"
++ " brittany cannot check that its output is syntactically"
++ " valid in its presence."
return $ Right True
CPPModeNowarn -> return $ Right True
else return $ Right False
let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
then case cppMode of
CPPModeAbort -> do
return $ Left "Encountered -XCPP. Aborting."
CPPModeWarn -> do
putErrorLnIO
$ "Warning: Encountered -XCPP."
++ " Be warned that -XCPP is not supported and that"
++ " brittany cannot check that its output is syntactically"
++ " valid in its presence."
return $ Right True
CPPModeNowarn -> return $ Right True
else return $ Right False
(parseResult, originalContents) <- case inputPathM of
Nothing -> do
-- TODO: refactor this hack to not be mixed into parsing logic
let
hackF s = if "#include" `isPrefixOf` s
then "-- BRITANY_INCLUDE_HACK " ++ s
else s
let
hackTransform = if hackAroundIncludes && not exactprintOnly
then List.intercalate "\n" . fmap hackF . lines'
else id
let hackF s = if "#include" `isPrefixOf` s
then "-- BRITANY_INCLUDE_HACK " ++ s
else s
let hackTransform = if hackAroundIncludes && not exactprintOnly
then List.intercalate "\n" . fmap hackF . lines'
else id
inputString <- liftIO System.IO.getContents
parseRes <- liftIO $ parseModuleFromString
ghcOptions
"stdin"
cppCheckFunc
(hackTransform inputString)
parseRes <- liftIO $ parseModuleFromString ghcOptions
"stdin"
cppCheckFunc
(hackTransform inputString)
return (parseRes, Text.pack inputString)
Just p -> liftIO $ do
parseRes <- parseModule ghcOptions p cppCheckFunc
parseRes <- parseModule ghcOptions p cppCheckFunc
inputText <- Text.IO.readFile p
-- The above means we read the file twice, but the
-- GHC API does not really expose the source it
@ -340,12 +346,10 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
pure c
let moduleConf = cZipWith fromOptionIdentity config inlineConf
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 ()
let
disableFormatting =
moduleConf & _conf_disable_formatting & confUnpack
let disableFormatting =
moduleConf & _conf_disable_formatting & confUnpack
(errsWarns, outSText, hasChanges) <- do
if
| disableFormatting -> do
@ -354,52 +358,46 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
let r = Text.pack $ ExactPrint.exactPrint parsedSource anns
pure ([], r, r /= originalContents)
| otherwise -> do
let
omitCheck =
moduleConf
& _conf_errorHandling
.> _econf_omit_output_valid_check
.> confUnpack
let omitCheck =
moduleConf
& _conf_errorHandling
.> _econf_omit_output_valid_check
.> confUnpack
(ews, outRaw) <- if hasCPP || omitCheck
then return
$ pPrintModule moduleConf perItemConf anns parsedSource
else liftIO $ pPrintModuleAndCheck
moduleConf
perItemConf
anns
parsedSource
let
hackF s = fromMaybe s $ TextL.stripPrefix
(TextL.pack "-- BRITANY_INCLUDE_HACK ")
s
let
out = TextL.toStrict $ if hackAroundIncludes
then
TextL.intercalate (TextL.pack "\n")
$ hackF
<$> TextL.splitOn (TextL.pack "\n") outRaw
else outRaw
else liftIO $ pPrintModuleAndCheck moduleConf
perItemConf
anns
parsedSource
let hackF s = fromMaybe s $ TextL.stripPrefix
(TextL.pack "-- BRITANY_INCLUDE_HACK ")
s
let out = TextL.toStrict $ if hackAroundIncludes
then
TextL.intercalate (TextL.pack "\n")
$ hackF
<$> TextL.splitOn (TextL.pack "\n") outRaw
else outRaw
out' <- if moduleConf & _conf_obfuscate & confUnpack
then lift $ obfuscate out
else pure out
pure $ (ews, out', out' /= originalContents)
let
customErrOrder ErrorInput{} = 4
customErrOrder LayoutWarning{} = -1 :: Int
customErrOrder ErrorOutputCheck{} = 1
customErrOrder ErrorUnusedComment{} = 2
customErrOrder ErrorUnknownNode{} = -2 :: Int
customErrOrder ErrorMacroConfig{} = 5
let customErrOrder ErrorInput{} = 4
customErrOrder LayoutWarning{} = -1 :: Int
customErrOrder ErrorOutputCheck{} = 1
customErrOrder ErrorUnusedComment{} = 2
customErrOrder ErrorUnknownNode{} = -2 :: Int
customErrOrder ErrorMacroConfig{} = 5
unless (null errsWarns) $ do
let
groupedErrsWarns =
Data.List.Extra.groupOn customErrOrder
$ List.sortOn customErrOrder
$ errsWarns
let groupedErrsWarns =
Data.List.Extra.groupOn customErrOrder
$ List.sortOn customErrOrder
$ errsWarns
groupedErrsWarns `forM_` \case
(ErrorOutputCheck{} : _) -> do
putErrorLn
$ "ERROR: brittany pretty printer"
$ "ERROR: brittany pretty printer"
++ " returned syntactically invalid result."
(ErrorInput str : _) -> do
putErrorLn $ "ERROR: parse error: " ++ str
@ -408,10 +406,9 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
$ "WARNING: encountered unknown syntactical constructs:"
uns `forM_` \case
ErrorUnknownNode str ast@(L loc _) -> do
putErrorLn $ " " <> str <> " at " <> showSDocUnsafe
(ppr loc)
putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc)
when
(config
( config
& _conf_debug
& _dconf_dump_ast_unknown
& confUnpack
@ -425,17 +422,17 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
putErrorLn $ "WARNINGS:"
warns `forM_` \case
LayoutWarning str -> putErrorLn str
_ -> error "cannot happen (TM)"
_ -> error "cannot happen (TM)"
unused@(ErrorUnusedComment{} : _) -> do
putErrorLn
$ "Error: detected unprocessed comments."
$ "Error: detected unprocessed comments."
++ " The transformation output will most likely"
++ " not contain some of the comments"
++ " present in the input haskell source file."
putErrorLn $ "Affected are the following comments:"
unused `forM_` \case
ErrorUnusedComment str -> putErrorLn str
_ -> error "cannot happen (TM)"
_ -> error "cannot happen (TM)"
(ErrorMacroConfig err input : _) -> do
putErrorLn $ "Error: parse error in inline configuration:"
putErrorLn err
@ -446,8 +443,8 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
let
hasErrors =
if config & _conf_errorHandling & _econf_Werror & confUnpack
then not $ null errsWarns
else 0 < maximum (-1 : fmap customErrOrder errsWarns)
then not $ null errsWarns
else 0 < maximum (-1 : fmap customErrOrder errsWarns)
outputOnErrs =
config
& _conf_errorHandling
@ -462,11 +459,10 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
$ addTraceSep (_conf_debug config)
$ case outputPathM of
Nothing -> liftIO $ Text.IO.putStr $ outSText
Just p -> liftIO $ do
let
isIdentical = case inputPathM of
Nothing -> False
Just _ -> not hasChanges
Just p -> liftIO $ do
let isIdentical = case inputPathM of
Nothing -> False
Just _ -> not hasChanges
unless isIdentical $ Text.IO.writeFile p $ outSText
when (checkMode && hasChanges) $ case inputPathM of
@ -478,15 +474,15 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
where
addTraceSep conf =
if or
[ confUnpack $ _dconf_dump_annotations conf
, confUnpack $ _dconf_dump_ast_unknown conf
, confUnpack $ _dconf_dump_ast_full conf
, confUnpack $ _dconf_dump_bridoc_raw conf
, confUnpack $ _dconf_dump_bridoc_simpl_alt conf
, confUnpack $ _dconf_dump_bridoc_simpl_floating conf
, confUnpack $ _dconf_dump_bridoc_simpl_columns conf
, confUnpack $ _dconf_dump_bridoc_simpl_indent conf
, confUnpack $ _dconf_dump_bridoc_final conf
]
[ confUnpack $ _dconf_dump_annotations conf
, confUnpack $ _dconf_dump_ast_unknown conf
, confUnpack $ _dconf_dump_ast_full conf
, confUnpack $ _dconf_dump_bridoc_raw conf
, confUnpack $ _dconf_dump_bridoc_simpl_alt conf
, confUnpack $ _dconf_dump_bridoc_simpl_floating conf
, confUnpack $ _dconf_dump_bridoc_simpl_columns conf
, confUnpack $ _dconf_dump_bridoc_simpl_indent conf
, confUnpack $ _dconf_dump_bridoc_final conf
]
then trace "----"
else id

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

@ -2,24 +2,35 @@
{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE ScopedTypeVariables #-}
import Data.Coerce (coerce)
import Data.List (groupBy)
import Language.Haskell.Brittany.Internal.Prelude
import qualified Data.Maybe
import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
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 System.FilePath ((</>))
import System.Timeout (timeout)
import Test.Hspec
import qualified Text.Parsec as Parsec
import Text.Parsec.Text (Parser)
import Test.Hspec
import qualified Text.Parsec as Parsec
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 (const Nothing) Just
@ -29,32 +40,32 @@ hush = either (const Nothing) Just
asymptoticPerfTest :: Spec
asymptoticPerfTest = do
it "10 do statements"
$ roundTripEqualWithTimeout 1500000
$ (Text.pack "func = do\n")
$ roundTripEqualWithTimeout 1500000
$ (Text.pack "func = do\n")
<> Text.replicate 10 (Text.pack " statement\n")
it "10 do nestings"
$ roundTripEqualWithTimeout 4000000
$ (Text.pack "func = ")
$ roundTripEqualWithTimeout 4000000
$ (Text.pack "func = ")
<> mconcat
([1 .. 10] <&> \(i :: Int) ->
(Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n")
( [1 .. 10]
<&> \(i :: Int) ->
(Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n")
)
<> Text.replicate 2000 (Text.pack " ")
<> Text.pack "return\n"
<> Text.replicate 2002 (Text.pack " ")
<> Text.pack "()"
it "10 AppOps"
$ roundTripEqualWithTimeout 1000000
$ (Text.pack "func = expr")
$ roundTripEqualWithTimeout 1000000
$ (Text.pack "func = expr")
<> Text.replicate 10 (Text.pack "\n . expr") --TODO
roundTripEqualWithTimeout :: Int -> Text -> Expectation
roundTripEqualWithTimeout time t =
timeout time (action >>= evaluate) >>= (`shouldSatisfy` Data.Maybe.isJust)
timeout time (action >>= evaluate) >>= (`shouldSatisfy`Data.Maybe.isJust)
where
action = fmap
(fmap PPTextWrapper)
(parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t)
action = fmap (fmap PPTextWrapper)
(parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t)
data InputLine
@ -74,11 +85,10 @@ data TestCase = TestCase
main :: IO ()
main = do
files <- System.Directory.listDirectory "data/"
let
blts =
List.sort
$ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x))
$ filter (".blt" `isSuffixOf`) files
let blts =
List.sort
$ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x))
$ filter (".blt" `isSuffixOf`) files
inputs <- blts `forM` \blt -> Text.IO.readFile ("data" </> blt)
let groups = createChunks =<< inputs
inputCtxFree <- Text.IO.readFile "data/30-tests-context-free.blt"
@ -89,17 +99,15 @@ main = do
it "gives properly formatted result for valid input" $ do
let
input = Text.pack $ unlines
[ "func = [00000000000000000000000, 00000000000000000000000, 00000000000000000000000, 00000000000000000000000]"
]
let
expected = Text.pack $ unlines
[ "func ="
, " [ 00000000000000000000000"
, " , 00000000000000000000000"
, " , 00000000000000000000000"
, " , 00000000000000000000000"
, " ]"
]
["func = [00000000000000000000000, 00000000000000000000000, 00000000000000000000000, 00000000000000000000000]"]
let expected = Text.pack $ unlines
[ "func ="
, " [ 00000000000000000000000"
, " , 00000000000000000000000"
, " , 00000000000000000000000"
, " , 00000000000000000000000"
, " ]"
]
output <- liftIO $ parsePrintModule staticDefaultConfig input
hush output `shouldBe` Just expected
groups `forM_` \(groupname, tests) -> do
@ -146,33 +154,30 @@ main = do
testProcessor = \case
HeaderLine n : rest ->
let normalLines = Data.Maybe.mapMaybe extractNormal rest
in
TestCase
{ testName = n
, isPending = any isPendingLine rest
, content = Text.unlines normalLines
}
in TestCase
{ testName = n
, isPending = any isPendingLine rest
, content = Text.unlines normalLines
}
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 _ = Nothing
extractNormal _ = Nothing
isPendingLine PendingLine{} = True
isPendingLine _ = False
isPendingLine _ = False
specialLineParser :: Parser InputLine
specialLineParser = Parsec.choice
[ [ GroupLine $ Text.pack name
| _ <- Parsec.try $ Parsec.string "#group"
, _ <- Parsec.many1 $ Parsec.oneOf " \t"
| _ <- Parsec.try $ Parsec.string "#group"
, _ <- Parsec.many1 $ Parsec.oneOf " \t"
, name <- Parsec.many1 $ Parsec.noneOf "\r\n:"
, _ <- Parsec.eof
, _ <- Parsec.eof
]
, [ HeaderLine $ Text.pack name
| _ <- Parsec.try $ Parsec.string "#test"
, _ <- Parsec.many1 $ Parsec.oneOf " \t"
| _ <- Parsec.try $ Parsec.string "#test"
, _ <- Parsec.many1 $ Parsec.oneOf " \t"
, name <- Parsec.many1 $ Parsec.noneOf "\r\n:"
, _ <- Parsec.eof
, _ <- Parsec.eof
]
, [ PendingLine
| _ <- Parsec.try $ Parsec.string "#pending"
@ -192,17 +197,17 @@ main = do
]
lineMapper :: Text -> InputLine
lineMapper line = case Parsec.runParser specialLineParser () "" line of
Left _e -> NormalLine line
Right l -> l
Left _e -> NormalLine line
Right l -> l
lineIsSpace :: InputLine -> Bool
lineIsSpace CommentLine = True
lineIsSpace _ = False
lineIsSpace _ = False
grouperG :: InputLine -> InputLine -> Bool
grouperG _ GroupLine{} = False
grouperG _ _ = True
grouperG _ _ = True
grouperT :: InputLine -> InputLine -> Bool
grouperT _ HeaderLine{} = False
grouperT _ _ = True
grouperT _ _ = True
--------------------
@ -220,42 +225,43 @@ instance Show PPTextWrapper where
show (PPTextWrapper t) = "\n" ++ Text.unpack t
-- brittany-next-binding --columns 160
-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft }
defaultTestConfig :: Config
defaultTestConfig = Config
{ _conf_version = _conf_version staticDefaultConfig
, _conf_debug = _conf_debug staticDefaultConfig
, _conf_layout = LayoutConfig
{ _lconfig_cols = coerce (80 :: Int)
, _lconfig_indentPolicy = coerce IndentPolicyFree
, _lconfig_indentAmount = coerce (2 :: Int)
, _lconfig_indentWhereSpecial = coerce True
, _lconfig_indentListSpecial = coerce True
, _lconfig_importColumn = coerce (60 :: Int)
, _lconfig_importAsColumn = coerce (60 :: Int)
, _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
, _lconfig_alignmentLimit = coerce (30 :: Int)
{ _conf_version = _conf_version staticDefaultConfig
, _conf_debug = _conf_debug staticDefaultConfig
, _conf_layout = LayoutConfig
{ _lconfig_cols = coerce (80 :: Int)
, _lconfig_indentPolicy = coerce IndentPolicyFree
, _lconfig_indentAmount = coerce (2 :: Int)
, _lconfig_indentWhereSpecial = coerce True
, _lconfig_indentListSpecial = coerce True
, _lconfig_importColumn = coerce (60 :: Int)
, _lconfig_importAsColumn = coerce (60 :: Int)
, _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
, _lconfig_alignmentLimit = coerce (30 :: Int)
, _lconfig_alignmentBreakOnMultiline = coerce True
, _lconfig_hangingTypeSignature = coerce False
, _lconfig_reformatModulePreamble = coerce True
, _lconfig_hangingTypeSignature = coerce False
, _lconfig_reformatModulePreamble = coerce True
, _lconfig_allowSingleLineExportList = coerce True
, _lconfig_allowHangingQuasiQuotes = coerce True
, _lconfig_allowHangingQuasiQuotes = coerce True
, _lconfig_experimentalSemicolonNewlines = coerce False
-- , _lconfig_allowSinglelineRecord = coerce False
}
, _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True }
, _conf_preprocessor = _conf_preprocessor staticDefaultConfig
, _conf_forward = ForwardOptions { _options_ghc = Identity [] }
, _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True }
, _conf_preprocessor = _conf_preprocessor staticDefaultConfig
, _conf_forward = ForwardOptions { _options_ghc = Identity [] }
, _conf_roundtrip_exactprint_only = coerce False
, _conf_disable_formatting = coerce False
, _conf_obfuscate = coerce False
, _conf_disable_formatting = coerce False
, _conf_obfuscate = coerce False
}
contextFreeTestConfig :: Config
contextFreeTestConfig = defaultTestConfig
{ _conf_layout = (_conf_layout defaultTestConfig)
{ _lconfig_indentPolicy = coerce IndentPolicyLeft
, _lconfig_alignmentLimit = coerce (1 :: Int)
, _lconfig_columnAlignMode = coerce ColumnAlignModeDisabled
}
{ _lconfig_indentPolicy = coerce IndentPolicyLeft
, _lconfig_alignmentLimit = coerce (1 :: Int)
, _lconfig_columnAlignMode = coerce ColumnAlignModeDisabled
}
}