Merge pull request #66 from eborden/indentpolicyleft

Support IndentPolicyLeft

src-literatetests/10-tests.blt

@@ -227,7 +227,7 @@ func
 {-# LANGUAGE ScopedTypeVariables #-}
 func
   :: forall m
-  .  ColMap2
+   . ColMap2
   -> ColInfo
   -> ColInfo
   -> ColInfo

src-literatetests/15-regressions.blt

@@ -31,7 +31,7 @@ func = do
 func = do
   s <- mGet
   mSet $ s { _lstate_indent = _lstate_indent state
-           , _lstate_indent = _lstate_indent state
+           , _lstate_foo    = _lstate_foo state
            }
 
 #test record update indentation 3
@@ -39,7 +39,23 @@ func = do
   s <- mGet
   mSet $ s
     { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
-    , _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+    , _lstate_foo    = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+    }
+
+#test record construction 1
+func = Foo {_lstate_indent = _lstate_indent state}
+
+#test record construction 2
+func = Foo
+  { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+  , _lstate_fooo   = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+  }
+
+#test record construction 3
+func = do
+  Foo
+    { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+    , _lstate_foo    = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
     }
 
 #test post-indent comment

src-literatetests/Main.hs

@@ -40,14 +40,27 @@ data InputLine
 main :: IO ()
 main = do
   files <- System.Directory.listDirectory "src-literatetests/"
-  let blts = List.sort $ filter (".blt" `isSuffixOf`) files
+  let blts =
+        List.sort
+          $ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x))
+          $ filter (".blt"`isSuffixOf`) files
   inputs <- blts `forM` \blt -> Text.IO.readFile ("src-literatetests" </> blt)
   let groups = createChunks =<< inputs
-  hspec $ groups `forM_` \(groupname, tests) -> do
+  inputCtxFree <- Text.IO.readFile "src-literatetests/tests-context-free.blt"
-    describe (Text.unpack groupname) $ tests `forM_` \(name, pend, inp) -> do
+  let groupsCtxFree = createChunks inputCtxFree
-      (if pend then before_ pending else id)
+  hspec $ do
-        $ it (Text.unpack name)
+    groups `forM_` \(groupname, tests) -> do
-        $ roundTripEqual inp
+      describe (Text.unpack groupname) $ tests `forM_` \(name, pend, inp) -> do
+        (if pend then before_ pending else id)
+          $ it (Text.unpack name)
+          $ roundTripEqual defaultTestConfig inp
+    groupsCtxFree `forM_` \(groupname, tests) -> do
+      describe ("context free: " ++ Text.unpack groupname)
+        $       tests
+        `forM_` \(name, pend, inp) -> do
+                  (if pend then before_ pending else id)
+                    $ it (Text.unpack name)
+                    $ roundTripEqual contextFreeTestConfig inp
  where
   -- this function might be implemented in a weirdly complex fashion; the
   -- reason being that it was copied from a somewhat more complex variant.
@@ -132,10 +145,10 @@ main = do
 --------------------
 -- past this line:  copy-pasta from other test (meh..)
 --------------------
-roundTripEqual :: Text -> Expectation
+roundTripEqual :: Config -> Text -> Expectation
-roundTripEqual t =
+roundTripEqual c t =
   fmap (fmap PPTextWrapper)
-       (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t)
+       (parsePrintModuleTests c "TestFakeFileName.hs" t)
     `shouldReturn` Right (PPTextWrapper t)
 
 newtype PPTextWrapper = PPTextWrapper Text
@@ -170,3 +183,12 @@ defaultTestConfig = Config
     }
   }
 
+contextFreeTestConfig :: Config
+contextFreeTestConfig =
+  defaultTestConfig
+  { _conf_layout = (_conf_layout defaultTestConfig)
+    {_lconfig_indentPolicy = coerce IndentPolicyLeft
+    ,_lconfig_alignmentLimit = coerce (1 :: Int)
+    ,_lconfig_columnAlignMode = coerce ColumnAlignModeDisabled
+    }
+  }

src/Language/Haskell/Brittany/Internal/Config/Types.hs

@@ -191,7 +191,7 @@ data IndentPolicy = IndentPolicyLeft -- never create a new indentation at more
                   | IndentPolicyFree -- can create new indentations whereever
                   | IndentPolicyMultiple -- can create indentations only
                                          -- at any n * amount.
-  deriving (Show, Generic, Data)
+  deriving (Eq, Show, Generic, Data)
 
 data AltChooser = AltChooserSimpleQuick -- always choose last alternative.
                                         -- leads to tons of sparsely filled

src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs

@@ -265,9 +265,15 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
         gs  -> docSeq
             $  [appSep $ docLit $ Text.pack "|"]
             ++ List.intersperse docCommaSep (return <$> gs)
-  docAlt
+
+  indentPolicy <- mAsk
+    <&> _conf_layout
+    .>  _lconfig_indentPolicy
+    .>  confUnpack
+  docAltFilter
     $  -- one-line solution
-       [ docCols
+       [ ( True
+         , docCols
          (ColBindingLine alignmentToken)
          [ docSeq (patPartInline ++ [guardPart])
          , docSeq
@@ -276,6 +282,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
            , wherePart
            ]
          ]
+         )
        | not hasComments
        , [(guards, body, _bodyRaw)] <- [clauseDocs]
        , let guardPart = singleLineGuardsDoc guards
@@ -289,7 +296,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
          _        -> []
        ]
     ++ -- one-line solution + where in next line(s)
-       [ docLines
+       [ ( True
+         , docLines
          $  [ docCols
               (ColBindingLine alignmentToken)
               [ docSeq (patPartInline ++ [guardPart])
@@ -298,23 +306,27 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
               ]
             ]
          ++ wherePartMultiLine
+         )
        | [(guards, body, _bodyRaw)] <- [clauseDocs]
        , let guardPart = singleLineGuardsDoc guards
        , Data.Maybe.isJust mWhereDocs
        ]
     ++ -- two-line solution + where in next line(s)
-       [ docLines
+       [ ( True 
+         , docLines
          $  [ docForceSingleline
             $ docSeq (patPartInline ++ [guardPart, return binderDoc])
             , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body
             ]
          ++ wherePartMultiLine
+         )
        | [(guards, body, _bodyRaw)] <- [clauseDocs]
        , let guardPart = singleLineGuardsDoc guards
        ]
     ++ -- pattern and exactly one clause in single line, body as par;
        -- where in following lines
-       [                            docLines
+       [ ( True
+         , docLines
          $  [ docCols
               (ColBindingLine alignmentToken)
               [ docSeq (patPartInline ++ [guardPart])
@@ -329,24 +341,28 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
           --   , docAddBaseY BrIndentRegular $ return body
           --   ]
          ++ wherePartMultiLine
+         )
        | [(guards, body, _bodyRaw)] <- [clauseDocs]
        , let guardPart = singleLineGuardsDoc guards
        ]
     ++ -- pattern and exactly one clause in single line, body in new line.
-       [ docLines
+       [ ( True
+         , docLines
          $  [ docSeq (patPartInline ++ [guardPart, return binderDoc])
             , docEnsureIndent BrIndentRegular
             $ docNonBottomSpacing
             $ (docAddBaseY BrIndentRegular $ return body)
             ]
          ++ wherePartMultiLine
+         )
        | [(guards, body, _)] <- [clauseDocs]
        , let guardPart = singleLineGuardsDoc guards
        ]
     ++ -- multiple clauses added in-paragraph, each in a single line
        -- example: foo | bar = baz
        --              | lll = asd
-       [ docLines
+       [ ( indentPolicy /= IndentPolicyLeft
+         , docLines
          $  [ docSeq
               [ appSep $ docForceSingleline $ return patDoc
               , docSetBaseY
@@ -370,10 +386,12 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
               ]
             ]
          ++ wherePartMultiLine
+         )
        | Just patDoc <- [mPatDoc]
        ]
     ++ -- multiple clauses, each in a separate, single line
-       [ docLines
+       [ ( True
+         , docLines
          $  [ docAddBaseY BrIndentRegular
               $   patPartParWrap
               $   docLines
@@ -396,10 +414,12 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
                       ]
             ]
          ++ wherePartMultiLine
+         )
        ]
     ++ -- multiple clauses, each with the guard(s) in a single line, body
        -- as a paragraph
-       [ docLines
+       [ ( True
+         , docLines
          $  [ docAddBaseY BrIndentRegular
               $   patPartParWrap
               $   docLines
@@ -431,10 +451,12 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
                          ]
             ]
          ++ wherePartMultiLine
+         )
        ]
     ++ -- multiple clauses, each with the guard(s) in a single line, body
        -- in a new line as a paragraph
-       [ docLines
+       [ ( True
+         , docLines
          $  [ docAddBaseY BrIndentRegular
               $   patPartParWrap
               $   docLines
@@ -464,9 +486,11 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
                        ]
             ]
          ++ wherePartMultiLine
+         )
        ]
     ++ -- conservative approach: everything starts on the left.
-       [ docLines
+       [ ( True
+         , docLines
          $  [ docAddBaseY BrIndentRegular
               $   patPartParWrap
               $   docLines
@@ -494,4 +518,5 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
                          ]
             ]
          ++ wherePartMultiLine
+         )
        ]

src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs

@@ -11,6 +11,7 @@ where
 
 import           Language.Haskell.Brittany.Internal.Types
 import           Language.Haskell.Brittany.Internal.LayouterBasics
+import           Language.Haskell.Brittany.Internal.Config.Types
 
 import           RdrName ( RdrName(..) )
 import           GHC ( runGhc, GenLocated(L), moduleNameString )
@@ -26,57 +27,91 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
 
 
 layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName))
-layoutStmt lstmt@(L _ stmt) = docWrapNode lstmt $ case stmt of
+layoutStmt lstmt@(L _ stmt) = do
-  LastStmt body False _    -> do
+  indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
-    layoutExpr body
+  docWrapNode lstmt $ case stmt of
-  BindStmt lPat expr _ _ _ -> do
+    LastStmt body False _ -> do
-    patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat
+      layoutExpr body
-    expDoc <- docSharedWrapper layoutExpr expr
+    BindStmt lPat expr _ _ _ -> do
-    docAlt
+      patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat
-      [ docCols
+      expDoc <- docSharedWrapper layoutExpr expr
-        ColBindStmt
+      docAlt
-        [ appSep patDoc
+        [ docCols
-        , docSeq [appSep $ docLit $ Text.pack "<-", docForceParSpacing expDoc]
+          ColBindStmt
+          [ appSep patDoc
+          , docSeq [appSep $ docLit $ Text.pack "<-", docForceParSpacing expDoc]
+          ]
+        , docCols
+          ColBindStmt
+          [ appSep patDoc
+          , docAddBaseY BrIndentRegular
+            $ docPar (docLit $ Text.pack "<-") (expDoc)
+          ]
         ]
-      , docCols
+    LetStmt binds -> layoutLocalBinds binds >>= \case
-        ColBindStmt
+      Nothing        -> docLit $ Text.pack "let" -- i just tested
-        [ appSep patDoc
+                                -- it, and it is
+                                -- indeed allowed.
+                                -- heh.
+      Just []        -> docLit $ Text.pack "let" -- this probably never happens
+      Just [bindDoc] -> docAlt
+        [ -- let bind = expr
+          docCols
+          ColDoLet
+          [ appSep $ docLit $ Text.pack "let"
+          , ( if indentPolicy == IndentPolicyLeft
+              then docForceSingleline
+              else docSetBaseAndIndent
+            )
+            $ return bindDoc
+          ]
+        , -- let
+          --   bind = expr
+          docAddBaseY BrIndentRegular $ docPar
+          (docLit $ Text.pack "let")
+          (docSetBaseAndIndent $ return bindDoc)
+        ]
+      Just bindDocs -> docAltFilter
+        [ -- let aaa = expra
+          --     bbb = exprb
+          --     ccc = exprc
+          ( indentPolicy /= IndentPolicyLeft
+          , docSeq
+            [ appSep $ docLit $ Text.pack "let"
+            , docSetBaseAndIndent $ docLines $ return <$> bindDocs
+            ]
+          )
+        , -- let
+          --   aaa = expra
+          --   bbb = exprb
+          --   ccc = exprc
+          ( True
+          , docAddBaseY BrIndentRegular $ docPar
+            (docLit $ Text.pack "let")
+            (docSetBaseAndIndent $ docLines $ return <$> bindDocs)
+          )
+        ]
+    RecStmt stmts _ _ _ _ _ _ _ _ _ -> docAltFilter
+      [ -- rec stmt1
+        --     stmt2
+        --     stmt3
+        ( indentPolicy /= IndentPolicyLeft
+        , docSeq
+          [ docLit (Text.pack "rec")
+          , docSeparator
+          , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts
+          ]
+        )
+      , -- rec
+        --   stmt1
+        --   stmt2
+        --   stmt3
+        ( True
         , docAddBaseY BrIndentRegular
-          $ docPar (docLit $ Text.pack "<-") (expDoc)
+          $ docPar (docLit (Text.pack "rec")) (docLines $ layoutStmt <$> stmts)
-        ]
+        )
       ]
-  LetStmt binds            -> layoutLocalBinds binds >>= \case
+    BodyStmt expr _ _ _ -> do
-    Nothing        -> docLit $ Text.pack "let" -- i just tested
+      expDoc <- docSharedWrapper layoutExpr expr
-                               -- it, and it is
+      docAddBaseY BrIndentRegular $ expDoc
-                               -- indeed allowed.
+    _ -> briDocByExactInlineOnly "some unknown statement" lstmt
-                               -- heh.
-    Just []        -> docLit $ Text.pack "let" -- this probably never happens
-    Just [bindDoc] -> docAlt
-      [ docCols
-        ColDoLet
-        [ appSep $ docLit $ Text.pack "let"
-        , docSetBaseAndIndent $ return bindDoc
-        ]
-      , docAddBaseY BrIndentRegular
-        $ docPar (docLit $ Text.pack "let")
-                 (docSetBaseAndIndent $ return bindDoc)
-      ]
-    Just bindDocs  -> docAlt
-      [ docSeq
-        [ appSep $ docLit $ Text.pack "let"
-        , docSetBaseAndIndent $ docLines $ return <$> bindDocs
-        ]
-      , docAddBaseY BrIndentRegular $ docPar
-        (docLit $ Text.pack "let")
-        (docSetBaseAndIndent $ docLines $ return <$> bindDocs)
-      ]
-  RecStmt stmts _ _ _ _ _ _ _ _ _ -> do
-    docSeq
-      [ docLit (Text.pack "rec")
-      , docSeparator
-      , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts
-      ]
-  BodyStmt expr _ _ _      -> do
-    expDoc <- docSharedWrapper layoutExpr expr
-    docAddBaseY BrIndentRegular $ expDoc
-  _                        -> briDocByExactInlineOnly "some unknown statement" lstmt

src/Language/Haskell/Brittany/Internal/Layouters/Type.hs

@@ -174,17 +174,17 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
         , docForceSingleline $ return $ typeDoc
         ]
       -- :: forall x
-      -- .  x
+      --  . x
       , docPar
           (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList)
           ( docCols ColTyOpPrefix
-            [ docWrapNodeRest ltype $ docLit $ Text.pack ". "
+            [ docWrapNodeRest ltype $ docLit $ Text.pack " . "
             , maybeForceML $ return typeDoc
             ]
           )
       -- :: forall
       --      (x :: *)
-      -- .  x
+      --  . x
       , docPar
           (docLit (Text.pack "forall"))
           (docLines
@@ -204,7 +204,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
                   ]
             )
           ++[ docCols ColTyOpPrefix
-              [ docWrapNodeRest ltype $ docLit $ Text.pack ". "
+              [ docWrapNodeRest ltype $ docLit $ Text.pack " . "
               , maybeForceML $ return typeDoc
               ]
             ]
@@ -499,7 +499,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
           )
           (docCols ColTyOpPrefix
             [ docWrapNodeRest ltype
-            $ docLit $ Text.pack "::"
+            $ docLit $ Text.pack ":: "
             , docAddBaseY (BrIndentSpecial 2) typeDoc1
             ])
       ]