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

Partially restore retaining-empty-lines behaviour 

Currently works for do blocks, multi-line list literals, and
lambda-case cases (apart from top-level blank lines that
never got ignored).
ghc92
Lennart Spitzner 2023-04-05 14:28:19 +00:00
parent 05270ecb45
commit f13a82964a
16 changed files with 251 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
data/15-regressions.blt
View File

@ -116,7 +116,8 @@ func = do
let (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs'
(bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets''
-- default local dir target if there's no given target
utargets'' = "foo"
utargets'' = "foo"
asd = True
return ()
#test list comprehension comment placement

62
source/library/Language/Haskell/Brittany/Internal/Components/BriDoc.hs
View File

@ -69,9 +69,11 @@ data BriDocW (w :: IsWrapped)
-- queue to be later flushed when the markers are reached
| BDFlushCommentsPrior RealSrcLoc (BriDocRec w)
-- process comments before loc from the queue
| BDFlushCommentsPost RealSrcLoc (BriDocRec w)
| BDFlushCommentsPost RealSrcLoc Bool (BriDocRec w)
-- process comments before loc from the queue, but flow to end of
-- child-nodes
-- child-nodes. The boolean determines whether we set this location for
-- purposes of multiple-line DP calculations. This determines whether
-- empty lines after this element will be retained in the output.
| BDEntryDelta DeltaPos (BriDocRec w)
-- Move to the specified delta position before rendering the inner
-- element. Currently this only ever respects newlines, i.e. Sameline
@ -124,8 +126,8 @@ instance Uniplate.Uniplate BriDoc where
plate BDQueueComments |- comms |* bd
uniplate (BDFlushCommentsPrior loc bd) =
plate BDFlushCommentsPrior |- loc |* bd
uniplate (BDFlushCommentsPost loc bd) =
plate BDFlushCommentsPost |- loc |* bd
uniplate (BDFlushCommentsPost loc shouldMark bd) =
plate BDFlushCommentsPost |- loc |- shouldMark |* bd
uniplate (BDEntryDelta dp bd ) = plate BDEntryDelta |- dp |* bd
uniplate (BDLines lines ) = plate BDLines ||* lines
uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd
@ -155,7 +157,7 @@ briDocSeqSpine = \case
BDPlain{} -> ()
BDQueueComments _comms bd -> briDocSeqSpine bd
BDFlushCommentsPrior _loc bd -> briDocSeqSpine bd
BDFlushCommentsPost _loc bd -> briDocSeqSpine bd
BDFlushCommentsPost _loc _m bd -> briDocSeqSpine bd
BDEntryDelta _dp bd -> briDocSeqSpine bd
BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines
BDEnsureIndent _ind bd -> briDocSeqSpine bd
@ -176,31 +178,31 @@ isNotEmpty _ = True
-- TODO: rename to "dropLabels" ?
unwrapBriDocNumbered :: BriDocNumbered -> BriDoc
unwrapBriDocNumbered tpl = case snd tpl of
BDEmpty -> BDEmpty
BDLit t -> BDLit t
BDSeq list -> BDSeq $ rec <$> list
BDCols sig list -> BDCols sig $ rec <$> list
BDSeparator -> BDSeparator
BDAddBaseY ind bd -> BDAddBaseY ind $ rec bd
BDBaseYPushCur bd -> BDBaseYPushCur $ rec bd
BDIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd
BDIndentLevelPop bd -> BDIndentLevelPop $ rec bd
BDPar ind line indented -> BDPar ind (rec line) (rec indented)
BDAlt alts -> BDAlt $ rec <$> alts -- not that this will happen
BDForwardLineMode bd -> BDForwardLineMode $ rec bd
BDExternal c t -> BDExternal c t
BDPlain t -> BDPlain t
BDQueueComments comms bd -> BDQueueComments comms $ rec bd
BDFlushCommentsPrior loc bd -> BDFlushCommentsPrior loc $ rec bd
BDFlushCommentsPost loc bd -> BDFlushCommentsPost loc $ rec bd
BDEntryDelta dp bd -> BDEntryDelta dp $ rec bd
BDLines lines -> BDLines $ rec <$> lines
BDEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd
BDForceMultiline bd -> BDForceMultiline $ rec bd
BDForceSingleline bd -> BDForceSingleline $ rec bd
BDNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd
BDSetParSpacing bd -> BDSetParSpacing $ rec bd
BDForceParSpacing bd -> BDForceParSpacing $ rec bd
BDEmpty -> BDEmpty
BDLit t -> BDLit t
BDSeq list -> BDSeq $ rec <$> list
BDCols sig list -> BDCols sig $ rec <$> list
BDSeparator -> BDSeparator
BDAddBaseY ind bd -> BDAddBaseY ind $ rec bd
BDBaseYPushCur bd -> BDBaseYPushCur $ rec bd
BDIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd
BDIndentLevelPop bd -> BDIndentLevelPop $ rec bd
BDPar ind line indented -> BDPar ind (rec line) (rec indented)
BDAlt alts -> BDAlt $ rec <$> alts -- not that this will happen
BDForwardLineMode bd -> BDForwardLineMode $ rec bd
BDExternal c t -> BDExternal c t
BDPlain t -> BDPlain t
BDQueueComments comms bd -> BDQueueComments comms $ rec bd
BDFlushCommentsPrior loc bd -> BDFlushCommentsPrior loc $ rec bd
BDFlushCommentsPost loc mrk bd -> BDFlushCommentsPost loc mrk $ rec bd
BDEntryDelta dp bd -> BDEntryDelta dp $ rec bd
BDLines lines -> BDLines $ rec <$> lines
BDEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd
BDForceMultiline bd -> BDForceMultiline $ rec bd
BDForceSingleline bd -> BDForceSingleline $ rec bd
BDNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd
BDSetParSpacing bd -> BDSetParSpacing $ rec bd
BDForceParSpacing bd -> BDForceParSpacing $ rec bd
BDDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd
where rec = unwrapBriDocNumbered

57
source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs
View File

@ -474,7 +474,7 @@ docAddEntryDelta dp bdm = do
allocateNode (BDEntryDelta dp bd)
docFlushRemaining :: FastString -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docFlushRemaining fileThing = docFlushCommsPost
docFlushRemaining fileThing = docFlushCommsPost False
(Just $ GHC.mkRealSrcLoc fileThing 999999 999999)
-- CLASS DocHandleComms --------------------------------------------------------
@ -671,28 +671,36 @@ instance ObtainAnnDeltaPos (EpAnn GHC.AnnsModule) where
)
pos
class DocFlushCommsPost a where
docFlushCommsPost :: Maybe GHC.RealSrcLoc -> a -> a
class DocFlushCommsPost ann a where
docFlushCommsPost :: Bool -> ann -> a -> a
instance DocFlushCommsPost (ToBriDocM BriDocNumbered) where
docFlushCommsPost = \case
instance DocFlushCommsPost (Maybe GHC.RealSrcLoc) (ToBriDocM BriDocNumbered) where
docFlushCommsPost shouldMark = \case
Nothing -> id
Just span -> \bdm -> do
Just loc -> \bdm -> do
i1 <- allocNodeIndex
bd <- bdm
pure (i1, BDFlushCommentsPost span bd)
pure (i1, BDFlushCommentsPost loc shouldMark bd)
instance DocFlushCommsPost (ToBriDocM [BriDocNumbered]) where
docFlushCommsPost loc bdm = do
instance DocFlushCommsPost ann (ToBriDocM BriDocNumbered)
=> DocFlushCommsPost ann (ToBriDocM [BriDocNumbered]) where
docFlushCommsPost shouldMark loc bdm = do
bds <- bdm
case bds of
[] -> do
e <- docFlushCommsPost loc docEmpty
e <- docFlushCommsPost shouldMark loc docEmpty
pure [e]
_ -> do
e <- docFlushCommsPost loc (pure $ List.last bds)
e <- docFlushCommsPost shouldMark loc (pure $ List.last bds)
pure (List.init bds ++ [e])
instance DocFlushCommsPost (Maybe GHC.RealSrcLoc) a
=> DocFlushCommsPost (LocatedA ast) a where
docFlushCommsPost shouldMark (L ann _) =
docFlushCommsPost shouldMark $ case GHC.locA ann of
GHC.RealSrcSpan s _ -> Just $ GHC.realSrcSpanEnd s
GHC.UnhelpfulSpan{} -> Nothing
unknownNodeError
:: (Data a, Data (GHC.Anno a), Outputable (GHC.Anno a))
=> String
@ -737,7 +745,32 @@ docHandleListElemComms
-> ToBriDocM BriDocNumbered
docHandleListElemComms layouter e = case obtainListElemStartCommaLocs e of
(posStart, posComma) ->
docHandleComms posStart $ docFlushCommsPost posComma $ layouter e
docHandleComms posStart $ docFlushCommsPost True posComma $ layouter e
docHandleListElemCommsProperPost
:: (LocatedA ast -> ToBriDocM BriDocNumbered)
-> [LocatedA ast]
-> ToBriDocM [(Maybe GHC.RealSrcLoc, ToBriDocM BriDocNumbered)]
docHandleListElemCommsProperPost layouter es = case es of
[] -> pure []
(e1 : rest) -> case obtainListElemStartCommaLocs e1 of
(posStart, posComma) -> do
res <- go posComma rest
pure
$ ( Nothing
, docFlushCommsPost True e1 $ docHandleComms posStart $ layouter e1
)
: res
where
go _intoComma [] = pure []
go intoComma (e1 : rest) = case obtainListElemStartCommaLocs e1 of
(posStart, posComma) -> do
res <- go posComma rest
pure
$ ( intoComma
, docFlushCommsPost True e1 $ docHandleComms posStart $ layouter e1
)
: res
epaLocationRealSrcSpanStart :: GHC.EpaLocation -> GHC.RealSrcLoc
epaLocationRealSrcSpanStart = GHC.realSrcSpanStart . GHC.epaLocationRealSrcSpan

51
source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs
View File

@ -31,6 +31,8 @@ import GHC ( Anchor(Anchor)
, LEpaComment
, RealSrcLoc
, DeltaPos(SameLine, DifferentLine)
, srcLocLine
, srcLocCol
)
import GHC.Types.SrcLoc ( realSrcSpanEnd )
import qualified GHC.OldList as List
@ -101,6 +103,7 @@ ppBriDoc briDoc flush = do
, _lstate_indLevelLinger = 0
, _lstate_plannedSpace = PlannedNone
, _lstate_commentNewlines = 0
, _lstate_markerForDelta = Nothing
}
state' <-
MultiRWSS.withMultiStateS state
@ -124,6 +127,7 @@ layoutBriDocM = \case
BDEmpty -> do
return () -- can it be that simple
BDLit t -> do
layoutSetMarker Nothing
layoutRemoveIndentLevelLinger
layoutWriteAppend t
BDSeq list -> do
@ -271,9 +275,25 @@ layoutBriDocM = \case
comms <- takeBefore loc
printComments comms
mModify (\s -> s + CommentCounter (length comms))
do
marker <- mGet <&> _lstate_markerForDelta
mModify $ \s -> s { _lstate_markerForDelta = Nothing }
case marker of
Nothing -> pure ()
Just m -> do
let p1 = (srcLocLine m, srcLocCol m)
let p2 = (srcLocLine loc, srcLocCol loc)
-- traceShow (ExactPrint.pos2delta p1 p2) $ pure ()
case ExactPrint.pos2delta p1 p2 of
SameLine{} -> pure ()
DifferentLine n _ -> layoutWriteNewlines n
layoutBriDocM bd
BDFlushCommentsPost loc bd -> do
BDFlushCommentsPost loc shouldMark bd -> do
layoutBriDocM bd
if shouldMark then
layoutSetMarker $ Just loc
else
layoutSetMarker Nothing
comms <- takeBefore loc
mModify (\s -> s + CommentCounter (length comms))
printComments comms
@ -305,20 +325,19 @@ printComments :: LayoutConstraints m => [GHC.LEpaComment] -> m ()
printComments comms = do
let addComment isBlock s anchor prior = do
case anchor of
Anchor span UnchangedAnchor -> layoutWriteComment
True
isBlock
(ExactPrint.ss2deltaEnd prior span)
1
(Text.pack s)
Anchor _span (MovedAnchor dp) ->
Anchor span UnchangedAnchor -> do
let dp = ExactPrint.ss2deltaEnd prior span
layoutWriteComment True isBlock dp 1 (Text.pack s)
layoutUpdateMarker $ realSrcSpanEnd span
Anchor span (MovedAnchor dp) -> do
layoutWriteComment False isBlock dp 1 (Text.pack s)
comms `forM_` \(L anch (EpaComment tok prior) ) -> case tok of
EpaDocCommentNext s -> addComment False s anch prior
EpaDocCommentPrev s -> addComment False s anch prior
layoutUpdateMarker $ realSrcSpanEnd span
comms `forM_` \(L anch (EpaComment tok prior)) -> case tok of
EpaDocCommentNext s -> addComment False s anch prior
EpaDocCommentPrev s -> addComment False s anch prior
EpaDocCommentNamed s -> addComment False s anch prior
EpaDocSection _ s -> addComment False s anch prior
EpaDocOptions s -> addComment False s anch prior
EpaLineComment s -> addComment False s anch prior
EpaBlockComment s -> addComment True s anch prior
EpaEofComment -> pure ()
EpaDocSection _ s -> addComment False s anch prior
EpaDocOptions s -> addComment False s anch prior
EpaLineComment s -> addComment False s anch prior
EpaBlockComment s -> addComment True s anch prior
EpaEofComment -> pure ()

4
source/library/Language/Haskell/Brittany/Internal/ToBriDoc/DataDecl.hs
View File

@ -471,7 +471,7 @@ createNamesAndTypeDoc
:: LConDeclField GhcPs
-> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)
createNamesAndTypeDoc lField@(L _ (ConDeclField epAnn names t _)) =
( docFlushCommsPost posColon
( docFlushCommsPost False posColon
$ docHandleComms posStart
$ docHandleComms epAnn
$ docSeq
@ -479,7 +479,7 @@ createNamesAndTypeDoc lField@(L _ (ConDeclField epAnn names t _)) =
L _ (FieldOcc _ fieldName) ->
docLit =<< lrdrNameToTextAnn fieldName
]
, docFlushCommsPost posComma (layoutType t)
, docFlushCommsPost True posComma (layoutType t)
)
where
(posStart, posComma) = obtainListElemStartCommaLocs lField

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

@ -18,6 +18,7 @@ import qualified GHC.OldList as List
import GHC.Types.Basic
(Activation(..), InlinePragma(..), InlineSpec(..), RuleMatchInfo(..))
import GHC.Types.SrcLoc (Located, getLoc, unLoc)
import qualified GHC
import qualified GHC.Types.SrcLoc as GHC
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
@ -240,7 +241,7 @@ layoutGrhs (L _ (GRHS epAnn guards body)) = do
let posArrow = obtainAnnPos epAnn AnnRarrow
guardDocs <- case guards of
[] -> pure []
_ -> docFlushCommsPost posArrow $ layoutStmt `mapM` guards
_ -> docFlushCommsPost False posArrow $ layoutStmt `mapM` guards
bodyDoc <- layoutExpr body
return (docHandleComms epAnn, guardDocs, bodyDoc)
@ -255,12 +256,16 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) =
let (GRHSs _ grhss whereBinds) = m_grhss match
patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p
let isInfix = isInfixMatch match
let matchEndLoc = case GHC.locA $ GHC.getLoc lmatch of
GHC.RealSrcSpan s _ -> Just $ GHC.realSrcSpanEnd s
GHC.UnhelpfulSpan{} -> Nothing
mIdDoc <- case match of
Match epAnn (FunRhs matchId _ _) _ _ ->
fmap Just $ docHandleComms epAnn $ do
t <- lrdrNameToTextAnn matchId
let t' = fixPatternBindIdentifier match t
docLit t'
fmap Just
$ docHandleComms epAnn $ do
t <- lrdrNameToTextAnn matchId
let t' = fixPatternBindIdentifier match t
docLit t'
_ -> pure Nothing
patDoc <- docHandleComms lmatch $ case (mIdDoc, patDocs) of
(Just idDoc, p1 : p2 : pr) | isInfix -> if null pr
@ -295,13 +300,14 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) =
-- let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch)
let alignmentToken = if null pats then Nothing else funId
let hasComments = hasAnyCommentsBelow lmatch
layoutPatternBindFinal
alignmentToken
binderDoc
(Just patDoc)
(Right grhss)
mWhereDocs
hasComments
docFlushCommsPost True matchEndLoc
$ layoutPatternBindFinal
alignmentToken
binderDoc
(Just patDoc)
(Right grhss)
mWhereDocs
hasComments
fixPatternBindIdentifier :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text
fixPatternBindIdentifier match idStr = go $ m_ctxt match

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

@ -1106,7 +1106,8 @@ recordExpression dotdot wrapO wrapDD wrapC indentPolicy _lexpr nameDoc nameLayou
if pun
then pure $ Left (posStart, fnameDoc)
else do
expDoc <- shareDoc $ docFlushCommsPost posComma $ layoutExpr rFExpr
expDoc <-
shareDoc $ docFlushCommsPost True posComma $ layoutExpr rFExpr
pure $ Right (posStart, fnameDoc, expDoc)
fieldTuple1 <- mkFieldTuple rF1
fieldTupleR <- rFr `forM` mkFieldTuple

2
source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs
View File

@ -77,7 +77,7 @@ splitArrowType ltype@(L _ typ) = case typ of
EpAnn _ AddVbarAnn{} _ ->
error "brittany internal error: HsFunTy EpAnn"
EpAnn _ (AddRarrowAnn loc) _ ->
docFlushCommsPost (Just $ epaLocationRealSrcSpanStart loc)
docFlushCommsPost True (Just $ epaLocationRealSrcSpanStart loc)
EpAnn _ AddRarrowAnnU{} _ ->
error "brittany internal error: HsFunTy EpAnn"
EpAnn _ AddLollyAnnU{} _ ->

8
source/library/Language/Haskell/Brittany/Internal/Transformations/T1_Alt.hs
View File

@ -301,8 +301,8 @@ transformAlts =
-- > bd' <- rec bd
-- not sure if the lineModeDecay is relevant any longer though..
reWrap . BDFlushCommentsPrior loc <$> rec bd
BDFlushCommentsPost loc bd ->
reWrap . BDFlushCommentsPost loc <$> rec bd
BDFlushCommentsPost loc shouldMark bd ->
reWrap . BDFlushCommentsPost loc shouldMark <$> rec bd
BDLines [] -> return $ reWrap BDEmpty -- evil transformation. or harmless.
BDLines (l : lr) -> do
ind <- _acp_indent <$> mGet
@ -487,7 +487,7 @@ getSpacing !bridoc = rec bridoc
_ -> VerticalSpacing 999 VerticalSpacingParNone False
BDQueueComments _comms bd -> rec bd
BDFlushCommentsPrior _loc bd -> rec bd
BDFlushCommentsPost _loc bd -> rec bd
BDFlushCommentsPost _loc _shouldMark bd -> rec bd
BDEntryDelta _dp bd -> rec bd
BDLines [] ->
return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False
@ -789,7 +789,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
]
BDQueueComments _comms bd -> rec bd
BDFlushCommentsPrior _loc bd -> rec bd
BDFlushCommentsPost _loc bd -> rec bd
BDFlushCommentsPost _loc _shouldMark bd -> rec bd
BDEntryDelta _dp bd -> rec bd
BDLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False]
BDLines ls@(_ : _) -> do

92
source/library/Language/Haskell/Brittany/Internal/Transformations/T2_Floating.hs
View File

@ -31,6 +31,8 @@ transformSimplifyFloating = stepBO .> stepFull
-- prior floating in
BDFlushCommentsPrior loc1 (BDFlushCommentsPrior loc2 x) ->
Just $ BDFlushCommentsPrior (max loc1 loc2) x
BDFlushCommentsPrior loc1 (BDFlushCommentsPost loc2 shouldMark2 x) ->
Just $ BDFlushCommentsPost loc2 shouldMark2 (BDFlushCommentsPrior loc1 x)
BDFlushCommentsPrior loc1 (BDPar ind line indented) ->
Just $ BDPar ind (BDFlushCommentsPrior loc1 line) indented
BDFlushCommentsPrior loc1 (BDSeq (l : lr)) ->
@ -43,32 +45,57 @@ transformSimplifyFloating = stepBO .> stepFull
Just $ BDAddBaseY indent $ BDFlushCommentsPrior loc1 x
BDFlushCommentsPrior loc1 (BDDebug s x) ->
Just $ BDDebug s $ BDFlushCommentsPrior loc1 x
BDFlushCommentsPrior loc1 (BDQueueComments comms1 x) ->
Just $ BDQueueComments comms1 $ BDFlushCommentsPrior loc1 x
_ -> Nothing
descendCommsPost = transformDownMay $ \case
-- post floating in
BDFlushCommentsPost loc1 (BDFlushCommentsPost loc2 x) ->
Just $ BDFlushCommentsPost (max loc1 loc2) x
BDFlushCommentsPost loc1 (BDPar ind line indented) ->
Just $ BDPar ind line $ BDFlushCommentsPost loc1 indented
BDFlushCommentsPost loc1 (BDSeq list) ->
BDFlushCommentsPost loc1 mark1 (BDFlushCommentsPost loc2 mark2 x) ->
Just $ BDFlushCommentsPost (max loc1 loc2) (mark1 || mark2) x
BDFlushCommentsPost loc1 shouldMark1 (BDPar ind line indented) ->
Just $ BDPar ind line $ BDFlushCommentsPost loc1 shouldMark1 indented
BDFlushCommentsPost loc1 shouldMark1 (BDSeq list) ->
Just
$ BDSeq
$ List.init list
++ [BDFlushCommentsPost loc1 $ List.last list]
BDFlushCommentsPost loc1 (BDLines list) ->
++ [BDFlushCommentsPost loc1 shouldMark1 $ List.last list]
BDFlushCommentsPost loc1 shouldMark1 (BDLines list) ->
Just
$ BDLines
$ List.init list
++ [BDFlushCommentsPost loc1 $ List.last list]
BDFlushCommentsPost loc1 (BDCols sig cols) ->
++ [BDFlushCommentsPost loc1 shouldMark1 $ List.last list]
BDFlushCommentsPost loc1 shouldMark1 (BDCols sig cols) ->
Just
$ BDCols sig
$ List.init cols
++ [BDFlushCommentsPost loc1 $ List.last cols]
BDFlushCommentsPost loc1 (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDFlushCommentsPost loc1 x
BDFlushCommentsPost loc1 (BDDebug s x) ->
Just $ BDDebug s $ BDFlushCommentsPost loc1 x
++ [BDFlushCommentsPost loc1 shouldMark1 $ List.last cols]
BDFlushCommentsPost loc1 shouldMark1 (BDIndentLevelPop x) ->
Just $ BDIndentLevelPop (BDFlushCommentsPost loc1 shouldMark1 x)
BDFlushCommentsPost loc1 shouldMark1 (BDIndentLevelPushCur x) ->
Just $ BDIndentLevelPushCur (BDFlushCommentsPost loc1 shouldMark1 x)
BDFlushCommentsPost loc1 shouldMark1 (BDBaseYPushCur x) ->
Just $ BDBaseYPushCur (BDFlushCommentsPost loc1 shouldMark1 x)
BDFlushCommentsPost loc1 shouldMark1 (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDFlushCommentsPost loc1 shouldMark1 x
BDFlushCommentsPost loc1 shouldMark1 (BDDebug s x) ->
Just $ BDDebug s $ BDFlushCommentsPost loc1 shouldMark1 x
_ -> Nothing
descendQueueComments = transformDownMay $ \case
-- queue comments floating in
BDQueueComments comms1 (BDQueueComments comms2 x) ->
Just $ BDQueueComments (comms1 ++ comms2) x
BDQueueComments comms1 (BDPar ind line indented) ->
Just $ BDPar ind (BDQueueComments comms1 line) indented
BDQueueComments comms1 (BDSeq (l : lr)) ->
Just $ BDSeq (BDQueueComments comms1 l : lr)
BDQueueComments comms1 (BDLines (l : lr)) ->
Just $ BDLines (BDQueueComments comms1 l : lr)
BDQueueComments comms1 (BDCols sig (l : lr)) ->
Just $ BDCols sig (BDQueueComments comms1 l : lr)
BDQueueComments comms1 (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDQueueComments comms1 x
BDQueueComments comms1 (BDDebug s x) ->
Just $ BDDebug s $ BDQueueComments comms1 x
_ -> Nothing
descendBYPush = transformDownMay $ \case
BDBaseYPushCur (BDCols sig cols@(_ : _)) ->
@ -114,8 +141,8 @@ transformSimplifyFloating = stepBO .> stepFull
Just $ BDPar (mergeIndents ind1 ind2) line indented
BDAddBaseY ind (BDFlushCommentsPrior loc x) ->
Just $ BDFlushCommentsPrior loc (BDAddBaseY ind x)
BDAddBaseY ind (BDFlushCommentsPost loc x) ->
Just $ BDFlushCommentsPost loc (BDAddBaseY ind x)
BDAddBaseY ind (BDFlushCommentsPost loc shouldMark x) ->
Just $ BDFlushCommentsPost loc shouldMark (BDAddBaseY ind x)
BDAddBaseY ind (BDQueueComments comms x) ->
Just $ BDQueueComments comms (BDAddBaseY ind x)
BDAddBaseY ind (BDSeq list) ->
@ -151,6 +178,7 @@ transformSimplifyFloating = stepBO .> stepFull
BDSeq xs -> BDSeq (dropWhile (\case BDEmpty -> True; _ -> False) xs)
x@BDFlushCommentsPrior{} -> descendCommsPrior x
x@BDFlushCommentsPost{} -> descendCommsPost x
x@BDQueueComments{} -> descendQueueComments x
x@BDAddBaseY{} -> descendAddB x
x@BDBaseYPushCur{} -> descendBYPush x
x@BDEntryDelta{} -> descendEntryDelta x
@ -186,8 +214,10 @@ transformSimplifyFloating = stepBO .> stepFull
-- BDEnsureIndent indent (BDLines lines) ->
-- Just $ BDLines $ BDEnsureIndent indent <$> lines
-- flush-prior floating in
BDFlushCommentsPrior loc (BDPar ind line indented) ->
Just $ BDPar ind (BDFlushCommentsPrior loc line) indented
BDFlushCommentsPrior loc1 (BDFlushCommentsPrior loc2 x) ->
Just $ BDFlushCommentsPrior (max loc1 loc2) x
BDFlushCommentsPrior loc1 (BDFlushCommentsPost loc2 shouldMark2 x) ->
Just $ BDFlushCommentsPost loc2 shouldMark2 (BDFlushCommentsPrior loc1 x)
BDFlushCommentsPrior loc (BDSeq (l : lr)) ->
Just $ BDSeq (BDFlushCommentsPrior loc l : lr)
BDFlushCommentsPrior loc (BDLines (l : lr)) ->
@ -195,14 +225,24 @@ transformSimplifyFloating = stepBO .> stepFull
BDFlushCommentsPrior loc (BDCols sig (l : lr)) ->
Just $ BDCols sig (BDFlushCommentsPrior loc l : lr)
-- flush-post floating in
BDFlushCommentsPost comms1 (BDPar ind line indented) ->
Just $ BDPar ind line $ BDFlushCommentsPost comms1 indented
BDFlushCommentsPost loc (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDFlushCommentsPost loc $ List.last list]
BDFlushCommentsPost loc (BDLines list) -> Just
$ BDLines $ List.init list ++ [BDFlushCommentsPost loc $ List.last list]
BDFlushCommentsPost loc (BDCols sig list) -> Just
$ BDCols sig $ List.init list ++ [BDFlushCommentsPost loc $ List.last list]
BDFlushCommentsPost loc1 mark1 (BDPar ind line indented) ->
Just $ BDPar ind line $ BDFlushCommentsPost loc1 mark1 indented
BDFlushCommentsPost loc1 mark1 (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDFlushCommentsPost loc1 mark1 $ List.last list]
BDFlushCommentsPost loc1 mark1 (BDLines list) ->
Just $ BDLines $ List.init list ++ [BDFlushCommentsPost loc1 mark1 $ List.last list]
BDFlushCommentsPost loc1 mark1 (BDCols sig list) ->
Just $ BDCols sig $ List.init list ++ [BDFlushCommentsPost loc1 mark1 $ List.last list]
BDFlushCommentsPost loc1 mark1 (BDIndentLevelPop x) ->
Just $ BDIndentLevelPop (BDFlushCommentsPost loc1 mark1 x)
BDFlushCommentsPost loc1 mark1 (BDIndentLevelPushCur x) ->
Just $ BDIndentLevelPushCur (BDFlushCommentsPost loc1 mark1 x)
BDFlushCommentsPost loc1 mark1 (BDBaseYPushCur x) ->
Just $ BDBaseYPushCur (BDFlushCommentsPost loc1 mark1 x)
BDFlushCommentsPost loc1 mark1 (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDFlushCommentsPost loc1 mark1 x
BDFlushCommentsPost loc1 mark1 (BDDebug s x) ->
Just $ BDDebug s $ BDFlushCommentsPost loc1 mark1 x
-- entry-delta floating in
BDEntryDelta dp (BDPar ind line indented) ->
Just $ BDPar ind (BDEntryDelta dp line) indented

18
source/library/Language/Haskell/Brittany/Internal/Transformations/T4_Columns.hs
View File

@ -33,7 +33,7 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
(\case
BDSeparator -> True
BDFlushCommentsPrior _ BDSeparator -> True
BDFlushCommentsPost _ BDSeparator -> True
BDFlushCommentsPost _ _ BDSeparator -> True
_ -> False
)
rest
@ -57,12 +57,16 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
BDFlushCommentsPrior loc (BDCols sig (l : lr)) ->
Just $ BDCols sig (BDFlushCommentsPrior loc l : lr)
-- flush-post floating in
BDFlushCommentsPost loc (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDFlushCommentsPost loc $ List.last list]
BDFlushCommentsPost loc (BDLines list) -> Just
$ BDLines $ List.init list ++ [BDFlushCommentsPost loc $ List.last list]
BDFlushCommentsPost loc (BDCols sig list) -> Just
$ BDCols sig $ List.init list ++ [BDFlushCommentsPost loc $ List.last list]
BDFlushCommentsPost loc shouldMark (BDSeq list) ->
Just
$ BDSeq
$ List.init list ++ [BDFlushCommentsPost loc shouldMark $ List.last list]
BDFlushCommentsPost loc shouldMark (BDLines list) -> Just
$ BDLines
$ List.init list ++ [BDFlushCommentsPost loc shouldMark $ List.last list]
BDFlushCommentsPost loc shouldMark (BDCols sig list) -> Just
$ BDCols sig
$ List.init list ++ [BDFlushCommentsPost loc shouldMark $ List.last list]
-- ensureIndent float-in
-- not sure if the following rule is necessary; tests currently are
-- unaffected.

4
source/library/Language/Haskell/Brittany/Internal/Transformations/T5_Indent.hs
View File

@ -42,8 +42,8 @@ transformSimplifyIndent = Uniplate.rewrite $ \case
BDLines [l] -> Just l
BDAddBaseY i (BDFlushCommentsPrior c x) ->
Just $ BDFlushCommentsPrior c (BDAddBaseY i x)
BDAddBaseY i (BDFlushCommentsPost c x) ->
Just $ BDFlushCommentsPost c (BDAddBaseY i x)
BDAddBaseY i (BDFlushCommentsPost c sm x) ->
Just $ BDFlushCommentsPost c sm (BDAddBaseY i x)
BDAddBaseY i (BDSeq l) ->
Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l]
BDAddBaseY i (BDCols sig l) ->

2
source/library/Language/Haskell/Brittany/Internal/Utils.hs
View File

@ -249,7 +249,7 @@ briDocToDoc = astToDoc . removeAnnotations
where
removeAnnotations = Uniplate.transform $ \case
BDFlushCommentsPrior _ x -> x
BDFlushCommentsPost _ x -> x
BDFlushCommentsPost _ _ x -> x
BDQueueComments _ x -> x
x -> x

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

@ -409,7 +409,7 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
BDPlain t -> return $ Text.length t
BDQueueComments _ bd -> rec bd
BDFlushCommentsPrior _ bd -> rec bd
BDFlushCommentsPost _ bd -> rec bd
BDFlushCommentsPost _ _ bd -> rec bd
BDLines ls@(_ : _) -> do
x <- StateS.get
return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x
@ -446,7 +446,7 @@ briDocIsMultiLine briDoc = rec briDoc
BDPlain _ -> True
BDQueueComments _ bd -> rec bd
BDFlushCommentsPrior _ bd -> rec bd
BDFlushCommentsPost _ bd -> rec bd
BDFlushCommentsPost _ _ bd -> rec bd
BDEntryDelta _dp bd -> rec bd
BDLines (_ : _ : _) -> True
BDLines [_] -> False

26
source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Operators.hs
View File

@ -15,8 +15,11 @@ module Language.Haskell.Brittany.Internal.WriteBriDoc.Operators
, layoutIndentLevelPushCur
, layoutIndentLevelPop
, layoutWriteNewline
, layoutWriteNewlines
, layoutWriteComment
, layoutFlushLine
, layoutSetMarker
, layoutUpdateMarker
)
where
@ -26,6 +29,7 @@ import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified GHC.OldList as List
import qualified GHC.Parser.Annotation as GHC
import GHC ( RealSrcLoc )
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.WriteBriDoc.Types
@ -93,6 +97,17 @@ layoutWriteNewline = do
{ _lstate_plannedSpace = PlannedNewline 1
}
layoutWriteNewlines
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
=> Int
-> m ()
layoutWriteNewlines n = do
traceLocal ("layoutWriteNewlines")
state <- mGet
mSet $ state
{ _lstate_plannedSpace = PlannedNewline n
}
-- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m
-- , MonadMultiWriter (Seq String) m) => Int -> m ()
-- layoutMoveToIndentCol i = do
@ -322,6 +337,17 @@ layoutFlushLine = do
state <- mGet
when (_lstate_curY state > 0) layoutWriteEnsureNewlineBlock
layoutSetMarker :: (MonadMultiState LayoutState m) => Maybe RealSrcLoc -> m ()
layoutSetMarker markerMay =
mModify $ \s -> s { _lstate_markerForDelta = markerMay }
layoutUpdateMarker :: (MonadMultiState LayoutState m) => RealSrcLoc -> m ()
layoutUpdateMarker marker = mModify $ \s -> s
{ _lstate_markerForDelta = case _lstate_markerForDelta s of
Nothing -> Nothing
Just _ -> Just marker
}
-- moveToY :: MonadMultiState LayoutState m => Int -> m ()
-- moveToY y = mModify $ \state ->
-- let

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

@ -7,6 +7,7 @@ import Language.Haskell.Brittany.Internal.Prelude
import qualified Safe
import GHC ( LEpaComment
, RealSrcLoc
)
import qualified Data.Text.Lazy.Builder as TextL.Builder
@ -60,6 +61,7 @@ data LayoutState = LayoutState
-- But the worst effect at the moment would
-- be that we introduce less newlines on
-- moveToKWDP, which seems harmless enough.
, _lstate_markerForDelta :: Maybe RealSrcLoc
}
lstate_baseY :: LayoutState -> Int