diff --git a/hindent.cabal b/hindent.cabal index 35e0de5e3..09d6b009a 100644 --- a/hindent.cabal +++ b/hindent.cabal @@ -68,6 +68,9 @@ library HIndent.Ast.Declaration.Instance.Class HIndent.Ast.Declaration.Instance.Family.Data HIndent.Ast.Declaration.Instance.Family.Type + HIndent.Ast.Declaration.Rule + HIndent.Ast.Declaration.Rule.Binder + HIndent.Ast.Declaration.Rule.Collection HIndent.Ast.Declaration.Signature HIndent.Ast.Declaration.Signature.BooleanFormula HIndent.Ast.Declaration.Signature.Fixity diff --git a/src/HIndent/Ast/Declaration.hs b/src/HIndent/Ast/Declaration.hs index 73a1abc9c..cad8635aa 100644 --- a/src/HIndent/Ast/Declaration.hs +++ b/src/HIndent/Ast/Declaration.hs @@ -19,6 +19,7 @@ import HIndent.Ast.Declaration.Foreign import HIndent.Ast.Declaration.Instance.Class import HIndent.Ast.Declaration.Instance.Family.Data import HIndent.Ast.Declaration.Instance.Family.Type +import HIndent.Ast.Declaration.Rule.Collection import HIndent.Ast.Declaration.Signature import HIndent.Ast.Declaration.Signature.StandaloneKind import HIndent.Ast.Declaration.StandAloneDeriving @@ -46,7 +47,7 @@ data Declaration | Foreign ForeignDeclaration | Warnings WarningCollection | Annotation Annotation - | RuleDecl (GHC.RuleDecls GHC.GhcPs) + | RuleDecl RuleCollection | SpliceDecl (GHC.SpliceDecl GHC.GhcPs) | RoleAnnotDecl (GHC.RoleAnnotDecl GHC.GhcPs) @@ -115,7 +116,7 @@ mkDeclaration (GHC.DefD _ x) = Default $ mkDefaultDeclaration x mkDeclaration (GHC.ForD _ x) = Foreign $ mkForeignDeclaration x mkDeclaration (GHC.WarningD _ x) = Warnings $ mkWarningCollection x mkDeclaration (GHC.AnnD _ x) = Annotation $ mkAnnotation x -mkDeclaration (GHC.RuleD _ x) = RuleDecl x +mkDeclaration (GHC.RuleD _ x) = RuleDecl $ mkRuleCollection x mkDeclaration (GHC.SpliceD _ x) = SpliceDecl x mkDeclaration (GHC.RoleAnnotD _ x) = RoleAnnotDecl x mkDeclaration GHC.DocD {} = diff --git a/src/HIndent/Ast/Declaration/Rule.hs b/src/HIndent/Ast/Declaration/Rule.hs new file mode 100644 index 000000000..0147b926e --- /dev/null +++ b/src/HIndent/Ast/Declaration/Rule.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} + +module HIndent.Ast.Declaration.Rule + ( RuleDeclaration + , mkRuleDeclaration + ) where + +import qualified GHC.Core as GHC +import qualified GHC.Data.FastString as GHC +import HIndent.Ast.Declaration.Rule.Binder +import HIndent.Ast.NodeComments +import HIndent.Ast.WithComments +import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC +import {-# SOURCE #-} HIndent.Pretty +import HIndent.Pretty.Combinators +import HIndent.Pretty.NodeComments + +data RuleDeclaration = RuleDeclaration + { name :: WithComments GHC.RuleName + , binders :: [WithComments RuleBinder] + , lhs :: WithComments (GHC.HsExpr GHC.GhcPs) + , rhs :: WithComments (GHC.HsExpr GHC.GhcPs) + } + +instance CommentExtraction RuleDeclaration where + nodeComments RuleDeclaration {} = NodeComments [] [] [] + +instance Pretty RuleDeclaration where + pretty' (RuleDeclaration {..}) = + spaced + [ prettyWith name (doubleQuotes . string . GHC.unpackFS) + , prettyLhs + , string "=" + , pretty rhs + ] + where + prettyLhs = + if null binders + then pretty lhs + else do + string "forall " + spaced $ fmap pretty binders + dot + space + pretty lhs + +mkRuleDeclaration :: GHC.RuleDecl GHC.GhcPs -> RuleDeclaration +mkRuleDeclaration rule@GHC.HsRule {..} = RuleDeclaration {..} + where + name = getName rule + binders = fmap (fmap mkRuleBinder . fromGenLocated) rd_tmvs + lhs = fromGenLocated rd_lhs + rhs = fromGenLocated rd_rhs + +getName :: GHC.RuleDecl GHC.GhcPs -> WithComments GHC.RuleName +#if MIN_VERSION_ghc_lib_parser(9, 6, 1) +getName = fromGenLocated . GHC.rd_name +#else +getName = fromGenLocated . fmap snd . GHC.rd_name +#endif diff --git a/src/HIndent/Ast/Declaration/Rule/Binder.hs b/src/HIndent/Ast/Declaration/Rule/Binder.hs new file mode 100644 index 000000000..581c0431e --- /dev/null +++ b/src/HIndent/Ast/Declaration/Rule/Binder.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE RecordWildCards #-} + +module HIndent.Ast.Declaration.Rule.Binder + ( RuleBinder + , mkRuleBinder + ) where + +import HIndent.Ast.NodeComments +import HIndent.Ast.WithComments +import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC +import {-# SOURCE #-} HIndent.Pretty +import HIndent.Pretty.Combinators +import HIndent.Pretty.NodeComments + +data RuleBinder = RuleBinder + { name :: GHC.LIdP GHC.GhcPs + , signature :: Maybe (WithComments (GHC.HsType GHC.GhcPs)) + } + +instance CommentExtraction RuleBinder where + nodeComments RuleBinder {} = NodeComments [] [] [] + +instance Pretty RuleBinder where + pretty' RuleBinder {signature = Nothing, ..} = pretty name + pretty' RuleBinder {signature = Just sig, ..} = + parens $ spaced [pretty name, string "::", pretty sig] + +mkRuleBinder :: GHC.RuleBndr GHC.GhcPs -> RuleBinder +mkRuleBinder (GHC.RuleBndr _ name) = RuleBinder {signature = Nothing, ..} +mkRuleBinder (GHC.RuleBndrSig _ name GHC.HsPS {..}) = + RuleBinder {signature = Just $ fromGenLocated hsps_body, ..} diff --git a/src/HIndent/Ast/Declaration/Rule/Collection.hs b/src/HIndent/Ast/Declaration/Rule/Collection.hs new file mode 100644 index 000000000..93ba5fa1a --- /dev/null +++ b/src/HIndent/Ast/Declaration/Rule/Collection.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE RecordWildCards #-} + +module HIndent.Ast.Declaration.Rule.Collection + ( RuleCollection + , mkRuleCollection + ) where + +import HIndent.Ast.Declaration.Rule +import HIndent.Ast.NodeComments +import HIndent.Ast.WithComments +import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC +import {-# SOURCE #-} HIndent.Pretty +import HIndent.Pretty.Combinators +import HIndent.Pretty.NodeComments + +newtype RuleCollection = + RuleCollection [WithComments RuleDeclaration] + +instance CommentExtraction RuleCollection where + nodeComments RuleCollection {} = NodeComments [] [] [] + +instance Pretty RuleCollection where + pretty' (RuleCollection xs) = + lined $ string "{-# RULES" : fmap pretty xs ++ [string " #-}"] + +mkRuleCollection :: GHC.RuleDecls GHC.GhcPs -> RuleCollection +mkRuleCollection GHC.HsRules {..} = + RuleCollection $ fmap (fmap mkRuleDeclaration . fromGenLocated) rds_rules diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs index c9fc755c9..f5b5d37c6 100644 --- a/src/HIndent/Pretty.hs +++ b/src/HIndent/Pretty.hs @@ -1454,48 +1454,6 @@ instance Pretty (GHC.HsFieldLabel GHC.GhcPs) where pretty' GHC.HsFieldLabel {..} = printCommentsAnd hflLabel (string . GHC.unpackFS) #endif -instance Pretty (GHC.RuleDecls GHC.GhcPs) where - pretty' GHC.HsRules {..} = - lined $ string "{-# RULES" : fmap pretty rds_rules ++ [string " #-}"] -#if MIN_VERSION_ghc_lib_parser(9,6,1) -instance Pretty (GHC.RuleDecl GHC.GhcPs) where - pretty' GHC.HsRule {..} = - spaced - [ printCommentsAnd rd_name (doubleQuotes . string . GHC.unpackFS) - , lhs - , string "=" - , pretty rd_rhs - ] - where - lhs = - if null rd_tmvs - then pretty rd_lhs - else do - string "forall " - spaced $ fmap pretty rd_tmvs - dot - space - pretty rd_lhs -#else -instance Pretty (GHC.RuleDecl GHC.GhcPs) where - pretty' GHC.HsRule {..} = - spaced - [ printCommentsAnd rd_name (doubleQuotes . string . GHC.unpackFS . snd) - , lhs - , string "=" - , pretty rd_rhs - ] - where - lhs = - if null rd_tmvs - then pretty rd_lhs - else do - string "forall " - spaced $ fmap pretty rd_tmvs - dot - space - pretty rd_lhs -#endif instance Pretty GHC.OccName where pretty' = output @@ -1735,11 +1693,6 @@ instance Pretty LetIn where pretty' LetIn {..} = lined [string "let " |=> pretty letBinds, string " in " |=> pretty inExpr] -instance Pretty (GHC.RuleBndr GHC.GhcPs) where - pretty' (GHC.RuleBndr _ name) = pretty name - pretty' (GHC.RuleBndrSig _ name sig) = - parens $ spaced [pretty name, string "::", pretty sig] - instance Pretty GHC.HsSrcBang where pretty' (GHC.HsSrcBang _ unpack strictness) = do pretty unpack diff --git a/src/HIndent/Pretty.hs-boot b/src/HIndent/Pretty.hs-boot index ebfdcc8c4..5cb1005ea 100644 --- a/src/HIndent/Pretty.hs-boot +++ b/src/HIndent/Pretty.hs-boot @@ -80,8 +80,6 @@ instance Pretty PatInsidePatDecl instance Pretty GHC.StringLiteral -instance Pretty (GHC.RuleDecls GHC.GhcPs) - instance Pretty (GHC.SpliceDecl GHC.GhcPs) instance Pretty (GHC.RoleAnnotDecl GHC.GhcPs)