Respect special where ind.; Some layouting fixes

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

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

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
-        wherePart = case mWhereDocs of
+          Nothing -> return @[] $ docEmpty
-          Nothing -> docEmpty
+          Just [w] -> return @[] $ docSeq
-          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)
-            ]
-          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
+    -- pattern and exactly one clause in single line, body as par;
-    -- indented if necessary.
+    -- 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
+    [ docLines
-    $ docPar
+    $ [ docSeq (patPartInline ++ [appSep $ guardPart, return binderDoc])
-      (docSeq (patPartInline ++ [appSep $ guardPart, return binderDoc]))
+      , docEnsureIndent BrIndentRegular
-      ( docNonBottomSpacing
+      $ 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
+    [ docLines $
-    $ patPartParWrap
+        [ patPartParWrap
-    $ docLines $
+        $ docLines
-        (clauseDocs >>= \(guardDocs, bodyDoc, _) ->
+        $ 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]
             ]
-        ) ++
+        ] ++ wherePartMultiLine
-        (case mWhereDocs of
-          Nothing -> []
-          Just whereDocs ->
-            [ docAddBaseY BrIndentRegular
-            $ docPar (docLit $ Text.pack "where")
-            $ docSetIndentLevel $ docLines (return <$> whereDocs)
-            ]
-        )
     ]

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

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

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 )