From ccf2eb092f0f9755d64b180807fd69852504f8af Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Sun, 1 Oct 2017 17:16:27 +0200
Subject: [PATCH] Support RecordWildCards, Add one-liner layouting for records

fixes #52
---
 src-literatetests/tests.blt                   |  15 +++
 .../Brittany/Internal/Layouters/Expr.hs       | 125 +++++++++++++-----
 .../Brittany/Internal/Layouters/Pattern.hs    |  20 +++
 3 files changed, 128 insertions(+), 32 deletions(-)

diff --git a/src-literatetests/tests.blt b/src-literatetests/tests.blt
index e54841b..f4db082 100644
--- a/src-literatetests/tests.blt
+++ b/src-literatetests/tests.blt
@@ -1042,6 +1042,21 @@ foo =
       cccc = ()
   in  foo
 
+#test issue 52 a
+
+{-# LANGUAGE RecordWildCards #-}
+v = A {a = 1, ..} where b = 2
+
+#test issue 52 b
+
+{-# LANGUAGE RecordWildCards #-}
+v = A {..} where b = 2
+
+#test issue 52 c
+
+{-# LANGUAGE RecordWildCards #-}
+v = A {a = 1, b = 2, c = 3}
+
 
 ###############################################################################
 ###############################################################################
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
index a6ba345..2808df2 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
@@ -672,42 +672,103 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
         then return Nothing
         else Just <$> docSharedWrapper layoutExpr fExpr
       return $ (fieldl, lrdrNameToText lnameF, fExpDoc)
+    let line1 appender wrapper =
+          [ appender $ 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
-      [ docSetParSpacing
+      [  docSeq
+      $  [docNodeAnnKW lexpr Nothing $ nameDoc, docSeparator]
+      ++ line1 id docForceSingleline
+      ++ join (lineR docForceSingleline)
+      ++ lineN
+      , docSetParSpacing
       $ docAddBaseY BrIndentRegular
       $ docPar
           (docNodeAnnKW lexpr Nothing $ nameDoc)
-          (docNonBottomSpacing $ docLines $ let
-            line1 = docCols ColRecUpdate
-              [ appSep $ docLit $ Text.pack "{"
-              , docWrapNodePrior fd1l $ appSep $ docLit $ fd1n
-              , case fd1e of
-                  Just x -> docSeq
-                    [ appSep $ docLit $ Text.pack "="
-                    , docWrapNodeRest fd1l $ docAddBaseY BrIndentRegular $ x
-                    ]
-                  Nothing -> docEmpty
-              ]
-            lineR = fdr <&> \(lfield, fText, fDoc) -> docCols ColRecUpdate
-              [ appSep $ docLit $ Text.pack ","
-              , appSep $ docLit $ fText
-              , case fDoc of
-                  Just x -> docWrapNode lfield $ docSeq
-                    [ appSep $ docLit $ Text.pack "="
-                    , docAddBaseY BrIndentRegular x
-                    ]
-                  Nothing -> docEmpty
-              ]
-            lineN = docSeq
-              [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty
-              , docLit $ Text.pack "}"
-              ]
-            in [line1] ++ lineR ++ [lineN])
-      -- TODO oneliner (?)
+          ( docNonBottomSpacing
+          $ docLines
+          $  [docCols ColRecUpdate $ line1 appSep (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
+    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 appender wrapper =
+          [ appender $ 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 lineDot =
+          [ docCommaSep
+          , docLit $ Text.pack ".."
+          ]
+    let lineN =
+          [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty
+          , docLit $ Text.pack "}"
+          ]
+    docAlt
+      [  docSeq
+      $  [docNodeAnnKW lexpr Nothing $ nameDoc, docSeparator]
+      ++ line1 id docForceSingleline
+      ++ join (lineR docForceSingleline)
+      ++ lineDot
+      ++ lineN
+      , docSetParSpacing
+      $ docAddBaseY BrIndentRegular
+      $ docPar
+          (docNodeAnnKW lexpr Nothing $ nameDoc)
+          ( docNonBottomSpacing
+          $ docLines
+          $  [docCols ColRecUpdate $ line1 appSep (docAddBaseY BrIndentRegular)]
+          ++ (docCols ColRecUpdate <$> lineR (docAddBaseY BrIndentRegular))
+          ++ [docSeq lineDot, docSeq lineN]
+          )
+      ]
   RecordCon{} ->
     unknownNodeError "RecordCon with puns" lexpr
   RecordUpd rExpr [] _ _ _ _ -> do
@@ -755,7 +816,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
                   Nothing -> docEmpty
               ]
             lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate
-              [ appSep $ docLit $ Text.pack ","
+              [ docCommaSep
               , appSep $ docLit $ fText
               , case fDoc of
                   Just x ->  docSeq [ appSep $ docLit $ Text.pack "="
@@ -785,7 +846,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
                   Nothing -> docEmpty
               ]
             lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate
-              [ appSep $ docLit $ Text.pack ","
+              [ docCommaSep
               , appSep $ docLit $ fText
               , case fDoc of
                   Just x ->  docSeq [ appSep $ docLit $ Text.pack "="
@@ -829,7 +890,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
         docSeq
           [ docLit $ Text.pack "["
           , docForceSingleline e1Doc
-          , appSep $ docLit $ Text.pack ","
+          , docCommaSep
           , appSep $ docForceSingleline e2Doc
           , docLit $ Text.pack "..]"
           ]
@@ -850,7 +911,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
         docSeq
           [ docLit $ Text.pack "["
           , docForceSingleline e1Doc
-          , appSep $ docLit $ Text.pack ","
+          , docCommaSep
           , appSep $ docForceSingleline e2Doc
           , appSep $ docLit $ Text.pack ".."
           , docForceSingleline eNDoc
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
index b36fcaa..3f66932 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
@@ -96,6 +96,26 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
       [ appSep $ docLit t
       , docLit $ Text.pack "{..}"
       ]
+  ConPatIn lname (RecCon (HsRecFields fs@(_:_) (Just dotdoti))) | dotdoti == length fs -> do
+    let t = lrdrNameToText lname
+    fds <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fPat pun)) -> do
+      fExpDoc <- if pun
+        then return Nothing
+        else Just <$> docSharedWrapper layoutPat fPat
+      return $ (lrdrNameToText lnameF, fExpDoc)
+    fmap Seq.singleton $ docSeq
+      [ appSep $ docLit t
+      , appSep $ docLit $ Text.pack "{"
+      , docSeq $ fds >>= \case
+          (fieldName, Just fieldDoc) ->
+            [ appSep $ docLit $ fieldName
+            , appSep $ docLit $ Text.pack "="
+            , fieldDoc >>= colsWrapPat
+            , docCommaSep
+            ]
+          (fieldName, Nothing) -> [docLit fieldName, docCommaSep]
+      , docLit $ Text.pack "..}"
+      ]
   TuplePat args boxity _ -> do
     case boxity of
       Boxed   -> wrapPatListy args "(" ")"