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"
let defUserConfigPath = userBritPath FilePath.</> "config.yaml"
merged <- case configPaths of
[] -> do
[] -> do
liftIO $ Directory.createDirectoryIfMissing False userBritPath
return cmdlineConfig
>>= readMergePersConfig defLocalConfigPath False
>>= readMergePersConfig defUserConfigPath True
>>= readMergePersConfig defUserConfigPath True
-- TODO: ensure that paths exist ?
paths -> foldl (\prev p -> prev >>= readMergePersConfig p False)
(return cmdlineConfig)

27
src-unittests/AsymptoticPerfTests.hs
View File

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

42
src-unittests/TestUtils.hs
View File

@ -21,15 +21,17 @@ import Data.Coerce ( coerce )
roundTripEqual :: Text -> Expectation
roundTripEqual t = fmap (fmap PPTextWrapper) (parsePrintModule defaultTestConfig "TestFakeFileName.hs" t)
roundTripEqual t =
fmap (fmap PPTextWrapper)
(parsePrintModule defaultTestConfig "TestFakeFileName.hs" t)
`shouldReturn` Right (PPTextWrapper t)
roundTripEqualWithTimeout :: Int -> Text -> Expectation
roundTripEqualWithTimeout time t =
timeout time (action >>= evaluate) >>= (`shouldSatisfy` Data.Maybe.isJust)
where
action = fmap (fmap PPTextWrapper)
(parsePrintModule defaultTestConfig "TestFakeFileName.hs" t)
timeout time (action >>= evaluate) >>= (`shouldSatisfy`Data.Maybe.isJust)
where
action = fmap (fmap PPTextWrapper)
(parsePrintModule defaultTestConfig "TestFakeFileName.hs" t)
newtype PPTextWrapper = PPTextWrapper Text
deriving Eq
@ -39,19 +41,19 @@ instance Show PPTextWrapper where
defaultTestConfig :: Config
defaultTestConfig = Config
{ _conf_debug = _conf_debug staticDefaultConfig
, _conf_layout = LayoutConfig
{ _lconfig_cols = coerce (80 :: Int)
, _lconfig_indentPolicy = coerce IndentPolicyFree
, _lconfig_indentAmount = coerce (2 :: Int)
, _lconfig_indentWhereSpecial = coerce True
, _lconfig_indentListSpecial = coerce True
, _lconfig_importColumn = coerce (60 :: Int)
, _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3
, _lconfig_columnAlignMode = coerce ColumnAlignModeUnanimously
}
, _conf_errorHandling = _conf_errorHandling staticDefaultConfig
, _conf_forward = ForwardOptions
{ _options_ghc = Identity []
}
{ _conf_debug = _conf_debug staticDefaultConfig
, _conf_layout = LayoutConfig
{ _lconfig_cols = coerce (80 :: Int)
, _lconfig_indentPolicy = coerce IndentPolicyFree
, _lconfig_indentAmount = coerce (2 :: Int)
, _lconfig_indentWhereSpecial = coerce True
, _lconfig_indentListSpecial = coerce True
, _lconfig_importColumn = coerce (60 :: Int)
, _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3
, _lconfig_columnAlignMode = coerce ColumnAlignModeUnanimously
}
, _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
-> ([LayoutError], TextL.Text)
pPrintModule conf anns parsedModule =
let ((out, errs), debugStrings)
= runIdentity
let
((out, errs), debugStrings) =
runIdentity
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterAW
@ -68,13 +69,18 @@ pPrintModule conf anns parsedModule =
$ MultiRWSS.withMultiReader anns
$ MultiRWSS.withMultiReader conf
$ do
traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations $ annsDoc anns
traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations
$ annsDoc anns
ppModule parsedModule
tracer = if Seq.null debugStrings
then id
else trace ("---- DEBUGMESSAGES ---- ")
. foldr (seq . join trace) id debugStrings
in tracer $ (errs, Text.Builder.toLazyText out)
tracer =
if Seq.null debugStrings
then
id
else
trace ("---- DEBUGMESSAGES ---- ")
. foldr (seq . join trace) id debugStrings
in
tracer $ (errs, Text.Builder.toLazyText out)
-- unless () $ do
--
-- debugStrings `forM_` \s ->
@ -101,27 +107,25 @@ pPrintModuleAndCheck conf anns parsedModule = do
-- used for testing mostly, currently.
parsePrintModule
:: Config
-> String
-> Text
-> IO (Either String Text)
parsePrintModule :: Config -> String -> Text -> IO (Either String Text)
parsePrintModule conf filename input = do
let inputStr = Text.unpack input
parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr
case parseResult of
Left (_, s) -> return $ Left $ "parsing error: " ++ s
Left (_ , s ) -> return $ Left $ "parsing error: " ++ s
Right (anns, parsedModule) -> do
(errs, ltext) <- pPrintModuleAndCheck conf anns parsedModule
return $ if null errs
then Right $ TextL.toStrict $ ltext
else
let errStrs = errs <&> \case
LayoutErrorUnusedComment str -> str
LayoutWarning str -> str
LayoutErrorUnknownNode str _ -> str
LayoutErrorOutputCheck -> "Output is not syntactically valid."
in Left $ "pretty printing error(s):\n" ++ List.unlines errStrs
let
errStrs = errs <&> \case
LayoutErrorUnusedComment str -> str
LayoutWarning str -> str
LayoutErrorUnknownNode str _ -> str
LayoutErrorOutputCheck -> "Output is not syntactically valid."
in
Left $ "pretty printing error(s):\n" ++ List.unlines errStrs
-- this approach would for with there was a pure GHC.parseDynamicFilePragma.
-- 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
Nothing -> (anns, [])
Just mAnn ->
let
modAnnsDp = ExactPrint.Types.annsDP mAnn
isWhere (ExactPrint.Types.G AnnWhere) = True
isWhere _ = False
isEof (ExactPrint.Types.G AnnEofPos) = True
isEof _ = False
whereInd = List.findIndex (isWhere . fst) modAnnsDp
eofInd = List.findIndex (isEof . fst) modAnnsDp
(pre, post) = case (whereInd, eofInd) of
(Nothing, Nothing) -> ([], modAnnsDp)
(Just i, Nothing) -> List.splitAt (i+1) modAnnsDp
(Nothing, Just _i) -> ([], modAnnsDp)
(Just i, Just j) -> List.splitAt (min (i+1) j) modAnnsDp
mAnn' = mAnn { ExactPrint.Types.annsDP = pre }
anns' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' anns
in (anns', post)
let modAnnsDp = ExactPrint.Types.annsDP mAnn
isWhere (ExactPrint.Types.G AnnWhere) = True
isWhere _ = False
isEof (ExactPrint.Types.G AnnEofPos) = True
isEof _ = False
whereInd = List.findIndex (isWhere . fst) modAnnsDp
eofInd = List.findIndex (isEof . fst) modAnnsDp
(pre, post) = case (whereInd, eofInd) of
(Nothing, Nothing) -> ([], modAnnsDp)
(Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp
(Nothing, Just _i) -> ([], modAnnsDp)
(Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp
mAnn' = mAnn { ExactPrint.Types.annsDP = pre }
anns' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' anns
in (anns', post)
MultiRWSS.withMultiReader anns' $ processDefault emptyModule
decls `forM_` ppDecl
let
finalComments = filter (fst .> \case ExactPrint.Types.AnnComment{} -> True
_ -> False)
post
let finalComments = filter ( fst .> \case
ExactPrint.Types.AnnComment{} -> True
_ -> False
)
post
post `forM_` \case
(ExactPrint.Types.AnnComment (ExactPrint.Types.Comment cmStr _ _), l) -> do
ppmMoveToExactLoc l
mTell $ Text.Builder.fromString cmStr
(ExactPrint.Types.G AnnEofPos, (ExactPrint.Types.DP (eofX,eofY))) ->
(ExactPrint.Types.G AnnEofPos, (ExactPrint.Types.DP (eofX, eofY))) ->
let folder acc (kw, ExactPrint.Types.DP (x, _)) = case kw of
ExactPrint.Types.AnnComment cm
| GHC.RealSrcSpan span <- ExactPrint.Types.commentIdentifier cm
-> acc + x + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span
_ -> acc + x
cmX = foldl' folder 0 finalComments
in ppmMoveToExactLoc $ ExactPrint.Types.DP (eofX - cmX, eofY)
in ppmMoveToExactLoc $ ExactPrint.Types.DP (eofX - cmX, eofY)
_ -> return ()
withTransformedAnns :: SYB.Data ast => ast -> PPM () -> PPM ()
@ -229,15 +233,15 @@ ppDecl d@(L loc decl) = case decl of
briDoc <- briDocMToPPM $ do
eitherNode <- layoutBind (L loc bind)
case eitherNode of
Left ns -> docLines $ return <$> ns
Left ns -> docLines $ return <$> ns
Right n -> return n
layoutBriDoc d briDoc
_ ->
briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc d
_ -> briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc d
_sigHead :: Sig RdrName -> String
_sigHead = \case
TypeSig names _ -> "TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names)
TypeSig names _ ->
"TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names)
_ -> "unknown sig"
_bindHead :: HsBind RdrName -> String

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
=> ast
-> BriDocNumbered
-> PPM ()
layoutBriDoc :: Data.Data.Data ast => ast -> BriDocNumbered -> PPM ()
layoutBriDoc ast briDoc = do
-- first step: transform the briDoc.
briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do
briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do
traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw
$ briDocToDoc
$ unwrapBriDocNumbered
$ briDoc
-- bridoc transformation: remove alts
transformAlts briDoc >>= mSet
mGet >>= traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt . briDocToDoc
mGet
>>= traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt
. briDocToDoc
-- bridoc transformation: float stuff in
mGet <&> transformSimplifyFloating >>= mSet
mGet >>= traceIfDumpConf "bridoc post-floating" _dconf_dump_bridoc_simpl_floating . briDocToDoc
mGet
>>= traceIfDumpConf "bridoc post-floating"
_dconf_dump_bridoc_simpl_floating
. briDocToDoc
-- bridoc transformation: par removal
mGet <&> transformSimplifyPar >>= mSet
mGet >>= traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par . briDocToDoc
mGet
>>= traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par
. briDocToDoc
-- bridoc transformation: float stuff in
mGet <&> transformSimplifyColumns >>= mSet
mGet >>= traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns . briDocToDoc
mGet
>>= traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns
. briDocToDoc
-- -- bridoc transformation: indent
mGet <&> transformSimplifyIndent >>= mSet
mGet >>= traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent . briDocToDoc
mGet >>= traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final . briDocToDoc
mGet
>>= traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent
. briDocToDoc
mGet
>>= traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final
. briDocToDoc
-- -- convert to Simple type
-- simpl <- mGet <&> transformToSimple
-- return simpl
@ -100,31 +110,35 @@ layoutBriDoc ast briDoc = do
anns :: ExactPrint.Types.Anns <- mAsk
let filteredAnns = filterAnns ast anns
traceIfDumpConf "bridoc annotations filtered/transformed" _dconf_dump_annotations $ annsDoc filteredAnns
traceIfDumpConf "bridoc annotations filtered/transformed"
_dconf_dump_annotations
$ annsDoc filteredAnns
let state = LayoutState
{ _lstate_baseYs = [0]
{ _lstate_baseYs = [0]
, _lstate_curYOrAddNewline = Right 0 -- important that we use left here
-- because moveToAnn stuff of the
-- first node needs to do its
-- thing properly.
, _lstate_indLevels = [0]
, _lstate_indLevelLinger = 0
, _lstate_comments = filteredAnns
, _lstate_commentCol = Nothing
, _lstate_addSepSpace = Nothing
, _lstate_inhibitMTEL = False
, _lstate_indLevels = [0]
, _lstate_indLevelLinger = 0
, _lstate_comments = filteredAnns
, _lstate_commentCol = Nothing
, _lstate_addSepSpace = Nothing
, _lstate_inhibitMTEL = False
}
state' <- MultiRWSS.withMultiStateS state
$ layoutBriDocM briDoc'
state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
let remainingComments =
extractAllComments =<< Map.elems (_lstate_comments state')
remainingComments `forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fst)
let
remainingComments =
extractAllComments =<< Map.elems (_lstate_comments state')
remainingComments
`forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fst)
return $ ()
data AltCurPos = AltCurPos
{ _acp_line :: Int -- chars in the current line
, _acp_indent :: Int -- current indentation level
@ -142,16 +156,16 @@ data AltLineModeState
deriving (Show)
altLineModeDecay :: AltLineModeState -> AltLineModeState
altLineModeDecay AltLineModeStateNone = AltLineModeStateNone
altLineModeDecay AltLineModeStateNone = AltLineModeStateNone
altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True
altLineModeDecay (AltLineModeStateForceML True) = AltLineModeStateNone
altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL
altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction
altLineModeDecay (AltLineModeStateForceML True ) = AltLineModeStateNone
altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL
altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction
altLineModeRefresh :: AltLineModeState -> AltLineModeState
altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone
altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False
altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL
altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone
altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False
altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL
altLineModeRefresh AltLineModeStateContradiction = AltLineModeStateContradiction
mergeLineMode :: AltCurPos -> AltLineModeState -> AltCurPos
@ -159,7 +173,8 @@ mergeLineMode acp s = case (_acp_forceMLFlag acp, s) of
(AltLineModeStateContradiction, _) -> acp
(AltLineModeStateNone, x) -> acp { _acp_forceMLFlag = x }
(AltLineModeStateForceSL, AltLineModeStateForceSL) -> acp
(AltLineModeStateForceML{}, AltLineModeStateForceML{}) -> acp { _acp_forceMLFlag = s }
(AltLineModeStateForceML{}, AltLineModeStateForceML{}) ->
acp { _acp_forceMLFlag = s }
_ -> acp { _acp_forceMLFlag = AltLineModeStateContradiction }
-- removes any BDAlt's from the BriDoc
@ -170,10 +185,12 @@ transformAlts
)
=> BriDocNumbered
-> MultiRWSS.MultiRWS r w s BriDoc
transformAlts briDoc
= MultiRWSS.withMultiStateA
(AltCurPos 0 0 0 AltLineModeStateNone)
$ Memo.startEvalMemoT $ fmap unwrapBriDocNumbered $ rec $ briDoc
transformAlts briDoc =
MultiRWSS.withMultiStateA (AltCurPos 0 0 0 AltLineModeStateNone)
$ Memo.startEvalMemoT
$ fmap unwrapBriDocNumbered
$ rec
$ briDoc
where
-- this funtion is exponential by nature and cannot be improved in any
-- way i can think of, and if tried. (stupid StableNames.)
@ -459,7 +476,11 @@ transformAlts briDoc
hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _)
= line + sameLine <= confUnpack (_lconfig_cols lconf)
getSpacing :: forall m . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) => BriDocNumbered -> m (LineModeValidity VerticalSpacing)
getSpacing
:: forall m
. (MonadMultiReader Config m, MonadMultiWriter (Seq String) m)
=> BriDocNumbered
-> m (LineModeValidity VerticalSpacing)
getSpacing !bridoc = rec bridoc
where
rec :: BriDocNumbered -> m (LineModeValidity VerticalSpacing)
@ -637,8 +658,12 @@ getSpacing !bridoc = rec bridoc
VerticalSpacingParNone -> 0
VerticalSpacingParAlways i -> i
getSpacings :: forall m . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m)
=> Int -> BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing]
getSpacings
:: forall m
. (MonadMultiReader Config m, MonadMultiWriter (Seq String) m)
=> Int
-> BriDocNumbered
-> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing]
getSpacings limit bridoc = preFilterLimit <$> rec bridoc
where
preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing]
@ -883,21 +908,21 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- note that this is not total, and cannot be with that exact signature.
mergeIndents :: BrIndent -> BrIndent -> BrIndent
mergeIndents BrIndentNone x = x
mergeIndents x BrIndentNone = x
mergeIndents BrIndentNone x = x
mergeIndents x BrIndentNone = x
mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j)
mergeIndents _ _ = error "mergeIndents"
mergeIndents _ _ = error "mergeIndents"
-- TODO: move to uniplate upstream?
-- 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
_transformDown :: Uniplate.Uniplate on => (on -> on) -> (on -> on)
_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
_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
@ -1078,29 +1103,31 @@ transformSimplifyPar = transformUp $ \case
-- Just $ BDPar ind1 line (BDLines [p1, p2])
x@(BDPar _ (BDPar _ BDPar{} _) _) -> x
BDPar ind1 (BDPar ind2 line p1) (BDLines indenteds) ->
BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1: indenteds))
BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds))
BDPar ind1 (BDPar ind2 line p1) p2 ->
BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2])
BDLines lines | any (\case BDLines{} -> True
BDEmpty{} -> True
_ -> False) lines ->
case go lines of
[] -> BDEmpty
[x] -> x
xs -> BDLines xs
where
go = (=<<) $ \case
BDLines l -> go l
BDEmpty -> []
x -> [x]
BDLines [] -> BDEmpty
BDLines [x] -> x
BDLines lines | any ( \case
BDLines{} -> True
BDEmpty{} -> True
_ -> False
)
lines -> case go lines of
[] -> BDEmpty
[x] -> x
xs -> BDLines xs
where
go = (=<<) $ \case
BDLines l -> go l
BDEmpty -> []
x -> [x]
BDLines [] -> BDEmpty
BDLines [x] -> x
-- BDCols sig cols | BDPar ind line indented <- List.last cols ->
-- Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented
-- BDPar BrIndentNone line indented ->
-- Just $ BDLines [line, indented]
BDEnsureIndent BrIndentNone x -> x
x -> x
x -> x
isNotEmpty :: BriDoc -> Bool
isNotEmpty BDEmpty = False
@ -1243,28 +1270,29 @@ transformSimplifyIndent = Uniplate.rewrite $ \case
-- [ BDAddBaseY ind x
-- , BDEnsureIndent ind indented
-- ]
BDLines lines | any (\case BDLines{} -> True
BDEmpty{} -> True
_ -> False) lines ->
BDLines lines | any ( \case
BDLines{} -> True
BDEmpty{} -> True
_ -> False
)
lines ->
Just $ BDLines $ filter isNotEmpty $ lines >>= \case
BDLines l -> l
x -> [x]
BDLines [l] ->
Just l
x -> [x]
BDLines [l] -> Just l
BDAddBaseY i (BDAnnotationPrior k 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)
BDAddBaseY i (BDAnnotationRest k x) ->
BDAddBaseY i (BDAnnotationRest k x) ->
Just $ BDAnnotationRest k (BDAddBaseY i x)
BDAddBaseY i (BDSeq l) ->
Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l]
BDAddBaseY i (BDCols sig l) ->
Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l]
BDAddBaseY _ lit@BDLit{} ->
Just lit
BDAddBaseY _ lit@BDLit{} -> Just lit
_ -> Nothing
_ -> Nothing
briDocLineLength :: BriDoc -> Int
@ -1273,35 +1301,35 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
-- appended at the current position.
where
rec = \case
BDEmpty -> return $ 0
BDLit t -> StateS.put False $> Text.length t
BDSeq bds -> sum <$> rec `mapM` bds
BDCols _ bds -> sum <$> rec `mapM` bds
BDEmpty -> return $ 0
BDLit t -> StateS.put False $> Text.length t
BDSeq bds -> sum <$> rec `mapM` bds
BDCols _ bds -> sum <$> rec `mapM` bds
BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1
BDAddBaseY _ bd -> rec bd
BDBaseYPushCur bd -> rec bd
BDBaseYPop bd -> rec bd
BDAddBaseY _ bd -> rec bd
BDBaseYPushCur bd -> rec bd
BDBaseYPop bd -> rec bd
BDIndentLevelPushCur bd -> rec bd
BDIndentLevelPop bd -> rec bd
BDPar _ line _ -> rec line
BDAlt{} -> error "briDocLineLength BDAlt"
BDForceMultiline bd -> rec bd
BDForceSingleline bd -> rec bd
BDForwardLineMode bd -> rec bd
BDExternal _ _ _ t -> return $ Text.length t
BDAnnotationPrior _ bd -> rec bd
BDAnnotationKW _ _ bd -> rec bd
BDAnnotationRest _ bd -> rec bd
BDLines ls@(_:_) -> do
BDIndentLevelPop bd -> rec bd
BDPar _ line _ -> rec line
BDAlt{} -> error "briDocLineLength BDAlt"
BDForceMultiline bd -> rec bd
BDForceSingleline bd -> rec bd
BDForwardLineMode bd -> rec bd
BDExternal _ _ _ t -> return $ Text.length t
BDAnnotationPrior _ bd -> rec bd
BDAnnotationKW _ _ bd -> rec bd
BDAnnotationRest _ bd -> rec bd
BDLines ls@(_:_) -> do
x <- StateS.get
return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x
BDLines [] -> error "briDocLineLength BDLines []"
BDEnsureIndent _ bd -> rec bd
BDProhibitMTEL bd -> rec bd
BDSetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd
BDNonBottomSpacing bd -> rec bd
BDDebug _ bd -> rec bd
BDLines [] -> error "briDocLineLength BDLines []"
BDEnsureIndent _ bd -> rec bd
BDProhibitMTEL bd -> rec bd
BDSetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd
BDNonBottomSpacing bd -> rec bd
BDDebug _ bd -> rec bd
layoutBriDocM
:: 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 = do
-- TODO: why does the default not trigger; ind never should be []!!
ind <- addFlagReadParam "" ["indent"] "AMOUNT"
(flagHelpStr "spaces per indentation level")
cols <- addFlagReadParam "" ["columns"] "AMOUNT"
(flagHelpStr "target max columns (80 is an old default for this)")
importCol <- addFlagReadParam "" ["import-col"] "N"
(flagHelpStr "column to align import lists at")
ind <- addFlagReadParam "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level")
cols <- addFlagReadParam "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)")
importCol <- addFlagReadParam "" ["import-col"] "N" (flagHelpStr "column to align import lists at")
dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (commandline + file + defaults)")
dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint")
dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany")
dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast")
dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc")
dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt")
dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par")
dumpBriDocFloating <- addSimpleBoolFlag "" ["dump-bridoc-floating"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating")
dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns")
dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent")
dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc")
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")
dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany")
dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast")
dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc")
dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt")
dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par")
dumpBriDocFloating <- addSimpleBoolFlag ""
["dump-bridoc-floating"]
(flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating")
dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns")
dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent")
dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc")
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
{ _conf_debug = DebugConfig
{ _dconf_dump_config = wrapLast $ falseToNothing dumpConfig
, _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations
, _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST
, _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST
{ _conf_debug = DebugConfig
{ _dconf_dump_config = wrapLast $ falseToNothing dumpConfig
, _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations
, _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST
, _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST
, _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw
, _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt
, _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar
@ -111,7 +117,7 @@ configParser = do
, _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent
, _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal
}
, _conf_layout = LayoutConfig
, _conf_layout = LayoutConfig
{ _lconfig_cols = optionConcat cols
, _lconfig_indentPolicy = mempty
, _lconfig_indentAmount = optionConcat ind
@ -126,18 +132,16 @@ configParser = do
, _econf_Werror = wrapLast $ falseToNothing wError
, _econf_CPPMode = mempty
}
, _conf_forward = ForwardOptions
{ _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs
| not $ null optionsGhc
]
, _conf_forward = ForwardOptions
{ _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ]
}
}
where falseToNothing = Option . Bool.bool Nothing (Just True)
wrapLast :: Option a -> Option (Semigroup.Last a)
wrapLast = fmap Semigroup.Last
optionConcat
:: (Semigroup.Semigroup (f a), Applicative f) => [a] -> Option (f a)
optionConcat = mconcat . fmap (pure . pure)
where
falseToNothing = Option . Bool.bool Nothing (Just True)
wrapLast :: Option a -> Option (Semigroup.Last a)
wrapLast = fmap Semigroup.Last
optionConcat :: (Semigroup.Semigroup (f a), Applicative f) => [a] -> Option (f a)
optionConcat = mconcat . fmap (pure . pure)
-- configParser :: Parser 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
{ _conf_debug = DebugConfig
{ _dconf_dump_config = coerce False
, _dconf_dump_annotations = coerce False
, _dconf_dump_ast_unknown = coerce False
, _dconf_dump_ast_full = coerce False
, _dconf_dump_bridoc_raw = coerce False
, _dconf_dump_bridoc_simpl_alt = coerce False
, _dconf_dump_bridoc_simpl_floating = coerce False
, _dconf_dump_bridoc_simpl_par = coerce False
, _dconf_dump_bridoc_simpl_columns = coerce False
, _dconf_dump_bridoc_simpl_indent = coerce False
, _dconf_dump_bridoc_final = coerce False
}
, _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_debug = DebugConfig
{ _dconf_dump_config = coerce False
, _dconf_dump_annotations = coerce False
, _dconf_dump_ast_unknown = coerce False
, _dconf_dump_ast_full = coerce False
, _dconf_dump_bridoc_raw = coerce False
, _dconf_dump_bridoc_simpl_alt = coerce False
, _dconf_dump_bridoc_simpl_floating = coerce False
, _dconf_dump_bridoc_simpl_par = coerce False
, _dconf_dump_bridoc_simpl_columns = coerce False
, _dconf_dump_bridoc_simpl_indent = coerce False
, _dconf_dump_bridoc_final = coerce False
}
, _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
-- 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
follows = ExactPrint.annFollowingComments ann1
assocs = ExactPrint.annsDP ann1
let processCom
:: (ExactPrint.Comment, ExactPrint.DeltaPos)
-> ExactPrint.TransformT Identity Bool
processCom comPair@(com, _) =
case GHC.srcSpanStart $ ExactPrint.commentIdentifier com of
GHC.UnhelpfulLoc{} -> return True -- retain comment at current node.
GHC.RealSrcLoc comLoc -> case Map.lookupLE comLoc annsMap of
Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of
(ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") ->
move $> False
(x,y) | x==y -> move $> False
_ -> return True
where
ExactPrint.AnnKey annKeyLoc1 con1 = annKey1
ExactPrint.AnnKey annKeyLoc2 con2 = annKey2
loc1 = GHC.srcSpanStart annKeyLoc1
loc2 = GHC.srcSpanStart annKeyLoc2
move = ExactPrint.modifyAnnsT $ \anns ->
let ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns
ann2' = ann2
{ ExactPrint.annFollowingComments =
ExactPrint.annFollowingComments ann2 ++ [comPair]
}
in Map.insert annKey2 ann2' anns
_ -> return True -- retain comment at current node.
let
processCom
:: (ExactPrint.Comment, ExactPrint.DeltaPos)
-> ExactPrint.TransformT Identity Bool
processCom comPair@(com, _) =
case GHC.srcSpanStart $ ExactPrint.commentIdentifier com of
GHC.UnhelpfulLoc{} -> return True -- retain comment at current node.
GHC.RealSrcLoc comLoc -> case Map.lookupLE comLoc annsMap of
Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of
(ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") ->
move $> False
(x, y) | x == y -> move $> False
_ -> return True
where
ExactPrint.AnnKey annKeyLoc1 con1 = annKey1
ExactPrint.AnnKey annKeyLoc2 con2 = annKey2
loc1 = GHC.srcSpanStart annKeyLoc1
loc2 = GHC.srcSpanStart annKeyLoc2
move = ExactPrint.modifyAnnsT $ \anns ->
let
ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns
ann2' = ann2
{ ExactPrint.annFollowingComments =
ExactPrint.annFollowingComments ann2 ++ [comPair]
}
in
Map.insert annKey2 ann2' anns
_ -> return True -- retain comment at current node.
priors' <- flip filterM priors processCom
follows' <- flip filterM follows $ processCom
assocs' <- flip filterM assocs $ \case

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

@ -135,11 +135,13 @@ traceLocal x = do
traceLocal _ = return ()
#endif
processDefault :: (ExactPrint.Annotate.Annotate ast, MonadMultiWriter
Text.Builder.Builder m,
MonadMultiReader ExactPrint.Types.Anns m)
=> GenLocated SrcSpan ast
-> m ()
processDefault
:: ( ExactPrint.Annotate.Annotate ast
, MonadMultiWriter Text.Builder.Builder m
, MonadMultiReader ExactPrint.Types.Anns m
)
=> GenLocated SrcSpan ast
-> m ()
processDefault x = do
anns <- mAsk
let str = ExactPrint.exactPrint x anns
@ -152,55 +154,66 @@ processDefault x = do
"\n" -> return ()
_ -> mTell $ Text.Builder.fromString $ str
briDocByExact :: (ExactPrint.Annotate.Annotate ast) => GenLocated SrcSpan ast -> ToBriDocM BriDocNumbered
-- | Use ExactPrint's output for this node; add a newly generated inline comment
-- at insertion position (meant to point out to the user that this node is
-- not handled by brittany yet). Useful when starting implementing new
-- syntactic constructs when children are not handled yet.
briDocByExact
:: (ExactPrint.Annotate.Annotate ast)
=> GenLocated SrcSpan ast
-> ToBriDocM BriDocNumbered
briDocByExact ast = do
anns <- mAsk
traceIfDumpConf "ast" _dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
traceIfDumpConf "ast"
_dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
docExt ast anns True
briDocByExactNoComment :: (ExactPrint.Annotate.Annotate ast) => GenLocated SrcSpan ast -> ToBriDocM BriDocNumbered
-- | Use ExactPrint's output for this node.
briDocByExactNoComment
:: (ExactPrint.Annotate.Annotate ast)
=> GenLocated SrcSpan ast
-> ToBriDocM BriDocNumbered
briDocByExactNoComment ast = do
anns <- mAsk
traceIfDumpConf "ast" _dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
traceIfDumpConf "ast"
_dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
docExt ast anns False
rdrNameToText :: RdrName -> Text
-- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr
rdrNameToText ( Unqual occname ) = Text.pack $ occNameString occname
rdrNameToText ( Qual mname occname ) = Text.pack $ moduleNameString mname
++ "."
++ occNameString occname
rdrNameToText ( Orig modul occname ) = Text.pack $ moduleNameString (moduleName modul)
++ occNameString occname
rdrNameToText ( Exact name ) = Text.pack $ getOccString name
rdrNameToText (Unqual occname) = Text.pack $ occNameString occname
rdrNameToText (Qual mname occname) =
Text.pack $ moduleNameString mname ++ "." ++ occNameString occname
rdrNameToText (Orig modul occname) =
Text.pack $ moduleNameString (moduleName modul) ++ occNameString occname
rdrNameToText (Exact name) = Text.pack $ getOccString name
lrdrNameToText :: GenLocated l RdrName -> Text
lrdrNameToText (L _ n) = rdrNameToText n
lrdrNameToTextAnn :: ( MonadMultiReader Config m
, MonadMultiReader (Map AnnKey Annotation) m
)
=> GenLocated SrcSpan RdrName
-> m Text
lrdrNameToTextAnn
:: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
=> GenLocated SrcSpan RdrName
-> m Text
lrdrNameToTextAnn ast@(L _ n) = do
anns <- mAsk
let t = rdrNameToText n
let hasUni x (ExactPrint.Types.G y, _) = x==y
hasUni _ _ = False
let hasUni x (ExactPrint.Types.G y, _) = x == y
hasUni _ _ = False
-- TODO: in general: we should _always_ process all annotaiton stuff here.
-- whatever we don't probably should have had some effect on the
-- output. in such cases, resorting to byExact is probably the safe
-- choice.
return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of
Nothing -> t
Nothing -> t
Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of
Exact{} | t == Text.pack "()" -> t
_ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`"
Exact{} | t == Text.pack "()" -> t
_ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`"
_ | any (hasUni AnnCommaTuple) aks -> t
_ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")"
_ | otherwise -> t
_ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")"
_ | otherwise -> t
lrdrNameToTextAnnTypeEqualityIsSpecial
:: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
@ -209,18 +222,19 @@ lrdrNameToTextAnnTypeEqualityIsSpecial
lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
x <- lrdrNameToTextAnn ast
return $ if x == Text.pack "Data.Type.Equality~"
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
else x
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
else x
askIndent :: (MonadMultiReader Config m) => m Int
askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk
layoutWriteAppend :: (MonadMultiWriter
Text.Builder.Builder m,
MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m)
=> Text
-> m ()
layoutWriteAppend
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Text
-> m ()
layoutWriteAppend t = do
traceLocal ("layoutWriteAppend", t)
state <- mGet
@ -250,32 +264,32 @@ layoutWriteAppend t = do
, _lstate_addSepSpace = Nothing
}
layoutWriteAppendSpaces :: (MonadMultiWriter
Text.Builder.Builder m,
MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m)
=> Int
-> m ()
layoutWriteAppendSpaces
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Int
-> m ()
layoutWriteAppendSpaces i = do
traceLocal ("layoutWriteAppendSpaces", i)
unless (i==0) $ do
unless (i == 0) $ do
state <- mGet
mSet $ state { _lstate_addSepSpace = Just
$ maybe i (+i)
$ _lstate_addSepSpace state
}
mSet $ state
{ _lstate_addSepSpace = Just $ maybe i (+i) $ _lstate_addSepSpace state
}
layoutWriteAppendMultiline :: (MonadMultiWriter
Text.Builder.Builder m,
MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m)
=> Text
-> m ()
layoutWriteAppendMultiline
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Text
-> m ()
layoutWriteAppendMultiline t = do
traceLocal ("layoutWriteAppendMultiline", t)
case Text.lines t of
[] ->
layoutWriteAppend t -- need to write empty, too.
[] -> layoutWriteAppend t -- need to write empty, too.
(l:lr) -> do
layoutWriteAppend l
lr `forM_` \x -> do
@ -283,17 +297,18 @@ layoutWriteAppendMultiline t = do
layoutWriteAppend x
-- adds a newline and adds spaces to reach the base column.
layoutWriteNewlineBlock :: (MonadMultiWriter
Text.Builder.Builder m,
MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m)
=> m ()
layoutWriteNewlineBlock
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> m ()
layoutWriteNewlineBlock = do
traceLocal ("layoutWriteNewlineBlock")
state <- mGet
mSet $ state { _lstate_curYOrAddNewline = Right 1
, _lstate_addSepSpace = Just $ lstate_baseY state
, _lstate_inhibitMTEL = False
, _lstate_addSepSpace = Just $ lstate_baseY state
, _lstate_inhibitMTEL = False
}
-- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m
@ -310,13 +325,12 @@ layoutWriteNewlineBlock = do
-- else _lstate_indLevelLinger state + i - _lstate_curY state
-- }
layoutSetCommentCol :: ( MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m )
=> m ()
layoutSetCommentCol
:: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
layoutSetCommentCol = do
state <- mGet
let col = case _lstate_curYOrAddNewline state of
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Right{} -> lstate_baseY state
traceLocal ("layoutSetCommentCol", col)
unless (Data.Maybe.isJust $ _lstate_commentCol state)
@ -337,90 +351,93 @@ layoutMoveToCommentPos y x = do
then do
mSet state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left i -> if y==0 then Left i else Right y
Left i -> if y == 0 then Left i else Right y
Right{} -> Right y
, _lstate_addSepSpace = Just $ case _lstate_curYOrAddNewline state of
Left{} -> if y==0
then x
else _lstate_indLevelLinger state + x
Right{} -> _lstate_indLevelLinger state + x
Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x
Right{} -> _lstate_indLevelLinger state + x
}
else do
mSet state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left i -> if y==0 then Left i else Right y
Left i -> if y == 0 then Left i else Right y
Right{} -> Right y
, _lstate_addSepSpace = Just $ if y==0
then x
else _lstate_indLevelLinger state + x
, _lstate_addSepSpace = Just
$ if y == 0 then x else _lstate_indLevelLinger state + x
, _lstate_commentCol = Just $ case _lstate_curYOrAddNewline state of
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Right{} -> lstate_baseY state
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Right{} -> lstate_baseY state
}
-- | does _not_ add spaces to again reach the current base column.
layoutWriteNewline :: (MonadMultiWriter
Text.Builder.Builder m,
MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m)
=> m ()
layoutWriteNewline
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> m ()
layoutWriteNewline = do
traceLocal ("layoutWriteNewline")
state <- mGet
mSet $ state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left{} -> Right 1
Right i -> Right (i+1)
, _lstate_addSepSpace = Nothing
, _lstate_inhibitMTEL = False
}
mSet $ state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left{} -> Right 1
Right i -> Right (i + 1)
, _lstate_addSepSpace = Nothing
, _lstate_inhibitMTEL = False
}
layoutWriteEnsureNewlineBlock :: (MonadMultiWriter
Text.Builder.Builder m,
MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m)
=> m ()
layoutWriteEnsureNewlineBlock
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> m ()
layoutWriteEnsureNewlineBlock = do
traceLocal ("layoutWriteEnsureNewlineBlock")
state <- mGet
mSet $ state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left{} -> Right 1
Right i -> Right $ max 1 i
, _lstate_addSepSpace = Just $ lstate_baseY state
, _lstate_inhibitMTEL = False
, _lstate_commentCol = Nothing
Left{} -> Right 1
Right i -> Right $ max 1 i
, _lstate_addSepSpace = Just $ lstate_baseY state
, _lstate_inhibitMTEL = False
, _lstate_commentCol = Nothing
}
layoutWriteEnsureBlock :: (MonadMultiWriter
Text.Builder.Builder m,
MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m)
=> m ()
layoutWriteEnsureBlock
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> m ()
layoutWriteEnsureBlock = do
traceLocal ("layoutWriteEnsureBlock")
state <- mGet
let
diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of
(Nothing, Left i) -> lstate_baseY state - i
(Nothing, Left i ) -> lstate_baseY state - i
(Nothing, Right{}) -> lstate_baseY state
(Just sp, Left i) -> max sp (lstate_baseY state - i)
(Just sp, Left i ) -> max sp (lstate_baseY state - i)
(Just sp, Right{}) -> max sp (lstate_baseY state)
-- when (diff>0) $ layoutWriteNewlineBlock
when (diff > 0) $ do
mSet $ state { _lstate_addSepSpace = Just $ diff }
layoutWriteEnsureAbsoluteN :: (MonadMultiWriter
Text.Builder.Builder m,
MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m)
=> Int -> m ()
layoutWriteEnsureAbsoluteN
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Int
-> m ()
layoutWriteEnsureAbsoluteN n = do
state <- mGet
let diff = case _lstate_curYOrAddNewline state of
Left i -> n-i
Left i -> n - i
Right{} -> n
traceLocal ("layoutWriteEnsureAbsoluteN", n, diff)
when (diff>0) $ do
when (diff > 0) $ do
mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to
-- at least (Just 1), so we won't
-- overwrite any old value in any
@ -448,7 +465,7 @@ layoutIndentLevelPushInternal
layoutIndentLevelPushInternal i = do
traceLocal ("layoutIndentLevelPushInternal", i)
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
, _lstate_indLevels = i : _lstate_indLevels s
, _lstate_indLevels = i : _lstate_indLevels s
}
layoutIndentLevelPopInternal
@ -456,7 +473,7 @@ layoutIndentLevelPopInternal
layoutIndentLevelPopInternal = do
traceLocal ("layoutIndentLevelPopInternal")
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
@ -469,13 +486,14 @@ layoutRemoveIndentLevelLinger = do
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
}
layoutWithAddBaseCol :: (MonadMultiWriter
Text.Builder.Builder m,
MonadMultiState LayoutState m
,MonadMultiReader Config m
, MonadMultiWriter (Seq String) m)
=> m ()
-> m ()
layoutWithAddBaseCol
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiReader Config m
, MonadMultiWriter (Seq String) m
)
=> m ()
-> m ()
layoutWithAddBaseCol m = do
#if INSERTTRACES
tellDebugMessShow ("layoutWithAddBaseCol")
@ -521,13 +539,14 @@ layoutWithAddBaseColNBlock amount m = do
m
layoutBaseYPopInternal
layoutWithAddBaseColN :: (MonadMultiWriter
Text.Builder.Builder m,
MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m)
=> Int
-> m ()
-> m ()
layoutWithAddBaseColN
:: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> Int
-> m ()
-> m ()
layoutWithAddBaseColN amount m = do
#if INSERTTRACES
tellDebugMessShow ("layoutWithAddBaseColN", amount)
@ -543,10 +562,11 @@ layoutBaseYPushCur = do
traceLocal ("layoutBaseYPushCur")
state <- mGet
case _lstate_commentCol state of
Nothing -> case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i, Just j) -> layoutBaseYPushInternal (i+j)
(Left i, Nothing) -> layoutBaseYPushInternal i
(Right{}, _) -> layoutBaseYPushInternal $ lstate_baseY state
Nothing ->
case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i , Just j ) -> layoutBaseYPushInternal (i + j)
(Left i , Nothing) -> layoutBaseYPushInternal i
(Right{}, _ ) -> layoutBaseYPushInternal $ lstate_baseY state
Just cCol -> layoutBaseYPushInternal cCol
layoutBaseYPop
@ -561,9 +581,9 @@ layoutIndentLevelPushCur = do
traceLocal ("layoutIndentLevelPushCur")
state <- mGet
let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i, Just j) -> i + j
(Left i, Nothing) -> i
(Right{}, Just j) -> j
(Left i , Just j ) -> i + j
(Left i , Nothing) -> i
(Right{}, Just j ) -> j
(Right{}, Nothing) -> 0
layoutIndentLevelPushInternal y
layoutBaseYPushInternal y
@ -588,7 +608,8 @@ layoutAddSepSpace = do
tellDebugMessShow ("layoutAddSepSpace")
#endif
state <- mGet
mSet $ state { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state }
mSet $ state
{ _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state }
-- TODO: when refactoring is complete, the other version of this method
-- can probably be removed.
@ -604,22 +625,25 @@ moveToExactAnn annKey = do
traceLocal ("moveToExactAnn", annKey)
anns <- mAsk
case Map.lookup annKey anns of
Nothing -> return ()
Nothing -> return ()
Just ann -> do
-- curY <- mGet <&> _lstate_curY
let ExactPrint.Types.DP (y, _x) = ExactPrint.Types.annEntryDelta ann
-- mModify $ \state -> state { _lstate_addNewline = Just x }
mModify $ \state ->
let upd = case _lstate_curYOrAddNewline state of
Left i -> if y==0 then Left i else Right y
Left i -> if y == 0 then Left i else Right y
Right i -> Right $ max y i
in state
{ _lstate_curYOrAddNewline = upd
, _lstate_addSepSpace = if Data.Either.isRight upd
then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just (lstate_baseY state)
else Nothing
, _lstate_commentCol = Nothing
}
in state
{ _lstate_curYOrAddNewline = upd
, _lstate_addSepSpace = if Data.Either.isRight upd
then
_lstate_commentCol state
<|> _lstate_addSepSpace state
<|> Just (lstate_baseY state)
else Nothing
, _lstate_commentCol = Nothing
}
-- fixMoveToLineByIsNewline :: MonadMultiState
-- LayoutState m => Int -> m Int
-- fixMoveToLineByIsNewline x = do
@ -628,18 +652,22 @@ moveToExactAnn annKey = do
-- then x-1
-- else x
ppmMoveToExactLoc :: MonadMultiWriter Text.Builder.Builder m
=> ExactPrint.Types.DeltaPos
-> m ()
ppmMoveToExactLoc (ExactPrint.Types.DP (x,y)) = do
ppmMoveToExactLoc
:: MonadMultiWriter Text.Builder.Builder m
=> ExactPrint.Types.DeltaPos
-> m ()
ppmMoveToExactLoc (ExactPrint.Types.DP (x, y)) = do
replicateM_ x $ mTell $ Text.Builder.fromString "\n"
replicateM_ y $ mTell $ Text.Builder.fromString " "
layoutWritePriorComments :: (Data.Data.Data ast,
MonadMultiWriter Text.Builder.Builder m,
MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m)
=> GenLocated SrcSpan ast -> m ()
layoutWritePriorComments
:: ( Data.Data.Data ast
, MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
, MonadMultiWriter (Seq String) m
)
=> GenLocated SrcSpan ast
-> m ()
layoutWritePriorComments ast = do
mAnn <- do
state <- mGet
@ -743,49 +771,43 @@ extractAllComments
extractAllComments ann =
ExactPrint.annPriorComments ann
++ ExactPrint.annFollowingComments ann
++ (ExactPrint.annsDP ann >>= \case
++ ( ExactPrint.annsDP ann >>= \case
(ExactPrint.AnnComment com, dp) -> [(com, dp)]
_ -> []
_ -> []
)
foldedAnnKeys :: Data.Data.Data ast
=> ast
-> Set ExactPrint.AnnKey
foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey
foldedAnnKeys ast = everything
Set.union
(\x -> maybe
Set.empty
Set.singleton
[ gmapQi 1 (\t -> ExactPrint.mkAnnKey $ L l t) x
| locTyCon == typeRepTyCon (typeOf x)
, l <- gmapQi 0 cast x
]
( \x -> maybe Set.empty
Set.singleton
[ gmapQi 1 (\t -> ExactPrint.mkAnnKey $ L l t) x
| locTyCon == typeRepTyCon (typeOf x)
, l <- gmapQi 0 cast x
]
)
ast
where
locTyCon = typeRepTyCon (typeOf (L () ()))
filterAnns :: Data.Data.Data ast
=> ast
-> ExactPrint.Anns
-> ExactPrint.Anns
filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns
filterAnns ast anns =
Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) anns
hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool
hasAnyCommentsBelow ast@(L l _) = do
anns <- filterAnns ast <$> mAsk
return $ List.any (\(c, _) -> ExactPrint.commentIdentifier c > l)
$ (=<<) extractAllComments
$ Map.elems
$ anns
return
$ List.any (\(c, _) -> ExactPrint.commentIdentifier c > l)
$ (=<<) extractAllComments
$ Map.elems
$ anns
-- new BriDoc stuff
allocateNode :: MonadMultiState NodeAllocIndex m
=> BriDocFInt
-> m BriDocNumbered
allocateNode
:: MonadMultiState NodeAllocIndex m => BriDocFInt -> m BriDocNumbered
allocateNode bd = do
i <- allocNodeIndex
return (i, bd)
@ -793,7 +815,7 @@ allocateNode bd = do
allocNodeIndex :: MonadMultiState NodeAllocIndex m => m Int
allocNodeIndex = do
NodeAllocIndex i <- mGet
mSet $ NodeAllocIndex (i+1)
mSet $ NodeAllocIndex (i + 1)
return i
-- docEmpty :: MonadMultiState NodeAllocIndex m => m BriDocNumbered
@ -901,13 +923,17 @@ docEmpty = allocateNode BDFEmpty
docLit :: Text -> ToBriDocM BriDocNumbered
docLit t = allocateNode $ BDFLit t
docExt :: (ExactPrint.Annotate.Annotate ast)
=> GenLocated SrcSpan ast -> ExactPrint.Types.Anns -> Bool -> ToBriDocM BriDocNumbered
docExt
:: (ExactPrint.Annotate.Annotate ast)
=> GenLocated SrcSpan ast
-> ExactPrint.Types.Anns
-> Bool
-> ToBriDocM BriDocNumbered
docExt x anns shouldAddComment = allocateNode $ BDFExternal
(ExactPrint.Types.mkAnnKey x)
(foldedAnnKeys x)
shouldAddComment
(Text.pack $ ExactPrint.exactPrint x anns)
(ExactPrint.Types.mkAnnKey x)
(foldedAnnKeys x)
shouldAddComment
(Text.pack $ ExactPrint.exactPrint x anns)
docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
docAlt l = allocateNode . BDFAlt =<< sequence l
@ -955,7 +981,10 @@ docAnnotationPrior
docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm
docAnnotationKW
:: AnnKey -> Maybe AnnKeywordId -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
:: AnnKey
-> Maybe AnnKeywordId
-> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm
docAnnotationRest
@ -1110,11 +1139,12 @@ instance DocWrapable ([BriDocNumbered], BriDocNumbered, a) where
docPar :: ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
docPar
:: ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered
docPar lineM indentedM = do
line <- lineM
line <- lineM
indented <- indentedM
allocateNode $ BDFPar BrIndentNone line indented
@ -1124,7 +1154,8 @@ docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm
docForceMultiline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm
docEnsureIndent :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docEnsureIndent
:: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd
unknownNodeError
@ -1140,13 +1171,14 @@ spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds]
briDocMToPPM :: ToBriDocM a -> PPM a
briDocMToPPM m = do
readers <- MultiRWSS.mGetRawR
let ((x, errs), debugs) = runIdentity
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiStateA (NodeAllocIndex 1)
$ MultiRWSS.withMultiReaders readers
$ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterAW
$ m
let ((x, errs), debugs) =
runIdentity
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiStateA (NodeAllocIndex 1)
$ MultiRWSS.withMultiReaders readers
$ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterAW
$ m
mTell debugs
mTell errs
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
nameStrs <- names `forM` lrdrNameToTextAnn
let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs
typeDoc <- docSharedWrapper layoutType typ
typeDoc <- docSharedWrapper layoutType typ
hasComments <- hasAnyCommentsBelow lsig
docAlt $
[ docSeq
[ appSep $ docWrapNodeRest lsig $ docLit nameStr
, appSep $ docLit $ Text.pack "::"
, docForceSingleline typeDoc
]
| not hasComments
] ++
[ docAddBaseY BrIndentRegular
$ docPar
(docWrapNodeRest lsig $ docLit nameStr)
( docCols ColTyOpPrefix
[ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 3) $ typeDoc
]
)
]
_ -> briDocByExactNoComment lsig -- TODO
docAlt
$ [ docSeq
[ appSep $ docWrapNodeRest lsig $ docLit nameStr
, appSep $ docLit $ Text.pack "::"
, docForceSingleline typeDoc
]
| not hasComments
]
++ [ docAddBaseY BrIndentRegular $ docPar
(docWrapNodeRest lsig $ docLit nameStr)
( docCols
ColTyOpPrefix
[ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 3) $ typeDoc
]
)
]
_ -> briDocByExactNoComment lsig -- TODO
layoutGuardLStmt :: ToBriDoc' (Stmt RdrName (LHsExpr RdrName))
layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
BodyStmt body _ _ _ -> layoutExpr body
BodyStmt body _ _ _ -> layoutExpr body
BindStmt lPat expr _ _ _ -> do
patDoc <- docSharedWrapper layoutPat lPat
expDoc <- docSharedWrapper layoutExpr expr
docCols ColBindStmt
[ appSep $ colsWrapPat =<< patDoc
, docSeq [appSep $ docLit $ Text.pack "<-", expDoc]
]
_ -> unknownNodeError "" lgstmt -- TODO
[ appSep $ colsWrapPat =<< patDoc
, docSeq [appSep $ docLit $ Text.pack "<-", expDoc]
]
_ -> unknownNodeError "" lgstmt -- TODO
layoutBind :: ToBriDocC (HsBindLR RdrName RdrName) (Either [BriDocNumbered] BriDocNumbered)
layoutBind
:: ToBriDocC
(HsBindLR RdrName RdrName)
(Either [BriDocNumbered] BriDocNumbered)
layoutBind lbind@(L _ bind) = case bind of
FunBind fId (MG lmatches@(L _ matches) _ _ _) _ _ [] -> do
idStr <- lrdrNameToTextAnn fId
binderDoc <- docLit $ Text.pack "="
funcPatDocs <- docWrapNode lbind $ docWrapNode lmatches $ layoutPatternBind (Just idStr) binderDoc `mapM` matches
idStr <- lrdrNameToTextAnn fId
binderDoc <- docLit $ Text.pack "="
funcPatDocs <-
docWrapNode lbind
$ docWrapNode lmatches
$ layoutPatternBind (Just idStr) binderDoc
`mapM` matches
return $ Left $ funcPatDocs
PatBind pat (GRHSs grhss whereBinds) _ _ ([], []) -> do
patDocs <- colsWrapPat =<< layoutPat pat
patDocs <- colsWrapPat =<< layoutPat pat
clauseDocs <- layoutGrhs `mapM` grhss
mWhereDocs <- layoutLocalBinds whereBinds
binderDoc <- docLit $ Text.pack "="
fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing binderDoc (Just patDocs) clauseDocs mWhereDocs
binderDoc <- docLit $ Text.pack "="
fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing
binderDoc
(Just patDocs)
clauseDocs
mWhereDocs
_ -> Right <$> unknownNodeError "" lbind
data BagBindOrSig = BagBind (LHsBindLR RdrName RdrName)
@ -96,210 +107,250 @@ bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan
bindOrSigtoSrcSpan (BagBind (L l _)) = l
bindOrSigtoSrcSpan (BagSig (L l _)) = l
layoutLocalBinds :: ToBriDocC (HsLocalBindsLR RdrName RdrName) (Maybe [BriDocNumbered])
layoutLocalBinds
:: ToBriDocC (HsLocalBindsLR RdrName RdrName) (Maybe [BriDocNumbered])
layoutLocalBinds lbinds@(L _ binds) = case binds of
-- HsValBinds (ValBindsIn lhsBindsLR []) ->
-- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering
-- x@(HsValBinds (ValBindsIn{})) ->
-- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x
HsValBinds (ValBindsIn bindlrs sigs) -> do
let unordered = [BagBind b | b <- Data.Foldable.toList bindlrs] ++ [BagSig s | s <- sigs]
ordered = sortBy (comparing bindOrSigtoSrcSpan) unordered
let
unordered
= [ BagBind b | b <- Data.Foldable.toList bindlrs ]
++ [ BagSig s | s <- sigs ]
ordered = sortBy (comparing bindOrSigtoSrcSpan) unordered
docs <- docWrapNode lbinds $ join <$> ordered `forM` \case
BagBind b -> either id return <$> layoutBind b
BagSig s -> return <$> layoutSig s
BagBind b -> either id return <$> layoutBind b
BagSig s -> return <$> layoutSig s
return $ Just $ docs
x@(HsValBinds (ValBindsOut _binds _lsigs)) ->
-- i _think_ this case never occurs in non-processed ast
Just . (:[]) <$> unknownNodeError "HsValBinds ValBindsOut{}" x
x@(HsIPBinds _ipBinds) ->
Just . (:[]) <$> unknownNodeError "HsIPBinds" x
EmptyLocalBinds ->
return $ Nothing
x@(HsIPBinds _ipBinds) -> Just . (:[]) <$> unknownNodeError "HsIPBinds" x
EmptyLocalBinds -> return $ Nothing
-- TODO: we don't need the `LHsExpr RdrName` anymore, now that there is
-- parSpacing stuff.B
layoutGrhs :: LGRHS RdrName (LHsExpr RdrName) -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr RdrName)
layoutGrhs lgrhs@(L _ (GRHS guards body))
= do
guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards
bodyDoc <- layoutExpr body
return (guardDocs, bodyDoc, body)
layoutGrhs
:: LGRHS RdrName (LHsExpr RdrName)
-> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr RdrName)
layoutGrhs lgrhs@(L _ (GRHS guards body)) = do
guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards
bodyDoc <- layoutExpr body
return (guardDocs, bodyDoc, body)
layoutPatternBind :: Maybe Text -> BriDocNumbered -> LMatch RdrName (LHsExpr RdrName) -> ToBriDocM BriDocNumbered
layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhss whereBinds)))
= do
patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p
let isInfix = isInfixMatch match
patDoc <- docWrapNodePrior lmatch $ case (mIdStr, patDocs) of
(Just idStr, p1:pr) | isInfix -> docCols ColPatternsFuncInfix
( [ appSep $ docForceSingleline p1
, appSep $ docLit idStr
]
++ (spacifyDocs $ docForceSingleline <$> pr)
)
(Just idStr, []) -> docLit idStr
(Just idStr, ps) -> docCols ColPatternsFuncPrefix
layoutPatternBind
:: Maybe Text
-> BriDocNumbered
-> LMatch RdrName (LHsExpr RdrName)
-> ToBriDocM BriDocNumbered
layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhss whereBinds))) = do
patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p
let isInfix = isInfixMatch match
patDoc <- docWrapNodePrior lmatch $ case (mIdStr, patDocs) of
(Just idStr, p1:pr) | isInfix -> docCols
ColPatternsFuncInfix
( [appSep $ docForceSingleline p1, appSep $ docLit idStr]
++ (spacifyDocs $ docForceSingleline <$> pr)
)
(Just idStr, [] ) -> docLit idStr
(Just idStr, ps) ->
docCols ColPatternsFuncPrefix
$ appSep (docLit $ idStr)
: (spacifyDocs $ docForceSingleline <$> ps)
(Nothing, ps) -> docCols ColPatterns
(Nothing, ps) ->
docCols ColPatterns
$ (List.intersperse docSeparator $ docForceSingleline <$> ps)
clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss
mWhereDocs <- layoutLocalBinds whereBinds
let alignmentToken = if null pats then Nothing else mIdStr
layoutPatternBindFinal alignmentToken binderDoc (Just patDoc) clauseDocs mWhereDocs
clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss
mWhereDocs <- layoutLocalBinds whereBinds
let alignmentToken = if null pats then Nothing else mIdStr
layoutPatternBindFinal alignmentToken
binderDoc
(Just patDoc)
clauseDocs
mWhereDocs
layoutPatternBindFinal :: Maybe Text -> BriDocNumbered -> Maybe BriDocNumbered -> [([BriDocNumbered], BriDocNumbered, LHsExpr RdrName)] -> Maybe [BriDocNumbered] -> ToBriDocM BriDocNumbered
layoutPatternBindFinal
:: Maybe Text
-> BriDocNumbered
-> Maybe BriDocNumbered
-> [([BriDocNumbered], BriDocNumbered, LHsExpr RdrName)]
-> Maybe [BriDocNumbered]
-> ToBriDocM BriDocNumbered
layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs = do
let patPartInline = case mPatDoc of
Nothing -> []
let patPartInline = case mPatDoc of
Nothing -> []
Just patDoc -> [appSep $ docForceSingleline $ return patDoc]
patPartParWrap = case mPatDoc of
Nothing -> id
Nothing -> id
Just patDoc -> docPar (return patDoc)
whereIndent <- mAsk
<&> _conf_layout
.> _lconfig_indentWhereSpecial
.> confUnpack
.> Bool.bool BrIndentRegular (BrIndentSpecial 1)
whereIndent <-
mAsk
<&> _conf_layout
.> _lconfig_indentWhereSpecial
.> confUnpack
.> Bool.bool BrIndentRegular (BrIndentSpecial 1)
-- TODO: apart from this, there probably are more nodes below which could
-- be shared between alternatives.
wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of
Nothing -> return $ []
Just ws -> fmap (fmap return) $ sequence $ return @[]
$ docEnsureIndent whereIndent
$ docLines
Nothing -> return $ []
Just ws ->
fmap (fmap return)
$ sequence
$ return @[]
$ docEnsureIndent whereIndent
$ docLines
[ docLit $ Text.pack "where"
, docEnsureIndent whereIndent
$ docSetIndentLevel
$ docNonBottomSpacing
$ docLines
$ return <$> ws
$ docSetIndentLevel
$ docNonBottomSpacing
$ docLines
$ return
<$> ws
]
docAlt $
-- one-line solution
[ docCols (ColBindingLine alignmentToken)
[ docSeq
(patPartInline ++ [guardPart])
, docSeq
[ appSep $ return binderDoc
, docForceSingleline $ return body
, wherePart
]
]
| [(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]
, wherePart <- case mWhereDocs of
Nothing -> return @[] $ docEmpty
Just [w] -> return @[] $ docSeq
[ docSeparator
, appSep $ docLit $ Text.pack "where"
, docSetIndentLevel $ docForceSingleline $ return w
docAlt
$ -- one-line solution
[ docCols
(ColBindingLine alignmentToken)
[ docSeq (patPartInline ++ [guardPart])
, docSeq
[ appSep $ return binderDoc
, docForceSingleline $ return body
, wherePart
]
]
| [(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]
, wherePart <- case mWhereDocs of
Nothing -> return @[] $ docEmpty
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
-- [ docSetBaseY $ return body
-- , docAddBaseY BrIndentRegular $ return body
-- ]
]
]
] ++ wherePartMultiLine
| [(guards, body, _bodyRaw)] <- [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)
] ++
-- pattern and exactly one clause in single line, body in new line.
[ docLines
$ [ docSeq (patPartInline ++ [appSep $ guardPart, return binderDoc])
, docEnsureIndent BrIndentRegular
$ docNonBottomSpacing
$ (docAddBaseY BrIndentRegular $ return body)
] ++ wherePartMultiLine
| [(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
| [(guards, body, _bodyRaw)] <- [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)
]
++ -- pattern and exactly one clause in single line, body in new line.
[ docLines
$ [ docSeq (patPartInline ++ [appSep $ guardPart, return binderDoc])
, docEnsureIndent BrIndentRegular
$ docNonBottomSpacing
$ (docAddBaseY BrIndentRegular $ return body)
]
] ++ wherePartMultiLine
]
++ wherePartMultiLine
| [(guards, body, _)] <- [clauseDocs]
, let
guardPart = case guards of
[] -> 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 = \case
HsChar 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
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
HsIntPrim 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
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
HsRat (FL t _) _type -> BDFLit $ Text.pack t
HsFloatPrim (FL t _) -> BDFLit $ Text.pack t
HsDoublePrim (FL t _) -> BDFLit $ Text.pack t
HsChar 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
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
HsIntPrim 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
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
HsRat (FL t _) _type -> BDFLit $ Text.pack t
HsFloatPrim (FL t _) -> BDFLit $ Text.pack t
HsDoublePrim (FL t _) -> BDFLit $ Text.pack t
overLitValBriDoc :: OverLitVal -> BriDocFInt
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 lstmt@(L _ stmt) = docWrapNode lstmt $ case stmt of
LastStmt body False _ -> do
LastStmt body False _ -> do
layoutExpr body
BindStmt lPat expr _ _ _ -> do
patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat
expDoc <- docSharedWrapper layoutExpr expr
docAlt
[ docCols ColBindStmt
[ docCols
ColBindStmt
[ appSep patDoc
, docSeq [appSep $ docLit $ Text.pack "<-", docForceParSpacing expDoc]
]
, docCols ColBindStmt
, docCols
ColBindStmt
[ appSep patDoc
, docAddBaseY BrIndentRegular
$ docPar (docLit $ Text.pack "<-")
(expDoc)
$ docPar (docLit $ Text.pack "<-") (expDoc)
]
]
LetStmt binds -> layoutLocalBinds binds >>= \case
Nothing ->
docLit $ Text.pack "let" -- i just tested
LetStmt binds -> layoutLocalBinds binds >>= \case
Nothing -> docLit $ Text.pack "let" -- i just tested
-- it, and it is
-- indeed allowed.
-- heh.
Just [] ->
docLit $ Text.pack "let" -- this probably never happens
Just [] -> docLit $ Text.pack "let" -- this probably never happens
Just [bindDoc] -> docAlt
[ docCols ColDoLet
[ docCols
ColDoLet
[ appSep $ docLit $ Text.pack "let"
, docSetBaseAndIndent $ return bindDoc
]
, docAddBaseY BrIndentRegular $ docPar
(docLit $ Text.pack "let")
(docSetBaseAndIndent $ return bindDoc)
, docAddBaseY BrIndentRegular
$ docPar (docLit $ Text.pack "let")
(docSetBaseAndIndent $ return bindDoc)
]
Just bindDocs -> docAlt
Just bindDocs -> docAlt
[ docSeq
[ appSep $ docLit $ Text.pack "let"
, docSetBaseAndIndent $ docLines $ return <$> bindDocs
]
, docAddBaseY BrIndentRegular
$ docPar
, docAddBaseY BrIndentRegular $ docPar
(docLit $ Text.pack "let")
(docSetBaseAndIndent $ docLines $ return <$> bindDocs)
]
BodyStmt expr _ _ _ -> do
BodyStmt expr _ _ _ -> do
expDoc <- docSharedWrapper layoutExpr expr
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 x@BDSeparator = plate x
uniplate (BDAddBaseY ind bd) = plate BDAddBaseY |- ind |* bd
uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd
uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd
uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd
uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd
uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd
uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd
uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd
uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented
uniplate (BDAlt alts) = plate BDAlt ||* alts
uniplate (BDForwardLineMode bd) = plate BDForwardLineMode |* bd
uniplate (BDAlt alts) = plate BDAlt ||* alts
uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd
uniplate x@BDExternal{} = plate x
uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd
uniplate (BDAnnotationKW annKey kw bd) = plate BDAnnotationKW |- annKey |- kw |* bd
uniplate (BDAnnotationRest annKey bd) = plate BDAnnotationRest |- annKey |* bd
uniplate (BDAnnotationRest annKey bd) = plate BDAnnotationRest |- annKey |* bd
uniplate (BDLines lines) = plate BDLines ||* lines
uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd
uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd
uniplate (BDForceSingleline bd) = plate BDForceSingleline |* bd
uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd
uniplate (BDForceSingleline bd) = plate BDForceSingleline |* bd
uniplate (BDNonBottomSpacing bd) = plate BDNonBottomSpacing |* bd
uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd
uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd
uniplate (BDProhibitMTEL bd) = plate BDProhibitMTEL |* bd
uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd
uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd
uniplate (BDProhibitMTEL bd) = plate BDProhibitMTEL |* bd
uniplate (BDDebug s bd) = plate BDDebug |- s |* bd
newtype NodeAllocIndex = NodeAllocIndex Int
unwrapBriDocNumbered :: BriDocNumbered -> BriDoc
unwrapBriDocNumbered tpl = case snd tpl of
BDFEmpty -> BDEmpty
BDFLit t -> BDLit t
BDFSeq list -> BDSeq $ rec <$> list
BDFCols sig list -> BDCols sig $ rec <$> list
BDFSeparator -> BDSeparator
BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd
BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd
BDFBaseYPop bd -> BDBaseYPop $ rec bd
BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd
BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd
BDFPar ind line indented -> BDPar ind (rec line) (rec indented)
BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen
BDFForwardLineMode bd -> BDForwardLineMode $ rec bd
BDFExternal k ks c t -> BDExternal k ks c t
BDFEmpty -> BDEmpty
BDFLit t -> BDLit t
BDFSeq list -> BDSeq $ rec <$> list
BDFCols sig list -> BDCols sig $ rec <$> list
BDFSeparator -> BDSeparator
BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd
BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd
BDFBaseYPop bd -> BDBaseYPop $ rec bd
BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd
BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd
BDFPar ind line indented -> BDPar ind (rec line) (rec indented)
BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen
BDFForwardLineMode bd -> BDForwardLineMode $ rec bd
BDFExternal k ks c t -> BDExternal k ks c t
BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd
BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd
BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd
BDFLines lines -> BDLines $ rec <$> lines
BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd
BDFForceMultiline bd -> BDForceMultiline $ rec bd
BDFForceSingleline bd -> BDForceSingleline $ rec bd
BDFNonBottomSpacing bd -> BDNonBottomSpacing $ rec bd
BDFSetParSpacing bd -> BDSetParSpacing $ rec bd
BDFForceParSpacing bd -> BDForceParSpacing $ rec bd
BDFProhibitMTEL bd -> BDProhibitMTEL $ rec bd
BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd
BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd
BDFLines lines -> BDLines $ rec <$> lines
BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd
BDFForceMultiline bd -> BDForceMultiline $ rec bd
BDFForceSingleline bd -> BDForceSingleline $ rec bd
BDFNonBottomSpacing bd -> BDNonBottomSpacing $ rec bd
BDFSetParSpacing bd -> BDSetParSpacing $ rec bd
BDFForceParSpacing bd -> BDForceParSpacing $ rec bd
BDFProhibitMTEL bd -> BDProhibitMTEL $ rec bd
BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd
where
rec = unwrapBriDocNumbered
-- this might not work. is not used anywhere either.
briDocSeqSpine :: BriDoc -> ()
briDocSeqSpine = \case
BDEmpty -> ()
BDLit _t -> ()
BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list
BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list
BDSeparator -> ()
BDAddBaseY _ind bd -> briDocSeqSpine bd
BDBaseYPushCur bd -> briDocSeqSpine bd
BDBaseYPop bd -> briDocSeqSpine bd
BDIndentLevelPushCur bd -> briDocSeqSpine bd
BDIndentLevelPop bd -> briDocSeqSpine bd
BDEmpty -> ()
BDLit _t -> ()
BDSeq list -> foldl' ((briDocSeqSpine.) . seq) () list
BDCols _sig list -> foldl' ((briDocSeqSpine.) . seq) () list
BDSeparator -> ()
BDAddBaseY _ind bd -> briDocSeqSpine bd
BDBaseYPushCur bd -> briDocSeqSpine bd
BDBaseYPop bd -> briDocSeqSpine bd
BDIndentLevelPushCur bd -> briDocSeqSpine bd
BDIndentLevelPop bd -> briDocSeqSpine bd
BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented
BDAlt alts -> foldl' (\(!()) -> briDocSeqSpine) () alts
BDForwardLineMode bd -> briDocSeqSpine bd
BDExternal{} -> ()
BDAnnotationPrior _annKey bd -> briDocSeqSpine bd
BDAlt alts -> foldl' (\(!()) -> briDocSeqSpine) () alts
BDForwardLineMode bd -> briDocSeqSpine bd
BDExternal{} -> ()
BDAnnotationPrior _annKey bd -> briDocSeqSpine bd
BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd
BDAnnotationRest _annKey bd -> briDocSeqSpine bd
BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines
BDEnsureIndent _ind bd -> briDocSeqSpine bd
BDForceMultiline bd -> briDocSeqSpine bd
BDForceSingleline bd -> briDocSeqSpine bd
BDNonBottomSpacing bd -> briDocSeqSpine bd
BDSetParSpacing bd -> briDocSeqSpine bd
BDForceParSpacing bd -> briDocSeqSpine bd
BDProhibitMTEL bd -> briDocSeqSpine bd
BDDebug _s bd -> briDocSeqSpine bd
BDAnnotationRest _annKey bd -> briDocSeqSpine bd
BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines
BDEnsureIndent _ind bd -> briDocSeqSpine bd
BDForceMultiline bd -> briDocSeqSpine bd
BDForceSingleline bd -> briDocSeqSpine bd
BDNonBottomSpacing bd -> briDocSeqSpine bd
BDSetParSpacing bd -> briDocSeqSpine bd
BDForceParSpacing bd -> briDocSeqSpine bd
BDProhibitMTEL bd -> briDocSeqSpine bd
BDDebug _s bd -> briDocSeqSpine bd
briDocForceSpine :: BriDoc -> BriDoc
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
fromMaybeIdentity :: Identity a -> Maybe a -> Identity a
fromMaybeIdentity x y = Data.Coerce.coerce
$ fromMaybe (Data.Coerce.coerce x) y
fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y
fromOptionIdentity :: Identity a -> Option a -> Identity a
fromOptionIdentity x y = Data.Coerce.coerce
$ fromMaybe (Data.Coerce.coerce x)
$ getOption y
fromOptionIdentity x y =
Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) $ getOption y
-- maximum monoid over N+0
-- or more than N, because Num is allowed.
@ -101,61 +99,68 @@ data A x = A ShowIsId x deriving Data
customLayouterF :: ExactPrint.Types.Anns -> LayouterF
customLayouterF anns layoutF =
DataToLayouter $ f `extQ` showIsId
`extQ` fastString
`extQ` bytestring
`extQ` occName
`extQ` srcSpan
`ext2Q` located
where
DataToLayouter f = defaultLayouterF layoutF
simpleLayouter :: String -> NodeLayouter
simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)
showIsId :: ShowIsId -> NodeLayouter
showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case
Left True -> PP.parens $ PP.text s
Left False -> PP.text s
Right _ -> PP.text s
fastString = simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString -> NodeLayouter
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString
srcSpan :: GHC.SrcSpan -> NodeLayouter
srcSpan ss = simpleLayouter
-- $ "{"++ showSDoc_ (GHC.ppr ss)++"}"
$ "{" ++ showGhc ss ++ "}"
located :: (Data b,Data loc) => GHC.GenLocated loc b -> NodeLayouter
located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a
where
annStr = case cast ss of
Just (s :: GHC.SrcSpan) -> ShowIsId
$ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns)
Nothing -> ShowIsId "nnnnnnnn"
DataToLayouter
$ f
`extQ` showIsId
`extQ` fastString
`extQ` bytestring
`extQ` occName
`extQ` srcSpan
`ext2Q` located
where
DataToLayouter f = defaultLayouterF layoutF
simpleLayouter :: String -> NodeLayouter
simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)
showIsId :: ShowIsId -> NodeLayouter
showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case
Left True -> PP.parens $ PP.text s
Left False -> PP.text s
Right _ -> PP.text s
fastString =
simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString
-> NodeLayouter
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString
srcSpan :: GHC.SrcSpan -> NodeLayouter
srcSpan ss = simpleLayouter
-- $ "{"++ showSDoc_ (GHC.ppr ss)++"}"
$ "{" ++ showGhc ss ++ "}"
located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter
located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a
where
annStr = case cast ss of
Just (s :: GHC.SrcSpan) ->
ShowIsId $ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns)
Nothing -> ShowIsId "nnnnnnnn"
customLayouterNoAnnsF :: LayouterF
customLayouterNoAnnsF layoutF =
DataToLayouter $ f `extQ` showIsId
`extQ` fastString
`extQ` bytestring
`extQ` occName
`extQ` srcSpan
`ext2Q` located
where
DataToLayouter f = defaultLayouterF layoutF
simpleLayouter :: String -> NodeLayouter
simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)
showIsId :: ShowIsId -> NodeLayouter
showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case
Left True -> PP.parens $ PP.text s
Left False -> PP.text s
Right _ -> PP.text s
fastString = simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString -> NodeLayouter
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString
srcSpan :: GHC.SrcSpan -> NodeLayouter
srcSpan ss = simpleLayouter
$ "{"++ showSDoc_ (GHC.ppr ss)++"}"
located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter
located (GHC.L _ss a) = runDataToLayouter layoutF a
DataToLayouter
$ f
`extQ` showIsId
`extQ` fastString
`extQ` bytestring
`extQ` occName
`extQ` srcSpan
`ext2Q` located
where
DataToLayouter f = defaultLayouterF layoutF
simpleLayouter :: String -> NodeLayouter
simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)
showIsId :: ShowIsId -> NodeLayouter
showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case
Left True -> PP.parens $ PP.text s
Left False -> PP.text s
Right _ -> PP.text s
fastString =
simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString
-> NodeLayouter
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString
srcSpan :: GHC.SrcSpan -> NodeLayouter
srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}"
located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter
located (GHC.L _ss a) = runDataToLayouter layoutF a
-- displayBriDocTree :: BriDoc -> PP.Doc
-- displayBriDocTree = \case
@ -205,13 +210,12 @@ customLayouterNoAnnsF layoutF =
-- : [PP.text "," <+> displayBriDocSimpleTree t | t<-xr]
-- ++ [PP.text "]"]
traceIfDumpConf :: (MonadMultiReader
Config m,
Show a)
=> String
-> (DebugConfig -> Identity (Semigroup.Last Bool))
-> a
-> m ()
traceIfDumpConf
:: (MonadMultiReader Config m, Show a)
=> String
-> (DebugConfig -> Identity (Semigroup.Last Bool))
-> a
-> m ()
traceIfDumpConf s accessor val = do
whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do
trace ("---- " ++ s ++ " ----\n" ++ show val) $ return ()
@ -237,8 +241,8 @@ briDocToDoc = astToDoc . removeAnnotations
removeAnnotations = Uniplate.transform $ \case
BDAnnotationPrior _ x -> x
BDAnnotationKW _ _ x -> x
BDAnnotationRest _ x -> x
x -> x
BDAnnotationRest _ x -> x
x -> x
briDocToDocWithAnns :: BriDoc -> PP.Doc
briDocToDocWithAnns = astToDoc
@ -246,16 +250,16 @@ briDocToDocWithAnns = astToDoc
annsDoc :: ExactPrint.Types.Anns -> PP.Doc
annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show)
breakEither :: (a -> Either b c) -> [a] -> ([b],[c])
breakEither _ [] = ([],[])
breakEither :: (a -> Either b c) -> [a] -> ([b], [c])
breakEither _ [] = ([], [])
breakEither fn (a1:aR) = case fn a1 of
Left b -> (b:bs,cs)
Right c -> (bs,c:cs)
where
(bs,cs) = breakEither fn aR
Left b -> (b : bs, cs)
Right c -> (bs, c : cs)
where
(bs, cs) = breakEither fn aR
spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])
spanMaybe f (x1:xR) | Just y <- f x1 = (y:ys, xs)
where
(ys, xs) = spanMaybe f xR
spanMaybe _ xs = ([], xs)
spanMaybe f (x1:xR) | Just y <- f x1 = (y : ys, xs)
where
(ys, xs) = spanMaybe f xR
spanMaybe _ xs = ([], xs)