From 6b748ea3eb4f219677524238e487c85667f9f0db Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 4 Aug 2016 19:53:37 +0200 Subject: [PATCH] Respect special where ind.; Some layouting fixes --- brittany.cabal | 3 + src/Language/Haskell/Brittany/BriLayouter.hs | 10 +- .../Haskell/Brittany/Layouters/Decl.hs | 126 +++++++++--------- .../Haskell/Brittany/Layouters/Stmt.hs | 8 +- src/Language/Haskell/Brittany/Types.hs | 4 +- srcinc/prelude.inc | 2 + 6 files changed, 81 insertions(+), 72 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 2f189f4..3de66fd 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -74,6 +74,7 @@ library { , strict >=0.3.2 && <0.4 , monad-memo >=0.4.1 && <0.5 , unsafe >=0.0 && <0.1 + , safe >=0.3.9 && <0.4 , deepseq >=1.4.2.0 && <1.5 } default-extensions: { @@ -129,6 +130,7 @@ executable brittany , uniplate , strict , monad-memo + , safe } hs-source-dirs: src-brittany default-language: Haskell2010 @@ -193,6 +195,7 @@ test-suite unittests , uniplate , strict , monad-memo + , safe } ghc-options: -Wall main-is: TestMain.hs diff --git a/src/Language/Haskell/Brittany/BriLayouter.hs b/src/Language/Haskell/Brittany/BriLayouter.hs index 72b38e7..b9ccaba 100644 --- a/src/Language/Haskell/Brittany/BriLayouter.hs +++ b/src/Language/Haskell/Brittany/BriLayouter.hs @@ -768,6 +768,8 @@ transformSimplifyFloating = stepBO .> stepFull -- note that semantically, stepFull is completely sufficient. -- but the bottom-up switch-to-top-down-on-match transformation has much -- better complexity. + -- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence + -- the push/pop cases would need to be copied over where descendPost = transformDownMay $ \case -- post floating in @@ -796,19 +798,19 @@ transformSimplifyFloating = stepBO .> stepFull Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x _ -> Nothing descendBYPush = transformDownMay $ \case - BDBaseYPushCur (BDCols sig cols) -> + BDBaseYPushCur (BDCols sig cols@(_:_)) -> Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) _ -> Nothing descendBYPop = transformDownMay $ \case - BDBaseYPop (BDCols sig cols) -> + BDBaseYPop (BDCols sig cols@(_:_)) -> Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) _ -> Nothing descendILPush = transformDownMay $ \case - BDIndentLevelPushCur (BDCols sig cols) -> + BDIndentLevelPushCur (BDCols sig cols@(_:_)) -> Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) _ -> Nothing descendILPop = transformDownMay $ \case - BDIndentLevelPop (BDCols sig cols) -> + BDIndentLevelPop (BDCols sig cols@(_:_)) -> Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) _ -> Nothing descendAddB = transformDownMay $ \case diff --git a/src/Language/Haskell/Brittany/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Layouters/Decl.hs index ee6cd8c..e85b133 100644 --- a/src/Language/Haskell/Brittany/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Layouters/Decl.hs @@ -149,11 +149,25 @@ layoutPatternBindFinal binderDoc mPatDoc clauseDocs mWhereDocs = do patPartParWrap = case mPatDoc of Nothing -> id Just patDoc -> docPar (return patDoc) - _whereIndent <- mAsk + whereIndent <- mAsk <&> _conf_layout .> _lconfig_indentWhereSpecial .> runIdentity .> Bool.bool BrIndentRegular (BrIndentSpecial 1) + -- TODO: apart from this, there probably are more nodes below which could + -- be shared between alternatives. + wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of + Nothing -> return $ [] + Just ws -> fmap (fmap return) $ sequence $ return @[] + $ docEnsureIndent whereIndent + $ docLines + [ docLit $ Text.pack "where" + , docEnsureIndent whereIndent + $ docSetIndentLevel + $ docNonBottomSpacing + $ docLines + $ return <$> ws + ] docAlt $ -- one-line solution [ docCols ColBindingLine @@ -177,38 +191,48 @@ layoutPatternBindFinal binderDoc mPatDoc clauseDocs mWhereDocs = do $ [appSep $ docLit $ Text.pack "|"] ++ List.intersperse docCommaSep (return <$> gs) ++ [docSeparator] - , let - wherePart = case mWhereDocs of - Nothing -> docEmpty - Just [w] -> docAlt - [ docSeq - [ docSeparator - , appSep $ docLit $ Text.pack "where" - , docSetIndentLevel $ docForceSingleline $ return w - ] - , docAddBaseY BrIndentRegular - $ docPar docEmpty - $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "where") - (docSetIndentLevel $ return w) + , wherePart <- case mWhereDocs of + Nothing -> return @[] $ docEmpty + Just [w] -> return @[] $ docSeq + [ docSeparator + , appSep $ docLit $ Text.pack "where" + , docSetIndentLevel $ docForceSingleline $ return w ] - Just ws -> - docAddBaseY BrIndentRegular - $ docPar docEmpty - $ docAddBaseY BrIndentRegular - $ docPar - (docLit $ Text.pack "where") - (docSetIndentLevel $ docLines $ return <$> ws) + _ -> [] ] ++ - -- two-line solution + -- one-line solution + where in next line(s) + [ docLines + $ [ docCols ColBindingLine + [ docSeq + (patPartInline ++ [guardPart]) + , docSeq + [ appSep $ return binderDoc + , lineMod $ return body + ] + ] + ] ++ wherePartMultiLine + | [(guards, body, bodyRaw)] <- [clauseDocs] + , let lineMod = case mWhereDocs of + Nothing | isExpressionTypeHeadPar bodyRaw -> + docAddBaseY BrIndentRegular + _ -> docForceSingleline + , 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] + , Data.Maybe.isJust mWhereDocs + ] ++ + -- two-line solution + where in next line(s) [ docLines $ [ docForceSingleline $ docSeq (patPartInline ++ [guardPart, return binderDoc]) , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body - ] ++ wherePart + ] ++ wherePartMultiLine | [(guards, body, _bodyRaw)] <- [clauseDocs] , let guardPart = case guards of [] -> docEmpty @@ -217,14 +241,9 @@ layoutPatternBindFinal binderDoc mPatDoc clauseDocs mWhereDocs = do $ [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. + -- pattern and exactly one clause in single line, body as par; + -- where in following lines [ docLines $ [ docCols ColBindingLine [ docSeq @@ -238,7 +257,7 @@ layoutPatternBindFinal binderDoc mPatDoc clauseDocs mWhereDocs = do -- ] ] ] - ] ++ wherePart + ] ++ wherePartMultiLine | [(guards, body, bodyRaw)] <- [clauseDocs] , let lineMod = case () of _ | isExpressionTypeHeadPar bodyRaw -> id @@ -249,20 +268,15 @@ layoutPatternBindFinal binderDoc mPatDoc clauseDocs mWhereDocs = do gs -> docSeq $ [appSep $ docLit $ Text.pack "|"] ++ List.intersperse docCommaSep (return <$> gs) - , 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 - $ docPar - (docSeq (patPartInline ++ [appSep $ guardPart, return binderDoc])) - ( docNonBottomSpacing + [ docLines + $ [ docSeq (patPartInline ++ [appSep $ guardPart, return binderDoc]) + , docEnsureIndent BrIndentRegular + $ docNonBottomSpacing $ docLines - $ [ docAddBaseY BrIndentRegular $ return body ] ++ wherePart - ) + $ [ docAddBaseY BrIndentRegular $ return body ] + ] ++ wherePartMultiLine | [(guards, body, _)] <- [clauseDocs] , let guardPart = case guards of [] -> docEmpty @@ -270,17 +284,13 @@ layoutPatternBindFinal binderDoc mPatDoc clauseDocs mWhereDocs = do gs -> docSeq $ [appSep $ docLit $ Text.pack "|"] ++ List.intersperse docCommaSep (return <$> gs) - , let wherePart = case mWhereDocs of - Nothing -> [] - Just ws -> pure $ docAddBaseY BrIndentRegular $ docPar - (docLit $ Text.pack "where") - (docSetIndentLevel $ docLines $ return <$> ws) ] ++ -- conservative approach: everything starts on the left. - [ docAddBaseY BrIndentRegular - $ patPartParWrap - $ docLines $ - (clauseDocs >>= \(guardDocs, bodyDoc, _) -> + [ docLines $ + [ patPartParWrap + $ docLines + $ fmap (docEnsureIndent BrIndentRegular) + $ clauseDocs >>= \(guardDocs, bodyDoc, _) -> (case guardDocs of [] -> [] [g] -> [docSeq [appSep $ docLit $ Text.pack "|", return g]] @@ -295,13 +305,5 @@ layoutPatternBindFinal binderDoc mPatDoc clauseDocs mWhereDocs = do [ appSep $ return binderDoc , docAddBaseY BrIndentRegular $ return bodyDoc] ] - ) ++ - (case mWhereDocs of - Nothing -> [] - Just whereDocs -> - [ docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "where") - $ docSetIndentLevel $ docLines (return <$> whereDocs) - ] - ) + ] ++ wherePartMultiLine ] diff --git a/src/Language/Haskell/Brittany/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Layouters/Stmt.hs index d902835..6937ba3 100644 --- a/src/Language/Haskell/Brittany/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Layouters/Stmt.hs @@ -46,7 +46,7 @@ layoutStmt lstmt@(L _ stmt) = docWrapNode lstmt $ case stmt of Just [bindDoc] -> docAlt [ docCols ColDoLet [ appSep $ docLit $ Text.pack "let" - , docSetIndentLevel $ docAddBaseY BrIndentRegular (return bindDoc) + , docSetIndentLevel $ return bindDoc ] , docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") @@ -59,17 +59,17 @@ layoutStmt lstmt@(L _ stmt) = docWrapNode lstmt $ case stmt of [ docLines $ (docCols ColDoLet [ appSep $ docLit $ Text.pack "let" - , docSetIndentLevel $ docAddBaseY BrIndentRegular (return bindDoc1) + , docSetIndentLevel $ return bindDoc1 ]) : (bindDocr <&> \bindDoc -> docCols ColDoLet [ docEnsureIndent (BrIndentSpecial 4) docEmpty - , docSetIndentLevel $ docAddBaseY BrIndentRegular (return bindDoc) + , docSetIndentLevel $ return bindDoc ]) , docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") - (docSetIndentLevel $ docAddBaseY BrIndentRegular $ docLines $ return <$> bindDocs) + (docSetIndentLevel $ docLines $ return <$> bindDocs) ] BodyStmt expr _ _ _ -> do expDoc <- docSharedWrapper layoutExpr expr diff --git a/src/Language/Haskell/Brittany/Types.hs b/src/Language/Haskell/Brittany/Types.hs index 5f010a2..8205e45 100644 --- a/src/Language/Haskell/Brittany/Types.hs +++ b/src/Language/Haskell/Brittany/Types.hs @@ -83,10 +83,10 @@ data LayoutState = LayoutState } lstate_baseY :: LayoutState -> Int -lstate_baseY = head . _lstate_baseYs +lstate_baseY = Safe.headNote "lstate_baseY" . _lstate_baseYs lstate_indLevel :: LayoutState -> Int -lstate_indLevel = head . _lstate_indLevels +lstate_indLevel = Safe.headNote "lstate_baseY" . _lstate_indLevels -- evil, incomplete Show instance; only for debugging. instance Show LayoutState where diff --git a/srcinc/prelude.inc b/srcinc/prelude.inc index 50f2cc8..125aa4b 100644 --- a/srcinc/prelude.inc +++ b/srcinc/prelude.inc @@ -428,6 +428,8 @@ import qualified Control.Monad.Trans.State.Strict as StateS import qualified Data.Strict.Maybe as Strict +import qualified Safe as Safe + import Data.Functor.Identity ( Identity(..) ) import Control.Concurrent.Chan ( Chan ) import Control.Concurrent.MVar ( MVar )