Implement RecordField (#907)

mihaimaruseac · Jun 5, 2024 · c9f55ca · c9f55ca
1 parent 1e4e4c0
commit c9f55ca
Show file tree

Hide file tree

Showing 6 changed files with 56 additions and 23 deletions.
diff --git a/hindent.cabal b/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

diff --git a/src/HIndent/Ast/Declaration/Data/GADT/Constructor/Signature.hs b/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

diff --git a/src/HIndent/Ast/Declaration/Data/Haskell98/Constructor/Body.hs b/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

diff --git a/src/HIndent/Ast/Declaration/Data/Record/Field.hs b/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
diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs
@@ -39,6 +39,7 @@ import HIndent.Applicative
 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
@@ -773,7 +774,8 @@ prettyHsType (GHC.HsKindSig _ t k) = spaced [pretty t, string "::", pretty k]
 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 (GHC.FieldOcc GHC.GhcPs) where
 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

diff --git a/src/HIndent/Pretty.hs-boot b/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)