From 522e40c8ed77646d554d50a3648ee2da3768d7f8 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 18 Sep 2018 18:05:03 +0200 Subject: [PATCH] Retain empty lines before "where" only applies to local "where"s (not module..where) --- .../Haskell/Brittany/Internal/Backend.hs | 17 ++++-- .../Brittany/Internal/LayouterBasics.hs | 9 ++- .../Brittany/Internal/Layouters/Decl.hs | 61 +++++++++++-------- .../Brittany/Internal/Layouters/Expr.hs | 6 +- .../Brittany/Internal/Layouters/Module.hs | 2 +- .../Brittany/Internal/Transformations/Alt.hs | 8 +-- .../Haskell/Brittany/Internal/Types.hs | 58 +++++++++--------- 7 files changed, 90 insertions(+), 71 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 1061f0e..d5a2434 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -235,7 +235,10 @@ layoutBriDocM = \case { _lstate_comments = Map.adjust ( \ann -> ann { ExactPrint.annFollowingComments = [] , ExactPrint.annPriorComments = [] - , ExactPrint.annsDP = [] + , ExactPrint.annsDP = + flip filter (ExactPrint.annsDP ann) $ \case + (ExactPrint.Types.AnnComment{}, _) -> False + _ -> True } ) annKey @@ -259,7 +262,7 @@ layoutBriDocM = \case -- layoutMoveToIndentCol y layoutWriteAppendMultiline $ Text.pack $ comment -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } - BDMoveToKWDP annKey keyword bd -> do + BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do mDP <- do state <- mGet let m = _lstate_comments state @@ -269,12 +272,14 @@ layoutBriDocM = \case , (ExactPrint.Types.G kw1, dp) <- ann , keyword == kw1 ] + -- mTell $ Seq.fromList ["KWDP: " ++ show annKey ++ " " ++ show mAnn] pure $ case relevant of [] -> Nothing (dp:_) -> Just dp case mDP of - Nothing -> pure () - Just (ExactPrint.Types.DP (y, x)) -> layoutMoveToCommentPos y x + Nothing -> pure () + Just (ExactPrint.Types.DP (y, x)) -> + layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) layoutBriDocM bd BDNonBottomSpacing bd -> layoutBriDocM bd BDSetParSpacing bd -> layoutBriDocM bd @@ -308,7 +313,7 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc BDAnnotationPrior _ bd -> rec bd BDAnnotationKW _ _ bd -> rec bd BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ bd -> rec bd + BDMoveToKWDP _ _ _ bd -> rec bd BDLines ls@(_:_) -> do x <- StateS.get return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x @@ -344,7 +349,7 @@ briDocIsMultiLine briDoc = rec briDoc BDAnnotationPrior _ bd -> rec bd BDAnnotationKW _ _ bd -> rec bd BDAnnotationRest _ bd -> rec bd - BDMoveToKWDP _ _ bd -> rec bd + BDMoveToKWDP _ _ _ bd -> rec bd BDLines (_:_:_) -> True BDLines [_ ] -> False BDLines [] -> error "briDocIsMultiLine BDLines []" diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 458f7ed..6352662 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -527,9 +527,11 @@ docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm docMoveToKWDP :: AnnKey -> AnnKeywordId + -> Bool -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docMoveToKWDP annKey kw bdm = allocateNode . BDFMoveToKWDP annKey kw =<< bdm +docMoveToKWDP annKey kw shouldRestoreIndent bdm = + allocateNode . BDFMoveToKWDP annKey kw shouldRestoreIndent =<< bdm docAnnotationRest :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered @@ -597,10 +599,11 @@ docNodeMoveToKWDP :: Data.Data.Data ast => Located ast -> AnnKeywordId + -> Bool -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docNodeMoveToKWDP ast kw bdm = - docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw bdm +docNodeMoveToKWDP ast kw shouldRestoreIndent bdm = + docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw shouldRestoreIndent bdm class DocWrapable a where docWrapNode :: ( Data.Data.Data ast) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index cf7da4f..2616312 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -26,11 +26,11 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import Language.Haskell.Brittany.Internal.ExactPrintUtils import Language.Haskell.Brittany.Internal.Utils -import GHC ( runGhc - , GenLocated(L) - , moduleNameString - , AnnKeywordId (..) - ) +import GHC ( runGhc + , GenLocated(L) + , moduleNameString + , AnnKeywordId(..) + ) import SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc ) import HsSyn import Name @@ -204,13 +204,14 @@ layoutBind lbind@(L _ bind) = case bind of patDocs <- colsWrapPat =<< layoutPat pat clauseDocs <- layoutGrhs `mapM` grhss mWhereDocs <- layoutLocalBinds whereBinds + let mWhereArg = mWhereDocs <&> \d -> (mkAnnKey lbind, d) -- TODO: is this the right AnnKey? binderDoc <- docLit $ Text.pack "=" hasComments <- hasAnyCommentsBelow lbind fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing binderDoc (Just patDocs) clauseDocs - mWhereDocs + mWhereArg hasComments _ -> Right <$> unknownNodeError "" lbind @@ -282,13 +283,14 @@ layoutPatternBind mIdStr binderDoc lmatch@(L _ match) = do $ (List.intersperse docSeparator $ docForceSingleline <$> ps) clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss mWhereDocs <- layoutLocalBinds whereBinds + let mWhereArg = mWhereDocs <&> \d -> (mkAnnKey lmatch, d) let alignmentToken = if null pats then Nothing else mIdStr hasComments <- hasAnyCommentsBelow lmatch layoutPatternBindFinal alignmentToken binderDoc (Just patDoc) clauseDocs - mWhereDocs + mWhereArg hasComments #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 && ghc-8.4 */ @@ -319,7 +321,8 @@ layoutPatternBindFinal -> BriDocNumbered -> Maybe BriDocNumbered -> [([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)] - -> Maybe [BriDocNumbered] + -> Maybe (ExactPrint.AnnKey, [BriDocNumbered]) + -- ^ AnnKey for the node that contains the AnnWhere position annotation -> Bool -> ToBriDocM BriDocNumbered layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments = do @@ -345,30 +348,36 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha -- be shared between alternatives. wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of Nothing -> return $ [] - Just [w] -> fmap (pure . pure) $ docAlt + Just (annKeyWhere, [w]) -> fmap (pure . pure) $ docAlt [ docEnsureIndent BrIndentRegular $ docSeq [ docLit $ Text.pack "where" , docSeparator , docForceSingleline $ return w ] - , docEnsureIndent whereIndent $ docLines - [ docLit $ Text.pack "where" - , docEnsureIndent whereIndent - $ docSetIndentLevel - $ docNonBottomSpacing - $ return w - ] - ] - Just ws -> fmap (pure . pure) $ docEnsureIndent whereIndent $ docLines - [ docLit $ Text.pack "where" - , docEnsureIndent whereIndent - $ docSetIndentLevel - $ docNonBottomSpacing - $ docLines - $ return - <$> ws + , docMoveToKWDP annKeyWhere AnnWhere False + $ docEnsureIndent whereIndent + $ docLines + [ docLit $ Text.pack "where" + , docEnsureIndent whereIndent + $ docSetIndentLevel + $ docNonBottomSpacing + $ return w + ] ] + Just (annKeyWhere, ws) -> + fmap (pure . pure) + $ docMoveToKWDP annKeyWhere AnnWhere False + $ docEnsureIndent whereIndent + $ docLines + [ docLit $ Text.pack "where" + , docEnsureIndent whereIndent + $ docSetIndentLevel + $ docNonBottomSpacing + $ docLines + $ return + <$> ws + ] let singleLineGuardsDoc guards = appSep $ case guards of [] -> docEmpty [g] -> docSeq @@ -380,7 +389,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ) wherePart = case mWhereDocs of Nothing -> Just docEmpty - Just [w] -> Just $ docSeq + Just (_, [w]) -> Just $ docSeq [ docSeparator , appSep $ docLit $ Text.pack "where" , docSetIndentLevel $ docForceSingleline $ return w diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 1da80ae..3ade42e 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -111,7 +111,8 @@ layoutExpr lexpr@(L _ expr) = do HsLamCase _ (MG lmatches@(L _ matches) _ _ _) -> do #endif binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches + funcPatDocs <- docWrapNode lmatches + $ layoutPatternBind Nothing binderDoc `mapM` matches docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "\\case") (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) @@ -410,7 +411,8 @@ layoutExpr lexpr@(L _ expr) = do HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do cExpDoc <- docSharedWrapper layoutExpr cExp binderDoc <- docLit $ Text.pack "->" - funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches + funcPatDocs <- docWrapNode lmatches + $ layoutPatternBind Nothing binderDoc `mapM` matches docAlt [ docSetParSpacing $ docAddBaseY BrIndentRegular diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index 2eebd20..cb82c75 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -40,7 +40,7 @@ layoutModule lmod@(L _ mod') = case mod' of [ docNodeAnnKW lmod Nothing docEmpty -- A pseudo node that serves merely to force documentation -- before the node - , docNodeMoveToKWDP lmod AnnModule $ runFilteredAlternative $ do + , docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do addAlternativeCond allowSingleLine $ docForceSingleline $ docSeq diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 218f596..b73fc77 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -296,8 +296,8 @@ transformAlts = reWrap . BDFAnnotationRest annKey <$> rec bd BDFAnnotationKW annKey kw bd -> reWrap . BDFAnnotationKW annKey kw <$> rec bd - BDFMoveToKWDP annKey kw bd -> - reWrap . BDFMoveToKWDP annKey kw <$> rec bd + BDFMoveToKWDP annKey kw b bd -> + reWrap . BDFMoveToKWDP annKey kw b <$> rec bd BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. BDFLines (l:lr) -> do ind <- _acp_indent <$> mGet @@ -457,7 +457,7 @@ getSpacing !bridoc = rec bridoc BDFAnnotationPrior _annKey bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd BDFAnnotationRest _annKey bd -> rec bd - BDFMoveToKWDP _annKey _kw bd -> rec bd + BDFMoveToKWDP _annKey _kw _b bd -> rec bd BDFLines [] -> return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False @@ -730,7 +730,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc BDFAnnotationPrior _annKey bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd BDFAnnotationRest _annKey bd -> rec bd - BDFMoveToKWDP _annKey _kw bd -> rec bd + BDFMoveToKWDP _annKey _kw _b 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/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index 9358c2b..e54d35e 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -246,7 +246,7 @@ data BriDoc | BDAnnotationPrior AnnKey BriDoc | BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc | BDAnnotationRest AnnKey BriDoc - | BDMoveToKWDP AnnKey AnnKeywordId BriDoc + | BDMoveToKWDP AnnKey AnnKeywordId Bool BriDoc -- True if should respect x offset | BDLines [BriDoc] | BDEnsureIndent BrIndent BriDoc -- the following constructors are only relevant for the alt transformation @@ -292,7 +292,7 @@ data BriDocF f | BDFAnnotationPrior AnnKey (f (BriDocF f)) | BDFAnnotationKW AnnKey (Maybe AnnKeywordId) (f (BriDocF f)) | BDFAnnotationRest AnnKey (f (BriDocF f)) - | BDFMoveToKWDP AnnKey AnnKeywordId (f (BriDocF f)) + | BDFMoveToKWDP AnnKey AnnKeywordId Bool (f (BriDocF f)) -- True if should respect x offset | BDFLines [(f (BriDocF f))] | BDFEnsureIndent BrIndent (f (BriDocF f)) | BDFForceMultiline (f (BriDocF f)) @@ -326,7 +326,7 @@ instance Uniplate.Uniplate BriDoc where 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 bd) = plate BDMoveToKWDP |- annKey |- kw |* 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 @@ -358,7 +358,7 @@ unwrapBriDocNumbered tpl = case snd tpl of BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd - BDFMoveToKWDP annKey kw bd -> BDMoveToKWDP annKey kw $ rec bd + 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 @@ -377,32 +377,32 @@ isNotEmpty _ = True -- this might not work. is not used anywhere either. briDocSeqSpine :: BriDoc -> () briDocSeqSpine = \case - BDEmpty -> () - BDLit _t -> () - BDSeq list -> foldl' ((briDocSeqSpine.) . seq) () list - BDCols _sig list -> foldl' ((briDocSeqSpine.) . seq) () list - BDSeparator -> () - BDAddBaseY _ind bd -> briDocSeqSpine bd - BDBaseYPushCur bd -> briDocSeqSpine bd - BDBaseYPop bd -> briDocSeqSpine bd - BDIndentLevelPushCur bd -> briDocSeqSpine bd - BDIndentLevelPop bd -> briDocSeqSpine bd + BDEmpty -> () + BDLit _t -> () + BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list + BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list + 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 - BDAlt alts -> foldl' (\(!()) -> briDocSeqSpine) () alts - BDForwardLineMode bd -> briDocSeqSpine bd - BDExternal{} -> () - BDAnnotationPrior _annKey bd -> briDocSeqSpine bd - BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd - BDAnnotationRest _annKey bd -> briDocSeqSpine bd - BDMoveToKWDP _annKey _kw 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 - BDDebug _s bd -> briDocSeqSpine bd + BDAlt alts -> foldl' (\(!()) -> briDocSeqSpine) () alts + BDForwardLineMode bd -> briDocSeqSpine bd + BDExternal{} -> () + BDAnnotationPrior _annKey bd -> briDocSeqSpine bd + BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd + BDAnnotationRest _annKey bd -> briDocSeqSpine bd + 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 + BDDebug _s bd -> briDocSeqSpine bd briDocForceSpine :: BriDoc -> BriDoc briDocForceSpine bd = briDocSeqSpine bd `seq` bd