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

Format Brittany with Brittany #359

Merged
tfausak merged 1 commits from gh-238-format-self into master 2021-11-29 13:14:35 +01:00
Conversation 0 Commits 1 Files Changed 26
26 changed files with 3870 additions and 3677 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -75,35 +75,36 @@ 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"
@ -122,39 +123,44 @@ 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
@ -162,30 +168,31 @@ 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]
@ -195,8 +202,8 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
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 ->
@ -214,7 +221,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]
]
@ -232,70 +239,76 @@ 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
@ -315,26 +328,27 @@ 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 ->
@ -349,15 +363,17 @@ 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)
@ -372,18 +388,19 @@ parsePrintModuleTests conf filename input = do
(const . pure $ Right ())
inputStr
case parseResult of
Left err -> return $ Left err
Left err -> return $ Left 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
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
@ -393,13 +410,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
-- this approach would for if there was a pure GHC.parseDynamicFilePragma.
-- Unfortunately that does not exist yet, so we cannot provide a nominally
@ -454,25 +471,26 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
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 defaultAnns $
Map.findWithDefault Map.empty declAnnKey annMap
let
mBindingConfs =
declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf
filteredAnns <- mAsk <&> \annMap ->
Map.union defaultAnns $ 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
toLocal config' filteredAnns $ do
@ -487,33 +505,34 @@ 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
@ -530,8 +549,9 @@ 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) =
@ -541,23 +561,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
@ -566,7 +586,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
@ -579,7 +599,7 @@ _bindHead :: HsBind GhcPs -> String
_bindHead = \case
FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId)
PatBind _ _pat _ ([], []) -> "PatBind smth"
_ -> "unknown bind"
_ -> "unknown bind"
@ -597,63 +617,67 @@ 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)

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

@ -31,16 +31,20 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
type ColIndex = Int
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
@ -50,20 +54,23 @@ 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
@ -84,10 +91,11 @@ 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
@ -102,36 +110,39 @@ 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
@ -148,9 +159,10 @@ 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
@ -161,8 +173,8 @@ layoutBriDocM = \case
}
return mAnn
case mAnn of
Nothing -> moveToExactLocationAction
Just [] -> moveToExactLocationAction
Nothing -> moveToExactLocationAction
Just [] -> moveToExactLocationAction
Just priors -> do
-- layoutResetSepSpace
priors
@ -170,9 +182,10 @@ 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
@ -184,18 +197,20 @@ 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 })
@ -207,17 +222,19 @@ 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
@ -226,21 +243,26 @@ 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)
@ -248,37 +270,40 @@ 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
@ -289,8 +314,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
@ -301,73 +326,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
-- =========
@ -452,16 +477,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) =
@ -478,40 +503,39 @@ 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) ->
(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)
@ -539,28 +563,27 @@ 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
@ -568,23 +591,22 @@ 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
@ -593,17 +615,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
@ -611,11 +633,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
@ -630,13 +652,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
curX <- do
state <- mGet
-- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state)))
let spaceAdd = fromMaybe 0 $ _lstate_addSepSpace state
@ -648,10 +670,11 @@ 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
@ -662,46 +685,48 @@ 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)

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

@ -22,17 +22,12 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
traceLocal
:: (MonadMultiState LayoutState m)
=> a
-> m ()
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
@ -48,15 +43,13 @@ 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
@ -64,20 +57,18 @@ 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
@ -85,16 +76,15 @@ 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 ()
@ -110,13 +100,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 }
@ -124,9 +114,7 @@ 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
@ -136,38 +124,35 @@ 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 ()
@ -175,77 +160,66 @@ _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 ()
layoutIndentLevelPushInternal :: (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
@ -277,9 +251,7 @@ layoutWithAddBaseColBlock m = do
layoutBaseYPopInternal
layoutWithAddBaseColNBlock
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
=> Int
-> m ()
-> m ()
@ -292,27 +264,23 @@ 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 ()
@ -322,39 +290,36 @@ 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
@ -364,12 +329,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.
@ -384,7 +349,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
@ -393,19 +358,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
@ -415,9 +380,7 @@ 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 " "
@ -433,75 +396,77 @@ 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,

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

@ -27,151 +27,151 @@ import UI.Butcher.Monadic
-- 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 { 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)
@ -218,8 +218,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)
@ -233,11 +233,12 @@ 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 +250,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,8 +262,9 @@ 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

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

@ -23,40 +23,40 @@ 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
@ -141,17 +141,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.
@ -161,21 +161,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
@ -186,10 +186,9 @@ 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

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

@ -29,7 +29,7 @@ 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
@ -104,17 +104,27 @@ 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

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

@ -53,26 +53,30 @@ parseModuleFromString = ParseModule.parseModule
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)
@ -84,31 +88,32 @@ 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
@ -196,29 +201,30 @@ 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 () ()))
@ -227,8 +233,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
@ -238,9 +244,10 @@ 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

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

@ -56,7 +56,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
@ -68,9 +68,10 @@ 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.
@ -84,9 +85,10 @@ 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,24 +101,26 @@ 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
@ -141,20 +145,21 @@ 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)
@ -167,9 +172,10 @@ 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
@ -187,10 +193,11 @@ 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
@ -208,12 +215,11 @@ 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
@ -231,15 +237,16 @@ 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
@ -286,7 +293,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
@ -300,7 +307,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)
@ -449,16 +456,13 @@ 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) =
docAlt $ Writer.execWriter action
runFilteredAlternative (CollectAltM action) = docAlt $ Writer.execWriter action
docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
@ -506,7 +510,8 @@ 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
@ -558,7 +563,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 "#)"]
@ -620,32 +625,26 @@ 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 +654,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 +685,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 +729,7 @@ docPar
-> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
docPar lineM indentedM = do
line <- lineM
line <- lineM
indented <- indentedM
allocateNode $ BDFPar BrIndentNone line indented
@ -767,14 +766,15 @@ 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)

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

@ -27,28 +27,29 @@ 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
@ -56,8 +57,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
@ -69,24 +70,26 @@ 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
@ -94,7 +97,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
]
]
(Just forallDoc, Nothing) -> docLines
[ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc]
[ docSeq
[docLitS "=", docSeparator, docForceSingleline forallDoc]
, docSeq [docLitS ".", docSeparator, rhsDoc]
]
(Nothing, Just rhsContextDoc) -> docSeq
@ -102,12 +106,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
@ -119,12 +123,13 @@ 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
]
@ -132,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
]
@ -162,8 +167,7 @@ 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
@ -184,13 +188,10 @@ 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 +205,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,20 +230,18 @@ 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
@ -251,10 +250,10 @@ 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
@ -263,36 +262,33 @@ derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of
(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
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
, whenMoreThan1Type ")"
, rhsStrategy
]
, 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
@ -302,21 +298,24 @@ 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
@ -326,79 +325,80 @@ 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 "}"
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
]
addAlternative $ docPar
(docLit consNameStr)
(docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines
[ docAlt
[ docCols ColRecDecl
[ appSep (docLitS "{")
, appSep $ docForceSingleline fName1
, 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 $ fType1
, docForceSingleline fType
]
, docSeq
[ docLitS "{"
[ docLitS ","
, docSeparator
, docSetBaseY $ docAddBaseY BrIndentRegular $ docPar
fName1
(docSeq [docLitS "::", docSeparator, fType1])
fName
(docSeq [docLitS "::", docSeparator, fType])
]
]
, 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 "}"
]
)
, docLitS "}"
]
)
InfixCon arg1 arg2 -> docSeq
[ layoutType $ hsScaledThing arg1
, docSeparator
@ -413,10 +413,11 @@ 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
@ -426,12 +427,8 @@ 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
)

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

File diff suppressed because it is too large Load Diff

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

File diff suppressed because it is too large Load Diff

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

@ -35,36 +35,40 @@ 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
@ -73,7 +77,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
@ -90,33 +94,36 @@ 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).
@ -129,21 +136,22 @@ 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"
@ -162,9 +170,10 @@ 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
@ -174,14 +183,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
@ -189,26 +198,27 @@ 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)

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

@ -30,111 +30,128 @@ 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
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]

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

@ -25,7 +25,7 @@ import Language.Haskell.GHC.ExactPrint.Types
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)
@ -36,10 +36,8 @@ 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
@ -49,30 +47,26 @@ layoutModule lmod@(L _ mod') = case mod' of
-- 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]
@ -84,7 +78,7 @@ data CommentedImport
instance Show CommentedImport where
show = \case
EmptyLine -> "EmptyLine"
EmptyLine -> "EmptyLine"
IndependentComment _ -> "IndependentComment"
ImportStatement r ->
"ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
@ -97,8 +91,9 @@ 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]
@ -116,10 +111,11 @@ 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 ->
@ -131,7 +127,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) =
@ -148,8 +144,8 @@ transformToCommentedImport is = do
, convertedIndependentComments
++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine
++ [ ImportStatement ImportStatementRecord
{ commentsBefore = beforeComments
, commentsAfter = accConnectedComm
{ commentsBefore = beforeComments
, commentsAfter = accConnectedComm
, importStatement = decl
}
]
@ -163,14 +159,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 =
@ -180,25 +176,22 @@ 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)

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

@ -31,17 +31,15 @@ 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
@ -67,10 +65,9 @@ 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
@ -83,7 +80,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
@ -96,37 +93,34 @@ 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 "="
@ -134,13 +128,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
@ -180,7 +174,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
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
@ -189,9 +183,7 @@ 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
@ -213,8 +205,5 @@ 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

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

@ -47,12 +47,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
@ -62,9 +62,10 @@ 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,10 +79,11 @@ 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
@ -89,8 +91,9 @@ 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

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

@ -24,76 +24,63 @@ 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
@ -103,75 +90,74 @@ 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
]
, docCols ColTyOpPrefix
[ docLit $ Text.pack "=> "
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc
]
forallDoc
(docLines
[ docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, docAddBaseY (BrIndentSpecial 3) $ contextDoc
]
)
, 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 ")"
]
)
++[ docCols ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, maybeForceML $ return typeDoc
(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
]
]
)
]
HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do
typeDoc <- docSharedWrapper layoutType typ1
@ -182,29 +168,25 @@ 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
@ -216,37 +198,39 @@ 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
docAlt
$ [ docSeq
[ appSep $ docForceSingleline typeDoc1
, appSep $ docLit $ Text.pack "->"
, docForceSingleline typeDoc2
]
| not hasComments
]
| not hasComments
] ++
[ docPar
(docNodeAnnKW ltype Nothing typeDoc1)
( docCols ColTyOpPrefix
[ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->"
, docAddBaseY (BrIndentSpecial 3)
$ maybeForceML typeDoc2
]
)
]
++ [ 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
@ -256,24 +240,28 @@ 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
@ -281,13 +269,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
typeDoc2 <- docSharedWrapper layoutType typ2
docAlt
[ docSeq
[ docForceSingleline typeDoc1
, docSeparator
, docForceSingleline typeDoc2
]
, docPar
typeDoc1
(docEnsureIndent BrIndentRegular typeDoc2)
[docForceSingleline typeDoc1, docSeparator, docForceSingleline typeDoc2]
, docPar typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2)
]
HsListTy _ typ1 -> do
typeDoc1 <- docSharedWrapper layoutType typ1
@ -298,51 +281,61 @@ 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])
@ -411,20 +404,18 @@ 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
@ -465,7 +456,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
@ -536,7 +527,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
@ -561,19 +552,23 @@ 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
@ -584,8 +579,7 @@ 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,14 +592,12 @@ 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

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

@ -18,9 +18,10 @@ 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
@ -72,14 +73,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')

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

@ -27,12 +27,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 (<$!>)
@ -48,10 +48,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

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

File diff suppressed because it is too large Load Diff

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

@ -16,118 +16,147 @@ 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]
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 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 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 sig2 cols2
]
BDLines [x] -> Just $ x
BDLines [] -> Just $ BDEmpty
BDSeq{} -> Nothing
BDCols{} -> Nothing
BDSeparator -> Nothing
BDAddBaseY{} -> Nothing
BDBaseYPushCur{} -> Nothing
BDBaseYPop{} -> Nothing
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

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

@ -14,10 +14,11 @@ import Language.Haskell.Brittany.Internal.Utils
-- 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
@ -27,169 +28,186 @@ 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

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

@ -27,15 +27,17 @@ 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 +51,4 @@ transformSimplifyIndent = Uniplate.rewrite $ \case
Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l]
BDAddBaseY _ lit@BDLit{} -> Just lit
_ -> Nothing
_ -> Nothing

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

@ -21,25 +21,28 @@ 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

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

@ -61,24 +61,26 @@ 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
@ -86,18 +88,22 @@ 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
@ -109,12 +115,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
@ -122,14 +128,15 @@ 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
@ -193,12 +200,11 @@ 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..
@ -213,29 +219,28 @@ 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
@ -245,7 +250,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`
@ -264,7 +269,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

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

@ -105,7 +105,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"
]
@ -142,15 +142,16 @@ 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"]
@ -176,7 +177,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!)"
@ -206,11 +207,12 @@ 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
@ -225,14 +227,15 @@ 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))
@ -268,51 +271,57 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
-- 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
@ -343,8 +352,9 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do
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
@ -353,46 +363,52 @@ 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
@ -403,7 +419,7 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
ErrorUnknownNode str ast@(L loc _) -> do
putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc)
when
( config
(config
& _conf_debug
& _dconf_dump_ast_unknown
& confUnpack
@ -417,17 +433,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
@ -438,8 +454,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
@ -454,10 +470,11 @@ 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
@ -469,15 +486,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