From e0049df7983ef1c3ccc58020c2a1da7fdcfc81d3 Mon Sep 17 00:00:00 2001 From: Hiroki Tokunaga Date: Wed, 5 Jun 2024 22:48:55 +0900 Subject: [PATCH] Implement `RecordField` --- hindent.cabal | 1 + .../Data/GADT/Constructor/Signature.hs | 11 +++++-- .../Data/Haskell98/Constructor/Body.hs | 18 +++++++---- .../Ast/Declaration/Data/Record/Field.hs | 30 +++++++++++++++++++ src/HIndent/Pretty.hs | 14 ++------- src/HIndent/Pretty.hs-boot | 5 +--- 6 files changed, 56 insertions(+), 23 deletions(-) create mode 100644 src/HIndent/Ast/Declaration/Data/Record/Field.hs diff --git a/hindent.cabal b/hindent.cabal index 65b6d69cb..bc0817187 100644 --- 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 index f78c08b2a..f5c0d7a9b 100644 --- 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 index fa0728d04..5c412796f 100644 --- 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 new file mode 100644 index 000000000..b06738d0d --- /dev/null +++ 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 index fa2093249..fa007a028 100644 --- 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 index 94e21e564..1cc61795f 100644 --- 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)