diff --git a/hindent.cabal b/hindent.cabal index e89aeeaf6..65b6d69cb 100644 --- a/hindent.cabal +++ b/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 diff --git a/src/HIndent/Ast/Declaration.hs b/src/HIndent/Ast/Declaration.hs index 77c7ea34f..387f6270a 100644 --- a/src/HIndent/Ast/Declaration.hs +++ b/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." diff --git a/src/HIndent/Ast/Declaration/Annotation/Role.hs b/src/HIndent/Ast/Declaration/Annotation/Role.hs new file mode 100644 index 000000000..35221afd8 --- /dev/null +++ b/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 diff --git a/src/HIndent/Ast/Role.hs b/src/HIndent/Ast/Role.hs new file mode 100644 index 000000000..3504b6494 --- /dev/null +++ b/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 diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs index cbe9a517b..fa2093249 100644 --- a/src/HIndent/Pretty.hs +++ b/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 diff --git a/src/HIndent/Pretty.hs-boot b/src/HIndent/Pretty.hs-boot index 6b54b7556..94e21e564 100644 --- a/src/HIndent/Pretty.hs-boot +++ b/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 +