Consolidate record expression layouter

Both record construction and record layouting have very similar constructions. These each had their own layouter with slightly different variations. Variations here lead to subtley different bugs in layout for nearly identicle syntactic forms. The record update logic is more advanced and respects `IndentPolicyLeft`. Instead of keeping these layouters distinct we can consolidate construction logic into the update logic. This results in a smaller volume of code and more uniform layouting of syntax for these simlilar forms. Record constructors with fields and wildcards are not included in this consolidation. A TODO has been left to handle this consolidation later.
2018-09-16 15:47:04 -04:00 · 2018-09-16 15:47:04 -04:00 · 92a1d89983
parent 932cf70f9b
commit 92a1d89983
5 changed files with 152 additions and 171 deletions
--- a/src-literatetests/15-regressions.blt
+++ b/src-literatetests/15-regressions.blt
@ -53,10 +53,9 @@ func = Foo

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

 #test post-indent comment
 func = do
--- a/src-literatetests/30-tests-context-free.blt
+++ b/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"
+    ]
+  }
+

 ###############################################################################
 ###############################################################################
--- a/src/Language/Haskell/Brittany/Internal/Backend.hs
+++ b/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
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
+++ b/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
-      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.
+    RecordCon lname _ _ (HsRecFields fields Nothing) -> do
      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
-          then return Nothing
-          else Just <$> docSharedWrapper layoutExpr fExpr
-        return (fieldl, lrdrNameToText lnameF, fExpDoc)
-      let line1 wrapper =
-            [ 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]
-            )
-        ]
+      rFs <- fields
+        `forM` \lfield@(L _ (HsRecField (L _ (FieldOcc lnameF _)) rFExpr pun)) -> do
+          rFExpDoc <- if pun
+            then return Nothing
+            else Just <$> docSharedWrapper layoutExpr rFExpr
+          return $ (lfield, lrdrNameToText lnameF, rFExpDoc)
+      recordExpression indentPolicy lexpr nameDoc rFs
+
    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 ColRecUpdate <$> lineR (docAddBaseY BrIndentRegular))
+            $  [docCols ColRec $ line1 (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 "{}"]
-    RecordUpd rExpr fields@(_:_) _ _ _ _ -> do
-      rExprDoc <- docSharedWrapper layoutExpr rExpr
-      rFs@((rF1f, rF1n, rF1e):rFr) <- fields
+      rFs <- 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
-        -- 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]
-              )
+      recordExpression indentPolicy lexpr rExprDoc rFs
 #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
--- a/src/Language/Haskell/Brittany/Internal/Types.hs
+++ b/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