Implement RuleCollection

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

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 {} =

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

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, ..}

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

src/HIndent/Pretty.hs

@@ -55,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)
@@ -545,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 ()
@@ -584,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 ()
@@ -1228,7 +1228,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 #-}"
@@ -1345,8 +1345,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
@@ -1454,48 +1454,6 @@
   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
 
@@ -1580,7 +1538,7 @@
   pretty' (GHC.HsFloatPrim _ x) = pretty x >> string "#"
   pretty' GHC.HsDoublePrim {} = notUsedInParsedStage
   pretty' x =
     case x of
       GHC.HsString {} -> prettyString
       GHC.HsStringPrim {} -> prettyString
     where
@@ -1712,7 +1670,7 @@
           string p |=> pretty (fmap StmtLRInsideVerticalList x)
           newline
         string "]"
       stmtsAndPrefixes l = ("| ", head l) : fmap (", ", ) (tail l)
 
 instance Pretty DoExpression where
   pretty' DoExpression {..} = do
@@ -1735,11 +1693,6 @@
   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

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)