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

Apply brittany on parts of its source; Add comments

pull/3/head
Lennart Spitzner 2016-09-03 23:02:32 +02:00
parent 3809ba9ef0
commit b03996e401
14 changed files with 977 additions and 840 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
src-unittests/AsymptoticPerfTests.hs
View File

@ -21,14 +21,23 @@ import TestUtils
asymptoticPerfTest :: Spec asymptoticPerfTest :: Spec
asymptoticPerfTest = do asymptoticPerfTest = do
it "1000 do statements" $ roundTripEqualWithTimeout 1000000 $ it "1000 do statements"
( Text.pack "func = do\n") $ roundTripEqualWithTimeout 1000000
$ (Text.pack "func = do\n")
<> Text.replicate 1000 (Text.pack " statement\n") <> Text.replicate 1000 (Text.pack " statement\n")
it "1000 do nestings" $ roundTripEqualWithTimeout 4000000 $ it "1000 do nestings"
( Text.pack "func = ") $ roundTripEqualWithTimeout 4000000
<> mconcat ([0..999] <&> \(i::Int) -> (Text.replicate (2*i) (Text.pack " ") <> Text.pack "do\n")) $ (Text.pack "func = ")
<> Text.replicate 2000 (Text.pack " ") <> Text.pack "return\n" <> mconcat
<> Text.replicate 2002 (Text.pack " ") <> Text.pack "()" ( [0 .. 999]
it "1000 AppOps" $ roundTripEqualWithTimeout 1000000 $ <&> \(i :: Int) ->
( Text.pack "func = expr") (Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n")
)
<> Text.replicate 2000 (Text.pack " ")
<> Text.pack "return\n"
<> Text.replicate 2002 (Text.pack " ")
<> Text.pack "()"
it "1000 AppOps"
$ roundTripEqualWithTimeout 1000000
$ (Text.pack "func = expr")
<> Text.replicate 200 (Text.pack "\n . expr") --TODO <> Text.replicate 200 (Text.pack "\n . expr") --TODO

4
src-unittests/TestUtils.hs
View File

@ -21,7 +21,9 @@ import Data.Coerce ( coerce )
roundTripEqual :: Text -> Expectation roundTripEqual :: Text -> Expectation
roundTripEqual t = fmap (fmap PPTextWrapper) (parsePrintModule defaultTestConfig "TestFakeFileName.hs" t) roundTripEqual t =
fmap (fmap PPTextWrapper)
(parsePrintModule defaultTestConfig "TestFakeFileName.hs" t)
`shouldReturn` Right (PPTextWrapper t) `shouldReturn` Right (PPTextWrapper t)
roundTripEqualWithTimeout :: Int -> Text -> Expectation roundTripEqualWithTimeout :: Int -> Text -> Expectation

48
src/Language/Haskell/Brittany.hs
View File

@ -59,8 +59,9 @@ pPrintModule
-> GHC.ParsedSource -> GHC.ParsedSource
-> ([LayoutError], TextL.Text) -> ([LayoutError], TextL.Text)
pPrintModule conf anns parsedModule = pPrintModule conf anns parsedModule =
let ((out, errs), debugStrings) let
= runIdentity ((out, errs), debugStrings) =
runIdentity
$ MultiRWSS.runMultiRWSTNil $ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiWriterAW
@ -68,13 +69,18 @@ pPrintModule conf anns parsedModule =
$ MultiRWSS.withMultiReader anns $ MultiRWSS.withMultiReader anns
$ MultiRWSS.withMultiReader conf $ MultiRWSS.withMultiReader conf
$ do $ do
traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations $ annsDoc anns traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations
$ annsDoc anns
ppModule parsedModule ppModule parsedModule
tracer = if Seq.null debugStrings tracer =
then id if Seq.null debugStrings
else trace ("---- DEBUGMESSAGES ---- ") then
id
else
trace ("---- DEBUGMESSAGES ---- ")
. foldr (seq . join trace) id debugStrings . foldr (seq . join trace) id debugStrings
in tracer $ (errs, Text.Builder.toLazyText out) in
tracer $ (errs, Text.Builder.toLazyText out)
-- unless () $ do -- unless () $ do
-- --
-- debugStrings `forM_` \s -> -- debugStrings `forM_` \s ->
@ -101,11 +107,7 @@ pPrintModuleAndCheck conf anns parsedModule = do
-- used for testing mostly, currently. -- used for testing mostly, currently.
parsePrintModule parsePrintModule :: Config -> String -> Text -> IO (Either String Text)
:: Config
-> String
-> Text
-> IO (Either String Text)
parsePrintModule conf filename input = do parsePrintModule conf filename input = do
let inputStr = Text.unpack input let inputStr = Text.unpack input
parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr
@ -116,12 +118,14 @@ parsePrintModule conf filename input = do
return $ if null errs return $ if null errs
then Right $ TextL.toStrict $ ltext then Right $ TextL.toStrict $ ltext
else else
let errStrs = errs <&> \case let
errStrs = errs <&> \case
LayoutErrorUnusedComment str -> str LayoutErrorUnusedComment str -> str
LayoutWarning str -> str LayoutWarning str -> str
LayoutErrorUnknownNode str _ -> str LayoutErrorUnknownNode str _ -> str
LayoutErrorOutputCheck -> "Output is not syntactically valid." LayoutErrorOutputCheck -> "Output is not syntactically valid."
in Left $ "pretty printing error(s):\n" ++ List.unlines errStrs in
Left $ "pretty printing error(s):\n" ++ List.unlines errStrs
-- this approach would for with there was a pure GHC.parseDynamicFilePragma. -- this approach would for with there was a pure GHC.parseDynamicFilePragma.
-- Unfortunately that does not exist yet, so we cannot provide a nominally -- Unfortunately that does not exist yet, so we cannot provide a nominally
@ -166,8 +170,7 @@ ppModule lmod@(L loc m@(HsModule _name _exports _imports decls _ _)) = do
return $ case Map.lookup (ExactPrint.Types.mkAnnKey lmod) anns of return $ case Map.lookup (ExactPrint.Types.mkAnnKey lmod) anns of
Nothing -> (anns, []) Nothing -> (anns, [])
Just mAnn -> Just mAnn ->
let let modAnnsDp = ExactPrint.Types.annsDP mAnn
modAnnsDp = ExactPrint.Types.annsDP mAnn
isWhere (ExactPrint.Types.G AnnWhere) = True isWhere (ExactPrint.Types.G AnnWhere) = True
isWhere _ = False isWhere _ = False
isEof (ExactPrint.Types.G AnnEofPos) = True isEof (ExactPrint.Types.G AnnEofPos) = True
@ -184,9 +187,10 @@ ppModule lmod@(L loc m@(HsModule _name _exports _imports decls _ _)) = do
in (anns', post) in (anns', post)
MultiRWSS.withMultiReader anns' $ processDefault emptyModule MultiRWSS.withMultiReader anns' $ processDefault emptyModule
decls `forM_` ppDecl decls `forM_` ppDecl
let let finalComments = filter ( fst .> \case
finalComments = filter (fst .> \case ExactPrint.Types.AnnComment{} -> True ExactPrint.Types.AnnComment{} -> True
_ -> False) _ -> False
)
post post
post `forM_` \case post `forM_` \case
(ExactPrint.Types.AnnComment (ExactPrint.Types.Comment cmStr _ _), l) -> do (ExactPrint.Types.AnnComment (ExactPrint.Types.Comment cmStr _ _), l) -> do
@ -232,12 +236,12 @@ ppDecl d@(L loc decl) = case decl of
Left ns -> docLines $ return <$> ns Left ns -> docLines $ return <$> ns
Right n -> return n Right n -> return n
layoutBriDoc d briDoc layoutBriDoc d briDoc
_ -> _ -> briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc d
briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc d
_sigHead :: Sig RdrName -> String _sigHead :: Sig RdrName -> String
_sigHead = \case _sigHead = \case
TypeSig names _ -> "TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names) TypeSig names _ ->
"TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names)
_ -> "unknown sig" _ -> "unknown sig"
_bindHead :: HsBind RdrName -> String _bindHead :: HsBind RdrName -> String

92
src/Language/Haskell/Brittany/BriLayouter.hs
View File

@ -66,10 +66,7 @@ import qualified Control.Monad.Trans.Writer.Strict as WriterS
layoutBriDoc :: Data.Data.Data ast layoutBriDoc :: Data.Data.Data ast => ast -> BriDocNumbered -> PPM ()
=> ast
-> BriDocNumbered
-> PPM ()
layoutBriDoc ast briDoc = do layoutBriDoc ast briDoc = do
-- first step: transform the briDoc. -- first step: transform the briDoc.
briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do
@ -79,20 +76,33 @@ layoutBriDoc ast briDoc = do
$ briDoc $ briDoc
-- bridoc transformation: remove alts -- bridoc transformation: remove alts
transformAlts briDoc >>= mSet transformAlts briDoc >>= mSet
mGet >>= traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt . briDocToDoc mGet
>>= traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt
. briDocToDoc
-- bridoc transformation: float stuff in -- bridoc transformation: float stuff in
mGet <&> transformSimplifyFloating >>= mSet mGet <&> transformSimplifyFloating >>= mSet
mGet >>= traceIfDumpConf "bridoc post-floating" _dconf_dump_bridoc_simpl_floating . briDocToDoc mGet
>>= traceIfDumpConf "bridoc post-floating"
_dconf_dump_bridoc_simpl_floating
. briDocToDoc
-- bridoc transformation: par removal -- bridoc transformation: par removal
mGet <&> transformSimplifyPar >>= mSet mGet <&> transformSimplifyPar >>= mSet
mGet >>= traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par . briDocToDoc mGet
>>= traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par
. briDocToDoc
-- bridoc transformation: float stuff in -- bridoc transformation: float stuff in
mGet <&> transformSimplifyColumns >>= mSet mGet <&> transformSimplifyColumns >>= mSet
mGet >>= traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns . briDocToDoc mGet
>>= traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns
. briDocToDoc
-- -- bridoc transformation: indent -- -- bridoc transformation: indent
mGet <&> transformSimplifyIndent >>= mSet mGet <&> transformSimplifyIndent >>= mSet
mGet >>= traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent . briDocToDoc mGet
mGet >>= traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final . briDocToDoc >>= traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent
. briDocToDoc
mGet
>>= traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final
. briDocToDoc
-- -- convert to Simple type -- -- convert to Simple type
-- simpl <- mGet <&> transformToSimple -- simpl <- mGet <&> transformToSimple
-- return simpl -- return simpl
@ -100,7 +110,9 @@ layoutBriDoc ast briDoc = do
anns :: ExactPrint.Types.Anns <- mAsk anns :: ExactPrint.Types.Anns <- mAsk
let filteredAnns = filterAnns ast anns let filteredAnns = filterAnns ast anns
traceIfDumpConf "bridoc annotations filtered/transformed" _dconf_dump_annotations $ annsDoc filteredAnns traceIfDumpConf "bridoc annotations filtered/transformed"
_dconf_dump_annotations
$ annsDoc filteredAnns
let state = LayoutState let state = LayoutState
{ _lstate_baseYs = [0] { _lstate_baseYs = [0]
@ -116,15 +128,17 @@ layoutBriDoc ast briDoc = do
, _lstate_inhibitMTEL = False , _lstate_inhibitMTEL = False
} }
state' <- MultiRWSS.withMultiStateS state state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
$ layoutBriDocM briDoc'
let remainingComments = let
remainingComments =
extractAllComments =<< Map.elems (_lstate_comments state') extractAllComments =<< Map.elems (_lstate_comments state')
remainingComments `forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fst) remainingComments
`forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fst)
return $ () return $ ()
data AltCurPos = AltCurPos data AltCurPos = AltCurPos
{ _acp_line :: Int -- chars in the current line { _acp_line :: Int -- chars in the current line
, _acp_indent :: Int -- current indentation level , _acp_indent :: Int -- current indentation level
@ -159,7 +173,8 @@ mergeLineMode acp s = case (_acp_forceMLFlag acp, s) of
(AltLineModeStateContradiction, _) -> acp (AltLineModeStateContradiction, _) -> acp
(AltLineModeStateNone, x) -> acp { _acp_forceMLFlag = x } (AltLineModeStateNone, x) -> acp { _acp_forceMLFlag = x }
(AltLineModeStateForceSL, AltLineModeStateForceSL) -> acp (AltLineModeStateForceSL, AltLineModeStateForceSL) -> acp
(AltLineModeStateForceML{}, AltLineModeStateForceML{}) -> acp { _acp_forceMLFlag = s } (AltLineModeStateForceML{}, AltLineModeStateForceML{}) ->
acp { _acp_forceMLFlag = s }
_ -> acp { _acp_forceMLFlag = AltLineModeStateContradiction } _ -> acp { _acp_forceMLFlag = AltLineModeStateContradiction }
-- removes any BDAlt's from the BriDoc -- removes any BDAlt's from the BriDoc
@ -170,10 +185,12 @@ transformAlts
) )
=> BriDocNumbered => BriDocNumbered
-> MultiRWSS.MultiRWS r w s BriDoc -> MultiRWSS.MultiRWS r w s BriDoc
transformAlts briDoc transformAlts briDoc =
= MultiRWSS.withMultiStateA MultiRWSS.withMultiStateA (AltCurPos 0 0 0 AltLineModeStateNone)
(AltCurPos 0 0 0 AltLineModeStateNone) $ Memo.startEvalMemoT
$ Memo.startEvalMemoT $ fmap unwrapBriDocNumbered $ rec $ briDoc $ fmap unwrapBriDocNumbered
$ rec
$ briDoc
where where
-- this funtion is exponential by nature and cannot be improved in any -- this funtion is exponential by nature and cannot be improved in any
-- way i can think of, and if tried. (stupid StableNames.) -- way i can think of, and if tried. (stupid StableNames.)
@ -459,7 +476,11 @@ transformAlts briDoc
hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _) hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _)
= line + sameLine <= confUnpack (_lconfig_cols lconf) = line + sameLine <= confUnpack (_lconfig_cols lconf)
getSpacing :: forall m . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) => BriDocNumbered -> m (LineModeValidity VerticalSpacing) getSpacing
:: forall m
. (MonadMultiReader Config m, MonadMultiWriter (Seq String) m)
=> BriDocNumbered
-> m (LineModeValidity VerticalSpacing)
getSpacing !bridoc = rec bridoc getSpacing !bridoc = rec bridoc
where where
rec :: BriDocNumbered -> m (LineModeValidity VerticalSpacing) rec :: BriDocNumbered -> m (LineModeValidity VerticalSpacing)
@ -637,8 +658,12 @@ getSpacing !bridoc = rec bridoc
VerticalSpacingParNone -> 0 VerticalSpacingParNone -> 0
VerticalSpacingParAlways i -> i VerticalSpacingParAlways i -> i
getSpacings :: forall m . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) getSpacings
=> Int -> BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] :: forall m
. (MonadMultiReader Config m, MonadMultiWriter (Seq String) m)
=> Int
-> BriDocNumbered
-> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing]
getSpacings limit bridoc = preFilterLimit <$> rec bridoc getSpacings limit bridoc = preFilterLimit <$> rec bridoc
where where
preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing] preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing]
@ -1081,10 +1106,12 @@ transformSimplifyPar = transformUp $ \case
BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds)) BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds))
BDPar ind1 (BDPar ind2 line p1) p2 -> BDPar ind1 (BDPar ind2 line p1) p2 ->
BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2]) BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2])
BDLines lines | any (\case BDLines{} -> True BDLines lines | any ( \case
BDLines{} -> True
BDEmpty{} -> True BDEmpty{} -> True
_ -> False) lines -> _ -> False
case go lines of )
lines -> case go lines of
[] -> BDEmpty [] -> BDEmpty
[x] -> x [x] -> x
xs -> BDLines xs xs -> BDLines xs
@ -1243,14 +1270,16 @@ transformSimplifyIndent = Uniplate.rewrite $ \case
-- [ BDAddBaseY ind x -- [ BDAddBaseY ind x
-- , BDEnsureIndent ind indented -- , BDEnsureIndent ind indented
-- ] -- ]
BDLines lines | any (\case BDLines{} -> True BDLines lines | any ( \case
BDLines{} -> True
BDEmpty{} -> True BDEmpty{} -> True
_ -> False) lines -> _ -> False
)
lines ->
Just $ BDLines $ filter isNotEmpty $ lines >>= \case Just $ BDLines $ filter isNotEmpty $ lines >>= \case
BDLines l -> l BDLines l -> l
x -> [x] x -> [x]
BDLines [l] -> BDLines [l] -> Just l
Just l
BDAddBaseY i (BDAnnotationPrior k x) -> BDAddBaseY i (BDAnnotationPrior k x) ->
Just $ BDAnnotationPrior k (BDAddBaseY i x) Just $ BDAnnotationPrior k (BDAddBaseY i x)
BDAddBaseY i (BDAnnotationKW k kw x) -> BDAddBaseY i (BDAnnotationKW k kw x) ->
@ -1261,8 +1290,7 @@ transformSimplifyIndent = Uniplate.rewrite $ \case
Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l] Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l]
BDAddBaseY i (BDCols sig l) -> BDAddBaseY i (BDCols sig l) ->
Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l] Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l]
BDAddBaseY _ lit@BDLit{} -> BDAddBaseY _ lit@BDLit{} -> Just lit
Just lit
_ -> Nothing _ -> Nothing

32
src/Language/Haskell/Brittany/Config.hs
View File

@ -73,12 +73,9 @@ import Data.Coerce ( Coercible, coerce )
configParser :: CmdParser Identity out (ConfigF Option) configParser :: CmdParser Identity out (ConfigF Option)
configParser = do configParser = do
-- TODO: why does the default not trigger; ind never should be []!! -- TODO: why does the default not trigger; ind never should be []!!
ind <- addFlagReadParam "" ["indent"] "AMOUNT" ind <- addFlagReadParam "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level")
(flagHelpStr "spaces per indentation level") cols <- addFlagReadParam "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)")
cols <- addFlagReadParam "" ["columns"] "AMOUNT" importCol <- addFlagReadParam "" ["import-col"] "N" (flagHelpStr "column to align import lists at")
(flagHelpStr "target max columns (80 is an old default for this)")
importCol <- addFlagReadParam "" ["import-col"] "N"
(flagHelpStr "column to align import lists at")
dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (commandline + file + defaults)") dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (commandline + file + defaults)")
dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint") dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint")
@ -87,7 +84,9 @@ configParser = do
dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc") 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") 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") 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") 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") 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") 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") dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc")
@ -95,7 +94,14 @@ configParser = do
outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible") 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") wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors")
optionsGhc <- addFlagStringParam "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc. Note that currently these options are applied _after_ the pragmas read in from the input.") optionsGhc <- addFlagStringParam
""
["ghc-options"]
"STRING"
( flagHelp
$ parDoc
"allows to define default language extensions. The parameter is forwarded to ghc. Note that currently these options are applied _after_ the pragmas read in from the input."
)
return $ Config return $ Config
{ _conf_debug = DebugConfig { _conf_debug = DebugConfig
@ -127,16 +133,14 @@ configParser = do
, _econf_CPPMode = mempty , _econf_CPPMode = mempty
} }
, _conf_forward = ForwardOptions , _conf_forward = ForwardOptions
{ _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ]
| not $ null optionsGhc
]
} }
} }
where falseToNothing = Option . Bool.bool Nothing (Just True) where
falseToNothing = Option . Bool.bool Nothing (Just True)
wrapLast :: Option a -> Option (Semigroup.Last a) wrapLast :: Option a -> Option (Semigroup.Last a)
wrapLast = fmap Semigroup.Last wrapLast = fmap Semigroup.Last
optionConcat optionConcat :: (Semigroup.Semigroup (f a), Applicative f) => [a] -> Option (f a)
:: (Semigroup.Semigroup (f a), Applicative f) => [a] -> Option (f a)
optionConcat = mconcat . fmap (pure . pure) optionConcat = mconcat . fmap (pure . pure)
-- configParser :: Parser Config -- configParser :: Parser Config

9
src/Language/Haskell/Brittany/ExactPrintUtils.hs
View File

@ -149,7 +149,8 @@ commentAnnFixTransformGlob ast = do
let priors = ExactPrint.annPriorComments ann1 let priors = ExactPrint.annPriorComments ann1
follows = ExactPrint.annFollowingComments ann1 follows = ExactPrint.annFollowingComments ann1
assocs = ExactPrint.annsDP ann1 assocs = ExactPrint.annsDP ann1
let processCom let
processCom
:: (ExactPrint.Comment, ExactPrint.DeltaPos) :: (ExactPrint.Comment, ExactPrint.DeltaPos)
-> ExactPrint.TransformT Identity Bool -> ExactPrint.TransformT Identity Bool
processCom comPair@(com, _) = processCom comPair@(com, _) =
@ -167,12 +168,14 @@ commentAnnFixTransformGlob ast = do
loc1 = GHC.srcSpanStart annKeyLoc1 loc1 = GHC.srcSpanStart annKeyLoc1
loc2 = GHC.srcSpanStart annKeyLoc2 loc2 = GHC.srcSpanStart annKeyLoc2
move = ExactPrint.modifyAnnsT $ \anns -> move = ExactPrint.modifyAnnsT $ \anns ->
let ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns let
ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns
ann2' = ann2 ann2' = ann2
{ ExactPrint.annFollowingComments = { 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. _ -> return True -- retain comment at current node.
priors' <- flip filterM priors processCom priors' <- flip filterM priors processCom
follows' <- flip filterM follows $ processCom follows' <- flip filterM follows $ processCom

230
src/Language/Haskell/Brittany/LayoutBasics.hs
View File

@ -135,9 +135,11 @@ traceLocal x = do
traceLocal _ = return () traceLocal _ = return ()
#endif #endif
processDefault :: (ExactPrint.Annotate.Annotate ast, MonadMultiWriter processDefault
Text.Builder.Builder m, :: ( ExactPrint.Annotate.Annotate ast
MonadMultiReader ExactPrint.Types.Anns m) , MonadMultiWriter Text.Builder.Builder m
, MonadMultiReader ExactPrint.Types.Anns m
)
=> GenLocated SrcSpan ast => GenLocated SrcSpan ast
-> m () -> m ()
processDefault x = do processDefault x = do
@ -152,36 +154,47 @@ processDefault x = do
"\n" -> return () "\n" -> return ()
_ -> mTell $ Text.Builder.fromString $ str _ -> mTell $ Text.Builder.fromString $ str
briDocByExact :: (ExactPrint.Annotate.Annotate ast) => GenLocated SrcSpan ast -> ToBriDocM BriDocNumbered -- | 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
-- not handled by brittany yet). Useful when starting implementing new
-- syntactic constructs when children are not handled yet.
briDocByExact
:: (ExactPrint.Annotate.Annotate ast)
=> GenLocated SrcSpan ast
-> ToBriDocM BriDocNumbered
briDocByExact ast = do briDocByExact ast = do
anns <- mAsk anns <- mAsk
traceIfDumpConf "ast" _dconf_dump_ast_unknown traceIfDumpConf "ast"
_dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast) (printTreeWithCustom 100 (customLayouterF anns) ast)
docExt ast anns True docExt ast anns True
briDocByExactNoComment :: (ExactPrint.Annotate.Annotate ast) => GenLocated SrcSpan ast -> ToBriDocM BriDocNumbered -- | Use ExactPrint's output for this node.
briDocByExactNoComment
:: (ExactPrint.Annotate.Annotate ast)
=> GenLocated SrcSpan ast
-> ToBriDocM BriDocNumbered
briDocByExactNoComment ast = do briDocByExactNoComment ast = do
anns <- mAsk anns <- mAsk
traceIfDumpConf "ast" _dconf_dump_ast_unknown traceIfDumpConf "ast"
_dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast) (printTreeWithCustom 100 (customLayouterF anns) ast)
docExt ast anns False docExt ast anns False
rdrNameToText :: RdrName -> Text rdrNameToText :: RdrName -> Text
-- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr -- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr
rdrNameToText (Unqual occname) = Text.pack $ occNameString occname rdrNameToText (Unqual occname) = Text.pack $ occNameString occname
rdrNameToText ( Qual mname occname ) = Text.pack $ moduleNameString mname rdrNameToText (Qual mname occname) =
++ "." Text.pack $ moduleNameString mname ++ "." ++ occNameString occname
++ occNameString occname rdrNameToText (Orig modul occname) =
rdrNameToText ( Orig modul occname ) = Text.pack $ moduleNameString (moduleName modul) Text.pack $ moduleNameString (moduleName modul) ++ occNameString occname
++ occNameString occname
rdrNameToText (Exact name) = Text.pack $ getOccString name rdrNameToText (Exact name) = Text.pack $ getOccString name
lrdrNameToText :: GenLocated l RdrName -> Text lrdrNameToText :: GenLocated l RdrName -> Text
lrdrNameToText (L _ n) = rdrNameToText n lrdrNameToText (L _ n) = rdrNameToText n
lrdrNameToTextAnn :: ( MonadMultiReader Config m lrdrNameToTextAnn
, MonadMultiReader (Map AnnKey Annotation) m :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
)
=> GenLocated SrcSpan RdrName => GenLocated SrcSpan RdrName
-> m Text -> m Text
lrdrNameToTextAnn ast@(L _ n) = do lrdrNameToTextAnn ast@(L _ n) = do
@ -215,10 +228,11 @@ lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
askIndent :: (MonadMultiReader Config m) => m Int askIndent :: (MonadMultiReader Config m) => m Int
askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk
layoutWriteAppend :: (MonadMultiWriter layoutWriteAppend
Text.Builder.Builder m, :: ( MonadMultiWriter Text.Builder.Builder m
MonadMultiState LayoutState m , MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m) , MonadMultiWriter (Seq String) m
)
=> Text => Text
-> m () -> m ()
layoutWriteAppend t = do layoutWriteAppend t = do
@ -250,32 +264,32 @@ layoutWriteAppend t = do
, _lstate_addSepSpace = Nothing , _lstate_addSepSpace = Nothing
} }
layoutWriteAppendSpaces :: (MonadMultiWriter layoutWriteAppendSpaces
Text.Builder.Builder m, :: ( MonadMultiWriter Text.Builder.Builder m
MonadMultiState LayoutState m , MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m) , MonadMultiWriter (Seq String) m
)
=> Int => Int
-> m () -> m ()
layoutWriteAppendSpaces i = do layoutWriteAppendSpaces i = do
traceLocal ("layoutWriteAppendSpaces", i) traceLocal ("layoutWriteAppendSpaces", i)
unless (i == 0) $ do unless (i == 0) $ do
state <- mGet state <- mGet
mSet $ state { _lstate_addSepSpace = Just mSet $ state
$ maybe i (+i) { _lstate_addSepSpace = Just $ maybe i (+i) $ _lstate_addSepSpace state
$ _lstate_addSepSpace state
} }
layoutWriteAppendMultiline :: (MonadMultiWriter layoutWriteAppendMultiline
Text.Builder.Builder m, :: ( MonadMultiWriter Text.Builder.Builder m
MonadMultiState LayoutState m , MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m) , MonadMultiWriter (Seq String) m
)
=> Text => Text
-> m () -> m ()
layoutWriteAppendMultiline t = do layoutWriteAppendMultiline t = do
traceLocal ("layoutWriteAppendMultiline", t) traceLocal ("layoutWriteAppendMultiline", t)
case Text.lines t of case Text.lines t of
[] -> [] -> layoutWriteAppend t -- need to write empty, too.
layoutWriteAppend t -- need to write empty, too.
(l:lr) -> do (l:lr) -> do
layoutWriteAppend l layoutWriteAppend l
lr `forM_` \x -> do lr `forM_` \x -> do
@ -283,10 +297,11 @@ layoutWriteAppendMultiline t = do
layoutWriteAppend x layoutWriteAppend x
-- adds a newline and adds spaces to reach the base column. -- adds a newline and adds spaces to reach the base column.
layoutWriteNewlineBlock :: (MonadMultiWriter layoutWriteNewlineBlock
Text.Builder.Builder m, :: ( MonadMultiWriter Text.Builder.Builder m
MonadMultiState LayoutState m , MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m) , MonadMultiWriter (Seq String) m
)
=> m () => m ()
layoutWriteNewlineBlock = do layoutWriteNewlineBlock = do
traceLocal ("layoutWriteNewlineBlock") traceLocal ("layoutWriteNewlineBlock")
@ -310,9 +325,8 @@ layoutWriteNewlineBlock = do
-- else _lstate_indLevelLinger state + i - _lstate_curY state -- else _lstate_indLevelLinger state + i - _lstate_curY state
-- } -- }
layoutSetCommentCol :: ( MonadMultiState LayoutState m layoutSetCommentCol
, MonadMultiWriter (Seq String) m ) :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
=> m ()
layoutSetCommentCol = do layoutSetCommentCol = do
state <- mGet state <- mGet
let col = case _lstate_curYOrAddNewline state of let col = case _lstate_curYOrAddNewline state of
@ -340,9 +354,7 @@ layoutMoveToCommentPos y x = do
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 Right{} -> Right y
, _lstate_addSepSpace = Just $ case _lstate_curYOrAddNewline state of , _lstate_addSepSpace = Just $ case _lstate_curYOrAddNewline state of
Left{} -> if y==0 Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x
then x
else _lstate_indLevelLinger state + x
Right{} -> _lstate_indLevelLinger state + x Right{} -> _lstate_indLevelLinger state + x
} }
else do else do
@ -350,34 +362,36 @@ layoutMoveToCommentPos y x = do
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of { _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 Right{} -> Right y
, _lstate_addSepSpace = Just $ if y==0 , _lstate_addSepSpace = Just
then x $ if y == 0 then x else _lstate_indLevelLinger state + x
else _lstate_indLevelLinger state + x
, _lstate_commentCol = Just $ case _lstate_curYOrAddNewline state of , _lstate_commentCol = Just $ case _lstate_curYOrAddNewline state of
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Right{} -> lstate_baseY state Right{} -> lstate_baseY state
} }
-- | does _not_ add spaces to again reach the current base column. -- | does _not_ add spaces to again reach the current base column.
layoutWriteNewline :: (MonadMultiWriter layoutWriteNewline
Text.Builder.Builder m, :: ( MonadMultiWriter Text.Builder.Builder m
MonadMultiState LayoutState m , MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m) , MonadMultiWriter (Seq String) m
)
=> m () => m ()
layoutWriteNewline = do layoutWriteNewline = do
traceLocal ("layoutWriteNewline") traceLocal ("layoutWriteNewline")
state <- mGet state <- mGet
mSet $ state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of mSet $ state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left{} -> Right 1 Left{} -> Right 1
Right i -> Right (i + 1) Right i -> Right (i + 1)
, _lstate_addSepSpace = Nothing , _lstate_addSepSpace = Nothing
, _lstate_inhibitMTEL = False , _lstate_inhibitMTEL = False
} }
layoutWriteEnsureNewlineBlock :: (MonadMultiWriter layoutWriteEnsureNewlineBlock
Text.Builder.Builder m, :: ( MonadMultiWriter Text.Builder.Builder m
MonadMultiState LayoutState m , MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m) , MonadMultiWriter (Seq String) m
)
=> m () => m ()
layoutWriteEnsureNewlineBlock = do layoutWriteEnsureNewlineBlock = do
traceLocal ("layoutWriteEnsureNewlineBlock") traceLocal ("layoutWriteEnsureNewlineBlock")
@ -391,10 +405,11 @@ layoutWriteEnsureNewlineBlock = do
, _lstate_commentCol = Nothing , _lstate_commentCol = Nothing
} }
layoutWriteEnsureBlock :: (MonadMultiWriter layoutWriteEnsureBlock
Text.Builder.Builder m, :: ( MonadMultiWriter Text.Builder.Builder m
MonadMultiState LayoutState m , MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m) , MonadMultiWriter (Seq String) m
)
=> m () => m ()
layoutWriteEnsureBlock = do layoutWriteEnsureBlock = do
traceLocal ("layoutWriteEnsureBlock") traceLocal ("layoutWriteEnsureBlock")
@ -409,11 +424,13 @@ layoutWriteEnsureBlock = do
when (diff > 0) $ do when (diff > 0) $ do
mSet $ state { _lstate_addSepSpace = Just $ diff } mSet $ state { _lstate_addSepSpace = Just $ diff }
layoutWriteEnsureAbsoluteN :: (MonadMultiWriter layoutWriteEnsureAbsoluteN
Text.Builder.Builder m, :: ( MonadMultiWriter Text.Builder.Builder m
MonadMultiState LayoutState m , MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m) , MonadMultiWriter (Seq String) m
=> Int -> m () )
=> Int
-> m ()
layoutWriteEnsureAbsoluteN n = do layoutWriteEnsureAbsoluteN n = do
state <- mGet state <- mGet
let diff = case _lstate_curYOrAddNewline state of let diff = case _lstate_curYOrAddNewline state of
@ -469,11 +486,12 @@ layoutRemoveIndentLevelLinger = do
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
} }
layoutWithAddBaseCol :: (MonadMultiWriter layoutWithAddBaseCol
Text.Builder.Builder m, :: ( MonadMultiWriter Text.Builder.Builder m
MonadMultiState LayoutState m , MonadMultiState LayoutState m
, MonadMultiReader Config m , MonadMultiReader Config m
, MonadMultiWriter (Seq String) m) , MonadMultiWriter (Seq String) m
)
=> m () => m ()
-> m () -> m ()
layoutWithAddBaseCol m = do layoutWithAddBaseCol m = do
@ -521,10 +539,11 @@ layoutWithAddBaseColNBlock amount m = do
m m
layoutBaseYPopInternal layoutBaseYPopInternal
layoutWithAddBaseColN :: (MonadMultiWriter layoutWithAddBaseColN
Text.Builder.Builder m, :: ( MonadMultiWriter Text.Builder.Builder m
MonadMultiState LayoutState m , MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m) , MonadMultiWriter (Seq String) m
)
=> Int => Int
-> m () -> m ()
-> m () -> m ()
@ -543,7 +562,8 @@ layoutBaseYPushCur = do
traceLocal ("layoutBaseYPushCur") traceLocal ("layoutBaseYPushCur")
state <- mGet state <- mGet
case _lstate_commentCol state of case _lstate_commentCol state of
Nothing -> case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of Nothing ->
case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i , Just j ) -> layoutBaseYPushInternal (i + j) (Left i , Just j ) -> layoutBaseYPushInternal (i + j)
(Left i , Nothing) -> layoutBaseYPushInternal i (Left i , Nothing) -> layoutBaseYPushInternal i
(Right{}, _ ) -> layoutBaseYPushInternal $ lstate_baseY state (Right{}, _ ) -> layoutBaseYPushInternal $ lstate_baseY state
@ -588,7 +608,8 @@ layoutAddSepSpace = do
tellDebugMessShow ("layoutAddSepSpace") tellDebugMessShow ("layoutAddSepSpace")
#endif #endif
state <- mGet state <- mGet
mSet $ state { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state } mSet $ state
{ _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state }
-- TODO: when refactoring is complete, the other version of this method -- TODO: when refactoring is complete, the other version of this method
-- can probably be removed. -- can probably be removed.
@ -616,7 +637,10 @@ moveToExactAnn annKey = do
in state in state
{ _lstate_curYOrAddNewline = upd { _lstate_curYOrAddNewline = upd
, _lstate_addSepSpace = if Data.Either.isRight upd , _lstate_addSepSpace = if Data.Either.isRight upd
then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just (lstate_baseY state) then
_lstate_commentCol state
<|> _lstate_addSepSpace state
<|> Just (lstate_baseY state)
else Nothing else Nothing
, _lstate_commentCol = Nothing , _lstate_commentCol = Nothing
} }
@ -628,18 +652,22 @@ moveToExactAnn annKey = do
-- then x-1 -- then x-1
-- else x -- else x
ppmMoveToExactLoc :: MonadMultiWriter Text.Builder.Builder m ppmMoveToExactLoc
:: MonadMultiWriter Text.Builder.Builder m
=> ExactPrint.Types.DeltaPos => ExactPrint.Types.DeltaPos
-> m () -> m ()
ppmMoveToExactLoc (ExactPrint.Types.DP (x, y)) = do ppmMoveToExactLoc (ExactPrint.Types.DP (x, y)) = do
replicateM_ x $ mTell $ Text.Builder.fromString "\n" replicateM_ x $ mTell $ Text.Builder.fromString "\n"
replicateM_ y $ mTell $ Text.Builder.fromString " " replicateM_ y $ mTell $ Text.Builder.fromString " "
layoutWritePriorComments :: (Data.Data.Data ast, layoutWritePriorComments
MonadMultiWriter Text.Builder.Builder m, :: ( Data.Data.Data ast
MonadMultiState LayoutState m , MonadMultiWriter Text.Builder.Builder m
, MonadMultiWriter (Seq String) m) , MonadMultiState LayoutState m
=> GenLocated SrcSpan ast -> m () , MonadMultiWriter (Seq String) m
)
=> GenLocated SrcSpan ast
-> m ()
layoutWritePriorComments ast = do layoutWritePriorComments ast = do
mAnn <- do mAnn <- do
state <- mGet state <- mGet
@ -749,13 +777,10 @@ extractAllComments ann =
) )
foldedAnnKeys :: Data.Data.Data ast foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey
=> ast
-> Set ExactPrint.AnnKey
foldedAnnKeys ast = everything foldedAnnKeys ast = everything
Set.union Set.union
(\x -> maybe ( \x -> maybe Set.empty
Set.empty
Set.singleton Set.singleton
[ gmapQi 1 (\t -> ExactPrint.mkAnnKey $ L l t) x [ gmapQi 1 (\t -> ExactPrint.mkAnnKey $ L l t) x
| locTyCon == typeRepTyCon (typeOf x) | locTyCon == typeRepTyCon (typeOf x)
@ -766,26 +791,23 @@ foldedAnnKeys ast = everything
where where
locTyCon = typeRepTyCon (typeOf (L () ())) locTyCon = typeRepTyCon (typeOf (L () ()))
filterAnns :: Data.Data.Data ast filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns
=> ast
-> ExactPrint.Anns
-> ExactPrint.Anns
filterAnns ast anns = filterAnns ast anns =
Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) anns Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) anns
hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool
hasAnyCommentsBelow ast@(L l _) = do hasAnyCommentsBelow ast@(L l _) = do
anns <- filterAnns ast <$> mAsk anns <- filterAnns ast <$> mAsk
return $ List.any (\(c, _) -> ExactPrint.commentIdentifier c > l) return
$ List.any (\(c, _) -> ExactPrint.commentIdentifier c > l)
$ (=<<) extractAllComments $ (=<<) extractAllComments
$ Map.elems $ Map.elems
$ anns $ anns
-- new BriDoc stuff -- new BriDoc stuff
allocateNode :: MonadMultiState NodeAllocIndex m allocateNode
=> BriDocFInt :: MonadMultiState NodeAllocIndex m => BriDocFInt -> m BriDocNumbered
-> m BriDocNumbered
allocateNode bd = do allocateNode bd = do
i <- allocNodeIndex i <- allocNodeIndex
return (i, bd) return (i, bd)
@ -901,8 +923,12 @@ docEmpty = allocateNode BDFEmpty
docLit :: Text -> ToBriDocM BriDocNumbered docLit :: Text -> ToBriDocM BriDocNumbered
docLit t = allocateNode $ BDFLit t docLit t = allocateNode $ BDFLit t
docExt :: (ExactPrint.Annotate.Annotate ast) docExt
=> GenLocated SrcSpan ast -> ExactPrint.Types.Anns -> Bool -> ToBriDocM BriDocNumbered :: (ExactPrint.Annotate.Annotate ast)
=> GenLocated SrcSpan ast
-> ExactPrint.Types.Anns
-> Bool
-> ToBriDocM BriDocNumbered
docExt x anns shouldAddComment = allocateNode $ BDFExternal docExt x anns shouldAddComment = allocateNode $ BDFExternal
(ExactPrint.Types.mkAnnKey x) (ExactPrint.Types.mkAnnKey x)
(foldedAnnKeys x) (foldedAnnKeys x)
@ -955,7 +981,10 @@ docAnnotationPrior
docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm
docAnnotationKW docAnnotationKW
:: AnnKey -> Maybe AnnKeywordId -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered :: AnnKey
-> Maybe AnnKeywordId
-> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm
docAnnotationRest docAnnotationRest
@ -1110,7 +1139,8 @@ instance DocWrapable ([BriDocNumbered], BriDocNumbered, a) where
docPar :: ToBriDocM BriDocNumbered docPar
:: ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docPar lineM indentedM = do docPar lineM indentedM = do
@ -1124,7 +1154,8 @@ docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm
docForceMultiline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docForceMultiline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm
docEnsureIndent :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docEnsureIndent
:: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd
unknownNodeError unknownNodeError
@ -1140,7 +1171,8 @@ spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds]
briDocMToPPM :: ToBriDocM a -> PPM a briDocMToPPM :: ToBriDocM a -> PPM a
briDocMToPPM m = do briDocMToPPM m = do
readers <- MultiRWSS.mGetRawR readers <- MultiRWSS.mGetRawR
let ((x, errs), debugs) = runIdentity let ((x, errs), debugs) =
runIdentity
$ MultiRWSS.runMultiRWSTNil $ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiStateA (NodeAllocIndex 1) $ MultiRWSS.withMultiStateA (NodeAllocIndex 1)
$ MultiRWSS.withMultiReaders readers $ MultiRWSS.withMultiReaders readers

233
src/Language/Haskell/Brittany/Layouters/Decl.hs
View File

@ -43,18 +43,18 @@ layoutSig lsig@(L _loc sig) = case sig of
let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs
typeDoc <- docSharedWrapper layoutType typ typeDoc <- docSharedWrapper layoutType typ
hasComments <- hasAnyCommentsBelow lsig hasComments <- hasAnyCommentsBelow lsig
docAlt $ docAlt
[ docSeq $ [ docSeq
[ appSep $ docWrapNodeRest lsig $ docLit nameStr [ appSep $ docWrapNodeRest lsig $ docLit nameStr
, appSep $ docLit $ Text.pack "::" , appSep $ docLit $ Text.pack "::"
, docForceSingleline typeDoc , docForceSingleline typeDoc
] ]
| not hasComments | not hasComments
] ++ ]
[ docAddBaseY BrIndentRegular ++ [ docAddBaseY BrIndentRegular $ docPar
$ docPar
(docWrapNodeRest lsig $ docLit nameStr) (docWrapNodeRest lsig $ docLit nameStr)
( docCols ColTyOpPrefix ( docCols
ColTyOpPrefix
[ docLit $ Text.pack ":: " [ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 3) $ typeDoc , docAddBaseY (BrIndentSpecial 3) $ typeDoc
] ]
@ -74,19 +74,30 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
] ]
_ -> unknownNodeError "" lgstmt -- TODO _ -> unknownNodeError "" lgstmt -- TODO
layoutBind :: ToBriDocC (HsBindLR RdrName RdrName) (Either [BriDocNumbered] BriDocNumbered) layoutBind
:: ToBriDocC
(HsBindLR RdrName RdrName)
(Either [BriDocNumbered] BriDocNumbered)
layoutBind lbind@(L _ bind) = case bind of layoutBind lbind@(L _ bind) = case bind of
FunBind fId (MG lmatches@(L _ matches) _ _ _) _ _ [] -> do FunBind fId (MG lmatches@(L _ matches) _ _ _) _ _ [] -> do
idStr <- lrdrNameToTextAnn fId idStr <- lrdrNameToTextAnn fId
binderDoc <- docLit $ Text.pack "=" binderDoc <- docLit $ Text.pack "="
funcPatDocs <- docWrapNode lbind $ docWrapNode lmatches $ layoutPatternBind (Just idStr) binderDoc `mapM` matches funcPatDocs <-
docWrapNode lbind
$ docWrapNode lmatches
$ layoutPatternBind (Just idStr) binderDoc
`mapM` matches
return $ Left $ funcPatDocs return $ Left $ funcPatDocs
PatBind pat (GRHSs grhss whereBinds) _ _ ([], []) -> do PatBind pat (GRHSs grhss whereBinds) _ _ ([], []) -> do
patDocs <- colsWrapPat =<< layoutPat pat patDocs <- colsWrapPat =<< layoutPat pat
clauseDocs <- layoutGrhs `mapM` grhss clauseDocs <- layoutGrhs `mapM` grhss
mWhereDocs <- layoutLocalBinds whereBinds mWhereDocs <- layoutLocalBinds whereBinds
binderDoc <- docLit $ Text.pack "=" binderDoc <- docLit $ Text.pack "="
fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing binderDoc (Just patDocs) clauseDocs mWhereDocs fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing
binderDoc
(Just patDocs)
clauseDocs
mWhereDocs
_ -> Right <$> unknownNodeError "" lbind _ -> Right <$> unknownNodeError "" lbind
data BagBindOrSig = BagBind (LHsBindLR RdrName RdrName) data BagBindOrSig = BagBind (LHsBindLR RdrName RdrName)
@ -96,14 +107,18 @@ bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan
bindOrSigtoSrcSpan (BagBind (L l _)) = l bindOrSigtoSrcSpan (BagBind (L l _)) = l
bindOrSigtoSrcSpan (BagSig (L l _)) = l bindOrSigtoSrcSpan (BagSig (L l _)) = l
layoutLocalBinds :: ToBriDocC (HsLocalBindsLR RdrName RdrName) (Maybe [BriDocNumbered]) layoutLocalBinds
:: ToBriDocC (HsLocalBindsLR RdrName RdrName) (Maybe [BriDocNumbered])
layoutLocalBinds lbinds@(L _ binds) = case binds of layoutLocalBinds lbinds@(L _ binds) = case binds of
-- HsValBinds (ValBindsIn lhsBindsLR []) -> -- HsValBinds (ValBindsIn lhsBindsLR []) ->
-- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering -- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering
-- x@(HsValBinds (ValBindsIn{})) -> -- x@(HsValBinds (ValBindsIn{})) ->
-- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x -- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x
HsValBinds (ValBindsIn bindlrs sigs) -> do HsValBinds (ValBindsIn bindlrs sigs) -> do
let unordered = [BagBind b | b <- Data.Foldable.toList bindlrs] ++ [BagSig s | s <- sigs] let
unordered
= [ BagBind b | b <- Data.Foldable.toList bindlrs ]
++ [ BagSig s | s <- sigs ]
ordered = sortBy (comparing bindOrSigtoSrcSpan) unordered ordered = sortBy (comparing bindOrSigtoSrcSpan) unordered
docs <- docWrapNode lbinds $ join <$> ordered `forM` \case docs <- docWrapNode lbinds $ join <$> ordered `forM` \case
BagBind b -> either id return <$> layoutBind b BagBind b -> either id return <$> layoutBind b
@ -112,44 +127,57 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of
x@(HsValBinds (ValBindsOut _binds _lsigs)) -> x@(HsValBinds (ValBindsOut _binds _lsigs)) ->
-- i _think_ this case never occurs in non-processed ast -- i _think_ this case never occurs in non-processed ast
Just . (:[]) <$> unknownNodeError "HsValBinds ValBindsOut{}" x Just . (:[]) <$> unknownNodeError "HsValBinds ValBindsOut{}" x
x@(HsIPBinds _ipBinds) -> x@(HsIPBinds _ipBinds) -> Just . (:[]) <$> unknownNodeError "HsIPBinds" x
Just . (:[]) <$> unknownNodeError "HsIPBinds" x EmptyLocalBinds -> return $ Nothing
EmptyLocalBinds ->
return $ Nothing
-- TODO: we don't need the `LHsExpr RdrName` anymore, now that there is -- TODO: we don't need the `LHsExpr RdrName` anymore, now that there is
-- parSpacing stuff.B -- parSpacing stuff.B
layoutGrhs :: LGRHS RdrName (LHsExpr RdrName) -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr RdrName) layoutGrhs
layoutGrhs lgrhs@(L _ (GRHS guards body)) :: LGRHS RdrName (LHsExpr RdrName)
= do -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr RdrName)
layoutGrhs lgrhs@(L _ (GRHS guards body)) = do
guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards
bodyDoc <- layoutExpr body bodyDoc <- layoutExpr body
return (guardDocs, bodyDoc, body) return (guardDocs, bodyDoc, body)
layoutPatternBind :: Maybe Text -> BriDocNumbered -> LMatch RdrName (LHsExpr RdrName) -> ToBriDocM BriDocNumbered layoutPatternBind
layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhss whereBinds))) :: Maybe Text
= do -> BriDocNumbered
-> LMatch RdrName (LHsExpr RdrName)
-> ToBriDocM BriDocNumbered
layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhss whereBinds))) = do
patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p
let isInfix = isInfixMatch match let isInfix = isInfixMatch match
patDoc <- docWrapNodePrior lmatch $ case (mIdStr, patDocs) of patDoc <- docWrapNodePrior lmatch $ case (mIdStr, patDocs) of
(Just idStr, p1:pr) | isInfix -> docCols ColPatternsFuncInfix (Just idStr, p1:pr) | isInfix -> docCols
( [ appSep $ docForceSingleline p1 ColPatternsFuncInfix
, appSep $ docLit idStr ( [appSep $ docForceSingleline p1, appSep $ docLit idStr]
]
++ (spacifyDocs $ docForceSingleline <$> pr) ++ (spacifyDocs $ docForceSingleline <$> pr)
) )
(Just idStr, [] ) -> docLit idStr (Just idStr, [] ) -> docLit idStr
(Just idStr, ps) -> docCols ColPatternsFuncPrefix (Just idStr, ps) ->
docCols ColPatternsFuncPrefix
$ appSep (docLit $ idStr) $ appSep (docLit $ idStr)
: (spacifyDocs $ docForceSingleline <$> ps) : (spacifyDocs $ docForceSingleline <$> ps)
(Nothing, ps) -> docCols ColPatterns (Nothing, ps) ->
docCols ColPatterns
$ (List.intersperse docSeparator $ docForceSingleline <$> ps) $ (List.intersperse docSeparator $ docForceSingleline <$> ps)
clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss
mWhereDocs <- layoutLocalBinds whereBinds mWhereDocs <- layoutLocalBinds whereBinds
let alignmentToken = if null pats then Nothing else mIdStr let alignmentToken = if null pats then Nothing else mIdStr
layoutPatternBindFinal alignmentToken binderDoc (Just patDoc) clauseDocs mWhereDocs layoutPatternBindFinal alignmentToken
binderDoc
(Just patDoc)
clauseDocs
mWhereDocs
layoutPatternBindFinal :: Maybe Text -> BriDocNumbered -> Maybe BriDocNumbered -> [([BriDocNumbered], BriDocNumbered, LHsExpr RdrName)] -> Maybe [BriDocNumbered] -> ToBriDocM BriDocNumbered layoutPatternBindFinal
:: Maybe Text
-> BriDocNumbered
-> Maybe BriDocNumbered
-> [([BriDocNumbered], BriDocNumbered, LHsExpr RdrName)]
-> Maybe [BriDocNumbered]
-> ToBriDocM BriDocNumbered
layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs = do layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs = do
let patPartInline = case mPatDoc of let patPartInline = case mPatDoc of
Nothing -> [] Nothing -> []
@ -157,7 +185,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs =
patPartParWrap = case mPatDoc of patPartParWrap = case mPatDoc of
Nothing -> id Nothing -> id
Just patDoc -> docPar (return patDoc) Just patDoc -> docPar (return patDoc)
whereIndent <- mAsk whereIndent <-
mAsk
<&> _conf_layout <&> _conf_layout
.> _lconfig_indentWhereSpecial .> _lconfig_indentWhereSpecial
.> confUnpack .> confUnpack
@ -166,7 +195,10 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs =
-- be shared between alternatives. -- be shared between alternatives.
wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of
Nothing -> return $ [] Nothing -> return $ []
Just ws -> fmap (fmap return) $ sequence $ return @[] Just ws ->
fmap (fmap return)
$ sequence
$ return @[]
$ docEnsureIndent whereIndent $ docEnsureIndent whereIndent
$ docLines $ docLines
[ docLit $ Text.pack "where" [ docLit $ Text.pack "where"
@ -174,13 +206,14 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs =
$ docSetIndentLevel $ docSetIndentLevel
$ docNonBottomSpacing $ docNonBottomSpacing
$ docLines $ docLines
$ return <$> ws $ return
<$> ws
] ]
docAlt $ docAlt
-- one-line solution $ -- one-line solution
[ docCols (ColBindingLine alignmentToken) [ docCols
[ docSeq (ColBindingLine alignmentToken)
(patPartInline ++ [guardPart]) [ docSeq (patPartInline ++ [guardPart])
, docSeq , docSeq
[ appSep $ return binderDoc [ appSep $ return binderDoc
, docForceSingleline $ return body , docForceSingleline $ return body
@ -188,10 +221,13 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs =
] ]
] ]
| [(guards, body, _bodyRaw)] <- [clauseDocs] | [(guards, body, _bodyRaw)] <- [clauseDocs]
, let guardPart = case guards of , let
guardPart = case guards of
[] -> docEmpty [] -> docEmpty
[g] -> docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator] [g] ->
gs -> docSeq docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator]
gs ->
docSeq
$ [appSep $ docLit $ Text.pack "|"] $ [appSep $ docLit $ Text.pack "|"]
++ List.intersperse docCommaSep (return <$> gs) ++ List.intersperse docCommaSep (return <$> gs)
++ [docSeparator] ++ [docSeparator]
@ -203,103 +239,118 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs =
, docSetIndentLevel $ docForceSingleline $ return w , docSetIndentLevel $ docForceSingleline $ return w
] ]
_ -> [] _ -> []
] ++ ]
-- one-line solution + where in next line(s) ++ -- one-line solution + where in next line(s)
[ docLines [ docLines
$ [ docCols (ColBindingLine alignmentToken) $ [ docCols
[ docSeq (ColBindingLine alignmentToken)
(patPartInline ++ [guardPart]) [ docSeq (patPartInline ++ [guardPart])
, docSeq , docSeq
[ appSep $ return binderDoc [appSep $ return binderDoc, docForceParSpacing $ return body]
, docForceParSpacing $ return body
] ]
] ]
] ++ wherePartMultiLine ++ wherePartMultiLine
| [(guards, body, _bodyRaw)] <- [clauseDocs] | [(guards, body, _bodyRaw)] <- [clauseDocs]
, let guardPart = case guards of , let
guardPart = case guards of
[] -> docEmpty [] -> docEmpty
[g] -> docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator] [g] ->
gs -> docSeq docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator]
gs ->
docSeq
$ [appSep $ docLit $ Text.pack "|"] $ [appSep $ docLit $ Text.pack "|"]
++ List.intersperse docCommaSep (return <$> gs) ++ List.intersperse docCommaSep (return <$> gs)
++ [docSeparator] ++ [docSeparator]
, Data.Maybe.isJust mWhereDocs , Data.Maybe.isJust mWhereDocs
] ++ ]
-- two-line solution + where in next line(s) ++ -- two-line solution + where in next line(s)
[ docLines [ docLines
$ [ docForceSingleline $ [ docForceSingleline
$ docSeq (patPartInline ++ [guardPart, return binderDoc]) $ docSeq (patPartInline ++ [guardPart, return binderDoc])
, docEnsureIndent BrIndentRegular , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body
$ docForceSingleline ]
$ return body ++ wherePartMultiLine
] ++ wherePartMultiLine
| [(guards, body, _bodyRaw)] <- [clauseDocs] | [(guards, body, _bodyRaw)] <- [clauseDocs]
, let guardPart = case guards of , let
guardPart = case guards of
[] -> docEmpty [] -> docEmpty
[g] -> docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator] [g] ->
gs -> docSeq docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator]
gs ->
docSeq
$ [appSep $ docLit $ Text.pack "|"] $ [appSep $ docLit $ Text.pack "|"]
++ List.intersperse docCommaSep (return <$> gs) ++ List.intersperse docCommaSep (return <$> gs)
++ [docSeparator] ++ [docSeparator]
] ++ ]
-- pattern and exactly one clause in single line, body as par; ++ -- pattern and exactly one clause in single line, body as par;
-- where in following lines -- where in following lines
[ docLines [ docLines
$ [ docCols (ColBindingLine alignmentToken) $ [ docCols
[ docSeq (ColBindingLine alignmentToken)
(patPartInline ++ [appSep guardPart]) [ docSeq (patPartInline ++ [appSep guardPart])
, docSeq , docSeq
[ appSep $ return binderDoc [ appSep $ return binderDoc
, docForceParSpacing $ docAddBaseY BrIndentRegular $ return body , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body
]
]
]
-- , lineMod $ docAlt -- , lineMod $ docAlt
-- [ docSetBaseY $ return body -- [ docSetBaseY $ return body
-- , docAddBaseY BrIndentRegular $ return body -- , docAddBaseY BrIndentRegular $ return body
-- ] -- ]
] ++ wherePartMultiLine
]
] ++ wherePartMultiLine
| [(guards, body, _bodyRaw)] <- [clauseDocs] | [(guards, body, _bodyRaw)] <- [clauseDocs]
, let guardPart = case guards of , let
guardPart = case guards of
[] -> docEmpty [] -> docEmpty
[g] -> docSeq [appSep $ docLit $ Text.pack "|", return g] [g] -> docSeq [appSep $ docLit $ Text.pack "|", return g]
gs -> docSeq gs -> docSeq $ [appSep $ docLit $ Text.pack "|"] ++ List.intersperse
$ [appSep $ docLit $ Text.pack "|"] docCommaSep
++ List.intersperse docCommaSep (return <$> gs) (return <$> gs)
] ++ ]
-- pattern and exactly one clause in single line, body in new line. ++ -- pattern and exactly one clause in single line, body in new line.
[ docLines [ docLines
$ [ docSeq (patPartInline ++ [appSep $ guardPart, return binderDoc]) $ [ docSeq (patPartInline ++ [appSep $ guardPart, return binderDoc])
, docEnsureIndent BrIndentRegular , docEnsureIndent BrIndentRegular
$ docNonBottomSpacing $ docNonBottomSpacing
$ (docAddBaseY BrIndentRegular $ return body) $ (docAddBaseY BrIndentRegular $ return body)
] ++ wherePartMultiLine ]
++ wherePartMultiLine
| [(guards, body, _)] <- [clauseDocs] | [(guards, body, _)] <- [clauseDocs]
, let guardPart = case guards of , let
guardPart = case guards of
[] -> docEmpty [] -> docEmpty
[g] -> docSeq [appSep $ docLit $ Text.pack "|", return g] [g] -> docSeq [appSep $ docLit $ Text.pack "|", return g]
gs -> docSeq gs -> docSeq $ [appSep $ docLit $ Text.pack "|"] ++ List.intersperse
$ [appSep $ docLit $ Text.pack "|"] docCommaSep
++ List.intersperse docCommaSep (return <$> gs) (return <$> gs)
] ++ ]
-- conservative approach: everything starts on the left. ++ -- conservative approach: everything starts on the left.
[ docLines $ [ docLines
[ patPartParWrap $ [ patPartParWrap
$ docLines $ docLines
$ fmap (docEnsureIndent BrIndentRegular) $ fmap (docEnsureIndent BrIndentRegular)
$ clauseDocs >>= \(guardDocs, bodyDoc, _) -> $ clauseDocs
>>= \(guardDocs, bodyDoc, _) ->
( case guardDocs of ( case guardDocs of
[] -> [] [] -> []
[g] -> [docSeq [appSep $ docLit $ Text.pack "|", return g]] [g] ->
[docSeq [appSep $ docLit $ Text.pack "|", return g]]
(g1:gr) -> (g1:gr) ->
( docSeq [appSep $ docLit $ Text.pack "|", return g1] ( docSeq [appSep $ docLit $ Text.pack "|", return g1]
: ( gr <&> \g -> : ( gr
docSeq [appSep $ docLit $ Text.pack ",", return g] <&> \g ->
docSeq
[appSep $ docLit $ Text.pack ",", return g]
) )
) )
) ++ )
[docCols ColOpPrefix ++ [ docCols
ColOpPrefix
[ appSep $ return binderDoc [ appSep $ return binderDoc
, docAddBaseY BrIndentRegular $ return bodyDoc] , docAddBaseY BrIndentRegular $ return bodyDoc
] ]
] ++ wherePartMultiLine ]
]
++ wherePartMultiLine
] ]

25
src/Language/Haskell/Brittany/Layouters/Stmt.hs
View File

@ -34,32 +34,32 @@ layoutStmt lstmt@(L _ stmt) = docWrapNode lstmt $ case stmt of
patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat
expDoc <- docSharedWrapper layoutExpr expr expDoc <- docSharedWrapper layoutExpr expr
docAlt docAlt
[ docCols ColBindStmt [ docCols
ColBindStmt
[ appSep patDoc [ appSep patDoc
, docSeq [appSep $ docLit $ Text.pack "<-", docForceParSpacing expDoc] , docSeq [appSep $ docLit $ Text.pack "<-", docForceParSpacing expDoc]
] ]
, docCols ColBindStmt , docCols
ColBindStmt
[ appSep patDoc [ appSep patDoc
, docAddBaseY BrIndentRegular , docAddBaseY BrIndentRegular
$ docPar (docLit $ Text.pack "<-") $ docPar (docLit $ Text.pack "<-") (expDoc)
(expDoc)
] ]
] ]
LetStmt binds -> layoutLocalBinds binds >>= \case LetStmt binds -> layoutLocalBinds binds >>= \case
Nothing -> Nothing -> docLit $ Text.pack "let" -- i just tested
docLit $ Text.pack "let" -- i just tested
-- it, and it is -- it, and it is
-- indeed allowed. -- indeed allowed.
-- heh. -- heh.
Just [] -> Just [] -> docLit $ Text.pack "let" -- this probably never happens
docLit $ Text.pack "let" -- this probably never happens
Just [bindDoc] -> docAlt Just [bindDoc] -> docAlt
[ docCols ColDoLet [ docCols
ColDoLet
[ appSep $ docLit $ Text.pack "let" [ appSep $ docLit $ Text.pack "let"
, docSetBaseAndIndent $ return bindDoc , docSetBaseAndIndent $ return bindDoc
] ]
, docAddBaseY BrIndentRegular $ docPar , docAddBaseY BrIndentRegular
(docLit $ Text.pack "let") $ docPar (docLit $ Text.pack "let")
(docSetBaseAndIndent $ return bindDoc) (docSetBaseAndIndent $ return bindDoc)
] ]
Just bindDocs -> docAlt Just bindDocs -> docAlt
@ -67,8 +67,7 @@ layoutStmt lstmt@(L _ stmt) = docWrapNode lstmt $ case stmt of
[ appSep $ docLit $ Text.pack "let" [ appSep $ docLit $ Text.pack "let"
, docSetBaseAndIndent $ docLines $ return <$> bindDocs , docSetBaseAndIndent $ docLines $ return <$> bindDocs
] ]
, docAddBaseY BrIndentRegular , docAddBaseY BrIndentRegular $ docPar
$ docPar
(docLit $ Text.pack "let") (docLit $ Text.pack "let")
(docSetBaseAndIndent $ docLines $ return <$> bindDocs) (docSetBaseAndIndent $ docLines $ return <$> bindDocs)
] ]

1
src/Language/Haskell/Brittany/Types.hs
View File

@ -350,6 +350,7 @@ unwrapBriDocNumbered tpl = case snd tpl of
where where
rec = unwrapBriDocNumbered rec = unwrapBriDocNumbered
-- this might not work. is not used anywhere either.
briDocSeqSpine :: BriDoc -> () briDocSeqSpine :: BriDoc -> ()
briDocSeqSpine = \case briDocSeqSpine = \case
BDEmpty -> () BDEmpty -> ()

36
src/Language/Haskell/Brittany/Utils.hs
View File

@ -76,13 +76,11 @@ showGhc :: (GHC.Outputable a) => a -> String
showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags
fromMaybeIdentity :: Identity a -> Maybe a -> Identity a fromMaybeIdentity :: Identity a -> Maybe a -> Identity a
fromMaybeIdentity x y = Data.Coerce.coerce fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y
$ fromMaybe (Data.Coerce.coerce x) y
fromOptionIdentity :: Identity a -> Option a -> Identity a fromOptionIdentity :: Identity a -> Option a -> Identity a
fromOptionIdentity x y = Data.Coerce.coerce fromOptionIdentity x y =
$ fromMaybe (Data.Coerce.coerce x) Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) $ getOption y
$ getOption y
-- maximum monoid over N+0 -- maximum monoid over N+0
-- or more than N, because Num is allowed. -- or more than N, because Num is allowed.
@ -101,7 +99,9 @@ data A x = A ShowIsId x deriving Data
customLayouterF :: ExactPrint.Types.Anns -> LayouterF customLayouterF :: ExactPrint.Types.Anns -> LayouterF
customLayouterF anns layoutF = customLayouterF anns layoutF =
DataToLayouter $ f `extQ` showIsId DataToLayouter
$ f
`extQ` showIsId
`extQ` fastString `extQ` fastString
`extQ` bytestring `extQ` bytestring
`extQ` occName `extQ` occName
@ -116,7 +116,9 @@ customLayouterF anns layoutF =
Left True -> PP.parens $ PP.text s Left True -> PP.parens $ PP.text s
Left False -> PP.text s Left False -> PP.text s
Right _ -> PP.text s Right _ -> PP.text s
fastString = simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString -> NodeLayouter fastString =
simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString
-> NodeLayouter
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString
srcSpan :: GHC.SrcSpan -> NodeLayouter srcSpan :: GHC.SrcSpan -> NodeLayouter
@ -127,13 +129,15 @@ customLayouterF anns layoutF =
located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a
where where
annStr = case cast ss of annStr = case cast ss of
Just (s :: GHC.SrcSpan) -> ShowIsId Just (s :: GHC.SrcSpan) ->
$ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns) ShowIsId $ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns)
Nothing -> ShowIsId "nnnnnnnn" Nothing -> ShowIsId "nnnnnnnn"
customLayouterNoAnnsF :: LayouterF customLayouterNoAnnsF :: LayouterF
customLayouterNoAnnsF layoutF = customLayouterNoAnnsF layoutF =
DataToLayouter $ f `extQ` showIsId DataToLayouter
$ f
`extQ` showIsId
`extQ` fastString `extQ` fastString
`extQ` bytestring `extQ` bytestring
`extQ` occName `extQ` occName
@ -148,12 +152,13 @@ customLayouterNoAnnsF layoutF =
Left True -> PP.parens $ PP.text s Left True -> PP.parens $ PP.text s
Left False -> PP.text s Left False -> PP.text s
Right _ -> PP.text s Right _ -> PP.text s
fastString = simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString -> NodeLayouter fastString =
simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString
-> NodeLayouter
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString
srcSpan :: GHC.SrcSpan -> NodeLayouter srcSpan :: GHC.SrcSpan -> NodeLayouter
srcSpan ss = simpleLayouter srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}"
$ "{"++ showSDoc_ (GHC.ppr ss)++"}"
located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter
located (GHC.L _ss a) = runDataToLayouter layoutF a located (GHC.L _ss a) = runDataToLayouter layoutF a
@ -205,9 +210,8 @@ customLayouterNoAnnsF layoutF =
-- : [PP.text "," <+> displayBriDocSimpleTree t | t<-xr] -- : [PP.text "," <+> displayBriDocSimpleTree t | t<-xr]
-- ++ [PP.text "]"] -- ++ [PP.text "]"]
traceIfDumpConf :: (MonadMultiReader traceIfDumpConf
Config m, :: (MonadMultiReader Config m, Show a)
Show a)
=> String => String
-> (DebugConfig -> Identity (Semigroup.Last Bool)) -> (DebugConfig -> Identity (Semigroup.Last Bool))
-> a -> a