Support new role annotation syntax.

This reverts the change to TyVarBndr (which now has only two
constructors, PlainTV and KindedTV) and adds a new Dec, RoleAnnotD.
There is also an updated definition for the type Role, to allow
for wildcard annotations.

4 files changed, 42 insertions, 24 deletions

diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs
index 5064b6aef0..38c91fe56d 100644
--- a/libraries/template-haskell/Language/Haskell/TH.hs
+++ b/libraries/template-haskell/Language/Haskell/TH.hs
@@ -30,6 +30,8 @@ module Language.Haskell.TH(
 	-- *** Instance lookup
 	reifyInstances,
 	isInstance,
+        -- *** Roles lookup
+        reifyRoles,
 
 	-- * Names
 	Name, NameSpace,	-- Abstract
@@ -59,7 +61,7 @@ module Language.Haskell.TH(
     -- ** Patterns
         Pat(..), FieldExp, FieldPat,
     -- ** Types
-        Type(..), TyVarBndr(..), TyLit(..), Kind, Cxt, Pred(..), Role(..),
+        Type(..), TyVarBndr(..), TyLit(..), Kind, Cxt, Pred(..), Syntax.Role(..),
 
     -- * Library functions
     -- ** Abbreviations
@@ -108,11 +110,16 @@ module Language.Haskell.TH(
     -- *** Kinds
   varK, conK, tupleK, arrowK, listK, appK, starK, constraintK,
 
+    -- *** Roles
+    nominalR, representationalR, phantomR, inferR,
+
     -- *** Top Level Declarations
     -- **** Data
 	valD, funD, tySynD, dataD, newtypeD,
     -- **** Class
     classD, instanceD, sigD,
+    -- **** Role annotations
+    roleAnnotD,
     -- **** Type Family / Data Family
     familyNoKindD, familyKindD, dataInstD,
     closedTypeFamilyNoKindD, closedTypeFamilyKindD,
@@ -129,7 +136,7 @@ module Language.Haskell.TH(
 
    ) where
 
-import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Syntax as Syntax
 import Language.Haskell.TH.Lib
 import Language.Haskell.TH.Ppr
 
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index b02732c10c..94696b822e 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -7,7 +7,8 @@ module Language.Haskell.TH.Lib where
     -- be "public" functions.  The main module TH
     -- re-exports them all.
 
-import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Syntax hiding (Role)
+import qualified Language.Haskell.TH.Syntax as TH
 import Control.Monad( liftM, liftM2 )
 import Data.Word( Word8 )
 
@@ -37,6 +38,7 @@ type VarStrictTypeQ = Q VarStrictType
 type FieldExpQ      = Q FieldExp
 type RuleBndrQ      = Q RuleBndr
 type TySynEqnQ      = Q TySynEqn
+type Role           = TH.Role       -- must be defined here for DsMeta to find it
 
 ----------------------------------------------------------
 -- * Lowercase pattern syntax functions
@@ -442,6 +444,9 @@ closedTypeFamilyKindD tc tvs kind eqns =
     eqns1 <- sequence eqns
     return (ClosedTypeFamilyD tc tvs (Just kind) eqns1)
 
+roleAnnotD :: Name -> [Role] -> DecQ
+roleAnnotD name roles = return $ RoleAnnotD name roles
+
 tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ
 tySynEqn lhs rhs =
   do
@@ -566,12 +571,6 @@ plainTV = PlainTV
 kindedTV :: Name -> Kind -> TyVarBndr
 kindedTV = KindedTV
 
-roledTV :: Name -> Role -> TyVarBndr
-roledTV = RoledTV
-
-kindedRoledTV :: Name -> Kind -> Role -> TyVarBndr
-kindedRoledTV = KindedRoledTV
-
 varK :: Name -> Kind
 varK = VarT
 
@@ -599,10 +598,11 @@ constraintK = ConstraintT
 -------------------------------------------------------------------------------
 -- *   Role
 
-nominal, representational, phantom :: Role
-nominal = Nominal
-representational = Representational
-phantom = Phantom
+nominalR, representationalR, phantomR, inferR :: Role
+nominalR          = NominalR
+representationalR = RepresentationalR
+phantomR          = PhantomR
+inferR            = InferR
 
 -------------------------------------------------------------------------------
 -- *   Callconv
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 415f171c10..8222085375 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -307,6 +307,8 @@ ppr_dec _ (ClosedTypeFamilyD tc tvs mkind eqns)
     ppr_eqn (TySynEqn lhs rhs)
       = ppr tc <+> sep (map pprParendType lhs) <+> text "=" <+> ppr rhs
 
+ppr_dec _ (RoleAnnotD name roles)
+  = hsep [ text "type role", ppr name ] <+> hsep (map ppr roles)
 
 ppr_data :: Doc -> Cxt -> Name -> Doc -> [Con] -> [Name] -> Doc
 ppr_data maybeInst ctxt t argsDoc cs decs
@@ -502,14 +504,12 @@ instance Ppr TyLit where
 instance Ppr TyVarBndr where
     ppr (PlainTV nm)    = ppr nm
     ppr (KindedTV nm k) = parens (ppr nm <+> text "::" <+> ppr k)
-    ppr (RoledTV nm r)  = ppr nm <> text "@" <> ppr r
-    ppr (KindedRoledTV nm k r)
-      = parens (ppr nm <+> text "::" <+> ppr k) <> text "@" <> ppr r
 
 instance Ppr Role where
-    ppr Nominal          = text "N"
-    ppr Representational = text "R"
-    ppr Phantom          = text "P"
+    ppr NominalR          = text "nominal"
+    ppr RepresentationalR = text "representational"
+    ppr PhantomR          = text "phantom"
+    ppr InferR            = text "_"
 
 ------------------------------
 pprCxt :: Cxt -> Doc
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 2995b58791..e53c787c34 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -54,6 +54,7 @@ class (Monad m, Applicative m) => Quasi m where
        -- Returns list of matching instance Decs 
        --    (with empty sub-Decs)
        -- Works for classes and type functions
+  qReifyRoles     :: Name -> m [Role]
 
   qLocation :: m Loc
 
@@ -84,6 +85,7 @@ instance Quasi IO where
   qLookupName _ _     = badIO "lookupName"
   qReify _            = badIO "reify"
   qReifyInstances _ _ = badIO "classInstances"
+  qReifyRoles _       = badIO "reifyRoles"
   qLocation    	      = badIO "currentLocation"
   qRecover _ _ 	      = badIO "recover" -- Maybe we could fix this?
   qAddDependentFile _ = badIO "addDependentFile"
@@ -288,6 +290,13 @@ all instances of this family at the types @tys@ are returned.
 reifyInstances :: Name -> [Type] -> Q [InstanceDec]
 reifyInstances cls tys = Q (qReifyInstances cls tys)
 
+{- | @reifyRoles nm@ returns the list of roles associated with the parameters of
+the tycon @nm@. Fails if @nm@ cannot be found or is not a tycon.
+The returned list should never contain 'InferR'.
+-}
+reifyRoles :: Name -> Q [Role]
+reifyRoles nm = Q (qReifyRoles nm)
+
 -- | Is the list of instances returned by 'reifyInstances' nonempty?
 isInstance :: Name -> [Type] -> Q Bool
 isInstance nm tys = do { decs <- reifyInstances nm tys
@@ -320,6 +329,7 @@ instance Quasi Q where
   qRecover  	    = recover 
   qReify    	    = reify
   qReifyInstances   = reifyInstances
+  qReifyRoles       = reifyRoles
   qLookupName       = lookupName
   qLocation 	    = location
   qRunIO    	    = runIO
@@ -1170,6 +1180,8 @@ data Dec
   | ClosedTypeFamilyD Name
       [TyVarBndr] (Maybe Kind)
       [TySynEqn]                  -- ^ @{ type family F a b :: * where ... }@
+
+  | RoleAnnotD Name [Role]        -- ^ @{ type role T nominal representational }@
   deriving( Show, Eq, Data, Typeable )
 
 -- | One equation of a type family instance or closed type family. The
@@ -1258,8 +1270,6 @@ data Type = ForallT [TyVarBndr] Cxt Type  -- ^ @forall \<vars\>. \<ctxt\> -> \<t
 
 data TyVarBndr = PlainTV  Name            -- ^ @a@
                | KindedTV Name Kind       -- ^ @(a :: k)@
-               | RoledTV  Name Role       -- ^ @a\@R@
-               | KindedRoledTV Name Kind Role -- ^ @(a :: k)\@R@
       deriving( Show, Eq, Data, Typeable )
 
 data TyLit = NumTyLit Integer             -- ^ @2@
@@ -1267,9 +1277,10 @@ data TyLit = NumTyLit Integer             -- ^ @2@
   deriving ( Show, Eq, Data, Typeable )
 
 -- | Role annotations
-data Role = Nominal            -- ^ @N@
-          | Representational   -- ^ @R@
-          | Phantom            -- ^ @P@
+data Role = NominalR            -- ^ @nominal@
+          | RepresentationalR   -- ^ @representational@
+          | PhantomR            -- ^ @phantom@
+          | InferR              -- ^ @_@
   deriving( Show, Eq, Data, Typeable )
 
 -- | To avoid duplication between kinds and types, they