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

4
src-brittany/Main.hs
View File

@ -225,11 +225,11 @@ readConfigs cmdlineConfig configPaths = do
userBritPath <- liftIO $ Directory.getAppUserDataDirectory "brittany" userBritPath <- liftIO $ Directory.getAppUserDataDirectory "brittany"
let defUserConfigPath = userBritPath FilePath.</> "config.yaml" let defUserConfigPath = userBritPath FilePath.</> "config.yaml"
merged <- case configPaths of merged <- case configPaths of
[] -> do [] -> do
liftIO $ Directory.createDirectoryIfMissing False userBritPath liftIO $ Directory.createDirectoryIfMissing False userBritPath
return cmdlineConfig return cmdlineConfig
>>= readMergePersConfig defLocalConfigPath False >>= readMergePersConfig defLocalConfigPath False
>>= readMergePersConfig defUserConfigPath True >>= readMergePersConfig defUserConfigPath True
-- TODO: ensure that paths exist ? -- TODO: ensure that paths exist ?
paths -> foldl (\prev p -> prev >>= readMergePersConfig p False) paths -> foldl (\prev p -> prev >>= readMergePersConfig p False)
(return cmdlineConfig) (return cmdlineConfig)

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

42
src-unittests/TestUtils.hs
View File

@ -21,15 +21,17 @@ 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
roundTripEqualWithTimeout time t = roundTripEqualWithTimeout time t =
timeout time (action >>= evaluate) >>= (`shouldSatisfy` Data.Maybe.isJust) timeout time (action >>= evaluate) >>= (`shouldSatisfy`Data.Maybe.isJust)
where where
action = fmap (fmap PPTextWrapper) action = fmap (fmap PPTextWrapper)
(parsePrintModule defaultTestConfig "TestFakeFileName.hs" t) (parsePrintModule defaultTestConfig "TestFakeFileName.hs" t)
newtype PPTextWrapper = PPTextWrapper Text newtype PPTextWrapper = PPTextWrapper Text
deriving Eq deriving Eq
@ -39,19 +41,19 @@ instance Show PPTextWrapper where
defaultTestConfig :: Config defaultTestConfig :: Config
defaultTestConfig = Config defaultTestConfig = Config
{ _conf_debug = _conf_debug staticDefaultConfig { _conf_debug = _conf_debug staticDefaultConfig
, _conf_layout = LayoutConfig , _conf_layout = LayoutConfig
{ _lconfig_cols = coerce (80 :: Int) { _lconfig_cols = coerce (80 :: Int)
, _lconfig_indentPolicy = coerce IndentPolicyFree , _lconfig_indentPolicy = coerce IndentPolicyFree
, _lconfig_indentAmount = coerce (2 :: Int) , _lconfig_indentAmount = coerce (2 :: Int)
, _lconfig_indentWhereSpecial = coerce True , _lconfig_indentWhereSpecial = coerce True
, _lconfig_indentListSpecial = coerce True , _lconfig_indentListSpecial = coerce True
, _lconfig_importColumn = coerce (60 :: Int) , _lconfig_importColumn = coerce (60 :: Int)
, _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3
, _lconfig_columnAlignMode = coerce ColumnAlignModeUnanimously , _lconfig_columnAlignMode = coerce ColumnAlignModeUnanimously
}
, _conf_errorHandling = _conf_errorHandling staticDefaultConfig
, _conf_forward = ForwardOptions
{ _options_ghc = Identity []
}
} }
, _conf_errorHandling = _conf_errorHandling staticDefaultConfig
, _conf_forward = ForwardOptions
{ _options_ghc = Identity []
}
}

96
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
. foldr (seq . join trace) id debugStrings id
in tracer $ (errs, Text.Builder.toLazyText out) else
trace ("---- DEBUGMESSAGES ---- ")
. foldr (seq . join trace) id debugStrings
in
tracer $ (errs, Text.Builder.toLazyText out)
-- unless () $ do -- unless () $ do
-- --
-- debugStrings `forM_` \s -> -- debugStrings `forM_` \s ->
@ -101,27 +107,25 @@ 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
case parseResult of case parseResult of
Left (_, s) -> return $ Left $ "parsing error: " ++ s Left (_ , s ) -> return $ Left $ "parsing error: " ++ s
Right (anns, parsedModule) -> do Right (anns, parsedModule) -> do
(errs, ltext) <- pPrintModuleAndCheck conf anns parsedModule (errs, ltext) <- pPrintModuleAndCheck conf anns parsedModule
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
LayoutErrorUnusedComment str -> str errStrs = errs <&> \case
LayoutWarning str -> str LayoutErrorUnusedComment str -> str
LayoutErrorUnknownNode str _ -> str LayoutWarning str -> str
LayoutErrorOutputCheck -> "Output is not syntactically valid." LayoutErrorUnknownNode str _ -> str
in Left $ "pretty printing error(s):\n" ++ List.unlines errStrs LayoutErrorOutputCheck -> "Output is not syntactically valid."
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,40 +170,40 @@ 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 isEof _ = False
isEof _ = False whereInd = List.findIndex (isWhere . fst) modAnnsDp
whereInd = List.findIndex (isWhere . fst) modAnnsDp eofInd = List.findIndex (isEof . fst) modAnnsDp
eofInd = List.findIndex (isEof . fst) modAnnsDp (pre, post) = case (whereInd, eofInd) of
(pre, post) = case (whereInd, eofInd) of (Nothing, Nothing) -> ([], modAnnsDp)
(Nothing, Nothing) -> ([], modAnnsDp) (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp
(Just i, Nothing) -> List.splitAt (i+1) modAnnsDp (Nothing, Just _i) -> ([], 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 }
mAnn' = mAnn { ExactPrint.Types.annsDP = pre } anns' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' anns
anns' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' anns 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
ppmMoveToExactLoc l ppmMoveToExactLoc l
mTell $ Text.Builder.fromString cmStr 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 let folder acc (kw, ExactPrint.Types.DP (x, _)) = case kw of
ExactPrint.Types.AnnComment cm ExactPrint.Types.AnnComment cm
| GHC.RealSrcSpan span <- ExactPrint.Types.commentIdentifier cm | GHC.RealSrcSpan span <- ExactPrint.Types.commentIdentifier cm
-> acc + x + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span -> acc + x + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span
_ -> acc + x _ -> acc + x
cmX = foldl' folder 0 finalComments cmX = foldl' folder 0 finalComments
in ppmMoveToExactLoc $ ExactPrint.Types.DP (eofX - cmX, eofY) in ppmMoveToExactLoc $ ExactPrint.Types.DP (eofX - cmX, eofY)
_ -> return () _ -> return ()
withTransformedAnns :: SYB.Data ast => ast -> PPM () -> PPM () withTransformedAnns :: SYB.Data ast => ast -> PPM () -> PPM ()
@ -229,15 +233,15 @@ ppDecl d@(L loc decl) = case decl of
briDoc <- briDocMToPPM $ do briDoc <- briDocMToPPM $ do
eitherNode <- layoutBind (L loc bind) eitherNode <- layoutBind (L loc bind)
case eitherNode of case eitherNode 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

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

@ -66,33 +66,43 @@ 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
traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw
$ briDocToDoc $ briDocToDoc
$ unwrapBriDocNumbered $ unwrapBriDocNumbered
$ 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,31 +110,35 @@ 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]
, _lstate_curYOrAddNewline = Right 0 -- important that we use left here , _lstate_curYOrAddNewline = Right 0 -- important that we use left here
-- because moveToAnn stuff of the -- because moveToAnn stuff of the
-- first node needs to do its -- first node needs to do its
-- thing properly. -- thing properly.
, _lstate_indLevels = [0] , _lstate_indLevels = [0]
, _lstate_indLevelLinger = 0 , _lstate_indLevelLinger = 0
, _lstate_comments = filteredAnns , _lstate_comments = filteredAnns
, _lstate_commentCol = Nothing , _lstate_commentCol = Nothing
, _lstate_addSepSpace = Nothing , _lstate_addSepSpace = Nothing
, _lstate_inhibitMTEL = False , _lstate_inhibitMTEL = False
} }
state' <- MultiRWSS.withMultiStateS state state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
$ layoutBriDocM briDoc'
let remainingComments = let
extractAllComments =<< Map.elems (_lstate_comments state') remainingComments =
remainingComments `forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fst) extractAllComments =<< Map.elems (_lstate_comments state')
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
@ -142,16 +156,16 @@ data AltLineModeState
deriving (Show) deriving (Show)
altLineModeDecay :: AltLineModeState -> AltLineModeState altLineModeDecay :: AltLineModeState -> AltLineModeState
altLineModeDecay AltLineModeStateNone = AltLineModeStateNone altLineModeDecay AltLineModeStateNone = AltLineModeStateNone
altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True
altLineModeDecay (AltLineModeStateForceML True) = AltLineModeStateNone altLineModeDecay (AltLineModeStateForceML True ) = AltLineModeStateNone
altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL
altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction
altLineModeRefresh :: AltLineModeState -> AltLineModeState altLineModeRefresh :: AltLineModeState -> AltLineModeState
altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone
altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False
altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL
altLineModeRefresh AltLineModeStateContradiction = AltLineModeStateContradiction altLineModeRefresh AltLineModeStateContradiction = AltLineModeStateContradiction
mergeLineMode :: AltCurPos -> AltLineModeState -> AltCurPos mergeLineMode :: AltCurPos -> AltLineModeState -> AltCurPos
@ -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]
@ -883,21 +908,21 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- note that this is not total, and cannot be with that exact signature. -- note that this is not total, and cannot be with that exact signature.
mergeIndents :: BrIndent -> BrIndent -> BrIndent mergeIndents :: BrIndent -> BrIndent -> BrIndent
mergeIndents BrIndentNone x = x mergeIndents BrIndentNone x = x
mergeIndents x BrIndentNone = x mergeIndents x BrIndentNone = x
mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j) mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j)
mergeIndents _ _ = error "mergeIndents" mergeIndents _ _ = error "mergeIndents"
-- TODO: move to uniplate upstream? -- TODO: move to uniplate upstream?
-- aka `transform` -- aka `transform`
transformUp :: Uniplate.Uniplate on => (on -> on) -> (on -> on) transformUp :: Uniplate.Uniplate on => (on -> on) -> (on -> on)
transformUp f = g where g = f . Uniplate.descend g transformUp f = g where g = f . Uniplate.descend g
_transformDown :: Uniplate.Uniplate on => (on -> on) -> (on -> on) _transformDown :: Uniplate.Uniplate on => (on -> on) -> (on -> on)
_transformDown f = g where g = Uniplate.descend g . f _transformDown f = g where g = Uniplate.descend g . f
transformDownMay :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) transformDownMay :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on)
transformDownMay f = g where g x = maybe x (Uniplate.descend g) $ f x transformDownMay f = g where g x = maybe x (Uniplate.descend g) $ f x
_transformDownRec :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on) _transformDownRec :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on)
_transformDownRec f = g where g x = maybe (Uniplate.descend g x) g $ f x _transformDownRec f = g where g x = maybe (Uniplate.descend g x) g $ f x
@ -1078,29 +1103,31 @@ transformSimplifyPar = transformUp $ \case
-- Just $ BDPar ind1 line (BDLines [p1, p2]) -- Just $ BDPar ind1 line (BDLines [p1, p2])
x@(BDPar _ (BDPar _ BDPar{} _) _) -> x x@(BDPar _ (BDPar _ BDPar{} _) _) -> x
BDPar ind1 (BDPar ind2 line p1) (BDLines indenteds) -> 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 (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
BDEmpty{} -> True BDLines{} -> True
_ -> False) lines -> BDEmpty{} -> True
case go lines of _ -> False
[] -> BDEmpty )
[x] -> x lines -> case go lines of
xs -> BDLines xs [] -> BDEmpty
where [x] -> x
go = (=<<) $ \case xs -> BDLines xs
BDLines l -> go l where
BDEmpty -> [] go = (=<<) $ \case
x -> [x] BDLines l -> go l
BDLines [] -> BDEmpty BDEmpty -> []
BDLines [x] -> x x -> [x]
BDLines [] -> BDEmpty
BDLines [x] -> x
-- BDCols sig cols | BDPar ind line indented <- List.last cols -> -- BDCols sig cols | BDPar ind line indented <- List.last cols ->
-- Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented -- Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented
-- BDPar BrIndentNone line indented -> -- BDPar BrIndentNone line indented ->
-- Just $ BDLines [line, indented] -- Just $ BDLines [line, indented]
BDEnsureIndent BrIndentNone x -> x BDEnsureIndent BrIndentNone x -> x
x -> x x -> x
isNotEmpty :: BriDoc -> Bool isNotEmpty :: BriDoc -> Bool
isNotEmpty BDEmpty = False isNotEmpty BDEmpty = False
@ -1243,28 +1270,29 @@ 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
BDEmpty{} -> True BDLines{} -> True
_ -> False) lines -> BDEmpty{} -> True
_ -> 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) ->
Just $ BDAnnotationKW k kw (BDAddBaseY i x) Just $ BDAnnotationKW k kw (BDAddBaseY i x)
BDAddBaseY i (BDAnnotationRest k x) -> BDAddBaseY i (BDAnnotationRest k x) ->
Just $ BDAnnotationRest k (BDAddBaseY i x) Just $ BDAnnotationRest k (BDAddBaseY i x)
BDAddBaseY i (BDSeq l) -> BDAddBaseY i (BDSeq l) ->
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
briDocLineLength :: BriDoc -> Int briDocLineLength :: BriDoc -> Int
@ -1273,35 +1301,35 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
-- appended at the current position. -- appended at the current position.
where where
rec = \case rec = \case
BDEmpty -> return $ 0 BDEmpty -> return $ 0
BDLit t -> StateS.put False $> Text.length t BDLit t -> StateS.put False $> Text.length t
BDSeq bds -> sum <$> rec `mapM` bds BDSeq bds -> sum <$> rec `mapM` bds
BDCols _ bds -> sum <$> rec `mapM` bds BDCols _ bds -> sum <$> rec `mapM` bds
BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1 BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1
BDAddBaseY _ bd -> rec bd BDAddBaseY _ bd -> rec bd
BDBaseYPushCur bd -> rec bd BDBaseYPushCur bd -> rec bd
BDBaseYPop bd -> rec bd BDBaseYPop bd -> rec bd
BDIndentLevelPushCur bd -> rec bd BDIndentLevelPushCur bd -> rec bd
BDIndentLevelPop bd -> rec bd BDIndentLevelPop bd -> rec bd
BDPar _ line _ -> rec line BDPar _ line _ -> rec line
BDAlt{} -> error "briDocLineLength BDAlt" BDAlt{} -> error "briDocLineLength BDAlt"
BDForceMultiline bd -> rec bd BDForceMultiline bd -> rec bd
BDForceSingleline bd -> rec bd BDForceSingleline bd -> rec bd
BDForwardLineMode bd -> rec bd BDForwardLineMode bd -> rec bd
BDExternal _ _ _ t -> return $ Text.length t BDExternal _ _ _ t -> return $ Text.length t
BDAnnotationPrior _ bd -> rec bd BDAnnotationPrior _ bd -> rec bd
BDAnnotationKW _ _ bd -> rec bd BDAnnotationKW _ _ bd -> rec bd
BDAnnotationRest _ bd -> rec bd BDAnnotationRest _ bd -> rec bd
BDLines ls@(_:_) -> do BDLines ls@(_:_) -> do
x <- StateS.get x <- StateS.get
return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x
BDLines [] -> error "briDocLineLength BDLines []" BDLines [] -> error "briDocLineLength BDLines []"
BDEnsureIndent _ bd -> rec bd BDEnsureIndent _ bd -> rec bd
BDProhibitMTEL bd -> rec bd BDProhibitMTEL bd -> rec bd
BDSetParSpacing bd -> rec bd BDSetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd BDForceParSpacing bd -> rec bd
BDNonBottomSpacing bd -> rec bd BDNonBottomSpacing bd -> rec bd
BDDebug _ bd -> rec bd BDDebug _ bd -> rec bd
layoutBriDocM layoutBriDocM
:: forall w m :: forall w m

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

@ -73,36 +73,42 @@ 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")
dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany") dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany")
dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast") dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast")
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 ""
dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns") ["dump-bridoc-floating"]
dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent") (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating")
dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc") dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns")
dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent")
dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc")
outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible") 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
{ _dconf_dump_config = wrapLast $ falseToNothing dumpConfig { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig
, _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations
, _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST
, _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST , _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST
, _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw , _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw
, _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt , _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt
, _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar , _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar
@ -111,7 +117,7 @@ configParser = do
, _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent
, _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal
} }
, _conf_layout = LayoutConfig , _conf_layout = LayoutConfig
{ _lconfig_cols = optionConcat cols { _lconfig_cols = optionConcat cols
, _lconfig_indentPolicy = mempty , _lconfig_indentPolicy = mempty
, _lconfig_indentAmount = optionConcat ind , _lconfig_indentAmount = optionConcat ind
@ -126,18 +132,16 @@ configParser = do
, _econf_Werror = wrapLast $ falseToNothing wError , _econf_Werror = wrapLast $ falseToNothing wError
, _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
wrapLast :: Option a -> Option (Semigroup.Last a) falseToNothing = Option . Bool.bool Nothing (Just True)
wrapLast = fmap Semigroup.Last wrapLast :: Option a -> Option (Semigroup.Last a)
optionConcat wrapLast = fmap Semigroup.Last
:: (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) optionConcat = mconcat . fmap (pure . pure)
-- configParser :: Parser Config -- configParser :: Parser Config
-- configParser = Config -- configParser = Config

62
src/Language/Haskell/Brittany/Config/Types.hs
View File

@ -227,38 +227,38 @@ data CPPMode = CPPModeAbort -- abort program on seeing -XCPP
staticDefaultConfig :: Config staticDefaultConfig :: Config
staticDefaultConfig = Config staticDefaultConfig = Config
{ _conf_debug = DebugConfig { _conf_debug = DebugConfig
{ _dconf_dump_config = coerce False { _dconf_dump_config = coerce False
, _dconf_dump_annotations = coerce False , _dconf_dump_annotations = coerce False
, _dconf_dump_ast_unknown = coerce False , _dconf_dump_ast_unknown = coerce False
, _dconf_dump_ast_full = coerce False , _dconf_dump_ast_full = coerce False
, _dconf_dump_bridoc_raw = coerce False , _dconf_dump_bridoc_raw = coerce False
, _dconf_dump_bridoc_simpl_alt = coerce False , _dconf_dump_bridoc_simpl_alt = coerce False
, _dconf_dump_bridoc_simpl_floating = coerce False , _dconf_dump_bridoc_simpl_floating = coerce False
, _dconf_dump_bridoc_simpl_par = coerce False , _dconf_dump_bridoc_simpl_par = coerce False
, _dconf_dump_bridoc_simpl_columns = coerce False , _dconf_dump_bridoc_simpl_columns = coerce False
, _dconf_dump_bridoc_simpl_indent = coerce False , _dconf_dump_bridoc_simpl_indent = coerce False
, _dconf_dump_bridoc_final = coerce False , _dconf_dump_bridoc_final = coerce False
}
, _conf_layout = LayoutConfig
{ _lconfig_cols = coerce (80 :: Int)
, _lconfig_indentPolicy = coerce IndentPolicyFree
, _lconfig_indentAmount = coerce (2 :: Int)
, _lconfig_indentWhereSpecial = coerce True
, _lconfig_indentListSpecial = coerce True
, _lconfig_importColumn = coerce (60 :: Int)
, _lconfig_altChooser = coerce (AltChooserBoundedSearch 3)
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
}
, _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = coerce False
, _econf_Werror = coerce False
, _econf_CPPMode = coerce CPPModeAbort
}
, _conf_forward = ForwardOptions
{ _options_ghc = Identity []
}
} }
, _conf_layout = LayoutConfig
{ _lconfig_cols = coerce (80 :: Int)
, _lconfig_indentPolicy = coerce IndentPolicyFree
, _lconfig_indentAmount = coerce (2 :: Int)
, _lconfig_indentWhereSpecial = coerce True
, _lconfig_indentListSpecial = coerce True
, _lconfig_importColumn = coerce (60 :: Int)
, _lconfig_altChooser = coerce (AltChooserBoundedSearch 3)
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
}
, _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = coerce False
, _econf_Werror = coerce False
, _econf_CPPMode = coerce CPPModeAbort
}
, _conf_forward = ForwardOptions
{ _options_ghc = Identity []
}
}
-- TODO: automate writing instances for this to get -- TODO: automate writing instances for this to get
-- the above Monoid instance for free. -- the above Monoid instance for free.

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

@ -149,31 +149,34 @@ 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
:: (ExactPrint.Comment, ExactPrint.DeltaPos) processCom
-> ExactPrint.TransformT Identity Bool :: (ExactPrint.Comment, ExactPrint.DeltaPos)
processCom comPair@(com, _) = -> ExactPrint.TransformT Identity Bool
case GHC.srcSpanStart $ ExactPrint.commentIdentifier com of processCom comPair@(com, _) =
GHC.UnhelpfulLoc{} -> return True -- retain comment at current node. case GHC.srcSpanStart $ ExactPrint.commentIdentifier com of
GHC.RealSrcLoc comLoc -> case Map.lookupLE comLoc annsMap of GHC.UnhelpfulLoc{} -> return True -- retain comment at current node.
Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of GHC.RealSrcLoc comLoc -> case Map.lookupLE comLoc annsMap of
(ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") -> Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of
move $> False (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") ->
(x,y) | x==y -> move $> False move $> False
_ -> return True (x, y) | x == y -> move $> False
where _ -> return True
ExactPrint.AnnKey annKeyLoc1 con1 = annKey1 where
ExactPrint.AnnKey annKeyLoc2 con2 = annKey2 ExactPrint.AnnKey annKeyLoc1 con1 = annKey1
loc1 = GHC.srcSpanStart annKeyLoc1 ExactPrint.AnnKey annKeyLoc2 con2 = annKey2
loc2 = GHC.srcSpanStart annKeyLoc2 loc1 = GHC.srcSpanStart annKeyLoc1
move = ExactPrint.modifyAnnsT $ \anns -> loc2 = GHC.srcSpanStart annKeyLoc2
let ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns move = ExactPrint.modifyAnnsT $ \anns ->
ann2' = ann2 let
{ ExactPrint.annFollowingComments = ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns
ExactPrint.annFollowingComments ann2 ++ [comPair] ann2' = ann2
} { ExactPrint.annFollowingComments =
in Map.insert annKey2 ann2' anns ExactPrint.annFollowingComments ann2 ++ [comPair]
_ -> return True -- retain comment at current node. }
in
Map.insert annKey2 ann2' anns
_ -> 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
assocs' <- flip filterM assocs $ \case assocs' <- flip filterM assocs $ \case

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

@ -135,11 +135,13 @@ 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
=> GenLocated SrcSpan ast , MonadMultiReader ExactPrint.Types.Anns m
-> m () )
=> GenLocated SrcSpan ast
-> m ()
processDefault x = do processDefault x = do
anns <- mAsk anns <- mAsk
let str = ExactPrint.exactPrint x anns let str = ExactPrint.exactPrint x anns
@ -152,55 +154,66 @@ 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"
(printTreeWithCustom 100 (customLayouterF anns) ast) _dconf_dump_ast_unknown
(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"
(printTreeWithCustom 100 (customLayouterF anns) ast) _dconf_dump_ast_unknown
(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
anns <- mAsk anns <- mAsk
let t = rdrNameToText n let t = rdrNameToText n
let hasUni x (ExactPrint.Types.G y, _) = x==y let hasUni x (ExactPrint.Types.G y, _) = x == y
hasUni _ _ = False hasUni _ _ = False
-- TODO: in general: we should _always_ process all annotaiton stuff here. -- TODO: in general: we should _always_ process all annotaiton stuff here.
-- whatever we don't probably should have had some effect on the -- whatever we don't probably should have had some effect on the
-- output. in such cases, resorting to byExact is probably the safe -- output. in such cases, resorting to byExact is probably the safe
-- choice. -- choice.
return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of
Nothing -> t Nothing -> t
Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of
Exact{} | t == Text.pack "()" -> t Exact{} | t == Text.pack "()" -> t
_ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`"
_ | any (hasUni AnnCommaTuple) aks -> t _ | any (hasUni AnnCommaTuple) aks -> t
_ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")"
_ | otherwise -> t _ | otherwise -> t
lrdrNameToTextAnnTypeEqualityIsSpecial lrdrNameToTextAnnTypeEqualityIsSpecial
:: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
@ -209,18 +222,19 @@ lrdrNameToTextAnnTypeEqualityIsSpecial
lrdrNameToTextAnnTypeEqualityIsSpecial ast = do lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
x <- lrdrNameToTextAnn ast x <- lrdrNameToTextAnn ast
return $ if x == Text.pack "Data.Type.Equality~" return $ if x == Text.pack "Data.Type.Equality~"
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
else x else x
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 )
-> m () => Text
-> m ()
layoutWriteAppend t = do layoutWriteAppend t = do
traceLocal ("layoutWriteAppend", t) traceLocal ("layoutWriteAppend", t)
state <- mGet state <- mGet
@ -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 )
-> m () => Int
-> 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 )
-> m () => Text
-> 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,17 +297,18 @@ 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")
state <- mGet state <- mGet
mSet $ state { _lstate_curYOrAddNewline = Right 1 mSet $ state { _lstate_curYOrAddNewline = Right 1
, _lstate_addSepSpace = Just $ lstate_baseY state , _lstate_addSepSpace = Just $ lstate_baseY state
, _lstate_inhibitMTEL = False , _lstate_inhibitMTEL = False
} }
-- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m -- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m
@ -310,13 +325,12 @@ 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
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Right{} -> lstate_baseY state Right{} -> lstate_baseY state
traceLocal ("layoutSetCommentCol", col) traceLocal ("layoutSetCommentCol", col)
unless (Data.Maybe.isJust $ _lstate_commentCol state) unless (Data.Maybe.isJust $ _lstate_commentCol state)
@ -337,90 +351,93 @@ layoutMoveToCommentPos y x = do
then do then do
mSet state mSet state
{ _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 $ 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 Right{} -> _lstate_indLevelLinger state + x
else _lstate_indLevelLinger state + x
Right{} -> _lstate_indLevelLinger state + x
} }
else do else do
mSet state mSet state
{ _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
Left{} -> Right 1 { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Right i -> Right (i+1) Left{} -> Right 1
, _lstate_addSepSpace = Nothing Right i -> Right (i + 1)
, _lstate_inhibitMTEL = False , _lstate_addSepSpace = Nothing
} , _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")
state <- mGet state <- mGet
mSet $ state mSet $ state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left{} -> Right 1 Left{} -> Right 1
Right i -> Right $ max 1 i Right i -> Right $ max 1 i
, _lstate_addSepSpace = Just $ lstate_baseY state , _lstate_addSepSpace = Just $ lstate_baseY state
, _lstate_inhibitMTEL = False , _lstate_inhibitMTEL = False
, _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")
state <- mGet state <- mGet
let let
diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of 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 (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) (Just sp, Right{}) -> max sp (lstate_baseY state)
-- when (diff>0) $ layoutWriteNewlineBlock -- when (diff>0) $ layoutWriteNewlineBlock
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
Left i -> n-i Left i -> n - i
Right{} -> n Right{} -> n
traceLocal ("layoutWriteEnsureAbsoluteN", n, diff) traceLocal ("layoutWriteEnsureAbsoluteN", n, diff)
when (diff>0) $ do when (diff > 0) $ do
mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to
-- at least (Just 1), so we won't -- at least (Just 1), so we won't
-- overwrite any old value in any -- overwrite any old value in any
@ -448,7 +465,7 @@ layoutIndentLevelPushInternal
layoutIndentLevelPushInternal i = do layoutIndentLevelPushInternal i = do
traceLocal ("layoutIndentLevelPushInternal", i) traceLocal ("layoutIndentLevelPushInternal", i)
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
, _lstate_indLevels = i : _lstate_indLevels s , _lstate_indLevels = i : _lstate_indLevels s
} }
layoutIndentLevelPopInternal layoutIndentLevelPopInternal
@ -456,7 +473,7 @@ layoutIndentLevelPopInternal
layoutIndentLevelPopInternal = do layoutIndentLevelPopInternal = do
traceLocal ("layoutIndentLevelPopInternal") traceLocal ("layoutIndentLevelPopInternal")
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
, _lstate_indLevels = List.tail $ _lstate_indLevels s , _lstate_indLevels = List.tail $ _lstate_indLevels s
} }
layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m
@ -469,13 +486,14 @@ 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
#if INSERTTRACES #if INSERTTRACES
tellDebugMessShow ("layoutWithAddBaseCol") tellDebugMessShow ("layoutWithAddBaseCol")
@ -521,13 +539,14 @@ 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 )
-> m () => Int
-> m () -> m ()
-> m ()
layoutWithAddBaseColN amount m = do layoutWithAddBaseColN amount m = do
#if INSERTTRACES #if INSERTTRACES
tellDebugMessShow ("layoutWithAddBaseColN", amount) tellDebugMessShow ("layoutWithAddBaseColN", amount)
@ -543,10 +562,11 @@ 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 ->
(Left i, Just j) -> layoutBaseYPushInternal (i+j) case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i, Nothing) -> layoutBaseYPushInternal i (Left i , Just j ) -> layoutBaseYPushInternal (i + j)
(Right{}, _) -> layoutBaseYPushInternal $ lstate_baseY state (Left i , Nothing) -> layoutBaseYPushInternal i
(Right{}, _ ) -> layoutBaseYPushInternal $ lstate_baseY state
Just cCol -> layoutBaseYPushInternal cCol Just cCol -> layoutBaseYPushInternal cCol
layoutBaseYPop layoutBaseYPop
@ -561,9 +581,9 @@ layoutIndentLevelPushCur = do
traceLocal ("layoutIndentLevelPushCur") traceLocal ("layoutIndentLevelPushCur")
state <- mGet state <- mGet
let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i, Just j) -> i + j (Left i , Just j ) -> i + j
(Left i, Nothing) -> i (Left i , Nothing) -> i
(Right{}, Just j) -> j (Right{}, Just j ) -> j
(Right{}, Nothing) -> 0 (Right{}, Nothing) -> 0
layoutIndentLevelPushInternal y layoutIndentLevelPushInternal y
layoutBaseYPushInternal y layoutBaseYPushInternal y
@ -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.
@ -604,22 +625,25 @@ moveToExactAnn annKey = do
traceLocal ("moveToExactAnn", annKey) traceLocal ("moveToExactAnn", annKey)
anns <- mAsk anns <- mAsk
case Map.lookup annKey anns of case Map.lookup annKey anns of
Nothing -> return () Nothing -> return ()
Just ann -> do Just ann -> do
-- curY <- mGet <&> _lstate_curY -- curY <- mGet <&> _lstate_curY
let ExactPrint.Types.DP (y, _x) = ExactPrint.Types.annEntryDelta ann let ExactPrint.Types.DP (y, _x) = ExactPrint.Types.annEntryDelta ann
-- mModify $ \state -> state { _lstate_addNewline = Just x } -- mModify $ \state -> state { _lstate_addNewline = Just x }
mModify $ \state -> mModify $ \state ->
let upd = case _lstate_curYOrAddNewline state of let upd = case _lstate_curYOrAddNewline state of
Left i -> if y==0 then Left i else Right y Left i -> if y == 0 then Left i else Right y
Right i -> Right $ max y i Right i -> Right $ max y i
in state in state
{ _lstate_curYOrAddNewline = upd { _lstate_curYOrAddNewline = upd
, _lstate_addSepSpace = if Data.Either.isRight upd , _lstate_addSepSpace = if Data.Either.isRight upd
then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just (lstate_baseY state) then
else Nothing _lstate_commentCol state
, _lstate_commentCol = Nothing <|> _lstate_addSepSpace state
} <|> Just (lstate_baseY state)
else Nothing
, _lstate_commentCol = Nothing
}
-- fixMoveToLineByIsNewline :: MonadMultiState -- fixMoveToLineByIsNewline :: MonadMultiState
-- LayoutState m => Int -> m Int -- LayoutState m => Int -> m Int
-- fixMoveToLineByIsNewline x = do -- fixMoveToLineByIsNewline x = do
@ -628,18 +652,22 @@ moveToExactAnn annKey = do
-- then x-1 -- then x-1
-- else x -- else x
ppmMoveToExactLoc :: MonadMultiWriter Text.Builder.Builder m ppmMoveToExactLoc
=> ExactPrint.Types.DeltaPos :: MonadMultiWriter Text.Builder.Builder m
-> m () => ExactPrint.Types.DeltaPos
ppmMoveToExactLoc (ExactPrint.Types.DP (x,y)) = do -> m ()
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
@ -743,49 +771,43 @@ extractAllComments
extractAllComments ann = extractAllComments ann =
ExactPrint.annPriorComments ann ExactPrint.annPriorComments ann
++ ExactPrint.annFollowingComments ann ++ ExactPrint.annFollowingComments ann
++ (ExactPrint.annsDP ann >>= \case ++ ( ExactPrint.annsDP ann >>= \case
(ExactPrint.AnnComment com, dp) -> [(com, dp)] (ExactPrint.AnnComment com, dp) -> [(com, dp)]
_ -> [] _ -> []
) )
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) , l <- gmapQi 0 cast x
, l <- gmapQi 0 cast x ]
]
) )
ast ast
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
$ (=<<) extractAllComments $ List.any (\(c, _) -> ExactPrint.commentIdentifier c > l)
$ Map.elems $ (=<<) extractAllComments
$ anns $ Map.elems
$ 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)
@ -793,7 +815,7 @@ allocateNode bd = do
allocNodeIndex :: MonadMultiState NodeAllocIndex m => m Int allocNodeIndex :: MonadMultiState NodeAllocIndex m => m Int
allocNodeIndex = do allocNodeIndex = do
NodeAllocIndex i <- mGet NodeAllocIndex i <- mGet
mSet $ NodeAllocIndex (i+1) mSet $ NodeAllocIndex (i + 1)
return i return i
-- docEmpty :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -- docEmpty :: MonadMultiState NodeAllocIndex m => m BriDocNumbered
@ -901,13 +923,17 @@ 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)
shouldAddComment shouldAddComment
(Text.pack $ ExactPrint.exactPrint x anns) (Text.pack $ ExactPrint.exactPrint x anns)
docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
docAlt l = allocateNode . BDFAlt =<< sequence l docAlt l = allocateNode . BDFAlt =<< sequence l
@ -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,11 +1139,12 @@ 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
line <- lineM line <- lineM
indented <- indentedM indented <- indentedM
allocateNode $ BDFPar BrIndentNone line indented allocateNode $ BDFPar BrIndentNone line indented
@ -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,13 +1171,14 @@ 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) =
$ MultiRWSS.runMultiRWSTNil runIdentity
$ MultiRWSS.withMultiStateA (NodeAllocIndex 1) $ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiReaders readers $ MultiRWSS.withMultiStateA (NodeAllocIndex 1)
$ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiReaders readers
$ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiWriterAW
$ m $ MultiRWSS.withMultiWriterAW
$ m
mTell debugs mTell debugs
mTell errs mTell errs
return x return x

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

@ -41,52 +41,63 @@ layoutSig lsig@(L _loc sig) = case sig of
TypeSig names (HsIB _ (HsWC _ _ typ)) -> docWrapNode lsig $ do TypeSig names (HsIB _ (HsWC _ _ typ)) -> docWrapNode lsig $ do
nameStrs <- names `forM` lrdrNameToTextAnn nameStrs <- names `forM` lrdrNameToTextAnn
let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs
typeDoc <- docSharedWrapper layoutType typ typeDoc <- docSharedWrapper layoutType typ
hasComments <- hasAnyCommentsBelow lsig hasComments <- hasAnyCommentsBelow lsig
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
( docCols ColTyOpPrefix ColTyOpPrefix
[ docLit $ Text.pack ":: " [ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 3) $ typeDoc , docAddBaseY (BrIndentSpecial 3) $ typeDoc
] ]
) )
] ]
_ -> briDocByExactNoComment lsig -- TODO _ -> briDocByExactNoComment lsig -- TODO
layoutGuardLStmt :: ToBriDoc' (Stmt RdrName (LHsExpr RdrName)) layoutGuardLStmt :: ToBriDoc' (Stmt RdrName (LHsExpr RdrName))
layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
BodyStmt body _ _ _ -> layoutExpr body BodyStmt body _ _ _ -> layoutExpr body
BindStmt lPat expr _ _ _ -> do BindStmt lPat expr _ _ _ -> do
patDoc <- docSharedWrapper layoutPat lPat patDoc <- docSharedWrapper layoutPat lPat
expDoc <- docSharedWrapper layoutExpr expr expDoc <- docSharedWrapper layoutExpr expr
docCols ColBindStmt docCols ColBindStmt
[ appSep $ colsWrapPat =<< patDoc [ appSep $ colsWrapPat =<< patDoc
, docSeq [appSep $ docLit $ Text.pack "<-", expDoc] , docSeq [appSep $ docLit $ Text.pack "<-", expDoc]
] ]
_ -> 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,210 +107,250 @@ 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
ordered = sortBy (comparing bindOrSigtoSrcSpan) unordered unordered
= [ BagBind b | b <- Data.Foldable.toList bindlrs ]
++ [ BagSig s | s <- sigs ]
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
BagSig s -> return <$> layoutSig s BagSig s -> return <$> layoutSig s
return $ Just $ docs return $ Just $ docs
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)
guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards layoutGrhs lgrhs@(L _ (GRHS guards body)) = do
bodyDoc <- layoutExpr body guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards
return (guardDocs, bodyDoc, body) bodyDoc <- layoutExpr 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
patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p -> LMatch RdrName (LHsExpr RdrName)
let isInfix = isInfixMatch match -> ToBriDocM BriDocNumbered
patDoc <- docWrapNodePrior lmatch $ case (mIdStr, patDocs) of layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhss whereBinds))) = do
(Just idStr, p1:pr) | isInfix -> docCols ColPatternsFuncInfix patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p
( [ appSep $ docForceSingleline p1 let isInfix = isInfixMatch match
, appSep $ docLit idStr patDoc <- docWrapNodePrior lmatch $ case (mIdStr, patDocs) of
] (Just idStr, p1:pr) | isInfix -> docCols
++ (spacifyDocs $ docForceSingleline <$> pr) ColPatternsFuncInfix
) ( [appSep $ docForceSingleline p1, appSep $ docLit idStr]
(Just idStr, []) -> docLit idStr ++ (spacifyDocs $ docForceSingleline <$> pr)
(Just idStr, ps) -> docCols ColPatternsFuncPrefix )
(Just idStr, [] ) -> docLit idStr
(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 -> []
Just patDoc -> [appSep $ docForceSingleline $ return patDoc] Just patDoc -> [appSep $ docForceSingleline $ return patDoc]
patPartParWrap = case mPatDoc of patPartParWrap = case mPatDoc of
Nothing -> id Nothing -> id
Just patDoc -> docPar (return patDoc) Just patDoc -> docPar (return patDoc)
whereIndent <- mAsk whereIndent <-
<&> _conf_layout mAsk
.> _lconfig_indentWhereSpecial <&> _conf_layout
.> confUnpack .> _lconfig_indentWhereSpecial
.> Bool.bool BrIndentRegular (BrIndentSpecial 1) .> confUnpack
.> Bool.bool BrIndentRegular (BrIndentSpecial 1)
-- TODO: apart from this, there probably are more nodes below which could -- TODO: apart from this, there probably are more nodes below which could
-- 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 ->
$ docEnsureIndent whereIndent fmap (fmap return)
$ docLines $ sequence
$ return @[]
$ docEnsureIndent whereIndent
$ docLines
[ docLit $ Text.pack "where" [ docLit $ Text.pack "where"
, docEnsureIndent whereIndent , docEnsureIndent whereIndent
$ 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
, wherePart , wherePart
] ]
] ]
| [(guards, body, _bodyRaw)] <- [clauseDocs] | [(guards, body, _bodyRaw)] <- [clauseDocs]
, let guardPart = case guards of , let
[] -> docEmpty guardPart = case guards of
[g] -> docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator] [] -> docEmpty
gs -> docSeq [g] ->
$ [appSep $ docLit $ Text.pack "|"] docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator]
++ List.intersperse docCommaSep (return <$> gs) gs ->
++ [docSeparator] docSeq
, wherePart <- case mWhereDocs of $ [appSep $ docLit $ Text.pack "|"]
Nothing -> return @[] $ docEmpty ++ List.intersperse docCommaSep (return <$> gs)
Just [w] -> return @[] $ docSeq ++ [docSeparator]
[ docSeparator , wherePart <- case mWhereDocs of
, appSep $ docLit $ Text.pack "where" Nothing -> return @[] $ docEmpty
, docSetIndentLevel $ docForceSingleline $ return w Just [w] -> return @[] $ docSeq
[ docSeparator
, appSep $ docLit $ Text.pack "where"
, docSetIndentLevel $ docForceSingleline $ return w
]
_ -> []
]
++ -- one-line solution + where in next line(s)
[ docLines
$ [ docCols
(ColBindingLine alignmentToken)
[ docSeq (patPartInline ++ [guardPart])
, docSeq
[appSep $ return binderDoc, docForceParSpacing $ return body]
]
]
++ wherePartMultiLine
| [(guards, body, _bodyRaw)] <- [clauseDocs]
, let
guardPart = case guards of
[] -> docEmpty
[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)
[ docLines
$ [ docForceSingleline
$ docSeq (patPartInline ++ [guardPart, return binderDoc])
, docEnsureIndent BrIndentRegular $ docForceSingleline $ return body
]
++ wherePartMultiLine
| [(guards, body, _bodyRaw)] <- [clauseDocs]
, let
guardPart = case guards of
[] -> docEmpty
[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;
-- where in following lines
[ docLines
$ [ docCols
(ColBindingLine alignmentToken)
[ docSeq (patPartInline ++ [appSep guardPart])
, docSeq
[ appSep $ return binderDoc
, docForceParSpacing $ docAddBaseY BrIndentRegular $ return body
]
]
] ]
_ -> []
] ++
-- one-line solution + where in next line(s)
[ docLines
$ [ docCols (ColBindingLine alignmentToken)
[ docSeq
(patPartInline ++ [guardPart])
, docSeq
[ appSep $ return binderDoc
, docForceParSpacing $ return body
]
]
] ++ wherePartMultiLine
| [(guards, body, _bodyRaw)] <- [clauseDocs]
, let guardPart = case guards of
[] -> docEmpty
[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)
[ docLines
$ [ docForceSingleline
$ docSeq (patPartInline ++ [guardPart, return binderDoc])
, docEnsureIndent BrIndentRegular
$ docForceSingleline
$ return body
] ++ wherePartMultiLine
| [(guards, body, _bodyRaw)] <- [clauseDocs]
, let guardPart = case guards of
[] -> docEmpty
[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;
-- where in following lines
[ docLines
$ [ docCols (ColBindingLine alignmentToken)
[ docSeq
(patPartInline ++ [appSep guardPart])
, docSeq
[ appSep $ return binderDoc
, docForceParSpacing $ docAddBaseY BrIndentRegular $ return body
-- , lineMod $ docAlt -- , lineMod $ docAlt
-- [ docSetBaseY $ return body -- [ docSetBaseY $ return body
-- , docAddBaseY BrIndentRegular $ return body -- , docAddBaseY BrIndentRegular $ return body
-- ] -- ]
] ++ wherePartMultiLine
] | [(guards, body, _bodyRaw)] <- [clauseDocs]
] ++ wherePartMultiLine , let
| [(guards, body, _bodyRaw)] <- [clauseDocs] 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 $ [appSep $ docLit $ Text.pack "|"] ++ List.intersperse
gs -> docSeq docCommaSep
$ [appSep $ docLit $ Text.pack "|"] (return <$> gs)
++ List.intersperse docCommaSep (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
| [(guards, body, _)] <- [clauseDocs]
, 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
$ docLines
$ fmap (docEnsureIndent BrIndentRegular)
$ clauseDocs >>= \(guardDocs, bodyDoc, _) ->
(case guardDocs of
[] -> []
[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]
)
)
) ++
[docCols ColOpPrefix
[ appSep $ return binderDoc
, docAddBaseY BrIndentRegular $ return bodyDoc]
] ]
] ++ wherePartMultiLine ++ wherePartMultiLine
] | [(guards, body, _)] <- [clauseDocs]
, 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
$ docLines
$ fmap (docEnsureIndent BrIndentRegular)
$ clauseDocs
>>= \(guardDocs, bodyDoc, _) ->
( case guardDocs of
[] -> []
[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]
)
)
)
++ [ docCols
ColOpPrefix
[ appSep $ return binderDoc
, docAddBaseY BrIndentRegular $ return bodyDoc
]
]
]
++ wherePartMultiLine
]

26
src/Language/Haskell/Brittany/Layouters/Expr.hs
View File

@ -777,19 +777,19 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
litBriDoc :: HsLit -> BriDocFInt litBriDoc :: HsLit -> BriDocFInt
litBriDoc = \case litBriDoc = \case
HsChar t _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] HsChar t _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\'']
HsCharPrim t _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\''] HsCharPrim t _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\'']
HsString t _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString HsString t _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString
HsStringPrim t _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString HsStringPrim t _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString
HsInt t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i HsInt t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
HsIntPrim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i HsIntPrim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
HsWordPrim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i HsWordPrim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
HsInt64Prim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i HsInt64Prim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
HsWord64Prim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i HsWord64Prim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
HsInteger t _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i HsInteger t _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
HsRat (FL t _) _type -> BDFLit $ Text.pack t HsRat (FL t _) _type -> BDFLit $ Text.pack t
HsFloatPrim (FL t _) -> BDFLit $ Text.pack t HsFloatPrim (FL t _) -> BDFLit $ Text.pack t
HsDoublePrim (FL t _) -> BDFLit $ Text.pack t HsDoublePrim (FL t _) -> BDFLit $ Text.pack t
overLitValBriDoc :: OverLitVal -> BriDocFInt overLitValBriDoc :: OverLitVal -> BriDocFInt
overLitValBriDoc = \case overLitValBriDoc = \case

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

@ -28,51 +28,50 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Layouters.Expr
layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName)) layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName))
layoutStmt lstmt@(L _ stmt) = docWrapNode lstmt $ case stmt of layoutStmt lstmt@(L _ stmt) = docWrapNode lstmt $ case stmt of
LastStmt body False _ -> do LastStmt body False _ -> do
layoutExpr body layoutExpr body
BindStmt lPat expr _ _ _ -> do BindStmt lPat expr _ _ _ -> do
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
[ docSeq [ docSeq
[ 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)
] ]
BodyStmt expr _ _ _ -> do BodyStmt expr _ _ _ -> do
expDoc <- docSharedWrapper layoutExpr expr expDoc <- docSharedWrapper layoutExpr expr
docAddBaseY BrIndentRegular $ expDoc docAddBaseY BrIndentRegular $ expDoc
_ -> unknownNodeError "" lstmt _ -> unknownNodeError "" lstmt

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

@ -296,88 +296,89 @@ instance Uniplate.Uniplate BriDoc where
uniplate (BDCols sig list) = plate BDCols |- sig ||* list uniplate (BDCols sig list) = plate BDCols |- sig ||* list
uniplate x@BDSeparator = plate x uniplate x@BDSeparator = plate x
uniplate (BDAddBaseY ind bd) = plate BDAddBaseY |- ind |* bd uniplate (BDAddBaseY ind bd) = plate BDAddBaseY |- ind |* bd
uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd
uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd
uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd
uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd
uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented
uniplate (BDAlt alts) = plate BDAlt ||* alts uniplate (BDAlt alts) = plate BDAlt ||* alts
uniplate (BDForwardLineMode bd) = plate BDForwardLineMode |* bd uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd
uniplate x@BDExternal{} = plate x uniplate x@BDExternal{} = plate x
uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd
uniplate (BDAnnotationKW annKey kw bd) = plate BDAnnotationKW |- annKey |- kw |* bd uniplate (BDAnnotationKW annKey kw bd) = plate BDAnnotationKW |- annKey |- kw |* bd
uniplate (BDAnnotationRest annKey bd) = plate BDAnnotationRest |- annKey |* bd uniplate (BDAnnotationRest annKey bd) = plate BDAnnotationRest |- annKey |* bd
uniplate (BDLines lines) = plate BDLines ||* lines uniplate (BDLines lines) = plate BDLines ||* lines
uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd
uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd
uniplate (BDForceSingleline bd) = plate BDForceSingleline |* bd uniplate (BDForceSingleline bd) = plate BDForceSingleline |* bd
uniplate (BDNonBottomSpacing bd) = plate BDNonBottomSpacing |* bd uniplate (BDNonBottomSpacing bd) = plate BDNonBottomSpacing |* bd
uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd
uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd
uniplate (BDProhibitMTEL bd) = plate BDProhibitMTEL |* bd uniplate (BDProhibitMTEL bd) = plate BDProhibitMTEL |* bd
uniplate (BDDebug s bd) = plate BDDebug |- s |* bd uniplate (BDDebug s bd) = plate BDDebug |- s |* bd
newtype NodeAllocIndex = NodeAllocIndex Int newtype NodeAllocIndex = NodeAllocIndex Int
unwrapBriDocNumbered :: BriDocNumbered -> BriDoc unwrapBriDocNumbered :: BriDocNumbered -> BriDoc
unwrapBriDocNumbered tpl = case snd tpl of unwrapBriDocNumbered tpl = case snd tpl of
BDFEmpty -> BDEmpty BDFEmpty -> BDEmpty
BDFLit t -> BDLit t BDFLit t -> BDLit t
BDFSeq list -> BDSeq $ rec <$> list BDFSeq list -> BDSeq $ rec <$> list
BDFCols sig list -> BDCols sig $ rec <$> list BDFCols sig list -> BDCols sig $ rec <$> list
BDFSeparator -> BDSeparator BDFSeparator -> BDSeparator
BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd
BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd
BDFBaseYPop bd -> BDBaseYPop $ rec bd BDFBaseYPop bd -> BDBaseYPop $ rec bd
BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd
BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd
BDFPar ind line indented -> BDPar ind (rec line) (rec indented) BDFPar ind line indented -> BDPar ind (rec line) (rec indented)
BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen
BDFForwardLineMode bd -> BDForwardLineMode $ rec bd BDFForwardLineMode bd -> BDForwardLineMode $ rec bd
BDFExternal k ks c t -> BDExternal k ks c t BDFExternal k ks c t -> BDExternal k ks c t
BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd
BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd
BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd
BDFLines lines -> BDLines $ rec <$> lines BDFLines lines -> BDLines $ rec <$> lines
BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd
BDFForceMultiline bd -> BDForceMultiline $ rec bd BDFForceMultiline bd -> BDForceMultiline $ rec bd
BDFForceSingleline bd -> BDForceSingleline $ rec bd BDFForceSingleline bd -> BDForceSingleline $ rec bd
BDFNonBottomSpacing bd -> BDNonBottomSpacing $ rec bd BDFNonBottomSpacing bd -> BDNonBottomSpacing $ rec bd
BDFSetParSpacing bd -> BDSetParSpacing $ rec bd BDFSetParSpacing bd -> BDSetParSpacing $ rec bd
BDFForceParSpacing bd -> BDForceParSpacing $ rec bd BDFForceParSpacing bd -> BDForceParSpacing $ rec bd
BDFProhibitMTEL bd -> BDProhibitMTEL $ rec bd BDFProhibitMTEL bd -> BDProhibitMTEL $ rec bd
BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd
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 -> ()
BDLit _t -> () BDLit _t -> ()
BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list BDSeq list -> foldl' ((briDocSeqSpine.) . seq) () list
BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list BDCols _sig list -> foldl' ((briDocSeqSpine.) . seq) () list
BDSeparator -> () BDSeparator -> ()
BDAddBaseY _ind bd -> briDocSeqSpine bd BDAddBaseY _ind bd -> briDocSeqSpine bd
BDBaseYPushCur bd -> briDocSeqSpine bd BDBaseYPushCur bd -> briDocSeqSpine bd
BDBaseYPop bd -> briDocSeqSpine bd BDBaseYPop bd -> briDocSeqSpine bd
BDIndentLevelPushCur bd -> briDocSeqSpine bd BDIndentLevelPushCur bd -> briDocSeqSpine bd
BDIndentLevelPop bd -> briDocSeqSpine bd BDIndentLevelPop bd -> briDocSeqSpine bd
BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented
BDAlt alts -> foldl' (\(!()) -> briDocSeqSpine) () alts BDAlt alts -> foldl' (\(!()) -> briDocSeqSpine) () alts
BDForwardLineMode bd -> briDocSeqSpine bd BDForwardLineMode bd -> briDocSeqSpine bd
BDExternal{} -> () BDExternal{} -> ()
BDAnnotationPrior _annKey bd -> briDocSeqSpine bd BDAnnotationPrior _annKey bd -> briDocSeqSpine bd
BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd
BDAnnotationRest _annKey bd -> briDocSeqSpine bd BDAnnotationRest _annKey bd -> briDocSeqSpine bd
BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines
BDEnsureIndent _ind bd -> briDocSeqSpine bd BDEnsureIndent _ind bd -> briDocSeqSpine bd
BDForceMultiline bd -> briDocSeqSpine bd BDForceMultiline bd -> briDocSeqSpine bd
BDForceSingleline bd -> briDocSeqSpine bd BDForceSingleline bd -> briDocSeqSpine bd
BDNonBottomSpacing bd -> briDocSeqSpine bd BDNonBottomSpacing bd -> briDocSeqSpine bd
BDSetParSpacing bd -> briDocSeqSpine bd BDSetParSpacing bd -> briDocSeqSpine bd
BDForceParSpacing bd -> briDocSeqSpine bd BDForceParSpacing bd -> briDocSeqSpine bd
BDProhibitMTEL bd -> briDocSeqSpine bd BDProhibitMTEL bd -> briDocSeqSpine bd
BDDebug _s bd -> briDocSeqSpine bd BDDebug _s bd -> briDocSeqSpine bd
briDocForceSpine :: BriDoc -> BriDoc briDocForceSpine :: BriDoc -> BriDoc
briDocForceSpine bd = briDocSeqSpine bd `seq` bd briDocForceSpine bd = briDocSeqSpine bd `seq` bd

156
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,61 +99,68 @@ 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
`extQ` fastString $ f
`extQ` bytestring `extQ` showIsId
`extQ` occName `extQ` fastString
`extQ` srcSpan `extQ` bytestring
`ext2Q` located `extQ` occName
where `extQ` srcSpan
DataToLayouter f = defaultLayouterF layoutF `ext2Q` located
simpleLayouter :: String -> NodeLayouter where
simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) DataToLayouter f = defaultLayouterF layoutF
showIsId :: ShowIsId -> NodeLayouter simpleLayouter :: String -> NodeLayouter
showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)
Left True -> PP.parens $ PP.text s showIsId :: ShowIsId -> NodeLayouter
Left False -> PP.text s showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case
Right _ -> PP.text s Left True -> PP.parens $ PP.text s
fastString = simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString -> NodeLayouter Left False -> PP.text s
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter Right _ -> PP.text s
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString fastString =
srcSpan :: GHC.SrcSpan -> NodeLayouter simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString
srcSpan ss = simpleLayouter -> NodeLayouter
-- $ "{"++ showSDoc_ (GHC.ppr ss)++"}" bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
$ "{" ++ showGhc ss ++ "}" occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString
located :: (Data b,Data loc) => GHC.GenLocated loc b -> NodeLayouter srcSpan :: GHC.SrcSpan -> NodeLayouter
located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a srcSpan ss = simpleLayouter
where -- $ "{"++ showSDoc_ (GHC.ppr ss)++"}"
annStr = case cast ss of $ "{" ++ showGhc ss ++ "}"
Just (s :: GHC.SrcSpan) -> ShowIsId located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter
$ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns) located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a
Nothing -> ShowIsId "nnnnnnnn" where
annStr = case cast ss of
Just (s :: GHC.SrcSpan) ->
ShowIsId $ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns)
Nothing -> ShowIsId "nnnnnnnn"
customLayouterNoAnnsF :: LayouterF customLayouterNoAnnsF :: LayouterF
customLayouterNoAnnsF layoutF = customLayouterNoAnnsF layoutF =
DataToLayouter $ f `extQ` showIsId DataToLayouter
`extQ` fastString $ f
`extQ` bytestring `extQ` showIsId
`extQ` occName `extQ` fastString
`extQ` srcSpan `extQ` bytestring
`ext2Q` located `extQ` occName
where `extQ` srcSpan
DataToLayouter f = defaultLayouterF layoutF `ext2Q` located
simpleLayouter :: String -> NodeLayouter where
simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) DataToLayouter f = defaultLayouterF layoutF
showIsId :: ShowIsId -> NodeLayouter simpleLayouter :: String -> NodeLayouter
showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)
Left True -> PP.parens $ PP.text s showIsId :: ShowIsId -> NodeLayouter
Left False -> PP.text s showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case
Right _ -> PP.text s Left True -> PP.parens $ PP.text s
fastString = simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString -> NodeLayouter Left False -> PP.text s
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter Right _ -> PP.text s
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString fastString =
srcSpan :: GHC.SrcSpan -> NodeLayouter simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString
srcSpan ss = simpleLayouter -> NodeLayouter
$ "{"++ showSDoc_ (GHC.ppr ss)++"}" bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString
located (GHC.L _ss a) = runDataToLayouter layoutF a srcSpan :: GHC.SrcSpan -> NodeLayouter
srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}"
located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter
located (GHC.L _ss a) = runDataToLayouter layoutF a
-- displayBriDocTree :: BriDoc -> PP.Doc -- displayBriDocTree :: BriDoc -> PP.Doc
-- displayBriDocTree = \case -- displayBriDocTree = \case
@ -205,13 +210,12 @@ 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 -> m ()
-> m ()
traceIfDumpConf s accessor val = do traceIfDumpConf s accessor val = do
whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do
trace ("---- " ++ s ++ " ----\n" ++ show val) $ return () trace ("---- " ++ s ++ " ----\n" ++ show val) $ return ()
@ -237,8 +241,8 @@ briDocToDoc = astToDoc . removeAnnotations
removeAnnotations = Uniplate.transform $ \case removeAnnotations = Uniplate.transform $ \case
BDAnnotationPrior _ x -> x BDAnnotationPrior _ x -> x
BDAnnotationKW _ _ x -> x BDAnnotationKW _ _ x -> x
BDAnnotationRest _ x -> x BDAnnotationRest _ x -> x
x -> x x -> x
briDocToDocWithAnns :: BriDoc -> PP.Doc briDocToDocWithAnns :: BriDoc -> PP.Doc
briDocToDocWithAnns = astToDoc briDocToDocWithAnns = astToDoc
@ -246,16 +250,16 @@ briDocToDocWithAnns = astToDoc
annsDoc :: ExactPrint.Types.Anns -> PP.Doc annsDoc :: ExactPrint.Types.Anns -> PP.Doc
annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show)
breakEither :: (a -> Either b c) -> [a] -> ([b],[c]) breakEither :: (a -> Either b c) -> [a] -> ([b], [c])
breakEither _ [] = ([],[]) breakEither _ [] = ([], [])
breakEither fn (a1:aR) = case fn a1 of breakEither fn (a1:aR) = case fn a1 of
Left b -> (b:bs,cs) Left b -> (b : bs, cs)
Right c -> (bs,c:cs) Right c -> (bs, c : cs)
where where
(bs,cs) = breakEither fn aR (bs, cs) = breakEither fn aR
spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])
spanMaybe f (x1:xR) | Just y <- f x1 = (y:ys, xs) spanMaybe f (x1:xR) | Just y <- f x1 = (y : ys, xs)
where where
(ys, xs) = spanMaybe f xR (ys, xs) = spanMaybe f xR
spanMaybe _ xs = ([], xs) spanMaybe _ xs = ([], xs)