Work-in-progress add record declaration layout

Simple records are supports. The tests cover:

- single records
- multi-field types
- columnized alignment
- basic deriving
- deriving strategies
- existential quanitification

A few items block merger

- retaining comments

A few items can be deferred:

- normal types
- sum types

src-literatetests/10-tests.blt

@@ -310,6 +310,76 @@ func = f
   f = id
 
 
+###############################################################################
+###############################################################################
+###############################################################################
+#group data type declarations
+###############################################################################
+###############################################################################
+###############################################################################
+
+#test single record
+data Foo = Bar { foo :: Baz }
+
+#test record multiple names
+data Foo = Bar { foo, bar :: Baz }
+
+#test record multiple types
+data Foo = Bar
+  { foo  :: Baz
+  , bars :: Bizzz
+  }
+
+#test record multiple types and names
+data Foo = Bar
+  { foo, biz :: Baz
+  , bar      :: Bizzz
+  }
+
+#test record multiple types deriving
+data Foo = Bar
+  { fooz :: Baz
+  , bar  :: Bizzz
+  }
+  deriving Show
+
+#test record multiple types deriving
+data Foo = Bar
+  { foo  :: Baz
+  , bars :: Bizzz
+  }
+  deriving (Show, Eq, Monad, Functor, Traversable, Foldable)
+
+#test record multiple deriving strategies
+data Foo = Bar
+  { foo  :: Baz
+  , bars :: Bizzz
+  }
+  deriving Show
+  deriving (Eq, Ord)
+  deriving stock Show
+  deriving stock (Eq, Ord)
+  deriving anyclass Show
+  deriving anyclass (Show, Eq, Monad, Functor)
+  deriving newtype Show
+  deriving newtype (Traversable, Foldable)
+  deriving ToJSON via (SomeType)
+  deriving (ToJSON, FromJSON) via (SomeType)
+
+#test single record existential
+{-# LANGUAGE ExistentialQuantification #-}
+
+data Foo = forall a . Show a => Bar { foo :: a }
+
+#test record multiple types existential
+{-# LANGUAGE ExistentialQuantification #-}
+
+data Foo = forall a b . (Show a, Eq b) => Bar
+  { foo  :: a
+  , bars :: b
+  }
+
+
 ###############################################################################
 ###############################################################################
 ###############################################################################

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

@@ -312,6 +312,47 @@ func = f
   f = id
 
 
+###############################################################################
+###############################################################################
+###############################################################################
+#group data type declarations
+###############################################################################
+###############################################################################
+###############################################################################
+
+#test single record
+data Foo = Bar { foo :: Baz }
+
+#test record multiple names
+data Foo = Bar { foo, bar :: Baz }
+
+#test record multiple types
+data Foo = Bar
+  { foo :: Baz
+  , bar :: Bizzz
+  }
+
+#test record multiple types and names
+data Foo = Bar
+  { foo, biz :: Baz
+  , bar :: Bizzz
+  }
+
+#test record multiple types deriving
+data Foo = Bar
+  { foo :: Baz
+  , bar :: Bizzz
+  }
+  deriving Show
+
+#test record multiple types deriving
+data Foo = Bar
+  { foo :: Baz
+  , bar :: Bizzz
+  }
+  deriving (Show, Eq, Monad, Functor, Traversable, Foldable)
+
+
 ###############################################################################
 ###############################################################################
 ###############################################################################

src/Language/Haskell/Brittany/Internal.hs

@@ -40,7 +40,6 @@ import           Language.Haskell.Brittany.Internal.LayouterBasics
 import           Language.Haskell.Brittany.Internal.Layouters.Type
 import           Language.Haskell.Brittany.Internal.Layouters.Decl
 import           Language.Haskell.Brittany.Internal.Layouters.Module
-import           Language.Haskell.Brittany.Internal.Layouters.DataDecl
 import           Language.Haskell.Brittany.Internal.Utils
 import           Language.Haskell.Brittany.Internal.Backend
 import           Language.Haskell.Brittany.Internal.BackendUtils

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

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

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

@@ -16,7 +16,7 @@ import           Language.Haskell.Brittany.Internal.LayouterBasics
 import           Language.Haskell.Brittany.Internal.Config.Types
 
 import           RdrName ( RdrName(..) )
-import           GHC ( Located, runGhc, GenLocated(L), moduleNameString )
+import           GHC ( Located, runGhc, GenLocated(L), moduleNameString, DerivStrategy(..) )
 import qualified GHC
 import           HsSyn
 import           Name
@@ -33,16 +33,16 @@ import           Bag ( mapBagM )
 
 
 layoutDataDecl
-  :: Located (HsDecl RdrName)
+  :: Located (TyClDecl GhcPs)
   -> Located RdrName
-  -> LHsQTyVars RdrName
-  -> HsDataDefn RdrName
+  -> LHsQTyVars GhcPs
+  -> HsDataDefn GhcPs
   -> ToBriDocM BriDocNumbered
-layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of
-
-  HsDataDefn NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of
-    (L _ (ConDeclH98 consName Nothing (Just (L _ [])) details _)) ->
-      docWrapNode ld $ do
+layoutDataDecl _ _ (XLHsQTyVars ext) _ = absurdExt ext
+layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
+  HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of
+    (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) ->
+      docWrapNode ltycl $ do
         nameStr     <- lrdrNameToTextAnn name
         consNameStr <- lrdrNameToTextAnn consName
         tyVarLine   <- fmap return $ createBndrDoc bndrs
@@ -61,10 +61,10 @@ layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of
           , docSeparator
           , rhsDoc
           ]
-    _ -> briDocByExact ld
+    _ -> briDocByExact ltycl
 
-  HsDataDefn DataType (L _ lhsContext) _ctype Nothing [] mDerivs ->
-    docWrapNode ld $ do
+  HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs ->
+    docWrapNode ltycl $ do
       lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
       nameStr       <- lrdrNameToTextAnn name
       tyVarLine     <- fmap return $ createBndrDoc bndrs
@@ -75,15 +75,15 @@ layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of
         , appSep tyVarLine
         ]
 
-  HsDataDefn DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs ->
+  HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs ->
     case cons of
-      (L _ (ConDeclH98 consName mForall mRhsContext details _)) ->
-        docWrapNode ld $ do
+      (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) ->
+        docWrapNode ltycl $ do
           lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
           nameStr       <- lrdrNameToTextAnn name
           consNameStr   <- lrdrNameToTextAnn consName
           tyVarLine     <- fmap return $ createBndrDoc bndrs
-          forallDoc     <- docSharedWrapper createForallDoc mForall
+          forallDoc     <- docSharedWrapper createForallDoc qvars
           rhsContextDoc <- case mRhsContext of
             Nothing         -> return docEmpty
             Just (L _ ctxt) -> docSharedWrapper createContextDoc ctxt
@@ -100,11 +100,11 @@ layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of
             , rhsContextDoc
             , rhsDoc
             ]
-      _ -> briDocByExact ld
+      _ -> briDocByExact ltycl
 
-  _ -> briDocByExactNoComment ld
- where
-  createContextDoc :: HsContext RdrName -> ToBriDocM BriDocNumbered
+  _ -> briDocByExactNoComment ltycl
+
+createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered
 createContextDoc [] = docEmpty
 createContextDoc [t] =
   docSeq [layoutType t, docSeparator, docLit (Text.pack "=>"), docSeparator]
@@ -114,13 +114,15 @@ layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of
   , docLit (Text.pack ") =>")
   , docSeparator
   ]
-  createBndrDoc :: [LHsTyVarBndr RdrName] -> ToBriDocM BriDocNumbered
+
+createBndrDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered
 createBndrDoc bs = do
   tyVarDocs <- bs `forM` \case
-      (L _ (UserTyVar vname)) -> return $ (lrdrNameToText vname, Nothing)
-      (L _ (KindedTyVar lrdrName kind)) -> do
+    (L _ (UserTyVar _ext vname)) -> return $ (lrdrNameToText vname, Nothing)
+    (L _ (KindedTyVar _ext lrdrName kind)) -> do
       d <- docSharedWrapper layoutType kind
       return $ (lrdrNameToText lrdrName, Just $ d)
+    (L _ (XTyVarBndr ext)) -> absurdExt ext
   docSeq
     $   List.intersperse docSeparator
     $   tyVarDocs
@@ -135,52 +137,90 @@ layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of
             , kind
             , docLit (Text.pack ")")
             ]
+
 createDerivingPar
-    :: HsDeriving RdrName
-    -> ToBriDocM BriDocNumbered
-    -> ToBriDocM BriDocNumbered
-  createDerivingPar mDerivs mainDoc = do
-    case mDerivs of
-      Nothing                 -> docLines [mainDoc]
-      Just (L _ [(HsIB _ t)]) -> do
-        docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq
-          [docLit $ Text.pack "deriving", docSeparator, layoutType t]
-      Just (L _ ts          ) -> do
-        docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq
-          [ docLit $ Text.pack "deriving"
+  :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
+createDerivingPar derivs mainDoc = do
+  case derivs of
+    (L _ []) -> docLines [mainDoc]
+    (L _ types) ->
+      docPar mainDoc
+        $   docEnsureIndent BrIndentRegular
+        $   docLines
+        $   derivingClauseDoc
+        <$> types
+
+derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered
+derivingClauseDoc (L _ (XHsDerivingClause ext)) = absurdExt ext
+derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of
+  (L _ []) -> docSeq []
+  (L _ ts) ->
+    let
+      tsLength = length ts
+      whenMoreThan1Type val =
+        if tsLength > 1 then docLit (Text.pack val) else docLit (Text.pack "")
+      (lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy
+    in
+      docSeq
+        [ docDeriving
+        , lhsStrategy
         , docSeparator
-          , docLit $ Text.pack "("
+        , whenMoreThan1Type "("
         , docSeq $ List.intersperse docCommaSep $ ts <&> \(HsIB _ t) ->
           layoutType t
-          , docLit $ Text.pack ")"
+        , whenMoreThan1Type ")"
+        , rhsStrategy
         ]
+ where
+  strategyLeftRight = \case
+    (L _ StockStrategy          ) -> (docLit $ Text.pack " stock", docEmpty)
+    (L _ AnyclassStrategy       ) -> (docLit $ Text.pack " anyclass", docEmpty)
+    (L _ NewtypeStrategy        ) -> (docLit $ Text.pack " newtype", docEmpty)
+    (L _ (ViaStrategy viaTypes) ) ->
+      ( docEmpty
+      , case viaTypes of
+          HsIB _ext t -> docSeq
+            [ docLit $ Text.pack " via "
+            , layoutType t
+            ]
+          XHsImplicitBndrs ext -> absurdExt ext
+      )
+
+docDeriving :: ToBriDocM BriDocNumbered
+docDeriving = docLit $ Text.pack "deriving"
+
 createDetailsDoc
-    :: Text -> HsConDeclDetails RdrName -> (ToBriDocM BriDocNumbered)
+  :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered)
 createDetailsDoc consNameStr details = case details of
   PrefixCon args -> docSeq
     [ docLit consNameStr
     , docSeparator
     , docSeq $ List.intersperse docSeparator $ args <&> layoutType
     ]
-    RecCon    (L _ fields) -> docSeq
-      [ appSep $ docLit $ Text.pack "{"
-      , docSeq
-        $   List.intersperse docSeparator
-        $   fields
-        <&> \(L _ (ConDeclField names t _)) -> do
-              docSeq
-                [ docSeq
-                  $   List.intersperse docCommaSep
-                  $   names
-                  <&> \(L _ (FieldOcc fieldName _)) ->
-                        docLit =<< lrdrNameToTextAnn fieldName
+  RecCon (L _ []) -> docEmpty
+  RecCon (L _ [L _ (ConDeclField _ext names t _)]) -> docSeq
+    [ docLit consNameStr
     , docSeparator
-                , docLit $ Text.pack "::"
+    , appSep $ docLit $ Text.pack "{"
+    , docSeq $ createNamesAndTypeDoc names t
     , docSeparator
-                , layoutType t
-                ]
     , docLit $ Text.pack "}"
     ]
+  RecCon (L _ (fstField:fields)) ->
+    docAddBaseY BrIndentRegular $ docPar
+      (docLit consNameStr)
+      (docLines
+        [ docCols ColRecDecl
+          $ docLit (Text.pack "{ ")
+          : let L _ (ConDeclField _ext names t _) = fstField
+              in createNamesAndTypeDoc names t
+        , docLines
+          $ (\(L _ (ConDeclField _ext names t _)) ->
+              docCols ColRecDecl $ docCommaSep : createNamesAndTypeDoc names t)
+          <$> fields
+        , docLit $ Text.pack "}"
+        ]
+      )
   InfixCon arg1 arg2 -> docSeq
     [ layoutType arg1
     , docSeparator
@@ -188,14 +228,30 @@ layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of
     , docSeparator
     , layoutType arg2
     ]
-  createForallDoc :: Maybe (LHsQTyVars RdrName) -> ToBriDocM BriDocNumbered
-  createForallDoc Nothing                   = docEmpty
-  createForallDoc (Just (HsQTvs _ bs _)) = do
-    tDoc <- fmap return $ createBndrDoc bs
-    docSeq
+
+createForallDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered
+createForallDoc []            = docEmpty
+createForallDoc lhsTyVarBndrs =  docSeq
   [ docLit (Text.pack "forall ")
-      , tDoc
+  , createBndrDoc lhsTyVarBndrs
   , docLit (Text.pack " .")
   , docSeparator
   ]
 
+createNamesAndTypeDoc
+  :: [GenLocated t (FieldOcc u)] -> Located (HsType GhcPs) -> [ToBriDocM BriDocNumbered]
+createNamesAndTypeDoc names t =
+  [ docSeq
+    [ docSeq
+      $   List.intersperse docCommaSep
+      $   names
+      <&> \(L _ (FieldOcc _ fieldName)) ->
+            docLit =<< lrdrNameToTextAnn fieldName
+    , docSeparator
+    ]
+  , docSeq
+    [ docLit $ Text.pack "::"
+    , docSeparator
+    , layoutType t
+    ]
+  ]

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

@@ -53,6 +53,7 @@ import           Language.Haskell.Brittany.Internal.Layouters.Type
 import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
 import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt
 import           Language.Haskell.Brittany.Internal.Layouters.Pattern
+import           Language.Haskell.Brittany.Internal.Layouters.DataDecl
 
 import           Bag ( mapBagM, bagToList, emptyBag )
 import           Data.Char (isUpper)
@@ -85,7 +86,6 @@ layoutDecl d@(L loc decl) = case decl of
   _                    -> briDocByExactNoComment d
 #endif
 
-
 --------------------------------------------------------------------------------
 -- Sig
 --------------------------------------------------------------------------------
@@ -741,6 +741,9 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of
     let wrapNodeRest = docWrapNodeRest ltycl
     docWrapNodePrior ltycl
       $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ
+  DataDecl _ext name tyVars _ dataDefn ->
+    docWrapNodePrior ltycl $
+      layoutDataDecl ltycl name tyVars dataDefn
   _ -> briDocByExactNoComment ltycl
 
 layoutSynDecl

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

@@ -185,6 +185,8 @@ data ColSig
   | ColBindStmt
   | ColDoLet -- the non-indented variant
   | ColRec
+  | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect?
+  | ColRecDecl
   | ColListComp
   | ColList
   | ColApp Text

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

@@ -25,6 +25,7 @@ module Language.Haskell.Brittany.Internal.Utils
   , splitFirstLast
   , lines'
   , showOutputable
+  , absurdExt
   )
 where
 
@@ -57,6 +58,7 @@ import           Language.Haskell.Brittany.Internal.Config.Types
 import           Language.Haskell.Brittany.Internal.Types
 
 import qualified Data.Generics.Uniplate.Direct as Uniplate
+import           HsExtension (NoExt)
 
 
 
@@ -293,3 +295,7 @@ lines' s = case break (== '\n') s of
   (s1, []) -> [s1]
   (s1, [_]) -> [s1, ""]
   (s1, (_:r)) -> s1 : lines' r
+
+-- | A method to dismiss NoExt patterns for total matches
+absurdExt :: NoExt -> a
+absurdExt = error "cannot construct NoExt"