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

1
data/15-regressions.blt
View File

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

14
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 -- queue to be later flushed when the markers are reached
| BDFlushCommentsPrior RealSrcLoc (BriDocRec w) | BDFlushCommentsPrior RealSrcLoc (BriDocRec w)
-- process comments before loc from the queue -- 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 -- 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) | BDEntryDelta DeltaPos (BriDocRec w)
-- Move to the specified delta position before rendering the inner -- Move to the specified delta position before rendering the inner
-- element. Currently this only ever respects newlines, i.e. Sameline -- element. Currently this only ever respects newlines, i.e. Sameline
@ -124,8 +126,8 @@ instance Uniplate.Uniplate BriDoc where
plate BDQueueComments |- comms |* bd plate BDQueueComments |- comms |* bd
uniplate (BDFlushCommentsPrior loc bd) = uniplate (BDFlushCommentsPrior loc bd) =
plate BDFlushCommentsPrior |- loc |* bd plate BDFlushCommentsPrior |- loc |* bd
uniplate (BDFlushCommentsPost loc bd) = uniplate (BDFlushCommentsPost loc shouldMark bd) =
plate BDFlushCommentsPost |- loc |* bd plate BDFlushCommentsPost |- loc |- shouldMark |* bd
uniplate (BDEntryDelta dp bd ) = plate BDEntryDelta |- dp |* bd uniplate (BDEntryDelta dp bd ) = plate BDEntryDelta |- dp |* bd
uniplate (BDLines lines ) = plate BDLines ||* lines uniplate (BDLines lines ) = plate BDLines ||* lines
uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd
@ -155,7 +157,7 @@ briDocSeqSpine = \case
BDPlain{} -> () BDPlain{} -> ()
BDQueueComments _comms bd -> briDocSeqSpine bd BDQueueComments _comms bd -> briDocSeqSpine bd
BDFlushCommentsPrior _loc bd -> briDocSeqSpine bd BDFlushCommentsPrior _loc bd -> briDocSeqSpine bd
BDFlushCommentsPost _loc bd -> briDocSeqSpine bd BDFlushCommentsPost _loc _m bd -> briDocSeqSpine bd
BDEntryDelta _dp bd -> briDocSeqSpine bd BDEntryDelta _dp bd -> briDocSeqSpine bd
BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines
BDEnsureIndent _ind bd -> briDocSeqSpine bd BDEnsureIndent _ind bd -> briDocSeqSpine bd
@ -192,7 +194,7 @@ unwrapBriDocNumbered tpl = case snd tpl of
BDPlain t -> BDPlain t BDPlain t -> BDPlain t
BDQueueComments comms bd -> BDQueueComments comms $ rec bd BDQueueComments comms bd -> BDQueueComments comms $ rec bd
BDFlushCommentsPrior loc bd -> BDFlushCommentsPrior loc $ rec bd BDFlushCommentsPrior loc bd -> BDFlushCommentsPrior loc $ rec bd
BDFlushCommentsPost loc bd -> BDFlushCommentsPost loc $ rec bd BDFlushCommentsPost loc mrk bd -> BDFlushCommentsPost loc mrk $ rec bd
BDEntryDelta dp bd -> BDEntryDelta dp $ rec bd BDEntryDelta dp bd -> BDEntryDelta dp $ rec bd
BDLines lines -> BDLines $ rec <$> lines BDLines lines -> BDLines $ rec <$> lines
BDEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd BDEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd

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

@ -474,7 +474,7 @@ docAddEntryDelta dp bdm = do
allocateNode (BDEntryDelta dp bd) allocateNode (BDEntryDelta dp bd)
docFlushRemaining :: FastString -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docFlushRemaining :: FastString -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docFlushRemaining fileThing = docFlushCommsPost docFlushRemaining fileThing = docFlushCommsPost False
(Just $ GHC.mkRealSrcLoc fileThing 999999 999999) (Just $ GHC.mkRealSrcLoc fileThing 999999 999999)
-- CLASS DocHandleComms -------------------------------------------------------- -- CLASS DocHandleComms --------------------------------------------------------
@ -671,28 +671,36 @@ instance ObtainAnnDeltaPos (EpAnn GHC.AnnsModule) where
) )
pos pos
class DocFlushCommsPost a where class DocFlushCommsPost ann a where
docFlushCommsPost :: Maybe GHC.RealSrcLoc -> a -> a docFlushCommsPost :: Bool -> ann -> a -> a
instance DocFlushCommsPost (ToBriDocM BriDocNumbered) where instance DocFlushCommsPost (Maybe GHC.RealSrcLoc) (ToBriDocM BriDocNumbered) where
docFlushCommsPost = \case docFlushCommsPost shouldMark = \case
Nothing -> id Nothing -> id
Just span -> \bdm -> do Just loc -> \bdm -> do
i1 <- allocNodeIndex i1 <- allocNodeIndex
bd <- bdm bd <- bdm
pure (i1, BDFlushCommentsPost span bd) pure (i1, BDFlushCommentsPost loc shouldMark bd)
instance DocFlushCommsPost (ToBriDocM [BriDocNumbered]) where instance DocFlushCommsPost ann (ToBriDocM BriDocNumbered)
docFlushCommsPost loc bdm = do => DocFlushCommsPost ann (ToBriDocM [BriDocNumbered]) where
docFlushCommsPost shouldMark loc bdm = do
bds <- bdm bds <- bdm
case bds of case bds of
[] -> do [] -> do
e <- docFlushCommsPost loc docEmpty e <- docFlushCommsPost shouldMark loc docEmpty
pure [e] pure [e]
_ -> do _ -> do
e <- docFlushCommsPost loc (pure $ List.last bds) e <- docFlushCommsPost shouldMark loc (pure $ List.last bds)
pure (List.init bds ++ [e]) 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 unknownNodeError
:: (Data a, Data (GHC.Anno a), Outputable (GHC.Anno a)) :: (Data a, Data (GHC.Anno a), Outputable (GHC.Anno a))
=> String => String
@ -737,7 +745,32 @@ docHandleListElemComms
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docHandleListElemComms layouter e = case obtainListElemStartCommaLocs e of docHandleListElemComms layouter e = case obtainListElemStartCommaLocs e of
(posStart, posComma) -> (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.EpaLocation -> GHC.RealSrcLoc
epaLocationRealSrcSpanStart = GHC.realSrcSpanStart . GHC.epaLocationRealSrcSpan epaLocationRealSrcSpanStart = GHC.realSrcSpanStart . GHC.epaLocationRealSrcSpan

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

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

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

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

12
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 import GHC.Types.Basic
(Activation(..), InlinePragma(..), InlineSpec(..), RuleMatchInfo(..)) (Activation(..), InlinePragma(..), InlineSpec(..), RuleMatchInfo(..))
import GHC.Types.SrcLoc (Located, getLoc, unLoc) import GHC.Types.SrcLoc (Located, getLoc, unLoc)
import qualified GHC
import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Types.SrcLoc as GHC
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
@ -240,7 +241,7 @@ layoutGrhs (L _ (GRHS epAnn guards body)) = do
let posArrow = obtainAnnPos epAnn AnnRarrow let posArrow = obtainAnnPos epAnn AnnRarrow
guardDocs <- case guards of guardDocs <- case guards of
[] -> pure [] [] -> pure []
_ -> docFlushCommsPost posArrow $ layoutStmt `mapM` guards _ -> docFlushCommsPost False posArrow $ layoutStmt `mapM` guards
bodyDoc <- layoutExpr body bodyDoc <- layoutExpr body
return (docHandleComms epAnn, guardDocs, bodyDoc) return (docHandleComms epAnn, guardDocs, bodyDoc)
@ -255,9 +256,13 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) =
let (GRHSs _ grhss whereBinds) = m_grhss match let (GRHSs _ grhss whereBinds) = m_grhss match
patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p
let isInfix = isInfixMatch match 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 mIdDoc <- case match of
Match epAnn (FunRhs matchId _ _) _ _ -> Match epAnn (FunRhs matchId _ _) _ _ ->
fmap Just $ docHandleComms epAnn $ do fmap Just
$ docHandleComms epAnn $ do
t <- lrdrNameToTextAnn matchId t <- lrdrNameToTextAnn matchId
let t' = fixPatternBindIdentifier match t let t' = fixPatternBindIdentifier match t
docLit t' docLit t'
@ -295,7 +300,8 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) =
-- let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch) -- let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch)
let alignmentToken = if null pats then Nothing else funId let alignmentToken = if null pats then Nothing else funId
let hasComments = hasAnyCommentsBelow lmatch let hasComments = hasAnyCommentsBelow lmatch
layoutPatternBindFinal docFlushCommsPost True matchEndLoc
$ layoutPatternBindFinal
alignmentToken alignmentToken
binderDoc binderDoc
(Just patDoc) (Just patDoc)

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 if pun
then pure $ Left (posStart, fnameDoc) then pure $ Left (posStart, fnameDoc)
else do else do
expDoc <- shareDoc $ docFlushCommsPost posComma $ layoutExpr rFExpr expDoc <-
shareDoc $ docFlushCommsPost True posComma $ layoutExpr rFExpr
pure $ Right (posStart, fnameDoc, expDoc) pure $ Right (posStart, fnameDoc, expDoc)
fieldTuple1 <- mkFieldTuple rF1 fieldTuple1 <- mkFieldTuple rF1
fieldTupleR <- rFr `forM` mkFieldTuple 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{} _ -> EpAnn _ AddVbarAnn{} _ ->
error "brittany internal error: HsFunTy EpAnn" error "brittany internal error: HsFunTy EpAnn"
EpAnn _ (AddRarrowAnn loc) _ -> EpAnn _ (AddRarrowAnn loc) _ ->
docFlushCommsPost (Just $ epaLocationRealSrcSpanStart loc) docFlushCommsPost True (Just $ epaLocationRealSrcSpanStart loc)
EpAnn _ AddRarrowAnnU{} _ -> EpAnn _ AddRarrowAnnU{} _ ->
error "brittany internal error: HsFunTy EpAnn" error "brittany internal error: HsFunTy EpAnn"
EpAnn _ AddLollyAnnU{} _ -> EpAnn _ AddLollyAnnU{} _ ->

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

@ -301,8 +301,8 @@ transformAlts =
-- > bd' <- rec bd -- > bd' <- rec bd
-- not sure if the lineModeDecay is relevant any longer though.. -- not sure if the lineModeDecay is relevant any longer though..
reWrap . BDFlushCommentsPrior loc <$> rec bd reWrap . BDFlushCommentsPrior loc <$> rec bd
BDFlushCommentsPost loc bd -> BDFlushCommentsPost loc shouldMark bd ->
reWrap . BDFlushCommentsPost loc <$> rec bd reWrap . BDFlushCommentsPost loc shouldMark <$> rec bd
BDLines [] -> return $ reWrap BDEmpty -- evil transformation. or harmless. BDLines [] -> return $ reWrap BDEmpty -- evil transformation. or harmless.
BDLines (l : lr) -> do BDLines (l : lr) -> do
ind <- _acp_indent <$> mGet ind <- _acp_indent <$> mGet
@ -487,7 +487,7 @@ getSpacing !bridoc = rec bridoc
_ -> VerticalSpacing 999 VerticalSpacingParNone False _ -> VerticalSpacing 999 VerticalSpacingParNone False
BDQueueComments _comms bd -> rec bd BDQueueComments _comms bd -> rec bd
BDFlushCommentsPrior _loc bd -> rec bd BDFlushCommentsPrior _loc bd -> rec bd
BDFlushCommentsPost _loc bd -> rec bd BDFlushCommentsPost _loc _shouldMark bd -> rec bd
BDEntryDelta _dp bd -> rec bd BDEntryDelta _dp bd -> rec bd
BDLines [] -> BDLines [] ->
return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False
@ -789,7 +789,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
] ]
BDQueueComments _comms bd -> rec bd BDQueueComments _comms bd -> rec bd
BDFlushCommentsPrior _loc bd -> rec bd BDFlushCommentsPrior _loc bd -> rec bd
BDFlushCommentsPost _loc bd -> rec bd BDFlushCommentsPost _loc _shouldMark bd -> rec bd
BDEntryDelta _dp bd -> rec bd BDEntryDelta _dp bd -> rec bd
BDLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] BDLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False]
BDLines ls@(_ : _) -> do 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 -- prior floating in
BDFlushCommentsPrior loc1 (BDFlushCommentsPrior loc2 x) -> BDFlushCommentsPrior loc1 (BDFlushCommentsPrior loc2 x) ->
Just $ BDFlushCommentsPrior (max loc1 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) -> BDFlushCommentsPrior loc1 (BDPar ind line indented) ->
Just $ BDPar ind (BDFlushCommentsPrior loc1 line) indented Just $ BDPar ind (BDFlushCommentsPrior loc1 line) indented
BDFlushCommentsPrior loc1 (BDSeq (l : lr)) -> BDFlushCommentsPrior loc1 (BDSeq (l : lr)) ->
@ -43,32 +45,57 @@ transformSimplifyFloating = stepBO .> stepFull
Just $ BDAddBaseY indent $ BDFlushCommentsPrior loc1 x Just $ BDAddBaseY indent $ BDFlushCommentsPrior loc1 x
BDFlushCommentsPrior loc1 (BDDebug s x) -> BDFlushCommentsPrior loc1 (BDDebug s x) ->
Just $ BDDebug s $ BDFlushCommentsPrior loc1 x Just $ BDDebug s $ BDFlushCommentsPrior loc1 x
BDFlushCommentsPrior loc1 (BDQueueComments comms1 x) ->
Just $ BDQueueComments comms1 $ BDFlushCommentsPrior loc1 x
_ -> Nothing _ -> Nothing
descendCommsPost = transformDownMay $ \case descendCommsPost = transformDownMay $ \case
-- post floating in -- post floating in
BDFlushCommentsPost loc1 (BDFlushCommentsPost loc2 x) -> BDFlushCommentsPost loc1 mark1 (BDFlushCommentsPost loc2 mark2 x) ->
Just $ BDFlushCommentsPost (max loc1 loc2) x Just $ BDFlushCommentsPost (max loc1 loc2) (mark1 || mark2) x
BDFlushCommentsPost loc1 (BDPar ind line indented) -> BDFlushCommentsPost loc1 shouldMark1 (BDPar ind line indented) ->
Just $ BDPar ind line $ BDFlushCommentsPost loc1 indented Just $ BDPar ind line $ BDFlushCommentsPost loc1 shouldMark1 indented
BDFlushCommentsPost loc1 (BDSeq list) -> BDFlushCommentsPost loc1 shouldMark1 (BDSeq list) ->
Just Just
$ BDSeq $ BDSeq
$ List.init list $ List.init list
++ [BDFlushCommentsPost loc1 $ List.last list] ++ [BDFlushCommentsPost loc1 shouldMark1 $ List.last list]
BDFlushCommentsPost loc1 (BDLines list) -> BDFlushCommentsPost loc1 shouldMark1 (BDLines list) ->
Just Just
$ BDLines $ BDLines
$ List.init list $ List.init list
++ [BDFlushCommentsPost loc1 $ List.last list] ++ [BDFlushCommentsPost loc1 shouldMark1 $ List.last list]
BDFlushCommentsPost loc1 (BDCols sig cols) -> BDFlushCommentsPost loc1 shouldMark1 (BDCols sig cols) ->
Just Just
$ BDCols sig $ BDCols sig
$ List.init cols $ List.init cols
++ [BDFlushCommentsPost loc1 $ List.last cols] ++ [BDFlushCommentsPost loc1 shouldMark1 $ List.last cols]
BDFlushCommentsPost loc1 (BDAddBaseY indent x) -> BDFlushCommentsPost loc1 shouldMark1 (BDIndentLevelPop x) ->
Just $ BDAddBaseY indent $ BDFlushCommentsPost loc1 x Just $ BDIndentLevelPop (BDFlushCommentsPost loc1 shouldMark1 x)
BDFlushCommentsPost loc1 (BDDebug s x) -> BDFlushCommentsPost loc1 shouldMark1 (BDIndentLevelPushCur x) ->
Just $ BDDebug s $ BDFlushCommentsPost loc1 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 _ -> Nothing
descendBYPush = transformDownMay $ \case descendBYPush = transformDownMay $ \case
BDBaseYPushCur (BDCols sig cols@(_ : _)) -> BDBaseYPushCur (BDCols sig cols@(_ : _)) ->
@ -114,8 +141,8 @@ transformSimplifyFloating = stepBO .> stepFull
Just $ BDPar (mergeIndents ind1 ind2) line indented Just $ BDPar (mergeIndents ind1 ind2) line indented
BDAddBaseY ind (BDFlushCommentsPrior loc x) -> BDAddBaseY ind (BDFlushCommentsPrior loc x) ->
Just $ BDFlushCommentsPrior loc (BDAddBaseY ind x) Just $ BDFlushCommentsPrior loc (BDAddBaseY ind x)
BDAddBaseY ind (BDFlushCommentsPost loc x) -> BDAddBaseY ind (BDFlushCommentsPost loc shouldMark x) ->
Just $ BDFlushCommentsPost loc (BDAddBaseY ind x) Just $ BDFlushCommentsPost loc shouldMark (BDAddBaseY ind x)
BDAddBaseY ind (BDQueueComments comms x) -> BDAddBaseY ind (BDQueueComments comms x) ->
Just $ BDQueueComments comms (BDAddBaseY ind x) Just $ BDQueueComments comms (BDAddBaseY ind x)
BDAddBaseY ind (BDSeq list) -> BDAddBaseY ind (BDSeq list) ->
@ -151,6 +178,7 @@ transformSimplifyFloating = stepBO .> stepFull
BDSeq xs -> BDSeq (dropWhile (\case BDEmpty -> True; _ -> False) xs) BDSeq xs -> BDSeq (dropWhile (\case BDEmpty -> True; _ -> False) xs)
x@BDFlushCommentsPrior{} -> descendCommsPrior x x@BDFlushCommentsPrior{} -> descendCommsPrior x
x@BDFlushCommentsPost{} -> descendCommsPost x x@BDFlushCommentsPost{} -> descendCommsPost x
x@BDQueueComments{} -> descendQueueComments x
x@BDAddBaseY{} -> descendAddB x x@BDAddBaseY{} -> descendAddB x
x@BDBaseYPushCur{} -> descendBYPush x x@BDBaseYPushCur{} -> descendBYPush x
x@BDEntryDelta{} -> descendEntryDelta x x@BDEntryDelta{} -> descendEntryDelta x
@ -186,8 +214,10 @@ transformSimplifyFloating = stepBO .> stepFull
-- BDEnsureIndent indent (BDLines lines) -> -- BDEnsureIndent indent (BDLines lines) ->
-- Just $ BDLines $ BDEnsureIndent indent <$> lines -- Just $ BDLines $ BDEnsureIndent indent <$> lines
-- flush-prior floating in -- flush-prior floating in
BDFlushCommentsPrior loc (BDPar ind line indented) -> BDFlushCommentsPrior loc1 (BDFlushCommentsPrior loc2 x) ->
Just $ BDPar ind (BDFlushCommentsPrior loc line) indented Just $ BDFlushCommentsPrior (max loc1 loc2) x
BDFlushCommentsPrior loc1 (BDFlushCommentsPost loc2 shouldMark2 x) ->
Just $ BDFlushCommentsPost loc2 shouldMark2 (BDFlushCommentsPrior loc1 x)
BDFlushCommentsPrior loc (BDSeq (l : lr)) -> BDFlushCommentsPrior loc (BDSeq (l : lr)) ->
Just $ BDSeq (BDFlushCommentsPrior loc l : lr) Just $ BDSeq (BDFlushCommentsPrior loc l : lr)
BDFlushCommentsPrior loc (BDLines (l : lr)) -> BDFlushCommentsPrior loc (BDLines (l : lr)) ->
@ -195,14 +225,24 @@ transformSimplifyFloating = stepBO .> stepFull
BDFlushCommentsPrior loc (BDCols sig (l : lr)) -> BDFlushCommentsPrior loc (BDCols sig (l : lr)) ->
Just $ BDCols sig (BDFlushCommentsPrior loc l : lr) Just $ BDCols sig (BDFlushCommentsPrior loc l : lr)
-- flush-post floating in -- flush-post floating in
BDFlushCommentsPost comms1 (BDPar ind line indented) -> BDFlushCommentsPost loc1 mark1 (BDPar ind line indented) ->
Just $ BDPar ind line $ BDFlushCommentsPost comms1 indented Just $ BDPar ind line $ BDFlushCommentsPost loc1 mark1 indented
BDFlushCommentsPost loc (BDSeq list) -> BDFlushCommentsPost loc1 mark1 (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDFlushCommentsPost loc $ List.last list] Just $ BDSeq $ List.init list ++ [BDFlushCommentsPost loc1 mark1 $ List.last list]
BDFlushCommentsPost loc (BDLines list) -> Just BDFlushCommentsPost loc1 mark1 (BDLines list) ->
$ BDLines $ List.init list ++ [BDFlushCommentsPost loc $ List.last list] Just $ BDLines $ List.init list ++ [BDFlushCommentsPost loc1 mark1 $ List.last list]
BDFlushCommentsPost loc (BDCols sig list) -> Just BDFlushCommentsPost loc1 mark1 (BDCols sig list) ->
$ BDCols sig $ List.init list ++ [BDFlushCommentsPost loc $ List.last 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 -- entry-delta floating in
BDEntryDelta dp (BDPar ind line indented) -> BDEntryDelta dp (BDPar ind line indented) ->
Just $ BDPar ind (BDEntryDelta dp 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 (\case
BDSeparator -> True BDSeparator -> True
BDFlushCommentsPrior _ BDSeparator -> True BDFlushCommentsPrior _ BDSeparator -> True
BDFlushCommentsPost _ BDSeparator -> True BDFlushCommentsPost _ _ BDSeparator -> True
_ -> False _ -> False
) )
rest rest
@ -57,12 +57,16 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
BDFlushCommentsPrior loc (BDCols sig (l : lr)) -> BDFlushCommentsPrior loc (BDCols sig (l : lr)) ->
Just $ BDCols sig (BDFlushCommentsPrior loc l : lr) Just $ BDCols sig (BDFlushCommentsPrior loc l : lr)
-- flush-post floating in -- flush-post floating in
BDFlushCommentsPost loc (BDSeq list) -> BDFlushCommentsPost loc shouldMark (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDFlushCommentsPost loc $ List.last list] Just
BDFlushCommentsPost loc (BDLines list) -> Just $ BDSeq
$ BDLines $ List.init list ++ [BDFlushCommentsPost loc $ List.last list] $ List.init list ++ [BDFlushCommentsPost loc shouldMark $ List.last list]
BDFlushCommentsPost loc (BDCols sig list) -> Just BDFlushCommentsPost loc shouldMark (BDLines list) -> Just
$ BDCols sig $ List.init list ++ [BDFlushCommentsPost loc $ List.last list] $ 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 -- ensureIndent float-in
-- not sure if the following rule is necessary; tests currently are -- not sure if the following rule is necessary; tests currently are
-- unaffected. -- 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 BDLines [l] -> Just l
BDAddBaseY i (BDFlushCommentsPrior c x) -> BDAddBaseY i (BDFlushCommentsPrior c x) ->
Just $ BDFlushCommentsPrior c (BDAddBaseY i x) Just $ BDFlushCommentsPrior c (BDAddBaseY i x)
BDAddBaseY i (BDFlushCommentsPost c x) -> BDAddBaseY i (BDFlushCommentsPost c sm x) ->
Just $ BDFlushCommentsPost c (BDAddBaseY i x) Just $ BDFlushCommentsPost c sm (BDAddBaseY i x)
BDAddBaseY i (BDSeq l) -> BDAddBaseY i (BDSeq l) ->
Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l] Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l]
BDAddBaseY i (BDCols sig l) -> BDAddBaseY i (BDCols sig l) ->

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

@ -249,7 +249,7 @@ briDocToDoc = astToDoc . removeAnnotations
where where
removeAnnotations = Uniplate.transform $ \case removeAnnotations = Uniplate.transform $ \case
BDFlushCommentsPrior _ x -> x BDFlushCommentsPrior _ x -> x
BDFlushCommentsPost _ x -> x BDFlushCommentsPost _ _ x -> x
BDQueueComments _ x -> x BDQueueComments _ x -> x
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 BDPlain t -> return $ Text.length t
BDQueueComments _ bd -> rec bd BDQueueComments _ bd -> rec bd
BDFlushCommentsPrior _ bd -> rec bd BDFlushCommentsPrior _ bd -> rec bd
BDFlushCommentsPost _ bd -> rec bd BDFlushCommentsPost _ _ bd -> rec bd
BDLines ls@(_ : _) -> do BDLines ls@(_ : _) -> do
x <- StateS.get x <- StateS.get
return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x
@ -446,7 +446,7 @@ briDocIsMultiLine briDoc = rec briDoc
BDPlain _ -> True BDPlain _ -> True
BDQueueComments _ bd -> rec bd BDQueueComments _ bd -> rec bd
BDFlushCommentsPrior _ bd -> rec bd BDFlushCommentsPrior _ bd -> rec bd
BDFlushCommentsPost _ bd -> rec bd BDFlushCommentsPost _ _ bd -> rec bd
BDEntryDelta _dp bd -> rec bd BDEntryDelta _dp bd -> rec bd
BDLines (_ : _ : _) -> True BDLines (_ : _ : _) -> True
BDLines [_] -> False 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 , layoutIndentLevelPushCur
, layoutIndentLevelPop , layoutIndentLevelPop
, layoutWriteNewline , layoutWriteNewline
, layoutWriteNewlines
, layoutWriteComment , layoutWriteComment
, layoutFlushLine , layoutFlushLine
, layoutSetMarker
, layoutUpdateMarker
) )
where where
@ -26,6 +29,7 @@ import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified GHC.OldList as List import qualified GHC.OldList as List
import qualified GHC.Parser.Annotation as GHC import qualified GHC.Parser.Annotation as GHC
import GHC ( RealSrcLoc )
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.WriteBriDoc.Types import Language.Haskell.Brittany.Internal.WriteBriDoc.Types
@ -93,6 +97,17 @@ layoutWriteNewline = do
{ _lstate_plannedSpace = PlannedNewline 1 { _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 -- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m
-- , MonadMultiWriter (Seq String) m) => Int -> m () -- , MonadMultiWriter (Seq String) m) => Int -> m ()
-- layoutMoveToIndentCol i = do -- layoutMoveToIndentCol i = do
@ -322,6 +337,17 @@ layoutFlushLine = do
state <- mGet state <- mGet
when (_lstate_curY state > 0) layoutWriteEnsureNewlineBlock 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 :: MonadMultiState LayoutState m => Int -> m ()
-- moveToY y = mModify $ \state -> -- moveToY y = mModify $ \state ->
-- let -- 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 qualified Safe
import GHC ( LEpaComment import GHC ( LEpaComment
, RealSrcLoc
) )
import qualified Data.Text.Lazy.Builder as TextL.Builder import qualified Data.Text.Lazy.Builder as TextL.Builder
@ -60,6 +61,7 @@ data LayoutState = LayoutState
-- But the worst effect at the moment would -- But the worst effect at the moment would
-- be that we introduce less newlines on -- be that we introduce less newlines on
-- moveToKWDP, which seems harmless enough. -- moveToKWDP, which seems harmless enough.
, _lstate_markerForDelta :: Maybe RealSrcLoc
} }
lstate_baseY :: LayoutState -> Int lstate_baseY :: LayoutState -> Int