From 1ce40c861cb27783acacd260e221c7e8bd26f9bd Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 3 Aug 2016 22:13:41 +0200 Subject: [PATCH] Various minor layouting fixes --- src/Language/Haskell/Brittany/BriLayouter.hs | 22 ++--- src/Language/Haskell/Brittany/LayoutBasics.hs | 10 ++- .../Haskell/Brittany/Layouters/Decl.hs | 46 ++++++++--- .../Haskell/Brittany/Layouters/Expr.hs | 81 ++++++++++++------- 4 files changed, 107 insertions(+), 52 deletions(-) diff --git a/src/Language/Haskell/Brittany/BriLayouter.hs b/src/Language/Haskell/Brittany/BriLayouter.hs index e7938c1..b45208a 100644 --- a/src/Language/Haskell/Brittany/BriLayouter.hs +++ b/src/Language/Haskell/Brittany/BriLayouter.hs @@ -102,7 +102,10 @@ layoutBriDoc ast briDoc = do let state = LayoutState { _lstate_baseY = 0 - , _lstate_curYOrAddNewline = Right 0 + , _lstate_curYOrAddNewline = Right 0 -- important that we use left here + -- because moveToAnn stuff of the + -- first node needs to do its + -- thing properly. , _lstate_indLevel = 0 , _lstate_indLevelLinger = 0 , _lstate_commentsPrior = extractCommentsPrior filteredAnns @@ -213,7 +216,10 @@ transformAlts briDoc #if INSERTTRACESALT do acp :: AltCurPos <- mGet - tellDebugMess $ "transformAlts: visiting: " ++ show (toConstr brDc, acp) + tellDebugMess $ "transformAlts: visiting: " ++ case brDc of + BDFAnnotationPrior annKey _ -> show (toConstr brDc, annKey, acp) + BDFAnnotationPost annKey _ -> show (toConstr brDc, annKey, acp) + _ -> show (toConstr brDc, acp) #endif let reWrap = (,) brDcId -- debugAcp :: AltCurPos <- mGet @@ -335,23 +341,21 @@ transformAlts briDoc <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) ( any (hasSpace2 lconf acp) vs && any lineCheck vs, bd)) + let checkedOptions :: [Maybe (Int, BriDocNumbered)] = + zip [1..] options <&> (\(i, (b,x)) -> [ (i, x) | b ]) #if INSERTTRACESALT zip spacings options `forM_` \(vs, (_, bd)) -> tellDebugMess $ " " ++ "spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace2 lconf acp <$> vs) ++ ",lineCheck=" ++ show (lineCheck <$> vs) ++ " " ++ show (toConstr bd) + tellDebugMess $ " " ++ show (Data.Maybe.mapMaybe (fmap fst) checkedOptions) #endif id -- $ (fmap $ \x -> traceShow (briDocToDoc x) x) $ rec $ fromMaybe (-- trace ("choosing last") $ List.last alts) - $ Data.List.Extra.firstJust (\(_i::Int, (b,x)) -> - [ -- traceShow ("choosing option " ++ show i) $ - x - | b - ]) - $ zip [1..] options + $ Data.List.Extra.firstJust (fmap snd) checkedOptions BDFForceMultiline bd -> do acp <- mGet x <- do @@ -635,7 +639,7 @@ getSpacings limit bridoc = rec bridoc BDFAlt [] -> error "empty BDAlt" -- BDAlt (alt:_) -> rec alt BDFAlt alts -> do - r <- filterAndLimit . join . Control.Lens.transposeOf traverse <$> (rec `mapM` alts) + r <- filterAndLimit . join . transpose <$> (rec `mapM` alts) return r BDFForceMultiline bd -> rec bd BDFForceSingleline bd -> do diff --git a/src/Language/Haskell/Brittany/LayoutBasics.hs b/src/Language/Haskell/Brittany/LayoutBasics.hs index 7d62477..181f4a6 100644 --- a/src/Language/Haskell/Brittany/LayoutBasics.hs +++ b/src/Language/Haskell/Brittany/LayoutBasics.hs @@ -510,10 +510,12 @@ layoutSetBaseColCur m = do tellDebugMessShow ("layoutSetBaseColCur") #endif state <- mGet - case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of - (Left i, Just j) -> layoutSetBaseColInternal (i+j) - (Left i, Nothing) -> layoutSetBaseColInternal i - (Right{}, _) -> return () + case _lstate_commentCol state of + Nothing -> case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of + (Left i, Just j) -> layoutSetBaseColInternal (i+j) + (Left i, Nothing) -> layoutSetBaseColInternal i + (Right{}, _) -> return () + Just cCol -> layoutSetBaseColInternal cCol m layoutSetBaseColInternal $ _lstate_baseY state diff --git a/src/Language/Haskell/Brittany/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Layouters/Decl.hs index 2891eb4..5ae16c1 100644 --- a/src/Language/Haskell/Brittany/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Layouters/Decl.hs @@ -180,19 +180,44 @@ layoutPatternBindFinal binderDoc mPatDoc clauseDocs mWhereDocs = do ] _ -> [] ] ++ + -- two-line solution + [ docLines + $ [ docForceSingleline + $ docSeq (patPartInline ++ [guardPart, return binderDoc]) + , docEnsureIndent BrIndentRegular + $ docForceSingleline + $ return body + ] ++ wherePart + | [(guards, body, _bodyRaw)] <- [clauseDocs] + , let guardPart = case guards of + [] -> docEmpty + [g] -> docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator] + gs -> docSeq + $ [appSep $ docLit $ Text.pack "|"] + ++ List.intersperse docCommaSep (return <$> gs) + ++ [docSeparator] + , let wherePart = case mWhereDocs of + Nothing -> [] + Just ws -> pure $ docEnsureIndent BrIndentRegular $ docPar + (docLit $ Text.pack "where") + (docSetIndentLevel $ docLines $ return <$> ws) + ] ++ -- pattern and exactly one clause in single line, body and where -- indented if necessary. - [ docAddBaseY BrIndentRegular - $ docPar - ( docCols ColBindingLine + [ docLines + $ [ docCols ColBindingLine [ docSeq (patPartInline ++ [appSep guardPart]) , docSeq [ appSep $ return binderDoc , lineMod $ docAddBaseY BrIndentRegular $ return body + -- , lineMod $ docAlt + -- [ docSetBaseY $ return body + -- , docAddBaseY BrIndentRegular $ return body + -- ] ] - ]) - wherePart + ] + ] ++ wherePart | [(guards, body, bodyRaw)] <- [clauseDocs] , let lineMod = case () of _ | isExpressionTypeHeadPar bodyRaw -> id @@ -203,11 +228,11 @@ layoutPatternBindFinal binderDoc mPatDoc clauseDocs mWhereDocs = do gs -> docSeq $ [appSep $ docLit $ Text.pack "|"] ++ List.intersperse docCommaSep (return <$> gs) - , wherePart <- case mWhereDocs of - Nothing -> [] - Just ws -> pure $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "where") - (docSetIndentLevel $ docLines $ return <$> ws) + , let wherePart = case mWhereDocs of + Nothing -> [] + Just ws -> pure $ docEnsureIndent BrIndentRegular $ docPar + (docLit $ Text.pack "where") + (docSetIndentLevel $ docLines $ return <$> ws) ] ++ -- pattern and exactly one clause in single line, body in new line. [ docAddBaseY BrIndentRegular @@ -227,6 +252,7 @@ layoutPatternBindFinal binderDoc mPatDoc clauseDocs mWhereDocs = do (docLit $ Text.pack "where") (docSetIndentLevel $ docLines $ return <$> ws) ] ++ + -- conservative approach: everything starts on the left. [ docAddBaseY BrIndentRegular $ patPartParWrap $ docLines $ diff --git a/src/Language/Haskell/Brittany/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Layouters/Expr.hs index 5930529..62ad036 100644 --- a/src/Language/Haskell/Brittany/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Layouters/Expr.hs @@ -60,11 +60,18 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of docAlt [ docSeq [ docLit $ Text.pack "\\" - , docWrapNode lmatch $ funcPatternPartLine + , docWrapNode lmatch $ docForceSingleline funcPatternPartLine , appSep $ docLit $ Text.pack "->" - , docWrapNode lgrhs $ bodyDoc + , docWrapNode lgrhs $ docForceSingleline bodyDoc ] - -- TODO + , docAddBaseY BrIndentRegular + $ docPar + (docSeq + [ docLit $ Text.pack "\\" + , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine + , docLit $ Text.pack "->" + ]) + (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc) ] HsLam{} -> unknownNodeError "HsLam too complex" lexpr @@ -142,15 +149,19 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of , appSep $ docForceSingleline opLastDoc , docForceSingleline expLastDoc ] - , docAddBaseY BrIndentRegular + , docSetBaseY $ docPar - (docSetBaseY leftOperandDoc) + leftOperandDoc + ( docLines + $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) + ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] + ) + , docPar + leftOperandDoc ( docLines $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] ) - -- TODO: singleline - -- TODO: wrapping on spine nodes ] OpApp expLeft expOp _ expRight -> do expDocLeft <- docSharedWrapper layoutExpr expLeft @@ -179,7 +190,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of $ docPar expDocLeft -- TODO: turn this into docCols? - (docCols ColOpPrefix [appSep $ expDocOp, expDocRight]) + (docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight]) ] NegApp{} -> do -- TODO @@ -192,7 +203,13 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of , docForceSingleline innerExpDoc , docLit $ Text.pack ")" ] - -- TODO + , docSetBaseY $ docLines + [ docCols ColOpPrefix + [ docParenLSep + , docAddBaseY (BrIndentSpecial 2) innerExpDoc + ] + , docLit $ Text.pack ")" + ] ] SectionL left op -> do -- TODO: add to testsuite leftDoc <- docSharedWrapper layoutExpr left @@ -241,7 +258,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of ) ( docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "of") - (docSetIndentLevel $ docLines $ return <$> funcPatDocs) + (docSetIndentLevel $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs) ) ] HsIf _ ifExpr thenExpr elseExpr -> do @@ -379,7 +396,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of [appSep $ docLit $ Text.pack "|", s1] lineM = sM <&> \d -> docCols ColListComp [docCommaSep, d] - end = docLit $ Text.pack "]" + end = docLit $ Text.pack " ]" in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end] ] HsDo{} -> do @@ -443,19 +460,20 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of docSeq [rExprDoc, docLit $ Text.pack "{}"] RecordUpd rExpr fields@(_:_) _ _ _ _ -> do rExprDoc <- docSharedWrapper layoutExpr rExpr - rFs@(rF1:rFr) <- fields `forM` \(L _ (HsRecField (L _ ambName) rFExpr _)) -> do - rFExpDoc <- docSharedWrapper layoutExpr rFExpr - return $ case ambName of - Unambiguous n _ -> (lrdrNameToText n, rFExpDoc) - Ambiguous n _ -> (lrdrNameToText n, rFExpDoc) + rFs@((rF1f, rF1n, rF1e):rFr) <- fields + `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr _)) -> do + rFExpDoc <- docSharedWrapper layoutExpr rFExpr + return $ case ambName of + Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) + Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) docAlt -- singleline [ docSeq [ appSep rExprDoc , appSep $ docLit $ Text.pack "{" , appSep $ docSeq $ List.intersperse docCommaSep - $ rFs <&> \(fieldStr, fieldDoc) -> - docSeq [ appSep $ docLit fieldStr + $ rFs <&> \(lfield, fieldStr, fieldDoc) -> + docSeq [ appSep $ docWrapNode lfield $ docLit fieldStr , appSep $ docLit $ Text.pack "=" , docForceSingleline fieldDoc ] @@ -467,14 +485,14 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of , docSetBaseY $ docLines $ let line1 = docCols ColRecUpdate [ appSep $ docLit $ Text.pack "{" - , appSep $ docLit $ fst rF1 + , appSep $ docLit $ rF1n , docSeq [ appSep $ docLit $ Text.pack "=" - , docForceSingleline $ snd rF1 + , docForceSingleline $ rF1e ] ] - lineR = rFr <&> \(fText, fDoc) -> docCols ColRecUpdate + lineR = rFr <&> \(lfield, fText, fDoc) -> docCols ColRecUpdate [ appSep $ docLit $ Text.pack "," - , appSep $ docLit $ fText + , appSep $ docWrapNode lfield $ docLit $ fText , docSeq [ appSep $ docLit $ Text.pack "=" , docForceSingleline fDoc ] @@ -486,17 +504,17 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of , docAddBaseY BrIndentRegular $ docPar rExprDoc - (docLines $ let + (docNonBottomSpacing $ docLines $ let line1 = docCols ColRecUpdate [ appSep $ docLit $ Text.pack "{" - , appSep $ docLit $ fst rF1 + , appSep $ docWrapNode rF1f $ docLit $ rF1n , docSeq [ appSep $ docLit $ Text.pack "=" - , docAddBaseY BrIndentRegular $ snd rF1 + , docAddBaseY BrIndentRegular $ rF1e ] ] - lineR = rFr <&> \(fText, fDoc) -> docCols ColRecUpdate + lineR = rFr <&> \(lfield, fText, fDoc) -> docCols ColRecUpdate [ appSep $ docLit $ Text.pack "," - , appSep $ docLit $ fText + , appSep $ docWrapNode lfield $ docLit $ fText , docSeq [ appSep $ docLit $ Text.pack "=" , docAddBaseY BrIndentRegular fDoc ] @@ -623,12 +641,18 @@ isExpressionTypeHeadPar (L _ expr) = case expr of RecordUpd{} -> True HsDo{} -> True HsIf{} -> True - HsCase{} -> True HsLamCase{} -> True -- TODO: these cases might have unfortunate layouts, if for some reason -- the first operand is multiline. OpApp _ _ _ (L _ HsDo{}) -> True OpApp _ _ _ (L _ HsLamCase{}) -> True + OpApp _ _ _ (L _ HsLam{}) -> True + OpApp (L _ (OpApp left _ _ _)) _ _ _ | leftVar left -> True + where + -- leftVar (L _ x) | traceShow (Data.Data.toConstr x) False = error "foo" + leftVar (L _ HsVar{}) = True + leftVar (L _ (OpApp x _ _ _)) = leftVar x + leftVar _ = False _ -> False isExpressionTypeHeadPar' :: LHsExpr RdrName -> Bool @@ -637,7 +661,6 @@ isExpressionTypeHeadPar' (L _ expr) = case expr of RecordUpd{} -> True HsDo{} -> True HsIf{} -> True - HsCase{} -> True HsLamCase{} -> True -- TODO: these cases might have unfortunate layouts, if for some reason -- the first operand is multiline.