Implement RecordField

hindent.cabal

@@ -58,6 +58,7 @@ library
       HIndent.Ast.Declaration.Data.Haskell98.Constructor.Body
       HIndent.Ast.Declaration.Data.Header
       HIndent.Ast.Declaration.Data.NewOrData
+      HIndent.Ast.Declaration.Data.Record.Field
       HIndent.Ast.Declaration.Default
       HIndent.Ast.Declaration.Family.Data
       HIndent.Ast.Declaration.Family.Type

src/HIndent/Ast/Declaration/Data/GADT/Constructor/Signature.hs

@@ -8,6 +8,7 @@ module HIndent.Ast.Declaration.Data.GADT.Constructor.Signature
   , prettyVertically
   ) where
 
+import HIndent.Ast.Declaration.Data.Record.Field
 import HIndent.Ast.NodeComments
 import HIndent.Ast.Type
 import HIndent.Ast.WithComments
@@ -23,7 +24,7 @@ data ConstructorSignature
       , result :: WithComments Type
       }
   | Record
-      { fields :: WithComments [GHC.LConDeclField GHC.GhcPs]
+      { fields :: WithComments [WithComments RecordField]
       , result :: WithComments Type
       }
 
@@ -59,14 +60,18 @@ mkConstructorSignature GHC.ConDeclGADT {con_g_args = GHC.PrefixConGADT xs, ..} =
 mkConstructorSignature GHC.ConDeclGADT {con_g_args = GHC.RecConGADT xs _, ..} =
   Just
     $ Record
-        { fields = fromGenLocated xs
+        { fields =
+            fromGenLocated
+              $ fmap (fmap (fmap mkRecordField . fromGenLocated)) xs
         , result = mkType <$> fromGenLocated con_res_ty
         }
 #else
 mkConstructorSignature GHC.ConDeclGADT {con_g_args = GHC.RecConGADT xs, ..} =
   Just
     $ Record
-        { fields = fromGenLocated xs
+        { fields =
+            fromGenLocated
+              $ fmap (fmap (fmap mkRecordField . fromGenLocated)) xs
         , result = mkType <$> fromGenLocated con_res_ty
         }
 #endif

src/HIndent/Ast/Declaration/Data/Haskell98/Constructor/Body.hs

@@ -6,7 +6,9 @@ module HIndent.Ast.Declaration.Data.Haskell98.Constructor.Body
   , isRecord
   ) where
 
+import HIndent.Ast.Declaration.Data.Record.Field
 import HIndent.Ast.NodeComments
+import HIndent.Ast.WithComments
 import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
 import {-# SOURCE #-} HIndent.Pretty
 import HIndent.Pretty.Combinators
@@ -25,7 +27,7 @@ data Haskell98ConstructorBody
       }
   | Record
       { name :: GHC.LIdP GHC.GhcPs
-      , record :: GHC.XRec GHC.GhcPs [GHC.LConDeclField GHC.GhcPs]
+      , records :: WithComments [WithComments RecordField]
       }
 
 instance CommentExtraction Haskell98ConstructorBody where
@@ -42,7 +44,7 @@ instance Pretty Haskell98ConstructorBody where
       ver = indentedBlock $ newlinePrefixed $ fmap pretty types
   pretty' Record {..} = do
     pretty name
-    printCommentsAnd record $ \r ->
+    prettyWith records $ \r ->
       newline >> indentedBlock (vFields $ fmap pretty r)
 
 mkHaskell98ConstructorBody ::
@@ -51,9 +53,15 @@ mkHaskell98ConstructorBody GHC.ConDeclH98 { con_args = GHC.InfixCon left right
                                           , ..
                                           } = Just Infix {name = con_name, ..}
 mkHaskell98ConstructorBody GHC.ConDeclH98 {con_args = GHC.PrefixCon _ types, ..} =
-  Just Prefix {name = con_name, ..}
-mkHaskell98ConstructorBody GHC.ConDeclH98 {con_args = GHC.RecCon record, ..} =
-  Just Record {name = con_name, ..}
+  Just Prefix {..}
+  where
+    name = con_name
+mkHaskell98ConstructorBody GHC.ConDeclH98 {con_args = GHC.RecCon rs, ..} =
+  Just Record {..}
+  where
+    name = con_name
+    records =
+      fromGenLocated $ fmap (fmap (fmap mkRecordField . fromGenLocated)) rs
 mkHaskell98ConstructorBody GHC.ConDeclGADT {} = Nothing
 
 isRecord :: Haskell98ConstructorBody -> Bool

src/HIndent/Ast/Declaration/Data/Record/Field.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module HIndent.Ast.Declaration.Data.Record.Field
+  ( RecordField
+  , mkRecordField
+  ) where
+
+import HIndent.Ast.NodeComments
+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
+import {-# SOURCE #-} HIndent.Pretty
+import HIndent.Pretty.Combinators
+import HIndent.Pretty.NodeComments
+
+data RecordField = RecordField
+  { names :: [GHC.LFieldOcc GHC.GhcPs]
+  , ty :: GHC.LBangType GHC.GhcPs
+  }
+
+instance CommentExtraction RecordField where
+  nodeComments RecordField {} = NodeComments [] [] []
+
+instance Pretty RecordField where
+  pretty' RecordField {..} =
+    spaced [hCommaSep $ fmap pretty names, string "::", pretty ty]
+
+mkRecordField :: GHC.ConDeclField GHC.GhcPs -> RecordField
+mkRecordField GHC.ConDeclField {..} = RecordField {..}
+  where
+    names = cd_fld_names
+    ty = cd_fld_type

src/HIndent/Pretty.hs

@@ -39,6 +39,7 @@
 import HIndent.Ast.Declaration
 import HIndent.Ast.Declaration.Bind
 import HIndent.Ast.Declaration.Data.Body
+import HIndent.Ast.Declaration.Data.Record.Field
 import HIndent.Ast.Declaration.Family.Type
 import HIndent.Ast.Declaration.Signature
 import HIndent.Ast.NodeComments
@@ -54,7 +55,7 @@
 import qualified Language.Haskell.GhclibParserEx.GHC.Hs.Expr as GHC
 import Text.Show.Unicode
 #if MIN_VERSION_ghc_lib_parser(9,6,1)
 import qualified Data.Foldable as NonEmpty
 import qualified GHC.Core.DataCon as GHC
 #endif
 #if !MIN_VERSION_ghc_lib_parser(9,6,1)
@@ -544,7 +545,7 @@
 prettyMatchExpr GHC.Match {m_ctxt = GHC.LambdaExpr, ..} = do
   string "\\"
   unless (null m_pats)
     $ case GHC.unLoc $ head m_pats of
         GHC.LazyPat {} -> space
         GHC.BangPat {} -> space
         _ -> return ()
@@ -583,7 +584,7 @@
 prettyMatchProc GHC.Match {m_ctxt = GHC.LambdaExpr, ..} = do
   string "\\"
   unless (null m_pats)
     $ case GHC.unLoc $ head m_pats of
         GHC.LazyPat {} -> space
         GHC.BangPat {} -> space
         _ -> return ()
@@ -773,7 +774,8 @@
 prettyHsType (GHC.HsSpliceTy _ sp) = pretty sp
 prettyHsType GHC.HsDocTy {} = docNode
 prettyHsType (GHC.HsBangTy _ pack x) = pretty pack >> pretty x
-prettyHsType (GHC.HsRecTy _ xs) = hvFields $ fmap pretty xs
+prettyHsType (GHC.HsRecTy _ xs) =
+  hvFields $ fmap (pretty . fmap mkRecordField . fromGenLocated) xs
 prettyHsType (GHC.HsExplicitListTy _ _ xs) =
   case xs of
     [] -> string "'[]"
@@ -1140,16 +1142,6 @@
 instance Pretty a => Pretty (GHC.HsScaled GHC.GhcPs a) where
   pretty' (GHC.HsScaled _ x) = pretty x
 
-instance Pretty (GHC.ConDeclField GHC.GhcPs) where
-  pretty' GHC.ConDeclField {..}
-    -- Here, we *ignore* the 'cd_fld_doc' field because doc strings are
-    -- also stored as comments, and printing both results in duplicated
-    -- comments.
-   = do
-    hCommaSep $ fmap pretty cd_fld_names
-    string " :: "
-    pretty cd_fld_type
-
 instance Pretty InfixExpr where
   pretty' (InfixExpr (GHC.L _ (GHC.HsVar _ bind))) = pretty $ fmap InfixOp bind
   pretty' (InfixExpr x) = pretty' x
@@ -1224,7 +1216,7 @@
   pretty' (GHC.DctMulti _ ts) = hvTuple $ fmap pretty ts
 
 instance Pretty GHC.OverlapMode where
   pretty' GHC.NoOverlap {} = notUsedInParsedStage
   pretty' GHC.Overlappable {} = string "{-# OVERLAPPABLE #-}"
   pretty' GHC.Overlapping {} = string "{-# OVERLAPPING #-}"
   pretty' GHC.Overlaps {} = string "{-# OVERLAPS #-}"
@@ -1341,8 +1333,8 @@
       [] -> pure ()
       [x'] -> string x'
       xs -> do
         string $ head xs
         indentedWithFixedLevel 0 $ newlinePrefixed $ string <$> tail xs
   pretty' (GHC.IEModuleContents _ name) =
     pretty $ fmap ModuleNameWithPrefix name
   pretty' GHC.IEGroup {} = docNode
@@ -1523,7 +1515,7 @@
   pretty' (GHC.HsFloatPrim _ x) = pretty x >> string "#"
   pretty' GHC.HsDoublePrim {} = notUsedInParsedStage
   pretty' x =
     case x of
       GHC.HsString {} -> prettyString
       GHC.HsStringPrim {} -> prettyString
     where
@@ -1655,7 +1647,7 @@
           string p |=> pretty (fmap StmtLRInsideVerticalList x)
           newline
         string "]"
       stmtsAndPrefixes l = ("| ", head l) : fmap (", ", ) (tail l)
 
 instance Pretty DoExpression where
   pretty' DoExpression {..} = do

src/HIndent/Pretty.hs-boot

@@ -44,8 +44,6 @@ instance Pretty
 
 instance Pretty GHC.RdrName
 
-instance Pretty (GHC.ConDeclField GHC.GhcPs)
-
 instance Pretty (GHC.HsOuterTyVarBndrs GHC.Specificity GHc.GhcPs)
 
 instance Pretty SigBindFamily
@@ -80,7 +78,6 @@ instance Pretty PatInsidePatDecl
 
 instance Pretty GHC.StringLiteral
 
-
 instance Pretty (GHC.HsSigType GHC.GhcPs)
 
 instance Pretty Context
@@ -106,4 +103,4 @@ instance Pretty (GHC.HsUntypedSplice GHC.GhcPs)
 #else
 instance Pretty (GHC.HsSplice GHC.GhcPs)
 #endif
-
+instance Pretty (GHC.FieldOcc GHC.GhcPs)