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 = do
it "1000 do statements" $ roundTripEqualWithTimeout 1000000 $
( Text.pack "func = do\n")
it "1000 do statements"
$ roundTripEqualWithTimeout 1000000
$ (Text.pack "func = do\n")
<> Text.replicate 1000 (Text.pack " statement\n")
it "1000 do nestings" $ roundTripEqualWithTimeout 4000000 $
( Text.pack "func = ")
<> mconcat ([0..999] <&> \(i::Int) -> (Text.replicate (2*i) (Text.pack " ") <> Text.pack "do\n"))
<> Text.replicate 2000 (Text.pack " ") <> Text.pack "return\n"
<> Text.replicate 2002 (Text.pack " ") <> Text.pack "()"
it "1000 AppOps" $ roundTripEqualWithTimeout 1000000 $
( Text.pack "func = expr")
it "1000 do nestings"
$ roundTripEqualWithTimeout 4000000
$ (Text.pack "func = ")
<> mconcat
( [0 .. 999]
<&> \(i :: Int) ->
(Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n")
)
<> Text.replicate 2000 (Text.pack " ")
<> Text.pack "return\n"
<> Text.replicate 2002 (Text.pack " ")
<> Text.pack "()"
it "1000 AppOps"
$ roundTripEqualWithTimeout 1000000
$ (Text.pack "func = expr")
<> Text.replicate 200 (Text.pack "\n . expr") --TODO

6
src-unittests/TestUtils.hs
View File

@ -21,12 +21,14 @@ import Data.Coerce ( coerce )
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)
roundTripEqualWithTimeout :: Int -> Text -> Expectation
roundTripEqualWithTimeout time t =
timeout time (action >>= evaluate) >>= (`shouldSatisfy` Data.Maybe.isJust)
timeout time (action >>= evaluate) >>= (`shouldSatisfy`Data.Maybe.isJust)
where
action = fmap (fmap PPTextWrapper)
(parsePrintModule defaultTestConfig "TestFakeFileName.hs" t)

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

@ -59,8 +59,9 @@ pPrintModule
-> GHC.ParsedSource
-> ([LayoutError], TextL.Text)
pPrintModule conf anns parsedModule =
let ((out, errs), debugStrings)
= runIdentity
let
((out, errs), debugStrings) =
runIdentity
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterAW
@ -68,13 +69,18 @@ pPrintModule conf anns parsedModule =
$ MultiRWSS.withMultiReader anns
$ MultiRWSS.withMultiReader conf
$ do
traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations $ annsDoc anns
traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations
$ annsDoc anns
ppModule parsedModule
tracer = if Seq.null debugStrings
then id
else trace ("---- DEBUGMESSAGES ---- ")
tracer =
if Seq.null debugStrings
then
id
else
trace ("---- DEBUGMESSAGES ---- ")
. foldr (seq . join trace) id debugStrings
in tracer $ (errs, Text.Builder.toLazyText out)
in
tracer $ (errs, Text.Builder.toLazyText out)
-- unless () $ do
--
-- debugStrings `forM_` \s ->
@ -101,27 +107,25 @@ pPrintModuleAndCheck conf anns parsedModule = do
-- used for testing mostly, currently.
parsePrintModule
:: Config
-> String
-> Text
-> IO (Either String Text)
parsePrintModule :: Config -> String -> Text -> IO (Either String Text)
parsePrintModule conf filename input = do
let inputStr = Text.unpack input
parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr
case parseResult of
Left (_, s) -> return $ Left $ "parsing error: " ++ s
Left (_ , s ) -> return $ Left $ "parsing error: " ++ s
Right (anns, parsedModule) -> do
(errs, ltext) <- pPrintModuleAndCheck conf anns parsedModule
return $ if null errs
then Right $ TextL.toStrict $ ltext
else
let errStrs = errs <&> \case
let
errStrs = errs <&> \case
LayoutErrorUnusedComment str -> str
LayoutWarning str -> str
LayoutErrorUnknownNode str _ -> str
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.
-- 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
Nothing -> (anns, [])
Just mAnn ->
let
modAnnsDp = ExactPrint.Types.annsDP mAnn
let modAnnsDp = ExactPrint.Types.annsDP mAnn
isWhere (ExactPrint.Types.G AnnWhere) = True
isWhere _ = False
isEof (ExactPrint.Types.G AnnEofPos) = True
@ -176,23 +179,24 @@ ppModule lmod@(L loc m@(HsModule _name _exports _imports decls _ _)) = do
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.Types.annsDP = pre }
anns' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' anns
in (anns', post)
MultiRWSS.withMultiReader anns' $ processDefault emptyModule
decls `forM_` ppDecl
let
finalComments = filter (fst .> \case ExactPrint.Types.AnnComment{} -> True
_ -> False)
let finalComments = filter ( fst .> \case
ExactPrint.Types.AnnComment{} -> True
_ -> False
)
post
post `forM_` \case
(ExactPrint.Types.AnnComment (ExactPrint.Types.Comment cmStr _ _), l) -> do
ppmMoveToExactLoc l
mTell $ Text.Builder.fromString cmStr
(ExactPrint.Types.G AnnEofPos, (ExactPrint.Types.DP (eofX,eofY))) ->
(ExactPrint.Types.G AnnEofPos, (ExactPrint.Types.DP (eofX, eofY))) ->
let folder acc (kw, ExactPrint.Types.DP (x, _)) = case kw of
ExactPrint.Types.AnnComment cm
| GHC.RealSrcSpan span <- ExactPrint.Types.commentIdentifier cm
@ -232,12 +236,12 @@ ppDecl d@(L loc decl) = case decl of
Left ns -> docLines $ return <$> ns
Right n -> return n
layoutBriDoc d briDoc
_ ->
briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc d
_ -> briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc d
_sigHead :: Sig RdrName -> String
_sigHead = \case
TypeSig names _ -> "TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names)
TypeSig names _ ->
"TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names)
_ -> "unknown sig"
_bindHead :: HsBind RdrName -> String

96
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
=> ast
-> BriDocNumbered
-> PPM ()
layoutBriDoc :: Data.Data.Data ast => ast -> BriDocNumbered -> PPM ()
layoutBriDoc ast briDoc = do
-- first step: transform the briDoc.
briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do
@ -79,20 +76,33 @@ layoutBriDoc ast briDoc = do
$ briDoc
-- bridoc transformation: remove alts
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
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
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
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
mGet <&> transformSimplifyIndent >>= mSet
mGet >>= traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent . briDocToDoc
mGet >>= traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final . briDocToDoc
mGet
>>= traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent
. briDocToDoc
mGet
>>= traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final
. briDocToDoc
-- -- convert to Simple type
-- simpl <- mGet <&> transformToSimple
-- return simpl
@ -100,7 +110,9 @@ layoutBriDoc ast briDoc = do
anns :: ExactPrint.Types.Anns <- mAsk
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
{ _lstate_baseYs = [0]
@ -116,15 +128,17 @@ layoutBriDoc ast briDoc = do
, _lstate_inhibitMTEL = False
}
state' <- MultiRWSS.withMultiStateS state
$ layoutBriDocM briDoc'
state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
let remainingComments =
let
remainingComments =
extractAllComments =<< Map.elems (_lstate_comments state')
remainingComments `forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fst)
remainingComments
`forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fst)
return $ ()
data AltCurPos = AltCurPos
{ _acp_line :: Int -- chars in the current line
, _acp_indent :: Int -- current indentation level
@ -144,7 +158,7 @@ data AltLineModeState
altLineModeDecay :: AltLineModeState -> AltLineModeState
altLineModeDecay AltLineModeStateNone = AltLineModeStateNone
altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True
altLineModeDecay (AltLineModeStateForceML True) = AltLineModeStateNone
altLineModeDecay (AltLineModeStateForceML True ) = AltLineModeStateNone
altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL
altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction
@ -159,7 +173,8 @@ mergeLineMode acp s = case (_acp_forceMLFlag acp, s) of
(AltLineModeStateContradiction, _) -> acp
(AltLineModeStateNone, x) -> acp { _acp_forceMLFlag = x }
(AltLineModeStateForceSL, AltLineModeStateForceSL) -> acp
(AltLineModeStateForceML{}, AltLineModeStateForceML{}) -> acp { _acp_forceMLFlag = s }
(AltLineModeStateForceML{}, AltLineModeStateForceML{}) ->
acp { _acp_forceMLFlag = s }
_ -> acp { _acp_forceMLFlag = AltLineModeStateContradiction }
-- removes any BDAlt's from the BriDoc
@ -170,10 +185,12 @@ transformAlts
)
=> BriDocNumbered
-> MultiRWSS.MultiRWS r w s BriDoc
transformAlts briDoc
= MultiRWSS.withMultiStateA
(AltCurPos 0 0 0 AltLineModeStateNone)
$ Memo.startEvalMemoT $ fmap unwrapBriDocNumbered $ rec $ briDoc
transformAlts briDoc =
MultiRWSS.withMultiStateA (AltCurPos 0 0 0 AltLineModeStateNone)
$ Memo.startEvalMemoT
$ fmap unwrapBriDocNumbered
$ rec
$ briDoc
where
-- this funtion is exponential by nature and cannot be improved in any
-- way i can think of, and if tried. (stupid StableNames.)
@ -459,7 +476,11 @@ transformAlts briDoc
hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _)
= 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
where
rec :: BriDocNumbered -> m (LineModeValidity VerticalSpacing)
@ -637,8 +658,12 @@ getSpacing !bridoc = rec bridoc
VerticalSpacingParNone -> 0
VerticalSpacingParAlways i -> i
getSpacings :: forall m . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m)
=> Int -> BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing]
getSpacings
:: forall m
. (MonadMultiReader Config m, MonadMultiWriter (Seq String) m)
=> Int
-> BriDocNumbered
-> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing]
getSpacings limit bridoc = preFilterLimit <$> rec bridoc
where
preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing]
@ -1078,13 +1103,15 @@ transformSimplifyPar = transformUp $ \case
-- Just $ BDPar ind1 line (BDLines [p1, p2])
x@(BDPar _ (BDPar _ BDPar{} _) _) -> x
BDPar ind1 (BDPar ind2 line p1) (BDLines indenteds) ->
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 line (BDLines [BDEnsureIndent ind2 p1, p2])
BDLines lines | any (\case BDLines{} -> True
BDLines lines | any ( \case
BDLines{} -> True
BDEmpty{} -> True
_ -> False) lines ->
case go lines of
_ -> False
)
lines -> case go lines of
[] -> BDEmpty
[x] -> x
xs -> BDLines xs
@ -1243,14 +1270,16 @@ transformSimplifyIndent = Uniplate.rewrite $ \case
-- [ BDAddBaseY ind x
-- , BDEnsureIndent ind indented
-- ]
BDLines lines | any (\case BDLines{} -> True
BDLines lines | any ( \case
BDLines{} -> True
BDEmpty{} -> True
_ -> False) lines ->
_ -> False
)
lines ->
Just $ BDLines $ filter isNotEmpty $ lines >>= \case
BDLines l -> l
x -> [x]
BDLines [l] ->
Just l
BDLines [l] -> Just l
BDAddBaseY i (BDAnnotationPrior k x) ->
Just $ BDAnnotationPrior k (BDAddBaseY i 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]
BDAddBaseY i (BDCols sig l) ->
Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l]
BDAddBaseY _ lit@BDLit{} ->
Just lit
BDAddBaseY _ lit@BDLit{} -> Just lit
_ -> 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 = do
-- TODO: why does the default not trigger; ind never should be []!!
ind <- addFlagReadParam "" ["indent"] "AMOUNT"
(flagHelpStr "spaces per indentation level")
cols <- addFlagReadParam "" ["columns"] "AMOUNT"
(flagHelpStr "target max columns (80 is an old default for this)")
importCol <- addFlagReadParam "" ["import-col"] "N"
(flagHelpStr "column to align import lists at")
ind <- addFlagReadParam "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level")
cols <- addFlagReadParam "" ["columns"] "AMOUNT" (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)")
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")
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")
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")
@ -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")
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
{ _conf_debug = DebugConfig
@ -127,16 +133,14 @@ configParser = do
, _econf_CPPMode = mempty
}
, _conf_forward = ForwardOptions
{ _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs
| not $ null optionsGhc
]
{ _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | 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 = fmap Semigroup.Last
optionConcat
:: (Semigroup.Semigroup (f a), Applicative f) => [a] -> Option (f a)
optionConcat :: (Semigroup.Semigroup (f a), Applicative f) => [a] -> Option (f a)
optionConcat = mconcat . fmap (pure . pure)
-- configParser :: Parser Config

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

@ -149,7 +149,8 @@ commentAnnFixTransformGlob ast = do
let priors = ExactPrint.annPriorComments ann1
follows = ExactPrint.annFollowingComments ann1
assocs = ExactPrint.annsDP ann1
let processCom
let
processCom
:: (ExactPrint.Comment, ExactPrint.DeltaPos)
-> ExactPrint.TransformT Identity Bool
processCom comPair@(com, _) =
@ -159,7 +160,7 @@ commentAnnFixTransformGlob ast = do
Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of
(ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") ->
move $> False
(x,y) | x==y -> move $> False
(x, y) | x == y -> move $> False
_ -> return True
where
ExactPrint.AnnKey annKeyLoc1 con1 = annKey1
@ -167,12 +168,14 @@ commentAnnFixTransformGlob ast = do
loc1 = GHC.srcSpanStart annKeyLoc1
loc2 = GHC.srcSpanStart annKeyLoc2
move = ExactPrint.modifyAnnsT $ \anns ->
let ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns
let
ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns
ann2' = ann2
{ ExactPrint.annFollowingComments =
ExactPrint.annFollowingComments ann2 ++ [comPair]
}
in Map.insert annKey2 ann2' anns
in
Map.insert annKey2 ann2' anns
_ -> return True -- retain comment at current node.
priors' <- flip filterM priors processCom
follows' <- flip filterM follows $ processCom

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

@ -135,9 +135,11 @@ traceLocal x = do
traceLocal _ = return ()
#endif
processDefault :: (ExactPrint.Annotate.Annotate ast, MonadMultiWriter
Text.Builder.Builder m,
MonadMultiReader ExactPrint.Types.Anns m)
processDefault
:: ( ExactPrint.Annotate.Annotate ast
, MonadMultiWriter Text.Builder.Builder m
, MonadMultiReader ExactPrint.Types.Anns m
)
=> GenLocated SrcSpan ast
-> m ()
processDefault x = do
@ -152,42 +154,53 @@ processDefault x = do
"\n" -> return ()
_ -> 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
anns <- mAsk
traceIfDumpConf "ast" _dconf_dump_ast_unknown
traceIfDumpConf "ast"
_dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
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
anns <- mAsk
traceIfDumpConf "ast" _dconf_dump_ast_unknown
traceIfDumpConf "ast"
_dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
docExt ast anns False
rdrNameToText :: RdrName -> Text
-- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr
rdrNameToText ( Unqual occname ) = Text.pack $ occNameString occname
rdrNameToText ( Qual mname occname ) = Text.pack $ moduleNameString mname
++ "."
++ occNameString occname
rdrNameToText ( Orig modul occname ) = Text.pack $ moduleNameString (moduleName modul)
++ occNameString occname
rdrNameToText ( Exact name ) = Text.pack $ getOccString name
rdrNameToText (Unqual occname) = Text.pack $ occNameString occname
rdrNameToText (Qual mname occname) =
Text.pack $ moduleNameString mname ++ "." ++ occNameString occname
rdrNameToText (Orig modul occname) =
Text.pack $ moduleNameString (moduleName modul) ++ occNameString occname
rdrNameToText (Exact name) = Text.pack $ getOccString name
lrdrNameToText :: GenLocated l RdrName -> Text
lrdrNameToText (L _ n) = rdrNameToText n
lrdrNameToTextAnn :: ( MonadMultiReader Config m
, MonadMultiReader (Map AnnKey Annotation) m
)
lrdrNameToTextAnn
:: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
=> GenLocated SrcSpan RdrName
-> m Text
lrdrNameToTextAnn ast@(L _ n) = do
anns <- mAsk
let t = rdrNameToText n
let hasUni x (ExactPrint.Types.G y, _) = x==y
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
@ -215,10 +228,11 @@ lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
askIndent :: (MonadMultiReader Config m) => m Int
askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk
layoutWriteAppend :: (MonadMultiWriter
Text.Builder.Builder m,
MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m)
layoutWriteAppend
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Text
-> m ()
layoutWriteAppend t = do
@ -250,32 +264,32 @@ layoutWriteAppend t = do
, _lstate_addSepSpace = Nothing
}
layoutWriteAppendSpaces :: (MonadMultiWriter
Text.Builder.Builder m,
MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m)
layoutWriteAppendSpaces
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Int
-> m ()
layoutWriteAppendSpaces i = do
traceLocal ("layoutWriteAppendSpaces", i)
unless (i==0) $ do
unless (i == 0) $ do
state <- mGet
mSet $ state { _lstate_addSepSpace = Just
$ maybe i (+i)
$ _lstate_addSepSpace state
mSet $ state
{ _lstate_addSepSpace = Just $ maybe i (+i) $ _lstate_addSepSpace state
}
layoutWriteAppendMultiline :: (MonadMultiWriter
Text.Builder.Builder m,
MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m)
layoutWriteAppendMultiline
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Text
-> m ()
layoutWriteAppendMultiline t = do
traceLocal ("layoutWriteAppendMultiline", t)
case Text.lines t of
[] ->
layoutWriteAppend t -- need to write empty, too.
[] -> layoutWriteAppend t -- need to write empty, too.
(l:lr) -> do
layoutWriteAppend l
lr `forM_` \x -> do
@ -283,10 +297,11 @@ layoutWriteAppendMultiline t = do
layoutWriteAppend x
-- adds a newline and adds spaces to reach the base column.
layoutWriteNewlineBlock :: (MonadMultiWriter
Text.Builder.Builder m,
MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m)
layoutWriteNewlineBlock
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> m ()
layoutWriteNewlineBlock = do
traceLocal ("layoutWriteNewlineBlock")
@ -310,9 +325,8 @@ layoutWriteNewlineBlock = do
-- else _lstate_indLevelLinger state + i - _lstate_curY state
-- }
layoutSetCommentCol :: ( MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m )
=> m ()
layoutSetCommentCol
:: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
layoutSetCommentCol = do
state <- mGet
let col = case _lstate_curYOrAddNewline state of
@ -337,47 +351,47 @@ layoutMoveToCommentPos y x = do
then do
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 = Just $ 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 do
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 = Just $ if y==0
then x
else _lstate_indLevelLinger state + x
, _lstate_addSepSpace = Just
$ if y == 0 then x else _lstate_indLevelLinger state + x
, _lstate_commentCol = Just $ case _lstate_curYOrAddNewline state of
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Right{} -> lstate_baseY state
}
-- | does _not_ add spaces to again reach the current base column.
layoutWriteNewline :: (MonadMultiWriter
Text.Builder.Builder m,
MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m)
layoutWriteNewline
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> m ()
layoutWriteNewline = do
traceLocal ("layoutWriteNewline")
state <- mGet
mSet $ state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
mSet $ state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left{} -> Right 1
Right i -> Right (i+1)
Right i -> Right (i + 1)
, _lstate_addSepSpace = Nothing
, _lstate_inhibitMTEL = False
}
layoutWriteEnsureNewlineBlock :: (MonadMultiWriter
Text.Builder.Builder m,
MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m)
layoutWriteEnsureNewlineBlock
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> m ()
layoutWriteEnsureNewlineBlock = do
traceLocal ("layoutWriteEnsureNewlineBlock")
@ -391,36 +405,39 @@ layoutWriteEnsureNewlineBlock = do
, _lstate_commentCol = Nothing
}
layoutWriteEnsureBlock :: (MonadMultiWriter
Text.Builder.Builder m,
MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m)
layoutWriteEnsureBlock
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) 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 }
layoutWriteEnsureAbsoluteN :: (MonadMultiWriter
Text.Builder.Builder m,
MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m)
=> Int -> m ()
layoutWriteEnsureAbsoluteN
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Int
-> m ()
layoutWriteEnsureAbsoluteN n = do
state <- mGet
let diff = case _lstate_curYOrAddNewline state of
Left i -> n-i
Left i -> n - i
Right{} -> n
traceLocal ("layoutWriteEnsureAbsoluteN", n, diff)
when (diff>0) $ do
when (diff > 0) $ do
mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to
-- at least (Just 1), so we won't
-- overwrite any old value in any
@ -469,11 +486,12 @@ layoutRemoveIndentLevelLinger = do
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
}
layoutWithAddBaseCol :: (MonadMultiWriter
Text.Builder.Builder m,
MonadMultiState LayoutState m
,MonadMultiReader Config m
, MonadMultiWriter (Seq String) m)
layoutWithAddBaseCol
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiReader Config m
, MonadMultiWriter (Seq String) m
)
=> m ()
-> m ()
layoutWithAddBaseCol m = do
@ -521,10 +539,11 @@ layoutWithAddBaseColNBlock amount m = do
m
layoutBaseYPopInternal
layoutWithAddBaseColN :: (MonadMultiWriter
Text.Builder.Builder m,
MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m)
layoutWithAddBaseColN
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Int
-> m ()
-> m ()
@ -543,10 +562,11 @@ 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
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
Just cCol -> layoutBaseYPushInternal cCol
layoutBaseYPop
@ -561,9 +581,9 @@ 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
(Left i , Just j ) -> i + j
(Left i , Nothing) -> i
(Right{}, Just j ) -> j
(Right{}, Nothing) -> 0
layoutIndentLevelPushInternal y
layoutBaseYPushInternal y
@ -588,7 +608,8 @@ layoutAddSepSpace = do
tellDebugMessShow ("layoutAddSepSpace")
#endif
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
-- can probably be removed.
@ -611,12 +632,15 @@ moveToExactAnn annKey = do
-- mModify $ \state -> state { _lstate_addNewline = Just x }
mModify $ \state ->
let upd = case _lstate_curYOrAddNewline state of
Left i -> if y==0 then Left i else Right y
Left i -> if y == 0 then Left i else Right y
Right i -> Right $ max y i
in state
{ _lstate_curYOrAddNewline = 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
, _lstate_commentCol = Nothing
}
@ -628,18 +652,22 @@ moveToExactAnn annKey = do
-- then x-1
-- else x
ppmMoveToExactLoc :: MonadMultiWriter Text.Builder.Builder m
ppmMoveToExactLoc
:: MonadMultiWriter Text.Builder.Builder m
=> ExactPrint.Types.DeltaPos
-> m ()
ppmMoveToExactLoc (ExactPrint.Types.DP (x,y)) = do
ppmMoveToExactLoc (ExactPrint.Types.DP (x, y)) = do
replicateM_ x $ mTell $ Text.Builder.fromString "\n"
replicateM_ y $ mTell $ Text.Builder.fromString " "
layoutWritePriorComments :: (Data.Data.Data ast,
MonadMultiWriter Text.Builder.Builder m,
MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m)
=> GenLocated SrcSpan ast -> m ()
layoutWritePriorComments
:: ( Data.Data.Data ast
, MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> GenLocated SrcSpan ast
-> m ()
layoutWritePriorComments ast = do
mAnn <- do
state <- mGet
@ -743,19 +771,16 @@ extractAllComments
extractAllComments ann =
ExactPrint.annPriorComments ann
++ ExactPrint.annFollowingComments ann
++ (ExactPrint.annsDP ann >>= \case
++ ( ExactPrint.annsDP ann >>= \case
(ExactPrint.AnnComment com, dp) -> [(com, dp)]
_ -> []
)
foldedAnnKeys :: Data.Data.Data ast
=> ast
-> Set ExactPrint.AnnKey
foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey
foldedAnnKeys ast = everything
Set.union
(\x -> maybe
Set.empty
( \x -> maybe Set.empty
Set.singleton
[ gmapQi 1 (\t -> ExactPrint.mkAnnKey $ L l t) x
| locTyCon == typeRepTyCon (typeOf x)
@ -766,26 +791,23 @@ foldedAnnKeys ast = everything
where
locTyCon = typeRepTyCon (typeOf (L () ()))
filterAnns :: Data.Data.Data ast
=> ast
-> ExactPrint.Anns
-> ExactPrint.Anns
filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns
filterAnns ast anns =
Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) anns
hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool
hasAnyCommentsBelow ast@(L l _) = do
anns <- filterAnns ast <$> mAsk
return $ List.any (\(c, _) -> ExactPrint.commentIdentifier c > l)
return
$ List.any (\(c, _) -> ExactPrint.commentIdentifier c > l)
$ (=<<) extractAllComments
$ Map.elems
$ anns
-- new BriDoc stuff
allocateNode :: MonadMultiState NodeAllocIndex m
=> BriDocFInt
-> m BriDocNumbered
allocateNode
:: MonadMultiState NodeAllocIndex m => BriDocFInt -> m BriDocNumbered
allocateNode bd = do
i <- allocNodeIndex
return (i, bd)
@ -793,7 +815,7 @@ allocateNode bd = do
allocNodeIndex :: MonadMultiState NodeAllocIndex m => m Int
allocNodeIndex = do
NodeAllocIndex i <- mGet
mSet $ NodeAllocIndex (i+1)
mSet $ NodeAllocIndex (i + 1)
return i
-- docEmpty :: MonadMultiState NodeAllocIndex m => m BriDocNumbered
@ -901,8 +923,12 @@ docEmpty = allocateNode BDFEmpty
docLit :: Text -> ToBriDocM BriDocNumbered
docLit t = allocateNode $ BDFLit t
docExt :: (ExactPrint.Annotate.Annotate ast)
=> GenLocated SrcSpan ast -> ExactPrint.Types.Anns -> Bool -> ToBriDocM BriDocNumbered
docExt
:: (ExactPrint.Annotate.Annotate ast)
=> GenLocated SrcSpan ast
-> ExactPrint.Types.Anns
-> Bool
-> ToBriDocM BriDocNumbered
docExt x anns shouldAddComment = allocateNode $ BDFExternal
(ExactPrint.Types.mkAnnKey x)
(foldedAnnKeys x)
@ -955,7 +981,10 @@ docAnnotationPrior
docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm
docAnnotationKW
:: AnnKey -> Maybe AnnKeywordId -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
:: AnnKey
-> Maybe AnnKeywordId
-> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm
docAnnotationRest
@ -1110,7 +1139,8 @@ instance DocWrapable ([BriDocNumbered], BriDocNumbered, a) where
docPar :: ToBriDocM BriDocNumbered
docPar
:: ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
docPar lineM indentedM = do
@ -1124,7 +1154,8 @@ docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm
docForceMultiline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
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
unknownNodeError
@ -1140,7 +1171,8 @@ spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds]
briDocMToPPM :: ToBriDocM a -> PPM a
briDocMToPPM m = do
readers <- MultiRWSS.mGetRawR
let ((x, errs), debugs) = runIdentity
let ((x, errs), debugs) =
runIdentity
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiStateA (NodeAllocIndex 1)
$ MultiRWSS.withMultiReaders readers

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

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

@ -302,7 +302,7 @@ instance Uniplate.Uniplate BriDoc where
uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd
uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented
uniplate (BDAlt alts) = plate BDAlt ||* alts
uniplate (BDForwardLineMode bd) = plate BDForwardLineMode |* bd
uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd
uniplate x@BDExternal{} = plate x
uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd
uniplate (BDAnnotationKW annKey kw bd) = plate BDAnnotationKW |- annKey |- kw |* bd
@ -350,12 +350,13 @@ unwrapBriDocNumbered tpl = case snd tpl of
where
rec = unwrapBriDocNumbered
-- this might not work. is not used anywhere either.
briDocSeqSpine :: BriDoc -> ()
briDocSeqSpine = \case
BDEmpty -> ()
BDLit _t -> ()
BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list
BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list
BDSeq list -> foldl' ((briDocSeqSpine.) . seq) () list
BDCols _sig list -> foldl' ((briDocSeqSpine.) . seq) () list
BDSeparator -> ()
BDAddBaseY _ind bd -> briDocSeqSpine bd
BDBaseYPushCur bd -> briDocSeqSpine bd

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

@ -76,13 +76,11 @@ showGhc :: (GHC.Outputable a) => a -> String
showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags
fromMaybeIdentity :: Identity a -> Maybe a -> Identity a
fromMaybeIdentity x y = Data.Coerce.coerce
$ fromMaybe (Data.Coerce.coerce x) y
fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y
fromOptionIdentity :: Identity a -> Option a -> Identity a
fromOptionIdentity x y = Data.Coerce.coerce
$ fromMaybe (Data.Coerce.coerce x)
$ getOption y
fromOptionIdentity x y =
Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) $ getOption y
-- maximum monoid over N+0
-- 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 anns layoutF =
DataToLayouter $ f `extQ` showIsId
DataToLayouter
$ f
`extQ` showIsId
`extQ` fastString
`extQ` bytestring
`extQ` occName
@ -116,24 +116,28 @@ customLayouterF anns layoutF =
Left True -> PP.parens $ PP.text s
Left False -> 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
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString
srcSpan :: GHC.SrcSpan -> NodeLayouter
srcSpan ss = simpleLayouter
-- $ "{"++ showSDoc_ (GHC.ppr ss)++"}"
$ "{" ++ showGhc ss ++ "}"
located :: (Data b,Data loc) => GHC.GenLocated loc b -> NodeLayouter
located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter
located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a
where
annStr = case cast ss of
Just (s :: GHC.SrcSpan) -> ShowIsId
$ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns)
Just (s :: GHC.SrcSpan) ->
ShowIsId $ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns)
Nothing -> ShowIsId "nnnnnnnn"
customLayouterNoAnnsF :: LayouterF
customLayouterNoAnnsF layoutF =
DataToLayouter $ f `extQ` showIsId
DataToLayouter
$ f
`extQ` showIsId
`extQ` fastString
`extQ` bytestring
`extQ` occName
@ -148,12 +152,13 @@ customLayouterNoAnnsF layoutF =
Left True -> PP.parens $ PP.text s
Left False -> 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
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString
srcSpan :: GHC.SrcSpan -> NodeLayouter
srcSpan ss = simpleLayouter
$ "{"++ showSDoc_ (GHC.ppr ss)++"}"
srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}"
located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter
located (GHC.L _ss a) = runDataToLayouter layoutF a
@ -205,9 +210,8 @@ customLayouterNoAnnsF layoutF =
-- : [PP.text "," <+> displayBriDocSimpleTree t | t<-xr]
-- ++ [PP.text "]"]
traceIfDumpConf :: (MonadMultiReader
Config m,
Show a)
traceIfDumpConf
:: (MonadMultiReader Config m, Show a)
=> String
-> (DebugConfig -> Identity (Semigroup.Last Bool))
-> a
@ -246,16 +250,16 @@ briDocToDocWithAnns = astToDoc
annsDoc :: ExactPrint.Types.Anns -> PP.Doc
annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show)
breakEither :: (a -> Either b c) -> [a] -> ([b],[c])
breakEither _ [] = ([],[])
breakEither :: (a -> Either b c) -> [a] -> ([b], [c])
breakEither _ [] = ([], [])
breakEither fn (a1:aR) = case fn a1 of
Left b -> (b:bs,cs)
Right c -> (bs,c:cs)
Left b -> (b : bs, cs)
Right c -> (bs, c : cs)
where
(bs,cs) = breakEither fn aR
(bs, cs) = breakEither fn aR
spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])
spanMaybe f (x1:xR) | Just y <- f x1 = (y:ys, xs)
spanMaybe f (x1:xR) | Just y <- f x1 = (y : ys, xs)
where
(ys, xs) = spanMaybe f xR
spanMaybe _ xs = ([], xs)