Implement RoleAnnotation (#899)

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
 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
@@ -1461,17 +1460,6 @@ instance Pretty
               (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
 

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
+