Change role annotation syntax.

This fixes bugs #8185, #8234, and #8246. The new syntax is explained
in the comments to #8185, appears in the "Roles" subsection of the
manual, and on the [wiki:Roles] wiki page.

This change also removes the ability for a role annotation on type
synonyms, as noted in #8234.

4 files changed, 89 insertions, 44 deletions

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 8a4f7d8783..616e05c9de 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -267,6 +267,11 @@ cvtDec (ClosedTypeFamilyD tc tyvars mkind eqns)
        ; returnL $ TyClD (FamDecl (FamilyDecl (ClosedTypeFamily eqns') tc' tvs' mkind')) }
   | otherwise
   = failWith (ptext (sLit "Illegal empty closed type family"))
+
+cvtDec (TH.RoleAnnotD tc roles)
+  = do { tc' <- tconNameL tc
+       ; let roles' = map (noLoc . cvtRole) roles
+       ; return $ noLoc $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') }
 ----------------
 cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
 cvtTySynEqn tc (TySynEqn lhs rhs)
@@ -856,25 +861,17 @@ cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
 cvt_tv (TH.PlainTV nm)
   = do { nm' <- tName nm
-       ; returnL $ HsTyVarBndr nm' Nothing Nothing }
+       ; returnL $ UserTyVar nm' }
 cvt_tv (TH.KindedTV nm ki)
   = do { nm' <- tName nm
        ; ki' <- cvtKind ki
-       ; returnL $ HsTyVarBndr nm' (Just ki') Nothing }
-cvt_tv (TH.RoledTV nm r)
-  = do { nm' <- tName nm
-       ; r'  <- cvtRole r
-       ; returnL $ HsTyVarBndr nm' Nothing (Just r') }
-cvt_tv (TH.KindedRoledTV nm k r)
-  = do { nm' <- tName nm
-       ; k'  <- cvtKind k
-       ; r'  <- cvtRole r
-       ; returnL $ HsTyVarBndr nm' (Just k') (Just r') }
-
-cvtRole :: TH.Role -> CvtM Coercion.Role
-cvtRole TH.Nominal          = return Coercion.Nominal
-cvtRole TH.Representational = return Coercion.Representational
-cvtRole TH.Phantom          = return Coercion.Phantom
+       ; returnL $ KindedTyVar nm' ki' }
+
+cvtRole :: TH.Role -> Maybe Coercion.Role
+cvtRole TH.NominalR          = Just Coercion.Nominal
+cvtRole TH.RepresentationalR = Just Coercion.Representational
+cvtRole TH.PhantomR          = Just Coercion.Phantom
+cvtRole TH.InferR            = Nothing
 
 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index ee4b0fab34..fe59763a83 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -15,7 +15,8 @@ module HsDecls (
   -- * Toplevel declarations
   HsDecl(..), LHsDecl, HsDataDefn(..),
   -- ** Class or type declarations
-  TyClDecl(..), LTyClDecl, TyClGroup,
+  TyClDecl(..), LTyClDecl,
+  TyClGroup(..), tyClGroupConcat, mkTyClGroup,
   isClassDecl, isDataDecl, isSynDecl, tcdName,
   isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,
   isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,
@@ -57,9 +58,12 @@ module HsDecls (
   -- ** Annotations
   AnnDecl(..), LAnnDecl, 
   AnnProvenance(..), annProvenanceName_maybe,
+  -- ** Role annotations
+  RoleAnnotDecl(..), LRoleAnnotDecl, roleAnnotDeclName,
 
   -- * Grouping
   HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups
+
     ) where
 
 -- friends:
@@ -116,6 +120,7 @@ data HsDecl id
   | SpliceD     (SpliceDecl id)
   | DocD        (DocDecl)
   | QuasiQuoteD (HsQuasiQuote id)
+  | RoleAnnotD  (RoleAnnotDecl id)
   deriving (Data, Typeable)
 
 
@@ -138,7 +143,7 @@ data HsGroup id
   = HsGroup {
         hs_valds  :: HsValBinds id,
 
-        hs_tyclds :: [[LTyClDecl id]],
+        hs_tyclds :: [TyClGroup id],
                 -- A list of mutually-recursive groups
                 -- No family-instances here; they are in hs_instds
                 -- Parser generates a singleton list;
@@ -234,6 +239,7 @@ instance OutputableBndr name => Outputable (HsDecl name) where
     ppr (SpliceD dd)            = ppr dd
     ppr (DocD doc)              = ppr doc
     ppr (QuasiQuoteD qq)        = ppr qq
+    ppr (RoleAnnotD ra)         = ppr ra
 
 instance OutputableBndr name => Outputable (HsGroup name) where
     ppr (HsGroup { hs_valds  = val_decls,
@@ -255,7 +261,7 @@ instance OutputableBndr name => Outputable (HsGroup name) where
              if isEmptyValBinds val_decls 
                 then Nothing 
                 else Just (ppr val_decls),
-             ppr_ds (concat tycl_decls), 
+             ppr_ds (tyClGroupConcat tycl_decls), 
              ppr_ds inst_decls,
              ppr_ds deriv_decls,
              ppr_ds foreign_decls]
@@ -423,9 +429,6 @@ Interface file code:
 
 \begin{code}
 type LTyClDecl name = Located (TyClDecl name)
-type TyClGroup name = [LTyClDecl name]  -- This is used in TcTyClsDecls to represent
-                                        -- strongly connected components of decls
-                                        -- No familiy instances in here
 
 -- | A type or class declaration.
 data TyClDecl name
@@ -439,10 +442,10 @@ data TyClDecl name
 
   | -- | @type@ declaration
     SynDecl { tcdLName  :: Located name            -- ^ Type constructor
-           , tcdTyVars :: LHsTyVarBndrs name      -- ^ Type variables; for an associated type
+            , tcdTyVars :: LHsTyVarBndrs name      -- ^ Type variables; for an associated type
                                                   --   these include outer binders
-           , tcdRhs    :: LHsType name            -- ^ RHS of type declaration
-           , tcdFVs    :: NameSet }
+            , tcdRhs    :: LHsType name            -- ^ RHS of type declaration
+            , tcdFVs    :: NameSet }
 
   | -- | @data@ declaration
     DataDecl { tcdLName    :: Located name        -- ^ Type constructor
@@ -467,8 +470,25 @@ data TyClDecl name
                 tcdDocs    :: [LDocDecl],               -- ^ Haddock docs
                 tcdFVs     :: NameSet
     }
+    
   deriving (Data, Typeable)
 
+ -- This is used in TcTyClsDecls to represent
+ -- strongly connected components of decls
+ -- No familiy instances in here
+ -- The role annotations must be grouped with their decls for the
+ -- type-checker to infer roles correctly
+data TyClGroup name
+  = TyClGroup { group_tyclds :: [LTyClDecl name]
+              , group_roles  :: [LRoleAnnotDecl name] }
+    deriving (Data, Typeable)
+
+tyClGroupConcat :: [TyClGroup name] -> [LTyClDecl name]
+tyClGroupConcat = concatMap group_tyclds
+
+mkTyClGroup :: [LTyClDecl name] -> TyClGroup name
+mkTyClGroup decls = TyClGroup { group_tyclds = decls, group_roles = [] }
+
 type LFamilyDecl name = Located (FamilyDecl name)
 data FamilyDecl name = FamilyDecl
   { fdInfo    :: FamilyInfo name            -- type or data, closed or open
@@ -613,6 +633,11 @@ instance OutputableBndr name
                      <+> pp_vanilla_decl_head lclas tyvars (unLoc context)
                      <+> pprFundeps (map unLoc fds)
 
+instance OutputableBndr name => Outputable (TyClGroup name) where
+  ppr (TyClGroup { group_tyclds = tyclds, group_roles = roles })
+    = ppr tyclds $$
+      ppr roles
+
 instance (OutputableBndr name) => Outputable (FamilyDecl name) where
   ppr (FamilyDecl { fdInfo = info, fdLName = ltycon, 
                     fdTyVars = tyvars, fdKindSig = mb_kind})
@@ -1383,3 +1408,32 @@ pprAnnProvenance ModuleAnnProvenance       = ptext (sLit "ANN module")
 pprAnnProvenance (ValueAnnProvenance name) = ptext (sLit "ANN") <+> ppr name
 pprAnnProvenance (TypeAnnProvenance name)  = ptext (sLit "ANN type") <+> ppr name
 \end{code}
+
+%************************************************************************
+%*                                                                      *
+\subsection[RoleAnnot]{Role annotations}
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+type LRoleAnnotDecl name = Located (RoleAnnotDecl name)
+
+-- See #8185 for more info about why role annotations are
+-- top-level declarations
+data RoleAnnotDecl name
+  = RoleAnnotDecl (Located name)         -- type constructor
+                  [Located (Maybe Role)] -- optional annotations
+  deriving (Data, Typeable)
+
+instance OutputableBndr name => Outputable (RoleAnnotDecl name) where
+  ppr (RoleAnnotDecl ltycon roles)
+    = ptext (sLit "type role") <+> ppr ltycon <+>
+      hsep (map (pp_role . unLoc) roles)
+    where
+      pp_role Nothing  = underscore
+      pp_role (Just r) = ppr r
+
+roleAnnotDeclName :: RoleAnnotDecl name -> name
+roleAnnotDeclName (RoleAnnotDecl (L _ name) _) = name
+
+\end{code}
\ No newline at end of file
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 485cfc14e3..dc442506c6 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -47,7 +47,6 @@ import Name( Name )
 import RdrName( RdrName )
 import DataCon( HsBang(..) )
 import Type
-import TyCon ( Role(..) )
 import HsDoc
 import BasicTypes
 import SrcLoc
@@ -181,12 +180,12 @@ instance OutputableBndr HsIPName where
     pprPrefixOcc n = ppr n
 
 data HsTyVarBndr name
-  = HsTyVarBndr name
-                (Maybe (LHsKind name)) -- See Note [Printing KindedTyVars]
-                (Maybe Role)
-      --  *** NOTA BENE *** A "monotype" in a pragma can have
-      -- for-alls in it, (mostly to do with dictionaries).  These
-      -- must be explicitly Kinded.
+  = UserTyVar        -- no explicit kinding
+         name
+
+  | KindedTyVar
+         name
+         (LHsKind name)  -- The user-supplied kind signature
   deriving (Data, Typeable)
 
 data HsType name
@@ -228,9 +227,6 @@ data HsType name
   | HsKindSig           (LHsType name)  -- (ty :: kind)
                         (LHsKind name)  -- A type with a kind signature
 
-  | HsRoleAnnot         (LHsType name)  -- ty@role, seen only right after parsing
-                        Role
-
   | HsQuasiQuoteTy      (HsQuasiQuote name)
 
   | HsSpliceTy          (HsSplice name) 
@@ -420,7 +416,8 @@ hsExplicitTvs _                                   = []
 
 ---------------------
 hsTyVarName :: HsTyVarBndr name -> name
-hsTyVarName (HsTyVarBndr n _ _) = n
+hsTyVarName (UserTyVar n)     = n
+hsTyVarName (KindedTyVar n _) = n
 
 hsLTyVarName :: LHsTyVarBndr name -> name
 hsLTyVarName = hsTyVarName . unLoc
@@ -541,10 +538,8 @@ instance (OutputableBndr name) => Outputable (LHsTyVarBndrs name) where
       = sep [ ifPprDebug $ braces (interppSP kvs), interppSP tvs ]
 
 instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where
-    ppr (HsTyVarBndr n Nothing  Nothing)  = ppr n
-    ppr (HsTyVarBndr n (Just k) Nothing)  = parens $ hsep [ppr n, dcolon, ppr k]
-    ppr (HsTyVarBndr n Nothing  (Just r)) = ppr n <> char '@' <> ppr r
-    ppr (HsTyVarBndr n (Just k) (Just r)) = parens $ hsep [ppr n, dcolon, ppr k] <> char '@' <> ppr r
+    ppr (UserTyVar n)     = ppr n
+    ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k]
 
 instance (Outputable thing) => Outputable (HsWithBndrs thing) where
     ppr (HsWB { hswb_cts = ty }) = ppr ty
@@ -636,7 +631,6 @@ ppr_mono_ty _    (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys)
                     HsUnboxedTuple -> UnboxedTuple
                     _              -> BoxedTuple
 ppr_mono_ty _    (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> ppr kind)
-ppr_mono_ty _    (HsRoleAnnot ty r)  = ppr ty <> char '@' <> ppr r
 ppr_mono_ty _    (HsListTy ty)       = brackets (ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty _    (HsPArrTy ty)       = paBrackets (ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty prec (HsIParamTy n ty)   = maybeParen prec pREC_FUN (ppr n <+> dcolon <+> ppr_mono_lty pREC_TOP ty)
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 267b2cac0e..0c4657534e 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -271,7 +271,7 @@ mkHsString s = HsString (mkFastString s)
 -------------
 userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)]
 -- Caller sets location
-userHsTyVarBndrs loc bndrs = [ L loc (HsTyVarBndr v Nothing Nothing) | v <- bndrs ]
+userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ]
 \end{code}
 
 
@@ -625,11 +625,11 @@ hsForeignDeclsBinders :: [LForeignDecl Name] -> [Name]
 hsForeignDeclsBinders foreign_decls
   = [n | L _ (ForeignImport (L _ n) _ _ _) <- foreign_decls]
 
-hsTyClDeclsBinders :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name]
+hsTyClDeclsBinders :: [TyClGroup Name] -> [Located (InstDecl Name)] -> [Name]
 -- We need to look at instance declarations too, 
 -- because their associated types may bind data constructors
 hsTyClDeclsBinders tycl_decls inst_decls
-  = map unLoc (concatMap (concatMap hsLTyClDeclBinders) tycl_decls ++
+  = map unLoc (concatMap (concatMap hsLTyClDeclBinders . group_tyclds) tycl_decls ++
                concatMap (hsInstDeclBinders . unLoc) inst_decls)
 
 -------------------