From ee2814e3a83e257969ed1f81e0b6a43bbb20865d Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 17 Mar 2023 15:02:48 +0000 Subject: [PATCH] Reintroduce BDAnnotationKW in the form of BDEntryDelta --- .../Brittany/Internal/Components/BriDoc.hs | 19 ++++--- .../Brittany/Internal/S3_ToBriDocTools.hs | 8 +-- .../Brittany/Internal/S4_WriteBriDoc.hs | 10 +++- .../Brittany/Internal/StepOrchestrate.hs | 7 --- .../Brittany/Internal/ToBriDoc/Module.hs | 12 ++++- .../Internal/Transformations/T1_Alt.hs | 14 +++--- .../Internal/Transformations/T2_Floating.hs | 49 ++++++++++++++++--- .../Internal/Transformations/T4_Columns.hs | 2 +- .../Internal/WriteBriDoc/AlignmentAlgo.hs | 4 +- 9 files changed, 86 insertions(+), 39 deletions(-) diff --git a/source/library/Language/Haskell/Brittany/Internal/Components/BriDoc.hs b/source/library/Language/Haskell/Brittany/Internal/Components/BriDoc.hs index 3d0cf07..ab92630 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Components/BriDoc.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Components/BriDoc.hs @@ -11,7 +11,7 @@ import Language.Haskell.Brittany.Internal.Prelude import Data.Generics.Uniplate.Direct as Uniplate import qualified Data.Data -import GHC (RealSrcLoc, LEpaComment) +import GHC (RealSrcLoc, LEpaComment, DeltaPos) @@ -29,7 +29,6 @@ data BriDoc | BDSeparator -- semantically, space-unless-at-end-of-line. | BDAddBaseY BrIndent BriDoc | BDBaseYPushCur BriDoc - | BDBaseYPop BriDoc | BDIndentLevelPushCur BriDoc | BDIndentLevelPop BriDoc | BDPar @@ -55,6 +54,14 @@ data BriDoc | BDFlushCommentsPost RealSrcLoc BriDoc -- process comments before loc from the queue, but flow to end of -- child-nodes + | BDEntryDelta DeltaPos BriDoc + -- Move to the specified delta position before rendering the inner + -- element. Currently this only ever respects newlines, i.e. Sameline + -- is ignored and only the `n` of DifferentLine n _ is used. + -- Purpose is to retain some spacing in the formatted code, inside + -- a particular declaration - on the top-level spacing is retained by + -- other means. + -- The deltas should in general derived via `obtainAnnDeltaPos`. | BDLines [BriDoc] | BDEnsureIndent BrIndent BriDoc -- the following constructors are only relevant for the alt transformation @@ -80,7 +87,6 @@ data BriDocF f | BDFSeparator -- semantically, space-unless-at-end-of-line. | BDFAddBaseY BrIndent (f (BriDocF f)) | BDFBaseYPushCur (f (BriDocF f)) - | BDFBaseYPop (f (BriDocF f)) | BDFIndentLevelPushCur (f (BriDocF f)) | BDFIndentLevelPop (f (BriDocF f)) | BDFPar @@ -106,6 +112,7 @@ data BriDocF f | BDFFlushCommentsPost RealSrcLoc (f (BriDocF f)) -- process comments before loc from the queue, but flow to end of -- child-nodes + | BDFEntryDelta DeltaPos (f (BriDocF f)) | BDFLines [(f (BriDocF f))] | BDFEnsureIndent BrIndent (f (BriDocF f)) | BDFForceMultiline (f (BriDocF f)) @@ -134,7 +141,6 @@ instance Uniplate.Uniplate BriDoc where 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 (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented @@ -148,6 +154,7 @@ instance Uniplate.Uniplate BriDoc where plate BDFlushCommentsPrior |- loc |* bd uniplate (BDFlushCommentsPost loc bd) = plate BDFlushCommentsPost |- loc |* bd + uniplate (BDEntryDelta dp bd ) = plate BDEntryDelta |- dp |* bd uniplate (BDLines lines ) = plate BDLines ||* lines uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd @@ -167,7 +174,6 @@ briDocSeqSpine = \case 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 @@ -178,6 +184,7 @@ briDocSeqSpine = \case BDQueueComments _comms bd -> briDocSeqSpine bd BDFlushCommentsPrior _loc bd -> briDocSeqSpine bd BDFlushCommentsPost _loc bd -> briDocSeqSpine bd + BDEntryDelta _dp bd -> briDocSeqSpine bd BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines BDEnsureIndent _ind bd -> briDocSeqSpine bd BDForceMultiline bd -> briDocSeqSpine bd @@ -204,7 +211,6 @@ unwrapBriDocNumbered tpl = case snd tpl of 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) @@ -215,6 +221,7 @@ unwrapBriDocNumbered tpl = case snd tpl of BDFQueueComments comms bd -> BDQueueComments comms $ rec bd BDFFlushCommentsPrior loc bd -> BDFlushCommentsPrior loc $ rec bd BDFFlushCommentsPost loc bd -> BDFlushCommentsPost loc $ rec bd + BDFEntryDelta dp bd -> BDEntryDelta dp $ rec bd BDFLines lines -> BDLines $ rec <$> lines BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd BDFForceMultiline bd -> BDForceMultiline $ rec bd diff --git a/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs b/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs index c97263a..c815e52 100644 --- a/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs +++ b/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs @@ -381,9 +381,7 @@ docSetBaseY bdm = do bd <- bdm -- the order here is important so that these two nodes can be treated -- properly over at `transformAlts`. - n1 <- allocateNode $ BDFBaseYPushCur bd - n2 <- allocateNode $ BDFBaseYPop n1 - return n2 + allocateNode $ BDFBaseYPushCur bd docSetIndentLevel :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docSetIndentLevel bdm = do @@ -470,6 +468,10 @@ docEnsureIndent :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd +docAddEntryDelta :: GHC.DeltaPos -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docAddEntryDelta dp bdm = do + bd <- bdm + allocateNode (BDFEntryDelta dp bd) docFlushRemaining :: FastString -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docFlushRemaining fileThing = docFlushCommsPost diff --git a/source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs b/source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs index c56e45e..64281a1 100644 --- a/source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs +++ b/source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs @@ -30,6 +30,7 @@ import GHC ( Anchor(Anchor) , GenLocated(L) , LEpaComment , RealSrcLoc + , DeltaPos(SameLine, DifferentLine) ) import GHC.Types.SrcLoc ( realSrcSpanEnd ) import qualified GHC.OldList as List @@ -143,8 +144,6 @@ layoutBriDocM = \case BDBaseYPushCur bd -> do layoutBaseYPushCur layoutBriDocM bd - BDBaseYPop bd -> do - layoutBriDocM bd layoutBaseYPop BDIndentLevelPushCur bd -> do layoutIndentLevelPushCur @@ -169,6 +168,13 @@ layoutBriDocM = \case indentF $ do layoutWriteNewline layoutBriDocM indented + BDEntryDelta dp bd -> do + case dp of + GHC.SameLine _ -> pure () + GHC.DifferentLine l _i -> mModify $ \s -> s { + _lstate_plannedSpace = PlannedNewline l + } + layoutBriDocM bd BDLines lines -> alignColsLines layoutBriDocM lines BDAlt [] -> error "empty BDAlt" BDAlt (alt : _) -> layoutBriDocM alt diff --git a/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs b/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs index 2bea417..cd92ad6 100644 --- a/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs +++ b/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs @@ -96,13 +96,6 @@ processModule traceFunc conf inlineConf parsedModule = do HsModule _ _layoutInfo Nothing Just{} _ _ _ _ -> error "brittany internal error: exports without module name" HsModule epAnn _layoutInfo (Just n) les _ _ _ _ -> do - let startDelta = obtainAnnDeltaPos epAnn GHC.AnnModule - tellDebugMess (show startDelta) - case startDelta of - Nothing -> pure () - Just GHC.SameLine{} -> pure () - Just (GHC.DifferentLine r _) -> - mTell $ TextL.Builder.fromString $ replicate (r - 1) '\n' (bd, _) <- briDocMToPPM $ maybe id diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Module.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Module.hs index 2323cb0..9128a94 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Module.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Module.hs @@ -33,9 +33,17 @@ moduleNameExportBridoc epAnn modName les = do -- the config should not prevent single-line layout when there is no -- export list let tn = Text.pack $ moduleNameString $ unLoc modName + let startDelta = obtainAnnDeltaPos epAnn AnnModule + -- tellDebugMess (show startDelta) + let wrapModule = case startDelta of + Nothing -> id + Just SameLine{} -> id + Just (DifferentLine 0 _) -> id + Just (DifferentLine 1 _) -> id + Just dp -> docAddEntryDelta dp docHandleComms epAnn $ docHandleComms posModule $ runFilteredAlternative $ do addAlternativeCond allowSingleLine $ docSeq - [ appSep $ docLit $ Text.pack "module" + [ appSep $ wrapModule $ docLit $ Text.pack "module" , appSep $ docLit tn , docForceSingleline $ appSep $ case les of Nothing -> docEmpty @@ -46,7 +54,7 @@ moduleNameExportBridoc epAnn modName les = do addAlternative $ docLines [ docAddBaseY BrIndentRegular $ docPar (docSeq - [appSep $ docLit $ Text.pack "module", docLit tn] + [appSep $ wrapModule $ docLit $ Text.pack "module", docLit tn] ) (docSeq [ case les of diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/T1_Alt.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/T1_Alt.hs index 7624be1..9bb2212 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/T1_Alt.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/T1_Alt.hs @@ -176,13 +176,11 @@ transformAlts = acp <- mGet mSet $ acp { _acp_indent = _acp_line acp } r <- rec bd - return $ reWrap $ BDFBaseYPushCur r - BDFBaseYPop bd -> do - acp <- mGet - r <- rec bd acp' <- mGet - mSet $ acp' { _acp_indent = _acp_indentPrep acp } - return $ reWrap $ BDFBaseYPop r + mSet $ acp' { _acp_indent = _acp_indent acp } + return $ reWrap $ BDFBaseYPushCur r + BDFEntryDelta dp bd -> do + return $ reWrap $ BDFEntryDelta dp bd BDFIndentLevelPushCur bd -> do reWrap . BDFIndentLevelPushCur <$> rec bd BDFIndentLevelPop bd -> do @@ -442,7 +440,6 @@ getSpacing !bridoc = rec bridoc ) , _vs_paragraph = VerticalSpacingParSome 0 } - BDFBaseYPop bd -> rec bd BDFIndentLevelPushCur bd -> rec bd BDFIndentLevelPop bd -> rec bd BDFPar BrIndentNone sameLine indented -> do @@ -491,6 +488,7 @@ getSpacing !bridoc = rec bridoc BDFQueueComments _comms bd -> rec bd BDFFlushCommentsPrior _loc bd -> rec bd BDFFlushCommentsPost _loc bd -> rec bd + BDFEntryDelta _dp bd -> rec bd BDFLines [] -> return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False BDFLines (l1 : lR) -> do @@ -740,7 +738,6 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc VerticalSpacingParSome i -> VerticalSpacingParSome i VerticalSpacingParAlways i -> VerticalSpacingParAlways i } - BDFBaseYPop bd -> rec bd BDFIndentLevelPushCur bd -> rec bd BDFIndentLevelPop bd -> rec bd BDFPar BrIndentNone sameLine indented -> do @@ -793,6 +790,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc BDFQueueComments _comms bd -> rec bd BDFFlushCommentsPrior _loc bd -> rec bd BDFFlushCommentsPost _loc bd -> rec bd + BDFEntryDelta _dp bd -> rec bd BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] BDFLines ls@(_ : _) -> do -- we simply assume that lines is only used "properly", i.e. in diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/T2_Floating.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/T2_Floating.hs index 470cea8..5791279 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/T2_Floating.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/T2_Floating.hs @@ -75,10 +75,20 @@ transformSimplifyFloating = stepBO .> stepFull Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) BDBaseYPushCur (BDDebug s x) -> Just $ BDDebug s (BDBaseYPushCur x) _ -> Nothing - descendBYPop = transformDownMay $ \case - BDBaseYPop (BDCols sig cols@(_ : _)) -> - Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) - BDBaseYPop (BDDebug s x) -> Just $ BDDebug s (BDBaseYPop x) + descendEntryDelta = transformDownMay $ \case + -- entry delta floating in + BDEntryDelta dp (BDPar ind line indented) -> + Just $ BDPar ind (BDEntryDelta dp line) indented + BDEntryDelta dp (BDSeq (l : lr)) -> + Just $ BDSeq (BDEntryDelta dp l : lr) + BDEntryDelta dp (BDLines (l : lr)) -> + Just $ BDLines (BDEntryDelta dp l : lr) + BDEntryDelta dp (BDCols sig (l : lr)) -> + Just $ BDCols sig (BDEntryDelta dp l : lr) + BDEntryDelta dp (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDEntryDelta dp x + BDEntryDelta dp (BDDebug s x) -> + Just $ BDDebug s $ BDEntryDelta dp x _ -> Nothing descendILPush = transformDownMay $ \case BDIndentLevelPushCur (BDCols sig cols@(_ : _)) -> @@ -113,7 +123,18 @@ transformSimplifyFloating = stepBO .> stepFull BDAddBaseY _ lit@BDLit{} -> Just $ lit BDAddBaseY ind (BDBaseYPushCur x) -> Just $ BDBaseYPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x) + -- TODO92 We have several rules here in conflict with each other. + -- Unless I forget some detail related to some elements being able + -- to float in further, we probably should define some + -- intended "floating" order that all rules should adhere. + -- According to that order, we should either have + -- A (B x) -> B (A x) + -- or + -- B (A x) -> A (B x) + -- but not both. + -- I have disable the following conflict for + -- BDAddBaseY vs BDEntryDelta for now. + -- BDAddBaseY ind (BDEntryDelta dp) -> Just $ BDEntryDelta dp (BDAddBaseY ind x) BDAddBaseY ind (BDDebug s x) -> Just $ BDDebug s (BDAddBaseY ind x) BDAddBaseY ind (BDIndentLevelPop x) -> Just $ BDIndentLevelPop (BDAddBaseY ind x) @@ -132,7 +153,7 @@ transformSimplifyFloating = stepBO .> stepFull x@BDFlushCommentsPost{} -> descendCommsPost x x@BDAddBaseY{} -> descendAddB x x@BDBaseYPushCur{} -> descendBYPush x - x@BDBaseYPop{} -> descendBYPop x + x@BDEntryDelta{} -> descendEntryDelta x x@BDIndentLevelPushCur{} -> descendILPush x x@BDIndentLevelPop{} -> descendILPop x x -> x @@ -157,7 +178,6 @@ transformSimplifyFloating = stepBO .> stepFull BDAddBaseY _ lit@BDLit{} -> Just $ lit BDAddBaseY ind (BDBaseYPushCur x) -> Just $ BDBaseYPushCur (BDAddBaseY ind x) - BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x) -- EnsureIndent float-in -- BDEnsureIndent indent (BDCols sig (col:colr)) -> -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) @@ -183,5 +203,18 @@ transformSimplifyFloating = stepBO .> stepFull $ 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] - + -- entry-delta floating in + BDEntryDelta dp (BDPar ind line indented) -> + Just $ BDPar ind (BDEntryDelta dp line) indented + BDEntryDelta dp (BDSeq (l : lr)) -> + Just $ BDSeq (BDEntryDelta dp l : lr) + BDEntryDelta dp (BDLines (l : lr)) -> + Just $ BDLines (BDEntryDelta dp l : lr) + BDEntryDelta dp (BDCols sig (l : lr)) -> + Just $ BDCols sig (BDEntryDelta dp l : lr) + BDEntryDelta dp (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDEntryDelta dp x + BDEntryDelta dp (BDDebug s x) -> + Just $ BDDebug s $ BDEntryDelta dp x + _ -> Nothing diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/T4_Columns.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/T4_Columns.hs index 8c6cf50..d46a796 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/T4_Columns.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/T4_Columns.hs @@ -121,7 +121,6 @@ transformSimplifyColumns = Uniplate.rewrite $ \case BDSeparator -> Nothing BDAddBaseY{} -> Nothing BDBaseYPushCur{} -> Nothing - BDBaseYPop{} -> Nothing BDIndentLevelPushCur{} -> Nothing BDIndentLevelPop{} -> Nothing BDPar{} -> Nothing @@ -135,6 +134,7 @@ transformSimplifyColumns = Uniplate.rewrite $ \case BDQueueComments{} -> Nothing BDFlushCommentsPrior{} -> Nothing BDFlushCommentsPost{} -> Nothing + BDEntryDelta{} -> Nothing BDEnsureIndent{} -> Nothing BDSetParSpacing{} -> Nothing BDForceParSpacing{} -> Nothing diff --git a/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/AlignmentAlgo.hs b/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/AlignmentAlgo.hs index 7698ade..168dbb9 100644 --- a/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/AlignmentAlgo.hs +++ b/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/AlignmentAlgo.hs @@ -398,7 +398,6 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc 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 BDIndentLevelPushCur bd -> rec bd BDIndentLevelPop bd -> rec bd BDPar _ line _ -> rec line @@ -414,6 +413,7 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc BDLines ls@(_ : _) -> do x <- StateS.get return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x + BDEntryDelta _dp bd -> rec bd BDLines [] -> error "briDocLineLength BDLines []" BDEnsureIndent _ bd -> rec bd BDSetParSpacing bd -> rec bd @@ -433,7 +433,6 @@ briDocIsMultiLine briDoc = rec briDoc BDSeparator -> False BDAddBaseY _ bd -> rec bd BDBaseYPushCur bd -> rec bd - BDBaseYPop bd -> rec bd BDIndentLevelPushCur bd -> rec bd BDIndentLevelPop bd -> rec bd BDPar{} -> True @@ -448,6 +447,7 @@ briDocIsMultiLine briDoc = rec briDoc BDQueueComments _ bd -> rec bd BDFlushCommentsPrior _ bd -> rec bd BDFlushCommentsPost _ bd -> rec bd + BDEntryDelta _dp bd -> rec bd BDLines (_ : _ : _) -> True BDLines [_] -> False BDLines [] -> error "briDocIsMultiLine BDLines []"