From 3c5670d5cdb9373e18ef9588729a38a7a9f81534 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 5 Jul 2018 21:31:28 +0200 Subject: [PATCH] Fix layouting for OpApps with comments (fixes 159) --- src-literatetests/15-regressions.blt | 7 ++++++ .../Brittany/Internal/LayouterBasics.hs | 16 +++++++++++++ .../Brittany/Internal/Layouters/Expr.hs | 23 +++++++++++++++---- .../Brittany/Internal/Transformations/Alt.hs | 10 ++++++-- 4 files changed, 49 insertions(+), 7 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index e066ca4..7e303cc 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -630,3 +630,10 @@ dsfnjKeekbwwbosbOfakxqRsiyix cnehokzozwbVaguvu migbnaRwutbz = xoheccewfWoeyiagOkfodiq sEmo quc = case migbnaRwutbz of Afogmf -> xgeqe (OfBkkuih quc) (Ciitog quc) sEmo in QabqyilexuiNizzhsQuxxac migbnaRwutbz (hwaTihhjt lhowvscIiozgqe) + +#test issue 159 +spec = do + it "creates a snapshot at the given level" . withGraph runDB $ do + lift $ do + studentDiagnosticReadingLevel updatedStudent `shouldBe` Just 10 -- x + elaSnapshotReadingLevel snapshot `shouldBe` 12 diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 191581c..d5aac63 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -57,6 +57,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , allocateNode , docSharedWrapper , hasAnyCommentsBelow + , hasAnyCommentsConnected , hasAnnKeyword ) where @@ -266,6 +267,9 @@ filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) +-- | True if there are any comments that are +-- a) connected to any node below (in AST sense) the given node AND +-- b) after (in source code order) the node. hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool hasAnyCommentsBelow ast@(L l _) = do anns <- filterAnns ast <$> mAsk @@ -275,6 +279,18 @@ hasAnyCommentsBelow ast@(L l _) = do $ Map.elems $ anns +-- | True if there are any comments that are +-- connected to any node below (in AST sense) the given node +hasAnyCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyCommentsConnected ast = do + anns <- filterAnns ast <$> mAsk + return + $ not + $ null + $ (=<<) extractAllComments + $ Map.elems + $ anns + hasAnnKeyword :: (Data a, MonadMultiReader (Map AnnKey Annotation) m) => Located a diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 4ee0920..0aca344 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -236,14 +236,21 @@ layoutExpr lexpr@(L _ expr) = do ] opLastDoc <- docSharedWrapper layoutExpr expOp expLastDoc <- docSharedWrapper layoutExpr expRight - hasComments <- hasAnyCommentsBelow lexpr + allowSinglelinePar <- do + hasComLeft <- hasAnyCommentsConnected expLeft + hasComOp <- hasAnyCommentsConnected expOp + pure $ not hasComLeft && not hasComOp let allowPar = case (expOp, expRight) of (L _ (HsVar (L _ (Unqual occname))), _) | occNameString occname == "$" -> True (_, L _ (HsApp _ (L _ HsVar{}))) -> False _ -> True runFilteredAlternative $ do - addAlternativeCond (not hasComments) + -- > one + two + three + -- or + -- > one + two + case x of + -- > _ -> three + addAlternativeCond allowSinglelinePar $ docSeq [ appSep $ docForceSingleline leftOperandDoc , docSeq @@ -265,6 +272,9 @@ layoutExpr lexpr@(L _ expr) = do -- $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) -- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] -- ) + -- > one + -- > + two + -- > + three addAlternative $ docPar leftOperandDoc @@ -300,7 +310,10 @@ layoutExpr lexpr@(L _ expr) = do addAlternative $ docAddBaseY BrIndentRegular $ docPar - expDocLeft + expDocLeft -- TODO: this is not forced to single-line, which has + -- certain.. interesting consequences. + -- At least, the "two-line" label is not entirely + -- accurate. ( docForceSingleline $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight] ) @@ -773,7 +786,7 @@ layoutExpr lexpr@(L _ expr) = do [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty , docLit $ Text.pack "}" ] - docAlt + docAlt -- TODO: make this addFilteredAlternative and a hanging layout when Free [ docSeq $ [docNodeAnnKW lexpr Nothing nameDoc, docSeparator] ++ line1 docForceSingleline @@ -829,7 +842,7 @@ layoutExpr lexpr@(L _ expr) = do [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty , docLit $ Text.pack "}" ] - docAlt + docAlt -- TODO: make this addFilteredAlternative and a hanging layout when Free [ docSeq $ [docNodeAnnKW lexpr Nothing nameDoc, docSeparator] ++ line1 docForceSingleline diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 053e032..f247170 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -440,7 +440,11 @@ getSpacing !bridoc = rec bridoc BDFPar{} -> error "BDPar with indent in getSpacing" BDFAlt [] -> error "empty BDAlt" BDFAlt (alt:_) -> rec alt - BDFForceMultiline bd -> rec bd + BDFForceMultiline bd -> do + mVs <- rec bd + return $ mVs >>= _vs_paragraph .> \case + VerticalSpacingParNone -> LineModeInvalid + _ -> mVs BDFForceSingleline bd -> do mVs <- rec bd return $ mVs >>= _vs_paragraph .> \case @@ -686,7 +690,9 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc BDFAlt alts -> do r <- rec `mapM` alts return $ filterAndLimit =<< r - BDFForceMultiline bd -> rec bd + BDFForceMultiline bd -> do + mVs <- filterAndLimit <$> rec bd + return $ filter ((/=VerticalSpacingParNone) . _vs_paragraph) mVs BDFForceSingleline bd -> do mVs <- filterAndLimit <$> rec bd return $ filter ((==VerticalSpacingParNone) . _vs_paragraph) mVs