Merge pull request #184 from eborden/consolidate-record-expression-layouter

Consolidate record expression layouter

src-literatetests/15-regressions.blt

@@ -53,8 +53,7 @@ func = Foo
 
 #test record construction 3
 func = do
-  Foo
+  Foo { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
-    { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
       , _lstate_foo    = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
       }
 

src-literatetests/30-tests-context-free.blt

@@ -1378,6 +1378,22 @@ foo =
     cccc = ()
   in foo
 
+#test issue 176
+
+record :: Record
+record = Record
+  { rProperties =
+    [ "foo" .= "bar"
+    , "foo" .= "bar"
+    , "foo" .= "bar"
+    , "foo" .= "bar"
+    , "foo" .= "bar"
+    , "foo" .= "bar"
+    , "foo" .= "bar"
+    , "foo" .= "bar"
+    ]
+  }
+
 
 ###############################################################################
 ###############################################################################

src/Language/Haskell/Brittany/Internal/Backend.hs

@@ -527,7 +527,7 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
           (BDCols ColGuardedBody        _) -> True
           (BDCols ColBindStmt           _) -> True
           (BDCols ColDoLet              _) -> True
-          (BDCols ColRecUpdate          _) -> False
+          (BDCols ColRec                _) -> False
           (BDCols ColListComp           _) -> False
           (BDCols ColList               _) -> False
           (BDCols ColApp{}              _) -> True

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

@@ -15,7 +15,7 @@ import           Language.Haskell.Brittany.Internal.Types
 import           Language.Haskell.Brittany.Internal.LayouterBasics
 import           Language.Haskell.Brittany.Internal.Config.Types
 
-import           GHC ( runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..), RdrName(..) )
+import           GHC ( runGhc, GenLocated(L), SrcSpan, moduleNameString, AnnKeywordId(..), RdrName(..) )
 import           HsSyn
 import           Name
 import qualified FastString
@@ -750,67 +750,21 @@ layoutExpr lexpr@(L _ expr) = do
     ExplicitPArr{} -> do
       -- TODO
       briDocByExactInlineOnly "ExplicitPArr{}" lexpr
-    RecordCon lname _ _ (HsRecFields [] Nothing) -> do
+    RecordCon lname _ _ (HsRecFields fields Nothing) -> do
-      let t = lrdrNameToText lname
-      docWrapNode lname $ docSeq
-        [ docNodeAnnKW lexpr (Just AnnOpenC) $ docLit $ t <> Text.pack "{"
-        , docLit $ Text.pack "}"
-        ]
-    RecordCon lname _ _ (HsRecFields fs@(_:_) Nothing) -> do
-      -- TODO: the layouter for RecordUpd is slightly more clever. Should
-      -- probably copy the approach from there.
       let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname
-      ((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do
+      rFs <- fields
-        fExpDoc <- if pun
+        `forM` \lfield@(L _ (HsRecField (L _ (FieldOcc lnameF _)) rFExpr pun)) -> do
+          rFExpDoc <- if pun
             then return Nothing
-          else Just <$> docSharedWrapper layoutExpr fExpr
+            else Just <$> docSharedWrapper layoutExpr rFExpr
-        return (fieldl, lrdrNameToText lnameF, fExpDoc)
+          return $ (lfield, lrdrNameToText lnameF, rFExpDoc)
-      let line1 wrapper =
+      recordExpression indentPolicy lexpr nameDoc rFs
-            [ appSep $ docLit $ Text.pack "{"
+
-            , docWrapNodePrior fd1l $ appSep $ docLit fd1n
-            , case fd1e of
-                Just x -> docSeq
-                  [ appSep $ docLit $ Text.pack "="
-                  , docWrapNodeRest fd1l $ wrapper x
-                  ]
-                Nothing -> docEmpty
-            ]
-      let lineR wrapper = fdr <&> \(lfield, fText, fDoc) ->
-            [ docCommaSep
-            , appSep $ docLit fText
-            , case fDoc of
-                Just x -> docWrapNode lfield $ docSeq
-                  [ appSep $ docLit $ Text.pack "="
-                  , wrapper x
-                  ]
-                Nothing -> docEmpty
-            ]
-      let lineN =
-            [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty
-            , docLit $ Text.pack "}"
-            ]
-      docAlt -- TODO: make this addFilteredAlternative and a hanging layout when Free
-        [  docSeq
-        $  [docNodeAnnKW lexpr Nothing nameDoc, docSeparator]
-        ++ line1 docForceSingleline
-        ++ join (lineR docForceSingleline)
-        ++ [docSeparator]
-        ++ lineN
-        , docSetParSpacing
-        $ docAddBaseY BrIndentRegular
-        $ docPar
-            (docNodeAnnKW lexpr Nothing nameDoc)
-            ( docNonBottomSpacing
-            $ docLines
-            $  [docCols ColRecUpdate $ line1 (docAddBaseY BrIndentRegular)]
-            ++ (docCols ColRecUpdate <$> lineR (docAddBaseY BrIndentRegular))
-            ++ [docSeq lineN]
-            )
-        ]
     RecordCon lname _ _ (HsRecFields [] (Just 0)) -> do
       let t = lrdrNameToText lname
       docWrapNode lname $ docLit $ t <> Text.pack " { .. }"
     RecordCon lname _ _ (HsRecFields fs@(_:_) (Just dotdoti)) | dotdoti == length fs -> do
+      -- TODO this should be consolidated into `recordExpression`
       let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname
       ((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do
         fExpDoc <- if pun
@@ -859,19 +813,16 @@ layoutExpr lexpr@(L _ expr) = do
             (docNodeAnnKW lexpr Nothing nameDoc)
             ( docNonBottomSpacing
             $ docLines
-            $  [docCols ColRecUpdate $ line1 (docAddBaseY BrIndentRegular)]
+            $  [docCols ColRec $ line1 (docAddBaseY BrIndentRegular)]
-            ++ (docCols ColRecUpdate <$> lineR (docAddBaseY BrIndentRegular))
+            ++ (docCols ColRec <$> lineR (docAddBaseY BrIndentRegular))
             ++ [docSeq lineDot, docSeq lineN]
             )
         ]
     RecordCon{} ->
       unknownNodeError "RecordCon with puns" lexpr
-    RecordUpd rExpr [] _ _ _ _ -> do
+    RecordUpd rExpr fields _ _ _ _ -> do
       rExprDoc <- docSharedWrapper layoutExpr rExpr
-      docSeq [rExprDoc, docLit $ Text.pack "{}"]
+      rFs <- fields
-    RecordUpd rExpr fields@(_:_) _ _ _ _ -> do
-      rExprDoc <- docSharedWrapper layoutExpr rExpr
-      rFs@((rF1f, rF1n, rF1e):rFr) <- fields
         `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do
           rFExpDoc <- if pun
             then return Nothing
@@ -879,106 +830,7 @@ layoutExpr lexpr@(L _ expr) = do
           return $ case ambName of
             Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc)
             Ambiguous   n _ -> (lfield, lrdrNameToText n, rFExpDoc)
-      runFilteredAlternative $ do
+      recordExpression indentPolicy lexpr rExprDoc rFs
-        -- container { fieldA = blub, fieldB = blub }
-        addAlternative
-          $ docSeq
-          [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline rExprDoc
-          , appSep $ docLit $ Text.pack "{"
-          , appSep $ docSeq $ List.intersperse docCommaSep
-                  $ rFs <&> \case
-                    (lfield, fieldStr, Just fieldDoc) ->
-                      docWrapNode lfield $ docSeq
-                            [ appSep $ docLit fieldStr
-                            , appSep $ docLit $ Text.pack "="
-                            , docForceSingleline fieldDoc
-                            ]
-                    (lfield, fieldStr, Nothing) ->
-                      docWrapNode lfield $ docLit fieldStr
-          , docLit $ Text.pack "}"
-          ]
-        -- hanging single-line fields
-        -- container { fieldA = blub
-        --           , fieldB = blub
-        --           }
-        addAlternativeCond (indentPolicy == IndentPolicyFree)
-          $ docSeq
-          [ docNodeAnnKW lexpr Nothing $ appSep rExprDoc
-          , docSetBaseY $ docLines $ let
-              line1 = docCols ColRecUpdate
-                [ appSep $ docLit $ Text.pack "{"
-                , docWrapNodePrior rF1f $ appSep $ docLit rF1n
-                , case rF1e of
-                    Just x -> docWrapNodeRest rF1f $ docSeq
-                                    [ appSep $ docLit $ Text.pack "="
-                                    , docForceSingleline x
-                                    ]
-                    Nothing -> docEmpty
-                ]
-              lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate
-                [ docCommaSep
-                , appSep $ docLit fText
-                , case fDoc of
-                    Just x ->  docSeq [ appSep $ docLit $ Text.pack "="
-                                      , docForceSingleline x
-                                      ]
-                    Nothing -> docEmpty
-                ]
-              lineN = docSeq
-                [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty
-                , docLit $ Text.pack "}"
-                ]
-              in [line1] ++ lineR ++ [lineN]
-          ]
-        -- non-hanging with expressions placed to the right of the names
-        -- container
-        -- { fieldA = blub
-        -- , fieldB = potentially
-        --     multiline
-        -- }
-        addAlternative
-          $ docSetParSpacing
-          $ docAddBaseY BrIndentRegular
-          $ docPar
-              (docNodeAnnKW lexpr Nothing rExprDoc)
-              (docNonBottomSpacing $ docLines $ let
-                expressionWrapper = case indentPolicy of
-                  IndentPolicyLeft -> docForceParSpacing
-                  IndentPolicyMultiple -> docForceParSpacing
-                  IndentPolicyFree -> docSetBaseY
-                line1 = docCols ColRecUpdate
-                  [ appSep $ docLit $ Text.pack "{"
-                  , docWrapNodePrior rF1f $ appSep $ docLit rF1n
-                  , docWrapNodeRest rF1f $ case rF1e of
-                      Just x -> docAlt
-                        [ docSeq [ appSep $ docLit $ Text.pack "="
-                                 , expressionWrapper x
-                                 ]
-                        , docAddBaseY BrIndentRegular
-                        $ docPar (docLit $ Text.pack "=") x
-                        ]
-                      Nothing -> docEmpty
-                  ]
-                lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield
-                  $ docCols ColRecUpdate
-                  [ docCommaSep
-                  , appSep $ docLit fText
-                  , case fDoc of
-                      Just x -> docAlt
-                        [ docSeq [ appSep $ docLit $ Text.pack "="
-                                 , expressionWrapper x
-                                 ]
-                        , docAddBaseY BrIndentRegular
-                        $ docPar (docLit $ Text.pack "=") x
-                        ]
-                      Nothing -> docEmpty
-                  ]
-                lineN = docSeq
-                  [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty
-                  , docLit $ Text.pack "}"
-                  ]
-                in [line1] ++ lineR ++ [lineN]
-              )
 #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
     ExprWithTySig exp1 (HsWC _ (HsIB _ typ1 _)) -> do
 #else /* ghc-8.0 */
@@ -1105,6 +957,120 @@ layoutExpr lexpr@(L _ expr) = do
       briDocByExactInlineOnly "ExplicitSum{}" lexpr
 #endif
 
+recordExpression
+  :: (Data.Data.Data lExpr, Data.Data.Data name)
+  => IndentPolicy
+  -> GenLocated SrcSpan lExpr
+  -> ToBriDocM BriDocNumbered
+  -> [(GenLocated SrcSpan name, Text, Maybe (ToBriDocM BriDocNumbered))]
+  -> ToBriDocM BriDocNumbered
+recordExpression _ lexpr nameDoc [] =
+  docSeq
+    [ docNodeAnnKW lexpr (Just AnnOpenC) $ docSeq [nameDoc, docLit $ Text.pack "{"]
+    , docLit $ Text.pack "}"
+    ]
+recordExpression indentPolicy lexpr nameDoc rFs@((rF1f, rF1n, rF1e):rFr) =
+  runFilteredAlternative $ do
+    -- container { fieldA = blub, fieldB = blub }
+    addAlternative
+      $ docSeq
+      [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline nameDoc
+      , appSep $ docLit $ Text.pack "{"
+      , appSep $ docSeq $ List.intersperse docCommaSep
+              $ rFs <&> \case
+                (lfield, fieldStr, Just fieldDoc) ->
+                  docWrapNode lfield $ docSeq
+                        [ appSep $ docLit fieldStr
+                        , appSep $ docLit $ Text.pack "="
+                        , docForceSingleline fieldDoc
+                        ]
+                (lfield, fieldStr, Nothing) ->
+                  docWrapNode lfield $ docLit fieldStr
+      , docLit $ Text.pack "}"
+      ]
+    -- hanging single-line fields
+    -- container { fieldA = blub
+    --           , fieldB = blub
+    --           }
+    addAlternativeCond (indentPolicy == IndentPolicyFree)
+      $ docSeq
+      [ docNodeAnnKW lexpr Nothing $ appSep nameDoc
+      , docSetBaseY $ docLines $ let
+          line1 = docCols ColRec
+            [ appSep $ docLit $ Text.pack "{"
+            , docWrapNodePrior rF1f $ appSep $ docLit rF1n
+            , case rF1e of
+                Just x -> docWrapNodeRest rF1f $ docSeq
+                                [ appSep $ docLit $ Text.pack "="
+                                , docForceSingleline x
+                                ]
+                Nothing -> docEmpty
+            ]
+          lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRec
+            [ docCommaSep
+            , appSep $ docLit fText
+            , case fDoc of
+                Just x ->  docSeq [ appSep $ docLit $ Text.pack "="
+                                  , docForceSingleline x
+                                  ]
+                Nothing -> docEmpty
+            ]
+          lineN = docSeq
+            [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty
+            , docLit $ Text.pack "}"
+            ]
+          in [line1] ++ lineR ++ [lineN]
+      ]
+    -- non-hanging with expressions placed to the right of the names
+    -- container
+    -- { fieldA = blub
+    -- , fieldB = potentially
+    --     multiline
+    -- }
+    addAlternative
+      $ docSetParSpacing
+      $ docAddBaseY BrIndentRegular
+      $ docPar
+          (docNodeAnnKW lexpr Nothing nameDoc)
+          (docNonBottomSpacing $ docLines $ let
+            expressionWrapper = case indentPolicy of
+              IndentPolicyLeft -> docForceParSpacing
+              IndentPolicyMultiple -> docForceParSpacing
+              IndentPolicyFree -> docSetBaseY
+            line1 = docCols ColRec
+              [ appSep $ docLit $ Text.pack "{"
+              , docWrapNodePrior rF1f $ appSep $ docLit rF1n
+              , docWrapNodeRest rF1f $ case rF1e of
+                  Just x -> docAlt
+                    [ docSeq [ appSep $ docLit $ Text.pack "="
+                             , expressionWrapper x
+                             ]
+                    , docAddBaseY BrIndentRegular
+                    $ docPar (docLit $ Text.pack "=") x
+                    ]
+                  Nothing -> docEmpty
+              ]
+            lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield
+              $ docCols ColRec
+              [ docCommaSep
+              , appSep $ docLit fText
+              , case fDoc of
+                  Just x -> docAlt
+                    [ docSeq [ appSep $ docLit $ Text.pack "="
+                             , expressionWrapper x
+                             ]
+                    , docAddBaseY BrIndentRegular
+                    $ docPar (docLit $ Text.pack "=") x
+                    ]
+                  Nothing -> docEmpty
+              ]
+            lineN = docSeq
+              [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty
+              , docLit $ Text.pack "}"
+              ]
+            in [line1] ++ lineR ++ [lineN]
+          )
+
 
 #if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */
 litBriDoc :: HsLit GhcPs -> BriDocFInt

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

@@ -184,7 +184,7 @@ data ColSig
     -- expected to have exactly two columns
   | ColBindStmt
   | ColDoLet -- the non-indented variant
-  | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect?
+  | ColRec
   | ColListComp
   | ColList
   | ColApp Text