Implement RoleAnnotation

hindent.cabal

@@ -41,6 +41,7 @@ library
       HIndent.Ast.Declaration
       HIndent.Ast.Declaration.Annotation
       HIndent.Ast.Declaration.Annotation.Provenance
+      HIndent.Ast.Declaration.Annotation.Role
       HIndent.Ast.Declaration.Bind
       HIndent.Ast.Declaration.Class
       HIndent.Ast.Declaration.Class.FunctionalDependency
@@ -99,6 +100,7 @@ library
       HIndent.Ast.Module.Name
       HIndent.Ast.Module.Warning
       HIndent.Ast.NodeComments
+      HIndent.Ast.Role
       HIndent.Ast.Type
       HIndent.Ast.Type.Variable
       HIndent.Ast.WithComments

src/HIndent/Ast/Declaration.hs

@@ -9,6 +9,7 @@ module HIndent.Ast.Declaration
 import Control.Applicative
 import Data.Maybe
 import HIndent.Ast.Declaration.Annotation
+import HIndent.Ast.Declaration.Annotation.Role
 import HIndent.Ast.Declaration.Bind
 import HIndent.Ast.Declaration.Class
 import HIndent.Ast.Declaration.Data
@@ -50,7 +51,7 @@ data Declaration
   | Annotation Annotation
   | RuleDecl RuleCollection
   | Splice SpliceDeclaration
-  | RoleAnnotDecl (GHC.RoleAnnotDecl GHC.GhcPs)
+  | RoleAnnotDecl RoleAnnotation
 
 instance CommentExtraction Declaration where
   nodeComments DataFamily {} = NodeComments [] [] []
@@ -119,7 +120,7 @@ mkDeclaration (GHC.WarningD _ x) = Warnings $ mkWarningCollection x
 mkDeclaration (GHC.AnnD _ x) = Annotation $ mkAnnotation x
 mkDeclaration (GHC.RuleD _ x) = RuleDecl $ mkRuleCollection x
 mkDeclaration (GHC.SpliceD _ x) = Splice $ mkSpliceDeclaration x
-mkDeclaration (GHC.RoleAnnotD _ x) = RoleAnnotDecl x
+mkDeclaration (GHC.RoleAnnotD _ x) = RoleAnnotDecl $ mkRoleAnnotation x
 mkDeclaration GHC.DocD {} =
   error
     "This node should never appear in the AST. If you see this error, please report it to the HIndent maintainers."

src/HIndent/Ast/Declaration/Annotation/Role.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module HIndent.Ast.Declaration.Annotation.Role
+  ( RoleAnnotation
+  , mkRoleAnnotation
+  ) where
+
+import HIndent.Ast.NodeComments
+import HIndent.Ast.Role
+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 RoleAnnotation = RoleAnnotation
+  { name :: GHC.LIdP GHC.GhcPs
+  , roles :: [WithComments (Maybe Role)]
+  }
+
+instance CommentExtraction RoleAnnotation where
+  nodeComments RoleAnnotation {} = NodeComments [] [] []
+
+instance Pretty RoleAnnotation where
+  pretty' RoleAnnotation {..} =
+    spaced
+      $ [string "type role", pretty name]
+          ++ fmap (`prettyWith` maybe (string "_") pretty) roles
+
+mkRoleAnnotation :: GHC.RoleAnnotDecl GHC.GhcPs -> RoleAnnotation
+mkRoleAnnotation (GHC.RoleAnnotDecl _ name rs) = RoleAnnotation {..}
+  where
+    roles = fmap (fmap (fmap mkRole) . fromGenLocated) rs

src/HIndent/Ast/Role.hs

@@ -0,0 +1,30 @@
+module HIndent.Ast.Role
+  ( Role
+  , mkRole
+  ) where
+
+import qualified GHC.Core.TyCon as GHC
+import HIndent.Ast.NodeComments
+import {-# SOURCE #-} HIndent.Pretty
+import HIndent.Pretty.Combinators
+import HIndent.Pretty.NodeComments
+
+data Role
+  = Nominal
+  | Representational
+  | Phantom
+
+instance CommentExtraction Role where
+  nodeComments Nominal = NodeComments [] [] []
+  nodeComments Representational = NodeComments [] [] []
+  nodeComments Phantom = NodeComments [] [] []
+
+instance Pretty Role where
+  pretty' Nominal = string "nominal"
+  pretty' Representational = string "representational"
+  pretty' Phantom = string "phantom"
+
+mkRole :: GHC.Role -> Role
+mkRole GHC.Nominal = Nominal
+mkRole GHC.Representational = Representational
+mkRole GHC.Phantom = Phantom

src/HIndent/Pretty.hs

@@ -25,7 +25,6 @@
 import Control.Monad.RWS
 import Data.Maybe
 import Data.Void
-import qualified GHC.Core.Coercion as GHC
 import qualified GHC.Data.Bag as GHC
 import qualified GHC.Data.FastString as GHC
 import qualified GHC.Hs as GHC
@@ -55,7 +54,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 +544,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 +583,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 ()
@@ -1225,7 +1224,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 #-}"
@@ -1342,8 +1341,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
@@ -1461,17 +1460,6 @@
               (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))) where
   pretty' GHC.HsWC {..} = pretty hswc_body
 
-instance Pretty (GHC.RoleAnnotDecl GHC.GhcPs) where
-  pretty' (GHC.RoleAnnotDecl _ name roles) =
-    spaced
-      $ [string "type role", pretty name]
-          ++ fmap (maybe (string "_") pretty . GHC.unLoc) roles
-
-instance Pretty GHC.Role where
-  pretty' GHC.Nominal = string "nominal"
-  pretty' GHC.Representational = string "representational"
-  pretty' GHC.Phantom = string "phantom"
-
 instance Pretty (GHC.TyFamInstDecl GHC.GhcPs) where
   pretty' GHC.TyFamInstDecl {..} = string "type " >> pretty tfid_eqn
 
@@ -1535,7 +1523,7 @@
   pretty' (GHC.HsFloatPrim _ x) = pretty x >> string "#"
   pretty' GHC.HsDoublePrim {} = notUsedInParsedStage
   pretty' x =
     case x of
       GHC.HsString {} -> prettyString
       GHC.HsStringPrim {} -> prettyString
     where
@@ -1667,7 +1655,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

@@ -80,7 +80,6 @@ instance Pretty PatInsidePatDecl
 
 instance Pretty GHC.StringLiteral
 
-instance Pretty (GHC.RoleAnnotDecl GHC.GhcPs)
 
 instance Pretty (GHC.HsSigType GHC.GhcPs)
 
@@ -107,3 +106,4 @@ instance Pretty (GHC.HsUntypedSplice GHC.GhcPs)
 #else
 instance Pretty (GHC.HsSplice GHC.GhcPs)
 #endif
+