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

Fix comments moving after "where"

ghc92
Lennart Spitzner 2023-04-18 17:15:41 +00:00
parent ebe85a5949
commit 2fef44559e
6 changed files with 120 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
data/15-regressions.blt
View File

@ -895,3 +895,37 @@ fieldWith
-> ToBriDocM BriDocNumbered
)
-> [ToBriDocM BriDocNumbered]
#test comment-before-where
briDocLineLength briDoc = flip StateS.evalState False $ go briDoc
-- the state encodes whether a separator was already
-- appended at the current position.
where
go = \case
BDEmpty -> return $ 0
BDLit t -> StateS.put False $> Text.length t
BDSeq bds -> sum <$> go `mapM` bds
#test where-funbind-no-empty-lines
alignColsLines layoutBriDocM bridocs = do -- colInfos `forM_` \colInfo -> do
-- tellDebugMess ("alignColsLines: at " ++ take 100 (show $ briDocToDoc $ head bridocs))
case () of
_ -> do
-- tellDebugMess ("colInfos:\n" ++ List.unlines [ "> " ++ prettyColInfos "> " x | x <- colInfos])
-- tellDebugMess ("processedMap: " ++ show processedMap)
sequence_
$ List.intersperse layoutWriteEnsureNewlineBlock
$ colInfos <&> processInfo layoutBriDocM colMax processedMap
where
(colInfos, finalState) =
StateS.runState (mergeBriDocs bridocs) (ColBuildState IntMapS.empty 0)
-- maxZipper :: [Int] -> [Int] -> [Int]
-- maxZipper [] ys = ys
-- maxZipper xs [] = xs
-- maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr
colAggregation :: [Int] -> Int
colAggregation [] = 0 -- this probably cannot happen the way we call
-- this function, because _cbs_map only ever
-- contains nonempty Seqs.
colAggregation xs = maximum [ x | x <- xs, x <= minimum xs + alignMax' ]
where alignMax' = max 0 alignMax

46
source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs
View File

@ -182,7 +182,7 @@ layoutIPBind lipbind@(L _ bind) = case bind of
binderDoc
(Just ipName)
(Left expr)
Nothing
(id, Nothing)
hasComments
@ -196,7 +196,8 @@ bindOrSigtoSrcSpan (BagSig (L (SrcSpanAnn _ l) _)) = l
layoutLocalBinds
:: HsLocalBindsLR GhcPs GhcPs
-> ToBriDocM
( Maybe
( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
, Maybe
( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
, [BriDocNumbered]
)
@ -207,23 +208,23 @@ layoutLocalBinds binds = case binds of
-- x@(HsValBinds (ValBindsIn{})) ->
-- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x
HsValBinds epAnn (ValBinds _ bindlrs sigs) -> do
let locWhere = obtainAnnPos epAnn AnnWhere
let unordered =
[ BagBind b | b <- Data.Foldable.toList bindlrs ]
++ [ BagSig s | s <- sigs ]
ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered
ds <- docHandleComms epAnn $ join <$> ordered `forM` \case
BagBind b -> either id return <$> layoutBind b
BagSig s@(L _ sig) -> do
doc <- layoutSig s sig
pure [doc]
pure $ Just (docHandleComms locWhere, ds)
let locWhere = obtainAnnPos epAnn AnnWhere
let unordered =
[ BagBind b | b <- Data.Foldable.toList bindlrs ]
++ [ BagSig s | s <- sigs ]
ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered
ds <- join <$> ordered `forM` \case
BagBind b -> either id return <$> layoutBind b
BagSig s@(L _ sig) -> do
doc <- layoutSig s sig
pure [doc]
pure $ (docHandleComms epAnn, Just (docHandleComms locWhere, ds))
-- x@(HsValBinds (ValBindsOut _binds _lsigs)) ->
HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR"
HsIPBinds epAnn (IPBinds _ bb) -> do
ds <- docHandleComms epAnn $ mapM layoutIPBind bb
pure $ Just (id, ds) -- TODO92 do we need to replace id?
EmptyLocalBinds NoExtField -> return $ Nothing
ds <- mapM layoutIPBind bb
pure $ (docHandleComms epAnn, Just (id, ds)) -- TODO92 do we need to replace id?
EmptyLocalBinds NoExtField -> return $ (id, Nothing)
layoutGrhs
:: LGRHS GhcPs (LHsExpr GhcPs)
@ -323,14 +324,15 @@ layoutPatternBindFinal
-> BriDocNumbered
-> Maybe BriDocNumbered
-> Either (LHsExpr GhcPs) [LGRHS GhcPs (LHsExpr GhcPs)]
-> ( Maybe
-> ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
, Maybe
( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
, [BriDocNumbered]
)
)
-> Bool
-> ToBriDocM BriDocNumbered
layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauses mWhereDocs hasComments
layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauses (wrapBinds, mWhereDocs) hasComments
= do
let
patPartInline = case mPatDoc of
@ -354,14 +356,14 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauses mWhereDocs hasCo
Just (wrapWhere, [w]) -> pure . pure <$> docAlt
[ docEnsureIndent BrIndentRegular
$ docSeq
[ wrapWhere $ docLit $ Text.pack "where"
[ wrapBinds $ wrapWhere $ docLit $ Text.pack "where"
, docSeparator
, docForceSingleline $ return w
]
, -- docMoveToKWDP annKeyWhere AnnWhere False -- TODO92
docEnsureIndent whereIndent
$ docLines
[ docLit $ Text.pack "where"
[ wrapBinds $ wrapWhere $ docLit $ Text.pack "where"
, docEnsureIndent whereIndent
$ docSetIndentLevel
$ docNonBottomSpacing
@ -373,7 +375,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauses mWhereDocs hasCo
-- $ docMoveToKWDP annKeyWhere AnnWhere False -- TODO92
$ docEnsureIndent whereIndent
$ docLines
[ wrapWhere $ docLit $ Text.pack "where"
[ wrapBinds $ wrapWhere $ docLit $ Text.pack "where"
, docEnsureIndent whereIndent
$ docSetIndentLevel
$ docNonBottomSpacing
@ -397,7 +399,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauses mWhereDocs hasCo
Nothing -> Just docEmpty
Just (wrapWhere, [w]) -> Just $ docSeq
[ docSeparator
, wrapWhere $ appSep $ docLit $ Text.pack "where"
, wrapBinds $ wrapWhere $ appSep $ docLit $ Text.pack "where"
, docSetIndentLevel $ docForceSingleline $ return w
]
_ -> Nothing

28
source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs
View File

@ -585,7 +585,7 @@ layoutExpr lexpr@(L _ expr) = do
binderDoc
Nothing
(Right cases)
Nothing
(id, Nothing)
hasComments
)
HsLet epAnn binds exp1 -> docHandleComms epAnn $ do
@ -593,7 +593,7 @@ layoutExpr lexpr@(L _ expr) = do
let hasComments = hasAnyCommentsBelow lexpr
let wrapLet = docHandleComms spanLet
let wrapIn = docHandleComms spanIn
mBindDocs <- callLayouter layout_localBinds binds
(wrapBinds, mBindDocs) <- callLayouter layout_localBinds binds
let ifIndentFreeElse :: a -> a -> a
ifIndentFreeElse x y = case indentPolicy of
IndentPolicyLeft -> y
@ -614,7 +614,7 @@ layoutExpr lexpr@(L _ expr) = do
Just [bindDoc] -> runFilteredAlternative $ do
addAlternativeCond (not hasComments) $ docSeq
[ appSep $ letDoc
, appSep $ docForceSingleline (pure bindDoc)
, wrapBinds $ appSep $ docForceSingleline (pure bindDoc)
, appSep $ inDoc
, docForceSingleline expDoc1
]
@ -622,11 +622,13 @@ layoutExpr lexpr@(L _ expr) = do
[ docAlt
[ docSeq
[ appSep $ letDoc
, ifIndentFreeElse docSetBaseAndIndent docForceSingleline
, wrapBinds
$ ifIndentFreeElse docSetBaseAndIndent docForceSingleline
$ pure bindDoc
]
, docAddBaseY BrIndentRegular
$ docPar (letDoc) (docSetBaseAndIndent $ pure bindDoc)
, docAddBaseY BrIndentRegular $ docPar
(letDoc)
(wrapBinds $ docSetBaseAndIndent $ pure bindDoc)
]
, docAlt
[ docSeq
@ -658,7 +660,9 @@ layoutExpr lexpr@(L _ expr) = do
let noHangingBinds =
[ docNonBottomSpacing $ docAddBaseY BrIndentRegular $ docPar
(letDoc)
(docSetBaseAndIndent $ docLines $ pure <$> bindDocs)
( wrapBinds
$ docSetBaseAndIndent $ docLines $ pure <$> bindDocs
)
, docSeq
[ wrapIn $ docLit $ Text.pack "in "
, docAddBaseY BrIndentRegular $ docForceParSpacing expDoc1
@ -671,7 +675,7 @@ layoutExpr lexpr@(L _ expr) = do
[ -- TODO92 docNodeAnnKW lexpr (Just AnnLet) $
docSeq
[ appSep $ letDoc
, docSetBaseAndIndent $ docLines $ pure <$> bindDocs
, wrapBinds $ docSetBaseAndIndent $ docLines $ pure <$> bindDocs
]
, docSeq
[ appSep $ wrapIn $ docLit $ Text.pack "in "
@ -682,12 +686,13 @@ layoutExpr lexpr@(L _ expr) = do
[ -- TODO92 docNodeAnnKW lexpr (Just AnnLet) $
docAddBaseY BrIndentRegular $ docPar
(letDoc)
(docSetBaseAndIndent $ docLines $ pure <$> bindDocs)
(wrapBinds $ docSetBaseAndIndent $ docLines $ pure <$> bindDocs)
, docAddBaseY BrIndentRegular
$ docPar (inDoc) (docSetBaseY $ expDoc1)
]
_ -> docSeq
[ docForceSingleline $ docSeq [letDoc, docSeparator, inDoc]
[ docForceSingleline $ docSeq
[letDoc, docSeparator, wrapBinds $ inDoc]
, docSeparator
, expDoc1
]
@ -696,10 +701,11 @@ layoutExpr lexpr@(L _ expr) = do
docHandleComms epAnn $ do
case stmtCtx of
DoExpr _ -> do
let locDo = obtainAnnPos epAnn AnnDo
stmtDocs <- docHandleComms stmtEpAnn $ do
stmts `forM` docHandleListElemComms (callLayouter layout_stmt)
docSetParSpacing $ docAddBaseY BrIndentRegularForce $ docPar
(docLit $ Text.pack "do")
(docHandleComms locDo $ docLit $ Text.pack "do")
( docSetBaseAndIndent
$ docNonBottomSpacing
$ docLines

11
source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Stmt.hs
View File

@ -49,7 +49,8 @@ layoutStmt lstmt@(L _ stmt) = do
LetStmt epAnn binds -> docHandleComms epAnn $ do
let isFree = indentPolicy == IndentPolicyFree
let indentFourPlus = indentAmount >= 4
callLayouter layout_localBinds binds >>= \case
(wrapBinds, bindrDocsMay) <- callLayouter layout_localBinds binds
case bindrDocsMay of
Nothing -> docLit $ Text.pack "let"
-- i just tested the above, and it is indeed allowed. heh.
Just (_, []) -> docLit $ Text.pack "let" -- this probably never happens
@ -65,13 +66,13 @@ layoutStmt lstmt@(L _ stmt) = do
IndentPolicyMultiple
| indentFourPlus -> docSetBaseAndIndent
| otherwise -> docForceSingleline
in f $ return bindDoc
in wrapBinds $ f $ return bindDoc
]
, -- let
-- bind = expr
docAddBaseY BrIndentRegular $ docPar
(docLit $ Text.pack "let")
(docSetBaseAndIndent $ return bindDoc)
(wrapBinds $ docSetBaseAndIndent $ return bindDoc)
]
Just (_, bindDocs) -> runFilteredAlternative $ do
-- let aaa = expra
@ -83,7 +84,7 @@ layoutStmt lstmt@(L _ stmt) = do
f = if indentFourPlus
then docEnsureIndent BrIndentRegular
else docSetBaseAndIndent
in f $ docLines $ return <$> bindDocs
in wrapBinds $ f $ docLines $ return <$> bindDocs
]
-- let
-- aaa = expra
@ -93,7 +94,7 @@ layoutStmt lstmt@(L _ stmt) = do
$ docAddBaseY BrIndentRegular
$ docPar
(docLit $ Text.pack "let")
(docSetBaseAndIndent $ docLines $ return <$> bindDocs)
(wrapBinds $ docSetBaseAndIndent $ docLines $ return <$> bindDocs)
RecStmt epAnn (L _ stmts) _ _ _ _ _ ->
docHandleComms epAnn $ runFilteredAlternative $ do
-- rec stmt1

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

@ -218,7 +218,8 @@ data Layouters = Layouters
-> BriDocNumbered
-> Maybe BriDocNumbered
-> Either (GHC.LHsExpr GhcPs) [GHC.LGRHS GhcPs (GHC.LHsExpr GhcPs)]
-> ( Maybe
-> ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
, Maybe
( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
, [BriDocNumbered]
)
@ -228,7 +229,8 @@ data Layouters = Layouters
, layout_localBinds
:: GHC.HsLocalBindsLR GhcPs GhcPs
-> ToBriDocM
( Maybe
( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
, Maybe
( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
, [BriDocNumbered]
)

70
source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/AlignmentAlgo.hs
View File

@ -386,68 +386,68 @@ withAlloc lastFlag f = do
return info
briDocLineLength :: BriDoc -> Int
briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
briDocLineLength briDoc = flip StateS.evalState False $ go briDoc
-- the state encodes whether a separator was already
-- appended at the current position.
where
rec = \case
go = \case
BDEmpty -> return $ 0
BDLit t -> StateS.put False $> Text.length t
BDSeq bds -> sum <$> rec `mapM` bds
BDCols _ bds -> sum <$> rec `mapM` bds
BDSeq bds -> sum <$> go `mapM` bds
BDCols _ bds -> sum <$> go `mapM` bds
BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1
BDAddBaseY _ bd -> rec bd
BDBaseYPushCur bd -> rec bd
BDIndentLevelPushCur bd -> rec bd
BDIndentLevelPop bd -> rec bd
BDPar _ line _ -> rec line
BDAddBaseY _ bd -> go bd
BDBaseYPushCur bd -> go bd
BDIndentLevelPushCur bd -> go bd
BDIndentLevelPop bd -> go bd
BDPar _ line _ -> go line
BDAlt{} -> error "briDocLineLength BDAlt"
BDForceAlt _ bd -> rec bd
BDForwardLineMode bd -> rec bd
BDForceAlt _ bd -> go bd
BDForwardLineMode bd -> go bd
BDExternal _ t -> return $ Text.length t
BDPlain t -> return $ Text.length t
BDQueueComments _ bd -> rec bd
BDFlushCommentsPrior _ bd -> rec bd
BDFlushCommentsPost _ _ bd -> rec bd
BDQueueComments _ bd -> go bd
BDFlushCommentsPrior _ bd -> go bd
BDFlushCommentsPost _ _ bd -> go bd
BDLines ls@(_ : _) -> do
x <- StateS.get
return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x
BDEntryDelta _dp bd -> rec bd
return $ maximum $ ls <&> \l -> StateS.evalState (go l) x
BDEntryDelta _dp bd -> go bd
BDLines [] -> error "briDocLineLength BDLines []"
BDEnsureIndent _ bd -> rec bd
BDDebug _ bd -> rec bd
BDEnsureIndent _ bd -> go bd
BDDebug _ bd -> go bd
briDocIsMultiLine :: BriDoc -> Bool
briDocIsMultiLine briDoc = rec briDoc
briDocIsMultiLine briDoc = go briDoc
where
rec :: BriDoc -> Bool
rec = \case
go :: BriDoc -> Bool
go = \case
BDEmpty -> False
BDLit _ -> False
BDSeq bds -> any rec bds
BDCols _ bds -> any rec bds
BDSeq bds -> any go bds
BDCols _ bds -> any go bds
BDSeparator -> False
BDAddBaseY _ bd -> rec bd
BDBaseYPushCur bd -> rec bd
BDIndentLevelPushCur bd -> rec bd
BDIndentLevelPop bd -> rec bd
BDAddBaseY _ bd -> go bd
BDBaseYPushCur bd -> go bd
BDIndentLevelPushCur bd -> go bd
BDIndentLevelPop bd -> go bd
BDPar{} -> True
BDAlt{} -> error "briDocIsMultiLine BDAlt"
BDForceAlt _ bd -> rec bd
BDForwardLineMode bd -> rec bd
BDForceAlt _ bd -> go bd
BDForwardLineMode bd -> go bd
BDExternal _ t | [_] <- Text.lines t -> False
BDExternal{} -> True
BDPlain t | [_] <- Text.lines t -> False
BDPlain _ -> True
BDQueueComments _ bd -> rec bd
BDFlushCommentsPrior _ bd -> rec bd
BDFlushCommentsPost _ _ bd -> rec bd
BDEntryDelta _dp bd -> rec bd
BDQueueComments _ bd -> go bd
BDFlushCommentsPrior _ bd -> go bd
BDFlushCommentsPost _ _ bd -> go bd
BDEntryDelta _dp bd -> go bd
BDLines (_ : _ : _) -> True
BDLines [_] -> False
BDLines [] -> error "briDocIsMultiLine BDLines []"
BDEnsureIndent _ bd -> rec bd
BDDebug _ bd -> rec bd
BDEnsureIndent _ bd -> go bd
BDDebug _ bd -> go bd
briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo
briDocToColInfo lastFlag = \case