From 00c6854887f3de22f5e036f652d6f16748a78be4 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 9 Dec 2019 22:35:26 +0100 Subject: [PATCH] Fix two minor data-decl layouting issues --- src-literatetests/10-tests.blt | 24 ++++++ .../Haskell/Brittany/Internal/Backend.hs | 22 ++--- .../Brittany/Internal/LayouterBasics.hs | 6 +- .../Brittany/Internal/Layouters/DataDecl.hs | 47 +++++----- .../Brittany/Internal/Transformations/Alt.hs | 37 ++++++-- .../Internal/Transformations/Columns.hs | 2 +- .../Haskell/Brittany/Internal/Types.hs | 85 ++++++++++--------- 7 files changed, 138 insertions(+), 85 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 684a711..a3d1138 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -583,6 +583,30 @@ data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse data GrantsForCompanyResp = GrantsForCompanyResp Types.Company [EnterpriseGrantResponse] +#test large record with a comment +data XIILqcacwiuNiu = XIILqcacwiuNiu + { oyyFtvbepgbOge_pebzVmuftEijwuj :: Jgtoyuh HessJvNlo + , wloQsiskdoxJop_xatiKrwedOxtu :: Jgtoyuh [Inotg] + , mmmJjcqtemyIyo_ovosDoreKeeoyamvove :: Jgtoyuh Eujo + , mbiIatelofxOzr_uluxNngiiMjah :: Jgtoyuh HessJvNlo + , obxIskfcxpkIkb_uuviTuevcSkrgo :: Jgtoyuh Int + , wqrAtuvuecoHwr_ilotNxbuPleo :: Jgtoyuh Ufaxdeq + , lofAfuebdhpLuv_cnekPoyFxmg :: Jgtoyuh Ufaxdeq + , ouoFugtawzvUpk_oupiLzptugy :: Jgtoyuh Eujo + , iqiXjtziwogNsa_uiyvSunaTtgUsf3 :: Jgtoyuh Oaivn + , odbIriaqnojUlz_onotoWuunehIpuy :: Jgtoyuh Eujo + , opjUxtkxzkiKse_luqjuZazt + :: Jgtoyuh [(Eujo, Int, Int, Int, Int, Int, NELUxro)] + -- , jcqRaqznxfhIpa_ywevMezmoYkutuwa :: Jgtoyuh () + , vayOmuasyphOfd_bcsVljmvt :: Jgtoyuh Eujo + , rifArahilooRax_ufikecqdImsv :: Jgtoyuh Oaivn + , raqKtopcpszDwb_oqocubasZuqjcryoDojGkw :: Jgtoyuh Oaivn + , mluJiilpcijUtt_gaisklifVekfeyagRmfbyzz :: Jgtoyuh Oaivn + , oqhPaahjupaSmi_gamwwoovKyxznecvEayluc :: Jgtoyuh Oaivn + , mazFubimwebZpa_itidehDodiDlboz :: Jgtoyuh Vrep + , jeyOcuesexaYoy_vpqn :: Jgtoyuh () + } + ############################################################################### ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 32c5aba..50522ed 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -287,7 +287,7 @@ layoutBriDocM = \case Just (ExactPrint.Types.DP (y, x)) -> layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) layoutBriDocM bd - BDNonBottomSpacing bd -> layoutBriDocM bd + BDNonBottomSpacing _ bd -> layoutBriDocM bd BDSetParSpacing bd -> layoutBriDocM bd BDForceParSpacing bd -> layoutBriDocM bd BDDebug s bd -> do @@ -321,15 +321,15 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc BDAnnotationKW _ _ bd -> rec bd BDAnnotationRest _ bd -> rec bd BDMoveToKWDP _ _ _ bd -> rec bd - BDLines ls@(_:_) -> do + BDLines ls@(_ : _) -> do x <- StateS.get return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x - BDLines [] -> error "briDocLineLength BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing bd -> rec bd - BDDebug _ bd -> rec bd + BDLines [] -> error "briDocLineLength BDLines []" + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing _ bd -> rec bd + BDDebug _ bd -> rec bd briDocIsMultiLine :: BriDoc -> Bool briDocIsMultiLine briDoc = rec briDoc @@ -363,9 +363,9 @@ briDocIsMultiLine briDoc = rec briDoc BDLines [_ ] -> False BDLines [] -> error "briDocIsMultiLine BDLines []" BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing _ bd -> rec bd BDDebug _ bd -> rec bd -- In theory diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index d46421e..6263f50 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -40,6 +40,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docAnnotationRest , docMoveToKWDP , docNonBottomSpacing + , docNonBottomSpacingS , docSetParSpacing , docForceParSpacing , docDebug @@ -576,7 +577,10 @@ docAnnotationRest docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm +docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing False =<< bdm + +docNonBottomSpacingS :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docNonBottomSpacingS bdm = allocateNode . BDFNonBottomSpacing True =<< bdm docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index dd3576f..00453b3 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -153,16 +153,18 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of ] , docLitS "=" , docSeparator - , case forallDocMay of - Nothing -> docEmpty - Just forallDoc -> docSeq - [ docForceSingleline forallDoc - , docSeparator - , docLitS "." - , docSeparator - ] - , maybe docEmpty docForceSingleline rhsContextDocMay - , rhsDoc + , docSetIndentLevel $ docSeq + [ case forallDocMay of + Nothing -> docEmpty + Just forallDoc -> docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] + , maybe docEmpty docForceSingleline rhsContextDocMay + , rhsDoc + ] ] , -- data D -- = forall a . Show a => D a @@ -178,16 +180,18 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of ( docSeq [ docLitS "=" , docSeparator - , case forallDocMay of - Nothing -> docEmpty - Just forallDoc -> docSeq - [ docForceSingleline forallDoc - , docSeparator - , docLitS "." - , docSeparator - ] - , maybe docEmpty docForceSingleline rhsContextDocMay - , rhsDoc + , docSetIndentLevel $ docSeq + [ case forallDocMay of + Nothing -> docEmpty + Just forallDoc -> docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] + , maybe docEmpty docForceSingleline rhsContextDocMay + , rhsDoc + ] ] ) , -- data D @@ -412,7 +416,6 @@ createDetailsDoc consNameStr details = case details of -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack let allowSingleline = False docAddBaseY BrIndentRegular - $ docSetIndentLevel $ runFilteredAlternative $ do -- single-line: { i :: Int, b :: Bool } @@ -441,7 +444,7 @@ createDetailsDoc consNameStr details = case details of ] addAlternative $ docPar (docLit consNameStr) - (docWrapNodePrior lRec $ docLines + (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines [ docAlt [ docCols ColRecDecl [ appSep (docLitS "{") diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 22d0555..6a15eac 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -331,7 +331,7 @@ transformAlts = BrIndentNone -> r BrIndentRegular -> reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r - BDFNonBottomSpacing bd -> rec bd + BDFNonBottomSpacing _ bd -> rec bd BDFSetParSpacing bd -> rec bd BDFForceParSpacing bd -> rec bd BDFDebug s bd -> do @@ -488,13 +488,18 @@ getSpacing !bridoc = rec bridoc BrIndentSpecial i -> i return $ mVs <&> \(VerticalSpacing lsp psp pf) -> VerticalSpacing (lsp + addInd) psp pf - BDFNonBottomSpacing bd -> do + BDFNonBottomSpacing b bd -> do mVs <- rec bd return $ mVs - <|> LineModeValid (VerticalSpacing 0 - (VerticalSpacingParAlways colMax) - False) + <|> LineModeValid + (VerticalSpacing + 0 + (if b then VerticalSpacingParSome 0 + else VerticalSpacingParAlways colMax + ) + False + ) BDFSetParSpacing bd -> do mVs <- rec bd return $ mVs <&> \vs -> vs { _vs_parFlag = True } @@ -799,16 +804,30 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc BrIndentSpecial i -> i return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> VerticalSpacing (lsp + addInd) psp parFlag - BDFNonBottomSpacing bd -> do + BDFNonBottomSpacing b bd -> do + -- TODO: the `b` flag is an ugly hack, but I was not able to make + -- all tests work without it. It should be possible to have + -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this + -- problem but breaks certain other cases. mVs <- rec bd return $ if null mVs - then [VerticalSpacing 0 (VerticalSpacingParAlways colMax) False] + then [VerticalSpacing + 0 + (if b then VerticalSpacingParSome 0 + else VerticalSpacingParAlways colMax + ) + False + ] else mVs <&> \vs -> vs { _vs_sameLine = min colMax (_vs_sameLine vs) , _vs_paragraph = case _vs_paragraph vs of VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> VerticalSpacingParAlways i - VerticalSpacingParSome i -> VerticalSpacingParAlways i + VerticalSpacingParAlways i + | b -> VerticalSpacingParSome 0 + | otherwise -> VerticalSpacingParAlways i + VerticalSpacingParSome i + | b -> VerticalSpacingParSome 0 + | otherwise -> VerticalSpacingParAlways i } -- the version below is an alternative idea: fold the input -- spacings into a single spacing. This was hoped to improve in diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs index 31ec86a..d652dda 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -135,4 +135,4 @@ transformSimplifyColumns = Uniplate.rewrite $ \case BDSetParSpacing{} -> Nothing BDForceParSpacing{} -> Nothing BDDebug{} -> Nothing - BDNonBottomSpacing x -> Just x + BDNonBottomSpacing _ x -> Just x diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index e3a5318..c8e37ff 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -258,7 +258,7 @@ data BriDoc -- after the alt transformation. | BDForceMultiline BriDoc | BDForceSingleline BriDoc - | BDNonBottomSpacing BriDoc + | BDNonBottomSpacing Bool BriDoc | BDSetParSpacing BriDoc | BDForceParSpacing BriDoc -- pseudo-deprecated @@ -303,7 +303,7 @@ data BriDocF f | BDFEnsureIndent BrIndent (f (BriDocF f)) | BDFForceMultiline (f (BriDocF f)) | BDFForceSingleline (f (BriDocF f)) - | BDFNonBottomSpacing (f (BriDocF f)) + | BDFNonBottomSpacing Bool (f (BriDocF f)) | BDFSetParSpacing (f (BriDocF f)) | BDFForceParSpacing (f (BriDocF f)) | BDFDebug String (f (BriDocF f)) @@ -315,33 +315,37 @@ type BriDocFInt = BriDocF ((,) Int) type BriDocNumbered = (Int, BriDocFInt) instance Uniplate.Uniplate BriDoc where - uniplate x@BDEmpty{} = plate x - uniplate x@BDLit{} = plate x - uniplate (BDSeq list) = plate BDSeq ||* list - uniplate (BDCols sig list) = plate BDCols |- sig ||* list - uniplate x@BDSeparator = plate x - uniplate (BDAddBaseY ind bd) = plate BDAddBaseY |- ind |* bd - uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd - uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd - uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd - uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd - uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented - uniplate (BDAlt alts) = plate BDAlt ||* alts - uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd - uniplate x@BDExternal{} = plate x - uniplate x@BDPlain{} = plate x - uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd - uniplate (BDAnnotationKW annKey kw bd) = plate BDAnnotationKW |- annKey |- kw |* bd - uniplate (BDAnnotationRest annKey bd) = plate BDAnnotationRest |- annKey |* bd - uniplate (BDMoveToKWDP annKey kw b bd) = plate BDMoveToKWDP |- annKey |- kw |- b |* bd - uniplate (BDLines lines) = plate BDLines ||* lines - uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd - uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd - uniplate (BDForceSingleline bd) = plate BDForceSingleline |* bd - uniplate (BDNonBottomSpacing bd) = plate BDNonBottomSpacing |* bd - uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd - uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd - uniplate (BDDebug s bd) = plate BDDebug |- s |* bd + uniplate x@BDEmpty{} = plate x + uniplate x@BDLit{} = plate x + uniplate (BDSeq list ) = plate BDSeq ||* list + uniplate (BDCols sig list) = plate BDCols |- sig ||* list + uniplate x@BDSeparator = plate x + uniplate (BDAddBaseY ind bd ) = plate BDAddBaseY |- ind |* bd + uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd + uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd + uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd + uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd + uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented + uniplate (BDAlt alts ) = plate BDAlt ||* alts + uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd + uniplate x@BDExternal{} = plate x + uniplate x@BDPlain{} = plate x + uniplate (BDAnnotationPrior annKey bd) = + plate BDAnnotationPrior |- annKey |* bd + uniplate (BDAnnotationKW annKey kw bd) = + plate BDAnnotationKW |- annKey |- kw |* bd + uniplate (BDAnnotationRest annKey bd) = + plate BDAnnotationRest |- annKey |* bd + uniplate (BDMoveToKWDP annKey kw b bd) = + plate BDMoveToKWDP |- annKey |- kw |- b |* bd + uniplate (BDLines lines ) = plate BDLines ||* lines + uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd + uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd + uniplate (BDForceSingleline bd ) = plate BDForceSingleline |* bd + uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd + uniplate (BDSetParSpacing bd ) = plate BDSetParSpacing |* bd + uniplate (BDForceParSpacing bd ) = plate BDForceParSpacing |* bd + uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd newtype NodeAllocIndex = NodeAllocIndex Int @@ -369,14 +373,13 @@ unwrapBriDocNumbered tpl = case snd tpl of BDFMoveToKWDP annKey kw b bd -> BDMoveToKWDP annKey kw b $ rec bd BDFLines lines -> BDLines $ rec <$> lines BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd - BDFForceMultiline bd -> BDForceMultiline $ rec bd - BDFForceSingleline bd -> BDForceSingleline $ rec bd - BDFNonBottomSpacing bd -> BDNonBottomSpacing $ rec bd - BDFSetParSpacing bd -> BDSetParSpacing $ rec bd - BDFForceParSpacing bd -> BDForceParSpacing $ rec bd + BDFForceMultiline bd -> BDForceMultiline $ rec bd + BDFForceSingleline bd -> BDForceSingleline $ rec bd + BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd + BDFSetParSpacing bd -> BDSetParSpacing $ rec bd + BDFForceParSpacing bd -> BDForceParSpacing $ rec bd BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd - where - rec = unwrapBriDocNumbered + where rec = unwrapBriDocNumbered isNotEmpty :: BriDoc -> Bool isNotEmpty BDEmpty = False @@ -406,11 +409,11 @@ briDocSeqSpine = \case BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines BDEnsureIndent _ind bd -> briDocSeqSpine bd - BDForceMultiline bd -> briDocSeqSpine bd - BDForceSingleline bd -> briDocSeqSpine bd - BDNonBottomSpacing bd -> briDocSeqSpine bd - BDSetParSpacing bd -> briDocSeqSpine bd - BDForceParSpacing bd -> briDocSeqSpine bd + BDForceMultiline bd -> briDocSeqSpine bd + BDForceSingleline bd -> briDocSeqSpine bd + BDNonBottomSpacing _ bd -> briDocSeqSpine bd + BDSetParSpacing bd -> briDocSeqSpine bd + BDForceParSpacing bd -> briDocSeqSpine bd BDDebug _s bd -> briDocSeqSpine bd briDocForceSpine :: BriDoc -> BriDoc