Change role annotation syntax.
authorRichard Eisenberg <eir@cis.upenn.edu>
Wed, 11 Sep 2013 04:52:56 +0000 (00:52 -0400)
committerRichard Eisenberg <eir@cis.upenn.edu>
Wed, 18 Sep 2013 01:37:23 +0000 (21:37 -0400)
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.

27 files changed:
compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsDecls.lhs
compiler/hsSyn/HsTypes.lhs
compiler/hsSyn/HsUtils.lhs
compiler/iface/IfaceSyn.lhs
compiler/iface/IfaceType.lhs
compiler/parser/Lexer.x
compiler/parser/Parser.y.pp
compiler/parser/ParserCore.y
compiler/parser/RdrHsSyn.lhs
compiler/rename/RnEnv.lhs
compiler/rename/RnNames.lhs
compiler/rename/RnSource.lhs
compiler/rename/RnTypes.lhs
compiler/typecheck/TcHsType.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcSplice.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/typecheck/TcTyDecls.lhs
compiler/types/CoAxiom.lhs
compiler/types/Coercion.lhs
compiler/types/TyCon.lhs
docs/users_guide/glasgow_exts.xml
docs/users_guide/separate_compilation.xml
utils/ghctags/Main.hs

index 218b00e..96cc568 100644 (file)
@@ -122,13 +122,14 @@ repTopDs group
         decls <- addBinds ss (do {
                         fix_ds  <- mapM repFixD (hs_fixds group) ;
                         val_ds  <- rep_val_binds (hs_valds group) ;
-                        tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ;
+                        tycl_ds <- mapM repTyClD (tyClGroupConcat (hs_tyclds group)) ;
+                        role_ds <- mapM repRoleD (concatMap group_roles (hs_tyclds group)) ;
                         inst_ds <- mapM repInstD (hs_instds group) ;
                         rule_ds <- mapM repRuleD (hs_ruleds group) ;
                         for_ds  <- mapM repForD  (hs_fords group) ;
                         -- more needed
                         return (de_loc $ sort_by_loc $
-                                val_ds ++ catMaybes tycl_ds ++ fix_ds
+                                val_ds ++ catMaybes tycl_ds ++ role_ds ++ fix_ds
                                        ++ inst_ds ++ rule_ds ++ for_ds) }) ;
 
         decl_ty <- lookupType decQTyConName ;
@@ -235,6 +236,15 @@ repTyClD (L loc d) = putSrcSpanDs loc $
                         ; return Nothing }
 
 -------------------------
+repRoleD :: LRoleAnnotDecl Name -> DsM (SrcSpan, Core TH.DecQ)
+repRoleD (L loc (RoleAnnotDecl tycon roles))
+  = do { tycon1 <- lookupLOcc tycon
+       ; roles1 <- mapM repRole roles
+       ; roles2 <- coreList roleTyConName roles1
+       ; dec <- repRoleAnnotD tycon1 roles2
+       ; return (loc, dec) }
+
+-------------------------
 repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr]
             -> Maybe (Core [TH.TypeQ])
             -> [Name] -> HsDataDefn Name
@@ -305,7 +315,7 @@ mk_extra_tvs tc tvs defn
       = do { uniq <- newUnique
            ; let { occ = mkTyVarOccFS (fsLit "t")
                  ; nm = mkInternalName uniq occ loc
-                 ; hs_tv = L loc (HsTyVarBndr nm (Just kind) Nothing) }
+                 ; hs_tv = L loc (KindedTyVar nm kind) }
            ; hs_tvs <- go rest
            ; return (hs_tv : hs_tvs) }
 
@@ -730,16 +740,10 @@ addTyClTyVarBinds tvs m
 --
 repTyVarBndrWithKind :: LHsTyVarBndr Name
                      -> Core TH.Name -> DsM (Core TH.TyVarBndr)
-repTyVarBndrWithKind (L _ (HsTyVarBndr _ Nothing Nothing)) nm
+repTyVarBndrWithKind (L _ (UserTyVar _)) nm
   = repPlainTV nm
-repTyVarBndrWithKind (L _ (HsTyVarBndr _ (Just ki) Nothing)) nm
+repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
   = repLKind ki >>= repKindedTV nm
-repTyVarBndrWithKind (L _ (HsTyVarBndr _ Nothing (Just r))) nm
-  = repRole r >>= repRoledTV nm
-repTyVarBndrWithKind (L _ (HsTyVarBndr _ (Just ki) (Just r))) nm
-  = do { ki' <- repLKind ki
-       ; r'  <- repRole r
-       ; repKindedRoledTV nm ki' r' }
 
 -- represent a type context
 --
@@ -883,10 +887,11 @@ repNonArrowKind (HsTupleTy _ ks)    = do  { ks' <- mapM repLKind ks
                                           }
 repNonArrowKind k                   = notHandled "Exotic form of kind" (ppr k)
 
-repRole :: Role -> DsM (Core TH.Role)
-repRole Nominal          = rep2 nominalName []
-repRole Representational = rep2 representationalName []
-repRole Phantom          = rep2 phantomName []
+repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
+repRole (L _ (Just Nominal))          = rep2 nominalRName []
+repRole (L _ (Just Representational)) = rep2 representationalRName []
+repRole (L _ (Just Phantom))          = rep2 phantomRName []
+repRole (L _ Nothing)                 = rep2 inferRName []
 
 -----------------------------------------------------------------------------
 --              Splices
@@ -1748,6 +1753,9 @@ repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
 repTySynEqn (MkC lhs) (MkC rhs)
   = rep2 tySynEqnName [lhs, rhs]
 
+repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ)
+repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]
+
 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
 
@@ -1854,13 +1862,6 @@ repPlainTV (MkC nm) = rep2 plainTVName [nm]
 repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)
 repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
 
-repRoledTV :: Core TH.Name -> Core TH.Role -> DsM (Core TH.TyVarBndr)
-repRoledTV (MkC nm) (MkC r) = rep2 roledTVName [nm, r]
-
-repKindedRoledTV :: Core TH.Name -> Core TH.Kind -> Core TH.Role
-                 -> DsM (Core TH.TyVarBndr)
-repKindedRoledTV (MkC nm) (MkC k) (MkC r) = rep2 kindedRoledTVName [nm, k, r]
-
 repKVar :: Core TH.Name -> DsM (Core TH.Kind)
 repKVar (MkC s) = rep2 varKName [s]
 
@@ -2055,6 +2056,7 @@ templateHaskellNames = [
     familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
     tySynInstDName, closedTypeFamilyKindDName, closedTypeFamilyNoKindDName,
     infixLDName, infixRDName, infixNDName,
+    roleAnnotDName,
     -- Cxt
     cxtName,
     -- Pred
@@ -2074,9 +2076,9 @@ templateHaskellNames = [
     -- TyLit
     numTyLitName, strTyLitName,
     -- TyVarBndr
-    plainTVName, kindedTVName, roledTVName, kindedRoledTVName,
+    plainTVName, kindedTVName,
     -- Role
-    nominalName, representationalName, phantomName,
+    nominalRName, representationalRName, phantomRName, inferRName,
     -- Kind
     varKName, conKName, tupleKName, arrowKName, listKName, appKName,
     starKName, constraintKName,
@@ -2109,6 +2111,7 @@ templateHaskellNames = [
     typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
     patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
     predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,
+    roleTyConName,
 
     -- Quasiquoting
     quoteDecName, quoteTypeName, quoteExpName, quotePatName]
@@ -2270,7 +2273,7 @@ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
     pragSpecInlDName, pragSpecInstDName, pragRuleDName, familyNoKindDName,
     familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName,
     closedTypeFamilyKindDName, closedTypeFamilyNoKindDName,
-    infixLDName, infixRDName, infixNDName :: Name
+    infixLDName, infixRDName, infixNDName, roleAnnotDName :: Name
 funDName          = libFun (fsLit "funD")          funDIdKey
 valDName          = libFun (fsLit "valD")          valDIdKey
 dataDName         = libFun (fsLit "dataD")         dataDIdKey
@@ -2297,6 +2300,7 @@ closedTypeFamilyNoKindDName
 infixLDName       = libFun (fsLit "infixLD")       infixLDIdKey
 infixRDName       = libFun (fsLit "infixRD")       infixRDIdKey
 infixNDName       = libFun (fsLit "infixND")       infixNDIdKey
+roleAnnotDName    = libFun (fsLit "roleAnnotD")    roleAnnotDIdKey
 
 -- type Ctxt = ...
 cxtName :: Name
@@ -2354,17 +2358,16 @@ numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey
 strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey
 
 -- data TyVarBndr = ...
-plainTVName, kindedTVName, roledTVName, kindedRoledTVName :: Name
+plainTVName, kindedTVName :: Name
 plainTVName       = libFun (fsLit "plainTV")       plainTVIdKey
 kindedTVName      = libFun (fsLit "kindedTV")      kindedTVIdKey
-roledTVName       = libFun (fsLit "roledTV")       roledTVIdKey
-kindedRoledTVName = libFun (fsLit "kindedRoledTV") kindedRoledTVIdKey
 
 -- data Role = ...
-nominalName, representationalName, phantomName :: Name
-nominalName          = libFun (fsLit "nominal")          nominalIdKey
-representationalName = libFun (fsLit "representational") representationalIdKey
-phantomName          = libFun (fsLit "phantom")          phantomIdKey
+nominalRName, representationalRName, phantomRName, inferRName :: Name
+nominalRName          = libFun (fsLit "nominalR")          nominalRIdKey
+representationalRName = libFun (fsLit "representationalR") representationalRIdKey
+phantomRName          = libFun (fsLit "phantomR")          phantomRIdKey
+inferRName            = libFun (fsLit "inferR")            inferRIdKey
 
 -- data Kind = ...
 varKName, conKName, tupleKName, arrowKName, listKName, appKName,
@@ -2428,7 +2431,7 @@ matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
     decQTyConName, conQTyConName, strictTypeQTyConName,
     varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
     patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,
-    ruleBndrQTyConName, tySynEqnQTyConName :: Name
+    ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName :: Name
 matchQTyConName         = libTc (fsLit "MatchQ")         matchQTyConKey
 clauseQTyConName        = libTc (fsLit "ClauseQ")        clauseQTyConKey
 expQTyConName           = libTc (fsLit "ExpQ")           expQTyConKey
@@ -2445,6 +2448,7 @@ fieldPatQTyConName      = libTc (fsLit "FieldPatQ")      fieldPatQTyConKey
 predQTyConName          = libTc (fsLit "PredQ")          predQTyConKey
 ruleBndrQTyConName      = libTc (fsLit "RuleBndrQ")      ruleBndrQTyConKey
 tySynEqnQTyConName      = libTc (fsLit "TySynEqnQ")      tySynEqnQTyConKey
+roleTyConName           = libTc (fsLit "Role")           roleTyConKey
 
 -- quasiquoting
 quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
@@ -2462,7 +2466,8 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
     decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
     fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
     fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
-    predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey :: Unique
+    predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey,
+    roleTyConKey :: Unique
 expTyConKey             = mkPreludeTyConUnique 200
 matchTyConKey           = mkPreludeTyConUnique 201
 clauseTyConKey          = mkPreludeTyConUnique 202
@@ -2492,6 +2497,7 @@ tyVarBndrTyConKey       = mkPreludeTyConUnique 225
 decsQTyConKey           = mkPreludeTyConUnique 226
 ruleBndrQTyConKey       = mkPreludeTyConUnique 227
 tySynEqnQTyConKey       = mkPreludeTyConUnique 228
+roleTyConKey            = mkPreludeTyConUnique 229
 
 -- IdUniques available: 200-499
 -- If you want to change this, make sure you check in PrelNames
@@ -2619,7 +2625,7 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
     familyNoKindDIdKey, familyKindDIdKey,
     dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey,
     closedTypeFamilyKindDIdKey, closedTypeFamilyNoKindDIdKey,
-    infixLDIdKey, infixRDIdKey, infixNDIdKey :: Unique
+    infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey :: Unique
 funDIdKey                    = mkPreludeMiscIdUnique 330
 valDIdKey                    = mkPreludeMiscIdUnique 331
 dataDIdKey                   = mkPreludeMiscIdUnique 332
@@ -2632,8 +2638,8 @@ forImpDIdKey                 = mkPreludeMiscIdUnique 338
 pragInlDIdKey                = mkPreludeMiscIdUnique 339
 pragSpecDIdKey               = mkPreludeMiscIdUnique 340
 pragSpecInlDIdKey            = mkPreludeMiscIdUnique 341
-pragSpecInstDIdKey           = mkPreludeMiscIdUnique 416
-pragRuleDIdKey               = mkPreludeMiscIdUnique 417
+pragSpecInstDIdKey           = mkPreludeMiscIdUnique 417
+pragRuleDIdKey               = mkPreludeMiscIdUnique 418
 familyNoKindDIdKey           = mkPreludeMiscIdUnique 342
 familyKindDIdKey             = mkPreludeMiscIdUnique 343
 dataInstDIdKey               = mkPreludeMiscIdUnique 344
@@ -2644,6 +2650,7 @@ closedTypeFamilyNoKindDIdKey = mkPreludeMiscIdUnique 348
 infixLDIdKey                 = mkPreludeMiscIdUnique 349
 infixRDIdKey                 = mkPreludeMiscIdUnique 350
 infixNDIdKey                 = mkPreludeMiscIdUnique 351
+roleAnnotDIdKey              = mkPreludeMiscIdUnique 352
 
 -- type Cxt = ...
 cxtIdKey :: Unique
@@ -2701,40 +2708,39 @@ numTyLitIdKey = mkPreludeMiscIdUnique 394
 strTyLitIdKey = mkPreludeMiscIdUnique 395
 
 -- data TyVarBndr = ...
-plainTVIdKey, kindedTVIdKey, roledTVIdKey, kindedRoledTVIdKey :: Unique
+plainTVIdKey, kindedTVIdKey :: Unique
 plainTVIdKey       = mkPreludeMiscIdUnique 396
 kindedTVIdKey      = mkPreludeMiscIdUnique 397
-roledTVIdKey       = mkPreludeMiscIdUnique 398
-kindedRoledTVIdKey = mkPreludeMiscIdUnique 399
 
 -- data Role = ...
-nominalIdKey, representationalIdKey, phantomIdKey :: Unique
-nominalIdKey          = mkPreludeMiscIdUnique 400
-representationalIdKey = mkPreludeMiscIdUnique 401
-phantomIdKey          = mkPreludeMiscIdUnique 402
+nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique
+nominalRIdKey          = mkPreludeMiscIdUnique 400
+representationalRIdKey = mkPreludeMiscIdUnique 401
+phantomRIdKey          = mkPreludeMiscIdUnique 402
+inferRIdKey            = mkPreludeMiscIdUnique 403
 
 -- data Kind = ...
 varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey,
   starKIdKey, constraintKIdKey :: Unique
-varKIdKey         = mkPreludeMiscIdUnique 403
-conKIdKey         = mkPreludeMiscIdUnique 404
-tupleKIdKey       = mkPreludeMiscIdUnique 405
-arrowKIdKey       = mkPreludeMiscIdUnique 406
-listKIdKey        = mkPreludeMiscIdUnique 407
-appKIdKey         = mkPreludeMiscIdUnique 408
-starKIdKey        = mkPreludeMiscIdUnique 409
-constraintKIdKey  = mkPreludeMiscIdUnique 410
+varKIdKey         = mkPreludeMiscIdUnique 404
+conKIdKey         = mkPreludeMiscIdUnique 405
+tupleKIdKey       = mkPreludeMiscIdUnique 406
+arrowKIdKey       = mkPreludeMiscIdUnique 407
+listKIdKey        = mkPreludeMiscIdUnique 408
+appKIdKey         = mkPreludeMiscIdUnique 409
+starKIdKey        = mkPreludeMiscIdUnique 410
+constraintKIdKey  = mkPreludeMiscIdUnique 411
 
 -- data Callconv = ...
 cCallIdKey, stdCallIdKey :: Unique
-cCallIdKey      = mkPreludeMiscIdUnique 411
-stdCallIdKey    = mkPreludeMiscIdUnique 412
+cCallIdKey      = mkPreludeMiscIdUnique 412
+stdCallIdKey    = mkPreludeMiscIdUnique 413
 
 -- data Safety = ...
 unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique
-unsafeIdKey        = mkPreludeMiscIdUnique 413
-safeIdKey          = mkPreludeMiscIdUnique 414
-interruptibleIdKey = mkPreludeMiscIdUnique 415
+unsafeIdKey        = mkPreludeMiscIdUnique 414
+safeIdKey          = mkPreludeMiscIdUnique 415
+interruptibleIdKey = mkPreludeMiscIdUnique 416
 
 -- data Inline = ...
 noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique
@@ -2755,25 +2761,25 @@ beforePhaseDataConKey = mkPreludeDataConUnique 47
 
 -- data FunDep = ...
 funDepIdKey :: Unique
-funDepIdKey = mkPreludeMiscIdUnique 418
+funDepIdKey = mkPreludeMiscIdUnique 419
 
 -- data FamFlavour = ...
 typeFamIdKey, dataFamIdKey :: Unique
-typeFamIdKey = mkPreludeMiscIdUnique 419
-dataFamIdKey = mkPreludeMiscIdUnique 420
+typeFamIdKey = mkPreludeMiscIdUnique 420
+dataFamIdKey = mkPreludeMiscIdUnique 421
 
 -- data TySynEqn = ...
 tySynEqnIdKey :: Unique
-tySynEqnIdKey = mkPreludeMiscIdUnique 421
+tySynEqnIdKey = mkPreludeMiscIdUnique 422
 
 -- quasiquoting
 quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique
-quoteExpKey  = mkPreludeMiscIdUnique 422
-quotePatKey  = mkPreludeMiscIdUnique 423
-quoteDecKey  = mkPreludeMiscIdUnique 424
-quoteTypeKey = mkPreludeMiscIdUnique 425
+quoteExpKey  = mkPreludeMiscIdUnique 423
+quotePatKey  = mkPreludeMiscIdUnique 424
+quoteDecKey  = mkPreludeMiscIdUnique 425
+quoteTypeKey = mkPreludeMiscIdUnique 426
 
 -- data RuleBndr = ...
 ruleVarIdKey, typedRuleVarIdKey :: Unique
-ruleVarIdKey      = mkPreludeMiscIdUnique 426
-typedRuleVarIdKey = mkPreludeMiscIdUnique 427
+ruleVarIdKey      = mkPreludeMiscIdUnique 427
+typedRuleVarIdKey = mkPreludeMiscIdUnique 428
index 8a4f7d8..616e05c 100644 (file)
@@ -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' }
index ee4b0fa..fe59763 100644 (file)
@@ -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
index 485cfc1..dc44250 100644 (file)
@@ -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)
index 267b2ca..0c46575 100644 (file)
@@ -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)
 
 -------------------
index e162cc3..c82973f 100644 (file)
@@ -31,7 +31,7 @@ module IfaceSyn (
         freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,
 
         -- Pretty printing
-        pprIfaceExpr, pprIfaceDeclHead
+        pprIfaceExpr
     ) where
 
 #include "HsVersions.h"
@@ -1010,20 +1010,19 @@ pprIfaceDecl (IfaceForeign {ifName = tycon})
 
 pprIfaceDecl (IfaceSyn {ifName = tycon,
                         ifTyVars = tyvars,
-                        ifRoles = roles,
                         ifSynRhs = IfaceSynonymTyCon mono_ty})
-  = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars roles)
+  = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars)
        4 (vcat [equals <+> ppr mono_ty])
 
-pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifRoles = roles,
+pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
                         ifSynRhs = IfaceOpenSynFamilyTyCon, ifSynKind = kind })
-  = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars roles)
+  = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars)
        4 (dcolon <+> ppr kind)
 
 -- this case handles both abstract and instantiated closed family tycons
-pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifRoles = roles,
+pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
                         ifSynRhs = _closedSynFamilyTyCon, ifSynKind = kind })
-  = hang (ptext (sLit "closed type family") <+> pprIfaceDeclHead [] tycon tyvars roles)
+  = hang (ptext (sLit "closed type family") <+> pprIfaceDeclHead [] tycon tyvars)
        4 (dcolon <+> ppr kind)
 
 pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType,
@@ -1031,8 +1030,9 @@ pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType,
                          ifTyVars = tyvars, ifRoles = roles, ifCons = condecls,
                          ifRec = isrec, ifPromotable = is_prom,
                          ifAxiom = mbAxiom})
-  = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars roles)
+  = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
        4 (vcat [ pprCType cType
+               , pprRoles roles
                , pprRec isrec <> comma <+> pp_prom 
                , pp_condecls tycon condecls
                , pprAxiom mbAxiom])
@@ -1048,8 +1048,9 @@ pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType,
 pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
                           ifRoles = roles, ifFDs = fds, ifATs = ats, ifSigs = sigs,
                           ifRec = isrec})
-  = hang (ptext (sLit "class") <+> pprIfaceDeclHead context clas tyvars roles <+> pprFundeps fds)
-       4 (vcat [pprRec isrec,
+  = hang (ptext (sLit "class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
+       4 (vcat [pprRoles roles,
+                pprRec isrec,
                 sep (map ppr ats),
                 sep (map ppr sigs)])
 
@@ -1061,6 +1062,10 @@ pprCType :: Maybe CType -> SDoc
 pprCType Nothing = ptext (sLit "No C type associated")
 pprCType (Just cType) = ptext (sLit "C type:") <+> ppr cType
 
+pprRoles :: [Role] -> SDoc
+pprRoles []    = empty
+pprRoles roles = text "Roles:" <+> ppr roles
+
 pprRec :: RecFlag -> SDoc
 pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec
 
@@ -1074,10 +1079,10 @@ instance Outputable IfaceClassOp where
 instance Outputable IfaceAT where
    ppr (IfaceAT d defs) = hang (ppr d) 2 (vcat (map ppr defs))
 
-pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> [Role] -> SDoc
-pprIfaceDeclHead context thing tyvars roles
+pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
+pprIfaceDeclHead context thing tyvars
   = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing),
-          pprIfaceTvBndrsRoles tyvars roles]
+          pprIfaceTvBndrs tyvars]
 
 pp_condecls :: OccName -> IfaceConDecls -> SDoc
 pp_condecls _  (IfAbstractTyCon {}) = empty
index fc05aa5..822e3da 100644 (file)
@@ -23,7 +23,7 @@ module IfaceType (
 
         -- Printing
         pprIfaceType, pprParendIfaceType, pprIfaceContext,
-        pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, pprIfaceTvBndrsRoles,
+        pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs,
         pprIfaceBndrs,
         tOP_PREC, tYCON_PREC, noParens, maybeParen, pprIfaceForAllPart,
         pprIfaceCoercion, pprParendIfaceCoercion
@@ -187,11 +187,6 @@ pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind)
 pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc
 pprIfaceTvBndrs tyvars = sep (map pprIfaceTvBndr tyvars)
 
-pprIfaceTvBndrsRoles :: [IfaceTvBndr] -> [Role] -> SDoc
-pprIfaceTvBndrsRoles tyvars roles = sep (zipWith ppr_bndr_role tyvars roles)
-  where
-    ppr_bndr_role bndr role = pprIfaceTvBndr bndr <> char '@' <> ppr role
-
 instance Binary IfaceBndr where
     put_ bh (IfaceIdBndr aa) = do
             putByte bh 0
@@ -357,7 +352,11 @@ ppr_special_co ctxt_prec doc cos
                (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))])
 
 ppr_role :: Role -> SDoc
-ppr_role r = underscore <> ppr r
+ppr_role r = underscore <> pp_role
+  where pp_role = case r of
+                    Nominal          -> char 'N'
+                    Representational -> char 'R'
+                    Phantom          -> char 'P'
 
 -------------------
 instance Outputable IfaceTyCon where
index 12389e7..344281a 100644 (file)
@@ -364,14 +364,14 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
   @qual @varid                  { idtoken qvarid }
   @qual @conid                  { idtoken qconid }
   @varid                        { varid }
-  @conid                        { conid }
+  @conid                        { idtoken conid }
 }
 
 <0> {
   @qual @varid "#"+ / { ifExtension magicHashEnabled } { idtoken qvarid }
   @qual @conid "#"+ / { ifExtension magicHashEnabled } { idtoken qconid }
   @varid "#"+       / { ifExtension magicHashEnabled } { varid }
-  @conid "#"+       / { ifExtension magicHashEnabled } { conid }
+  @conid "#"+       / { ifExtension magicHashEnabled } { idtoken conid }
 }
 
 -- ToDo: - move `var` and (sym) into lexical syntax?
@@ -475,12 +475,10 @@ data Token
   | ITjavascriptcallconv
   | ITmdo
   | ITfamily
+  | ITrole
   | ITgroup
   | ITby
   | ITusing
-  | ITnominal
-  | ITrepresentational
-  | ITphantom
 
   -- Pragmas
   | ITinline_prag InlineSpec RuleMatchInfo
@@ -652,7 +650,9 @@ reservedWordsFM = listToUFM $
          ( "forall",         ITforall,        bit explicitForallBit .|.
                                               bit inRulePragBit),
          ( "mdo",            ITmdo,           bit recursiveDoBit),
-         ( "family",         ITfamily,        bit tyFamBit),
+             -- See Note [Lexing type pseudo-keywords]
+         ( "family",         ITfamily,        0 ),
+         ( "role",           ITrole,          0 ),
          ( "group",          ITgroup,         bit transformComprehensionsBit),
          ( "by",             ITby,            bit transformComprehensionsBit),
          ( "using",          ITusing,         bit transformComprehensionsBit),
@@ -676,13 +676,22 @@ reservedWordsFM = listToUFM $
          ( "proc",           ITproc,          bit arrowsBit)
      ]
 
-reservedUpcaseWordsFM :: UniqFM (Token, Int)
-reservedUpcaseWordsFM = listToUFM $
-    map (\(x, y, z) -> (mkFastString x, (y, z)))
-       [ ( "N",     ITnominal,          0 ), -- no extension bit for better error msgs
-         ( "R",     ITrepresentational, 0 ),
-         ( "P",     ITphantom,          0 )
-       ]
+{-----------------------------------
+Note [Lexing type pseudo-keywords]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+One might think that we wish to treat 'family' and 'role' as regular old
+varids whenever -XTypeFamilies and -XRoleAnnotations are off, respectively.
+But, there is no need to do so. These pseudo-keywords are not stolen syntax:
+they are only used after the keyword 'type' at the top-level, where varids are
+not allowed. Furthermore, checks further downstream (TcTyClsDecls) ensure that
+type families and role annotations are never declared without their extensions
+on. In fact, by unconditionally lexing these pseudo-keywords as special, we
+can get better error messages.
+
+Also, note that these are included in the `varid` production in the parser --
+a key detail to make all this work.
+-------------------------------------}
 
 reservedSymsFM :: UniqFM (Token, Int -> Bool)
 reservedSymsFM = listToUFM $
@@ -1028,20 +1037,8 @@ varid span buf len =
   where
     !fs = lexemeToFastString buf len
 
-conid :: Action
-conid span buf len =
-  case lookupUFM reservedUpcaseWordsFM fs of
-    Just (keyword, 0) -> return $ L span keyword
-
-    Just (keyword, exts) -> do
-      extsEnabled <- extension $ \i -> exts .&. i /= 0
-      if extsEnabled
-        then return $ L span keyword
-        else return $ L span $ ITconid fs
-
-    Nothing -> return $ L span $ ITconid fs
-  where
-    !fs = lexemeToFastString buf len
+conid :: StringBuffer -> Int -> Token
+conid buf len = ITconid $! lexemeToFastString buf len
 
 qvarsym, qconsym, prefixqvarsym, prefixqconsym :: StringBuffer -> Int -> Token
 qvarsym buf len = ITqvarsym $! splitQualName buf len False
@@ -1856,8 +1853,7 @@ explicitForallBit = 7 -- the 'forall' keyword and '.' symbol
 bangPatBit :: Int
 bangPatBit = 8  -- Tells the parser to understand bang-patterns
                 -- (doesn't affect the lexer)
-tyFamBit :: Int
-tyFamBit = 9    -- indexed type families: 'family' keyword and kind sigs
+-- Bit #9 is available!
 haddockBit :: Int
 haddockBit = 10 -- Lex and parse Haddock comments
 magicHashBit :: Int
@@ -1902,6 +1898,7 @@ lambdaCaseBit :: Int
 lambdaCaseBit = 30
 negativeLiteralsBit :: Int
 negativeLiteralsBit = 31
+-- need another bit? See bit 9 above.
 
 
 always :: Int -> Bool
@@ -1918,8 +1915,6 @@ explicitForallEnabled :: Int -> Bool
 explicitForallEnabled flags = testBit flags explicitForallBit
 bangPatEnabled :: Int -> Bool
 bangPatEnabled   flags = testBit flags bangPatBit
--- tyFamEnabled :: Int -> Bool
--- tyFamEnabled     flags = testBit flags tyFamBit
 haddockEnabled :: Int -> Bool
 haddockEnabled   flags = testBit flags haddockBit
 magicHashEnabled :: Int -> Bool
@@ -2001,7 +1996,6 @@ mkPState flags buf loc =
                .|. ipBit                       `setBitIf` xopt Opt_ImplicitParams           flags
                .|. explicitForallBit           `setBitIf` xopt Opt_ExplicitForAll           flags
                .|. bangPatBit                  `setBitIf` xopt Opt_BangPatterns             flags
-               .|. tyFamBit                    `setBitIf` xopt Opt_TypeFamilies             flags
                .|. haddockBit                  `setBitIf` gopt Opt_Haddock                  flags
                .|. magicHashBit                `setBitIf` xopt Opt_MagicHash                flags
                .|. kindSigsBit                 `setBitIf` xopt Opt_KindSignatures           flags
index f30072c..0ea48dd 100644 (file)
@@ -33,7 +33,6 @@ import Type             ( funTyCon )
 import ForeignCall
 import OccName          ( varName, dataName, tcClsName, tvName )
 import DataCon          ( DataCon, dataConName )
-import CoAxiom          ( Role(..) )
 import SrcLoc
 import Module
 import Kind             ( Kind, liftedTypeKind, unliftedTypeKind, mkArrowKind )
@@ -239,6 +238,7 @@ incorrect.
  'unsafe'       { L _ ITunsafe }
  'mdo'          { L _ ITmdo }
  'family'       { L _ ITfamily }
+ 'role'         { L _ ITrole }
  'stdcall'      { L _ ITstdcallconv }
  'ccall'        { L _ ITccallconv }
  'capi'         { L _ ITcapiconv }
@@ -249,9 +249,6 @@ incorrect.
  'group'    { L _ ITgroup }     -- for list transform extension
  'by'       { L _ ITby }        -- for list transform extension
  'using'    { L _ ITusing }     -- for list transform extension
- 'N'        { L _ ITnominal }            -- Nominal role
- 'R'        { L _ ITrepresentational }   -- Representational role
- 'P'        { L _ ITphantom }            -- Phantom role
 
  '{-# INLINE'             { L _ (ITinline_prag _ _) }
  '{-# SPECIALISE'         { L _ ITspec_prag }
@@ -574,6 +571,7 @@ topdecl :: { OrdList (LHsDecl RdrName) }
         | ty_decl                               { unitOL (L1 (TyClD (unLoc $1))) }
         | inst_decl                             { unitOL (L1 (InstD (unLoc $1))) }
         | stand_alone_deriving                  { unitOL (LL (DerivD (unLoc $1))) }
+        | role_annot                            { unitOL (L1 (RoleAnnotD (unLoc $1))) }
         | 'default' '(' comma_types0 ')'        { unitOL (LL $ DefD (DefaultDecl $3)) }
         | 'foreign' fdecl                       { unitOL (LL (unLoc $2)) }
         | '{-# DEPRECATED' deprecations '#-}'   { $2 }
@@ -784,6 +782,27 @@ stand_alone_deriving :: { LDerivDecl RdrName }
         : 'deriving' 'instance' inst_type { LL (DerivDecl $3) }
 
 -----------------------------------------------------------------------------
+-- Role annotations
+
+role_annot :: { LRoleAnnotDecl RdrName }
+role_annot : 'type' 'role' oqtycon maybe_roles
+              {% mkRoleAnnotDecl (comb3 $1 $3 $4) $3 (reverse (unLoc $4)) }
+
+-- Reversed!
+maybe_roles :: { Located [Located (Maybe FastString)] }
+maybe_roles : {- empty -}    { noLoc [] }
+            | roles          { $1 }
+
+roles :: { Located [Located (Maybe FastString)] }
+roles : role             { LL [$1] }
+      | roles role       { LL $ $2 : unLoc $1 }
+
+-- read it in as a varid for better error messages
+role :: { Located (Maybe FastString) }
+role : VARID             { L1 $ Just $ getVARID $1 }
+     | '_'               { L1 Nothing }
+
+-----------------------------------------------------------------------------
 -- Nested declarations
 
 -- Declaration in class bodies
@@ -1109,7 +1128,6 @@ atype :: { LHsType RdrName }
         | '[:' ctype ':]'                { LL $ HsPArrTy  $2 }
         | '(' ctype ')'                  { LL $ HsParTy   $2 }
         | '(' ctype '::' kind ')'        { LL $ HsKindSig $2 $4 }
-        | atype '@' role                 { LL $ HsRoleAnnot $1 (unLoc $3) }
         | quasiquote                     { L1 (HsQuasiQuoteTy (unLoc $1)) }
         | '$(' exp ')'                   { LL $ mkHsSpliceTy $2 }
         | TH_ID_SPLICE                   { LL $ mkHsSpliceTy $ L1 $ HsVar $
@@ -1147,8 +1165,8 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
          | {- empty -}                  { [] }
 
 tv_bndr :: { LHsTyVarBndr RdrName }
-        : tyvar                         { L1 (HsTyVarBndr (unLoc $1) Nothing Nothing) }
-        | '(' tyvar '::' kind ')'       { LL (HsTyVarBndr (unLoc $2) (Just $4) Nothing) }
+        : tyvar                         { L1 (UserTyVar (unLoc $1)) }
+        | '(' tyvar '::' kind ')'       { LL (KindedTyVar (unLoc $2) $4) }
 
 fds :: { Located [Located (FunDep RdrName)] }
         : {- empty -}                   { noLoc [] }
@@ -1166,11 +1184,6 @@ varids0 :: { Located [RdrName] }
         : {- empty -}                   { noLoc [] }
         | varids0 tyvar                 { LL (unLoc $2 : unLoc $1) }
 
-role :: { Located Role }
-          : 'N'                         { LL Nominal }
-          | 'R'                         { LL Representational }
-          | 'P'                         { LL Phantom }
-
 -----------------------------------------------------------------------------
 -- Kinds
 
@@ -1912,7 +1925,7 @@ qtycon :: { Located RdrName }   -- Qualified or unqualified
         | tycon                         { $1 }
 
 tycon   :: { Located RdrName }  -- Unqualified
-        : upcase_id                     { L1 $! mkUnqual tcClsName (unLoc $1) }
+        : CONID                         { L1 $! mkUnqual tcClsName (getCONID $1) }
 
 qtyconsym :: { Located RdrName }
         : QCONSYM                       { L1 $! mkQual tcClsName (getQCONSYM $1) }
@@ -1996,6 +2009,9 @@ qvarid :: { Located RdrName }
         | QVARID                { L1 $! mkQual varName (getQVARID $1) }
         | PREFIXQVARSYM         { L1 $! mkQual varName (getPREFIXQVARSYM $1) }
 
+-- Note that 'role' and 'family' get lexed separately regardless of
+-- the use of extensions. However, because they are listed here, this
+-- is OK and they can be used as normal varids.
 varid :: { Located RdrName }
         : VARID                 { L1 $! mkUnqual varName (getVARID $1) }
         | special_id            { L1 $! mkUnqual varName (unLoc $1) }
@@ -2004,6 +2020,7 @@ varid :: { Located RdrName }
         | 'interruptible'       { L1 $! mkUnqual varName (fsLit "interruptible") }
         | 'forall'              { L1 $! mkUnqual varName (fsLit "forall") }
         | 'family'              { L1 $! mkUnqual varName (fsLit "family") }
+        | 'role'                { L1 $! mkUnqual varName (fsLit "role") }
 
 qvarsym :: { Located RdrName }
         : varsym                { $1 }
@@ -2027,8 +2044,8 @@ varsym_no_minus :: { Located RdrName } -- varsym not including '-'
 
 -- These special_ids are treated as keywords in various places,
 -- but as ordinary ids elsewhere.   'special_id' collects all these
--- except 'unsafe', 'interruptible', 'forall', and 'family' whose treatment differs
--- depending on context
+-- except 'unsafe', 'interruptible', 'forall', 'family', and 'role',
+-- whose treatment differs depending on context
 special_id :: { Located FastString }
 special_id
         : 'as'                  { L1 (fsLit "as") }
@@ -2058,7 +2075,7 @@ qconid :: { Located RdrName }   -- Qualified or unqualified
         | PREFIXQCONSYM         { L1 $! mkQual dataName (getPREFIXQCONSYM $1) }
 
 conid   :: { Located RdrName }
-        : upcase_id             { L1 $ mkUnqual dataName (unLoc $1) }
+        : CONID                 { L1 $ mkUnqual dataName (getCONID $1) }
 
 qconsym :: { Located RdrName }  -- Qualified or unqualified
         : consym                { $1 }
@@ -2095,7 +2112,7 @@ close :: { () }
 -- Miscellaneous (mostly renamings)
 
 modid   :: { Located ModuleName }
-        : upcase_id             { L1 $ mkModuleNameFS (unLoc $1) }
+        : CONID                 { L1 $ mkModuleNameFS (getCONID $1) }
         | QCONID                { L1 $ let (mod,c) = getQCONID $1 in
                                   mkModuleNameFS
                                    (mkFastString
@@ -2106,12 +2123,6 @@ commas :: { Int }   -- One or more commas
         : commas ','                    { $1 + 1 }
         | ','                           { 1 }
 
-upcase_id :: { Located FastString }
-        : CONID                         { L1 $! getCONID $1 }
-        | 'N'                           { L1 (fsLit "N") }
-        | 'R'                           { L1 (fsLit "R") }
-        | 'P'                           { L1 (fsLit "P") }
-
 -----------------------------------------------------------------------------
 -- Documentation comments
 
index 2a4c957..bfd4dc7 100644 (file)
@@ -378,7 +378,7 @@ ifaceUnliftedTypeKind = ifaceTcType (IfaceTc unliftedTypeKindTyConName)
 ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
 
 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
-toHsTvBndr (tv,k) = noLoc $ HsTyVarBndr (mkRdrUnqual (mkTyVarOccFS tv)) (Just bsig) Nothing
+toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig
                   where
                     bsig = toHsKind k
 
index e925881..715af25 100644 (file)
@@ -8,6 +8,7 @@ module RdrHsSyn (
         mkHsOpApp,
         mkHsIntegral, mkHsFractional, mkHsIsString,
         mkHsDo, mkHsSplice, mkTopSpliceDecl,
+        mkRoleAnnotDecl,
         mkClassDecl, 
         mkTyData, mkFamInstData, 
         mkTySynonym, mkTyFamInstEqn,
@@ -56,6 +57,7 @@ module RdrHsSyn (
 
 import HsSyn            -- Lots of it
 import Class            ( FunDep )
+import CoAxiom          ( Role, fsFromRole )
 import RdrName          ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, 
                           isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace,
                           rdrNameSpace )
@@ -84,6 +86,8 @@ import Control.Monad
 import Text.ParserCombinators.ReadP as ReadP
 import Data.Char
 
+import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )
+
 #include "HsVersions.h"
 \end{code}
 
@@ -214,7 +218,6 @@ mkTopSpliceDecl (L _ (HsQuasiQuoteE qq))            = QuasiQuoteD qq
 mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr       Explicit)
 mkTopSpliceDecl other_expr                          = SpliceD (SpliceDecl other_expr Implicit)
 
-
 -- Ensure a type literal is used correctly; notably, we need the proper extension enabled,
 -- and if it's an integer literal, the literal must be >= 0. This can occur with
 -- -XNegativeLiterals enabled (see #8306)
@@ -227,11 +230,39 @@ mkTyLit lit = extension typeLiteralsEnabled >>= check
     check False =
       parseErrorSDoc (getLoc lit)
         (text "Illegal literal in type (use DataKinds to enable):" <+> ppr lit)
-
     check True  =
       if not (negLit lit) then return (HsTyLit `fmap` lit)
        else parseErrorSDoc (getLoc lit)
               (text "Illegal literal in type (type literals must not be negative):" <+> ppr lit)
+
+
+mkRoleAnnotDecl :: SrcSpan
+                -> Located RdrName                   -- type being annotated
+                -> [Located (Maybe FastString)]      -- roles
+                -> P (LRoleAnnotDecl RdrName)
+mkRoleAnnotDecl loc tycon roles
+  = do { roles' <- mapM parse_role roles
+       ; return $ L loc $ RoleAnnotDecl tycon roles' }
+  where
+    role_data_type = dataTypeOf (undefined :: Role)
+    all_roles = map fromConstr $ dataTypeConstrs role_data_type
+    possible_roles = [(fsFromRole role, role) | role <- all_roles]
+
+    parse_role (L loc_role Nothing) = return $ L loc_role Nothing
+    parse_role (L loc_role (Just role))
+      = case lookup role possible_roles of
+          Just found_role -> return $ L loc_role $ Just found_role
+          Nothing         ->
+            let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) in
+            parseErrorSDoc loc_role
+              (text "Illegal role name" <+> quotes (ppr role) $$
+               suggestions nearby)
+
+    suggestions []   = empty
+    suggestions [r]  = text "Perhaps you meant" <+> quotes (ppr r)
+      -- will this last case ever happen??
+    suggestions list = hang (text "Perhaps you meant one of these:")
+                       2 (pprWithCommas (quotes . ppr) list)
 \end{code}
 
 %************************************************************************
@@ -470,14 +501,10 @@ checkTyVars tycl_hdr tparms = do { tvs <- mapM chk tparms
                                  ; return (mkHsQTvs tvs) }
   where
         -- Check that the name space is correct!
-    chk (L l (HsRoleAnnot (L _ (HsKindSig (L _ (HsTyVar tv)) k)) r))
-        | isRdrTyVar tv    = return (L l (HsTyVarBndr tv (Just k) (Just r)))
     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
-        | isRdrTyVar tv    = return (L l (HsTyVarBndr tv (Just k) Nothing))
-    chk (L l (HsRoleAnnot (L _ (HsTyVar tv)) r))
-        | isRdrTyVar tv    = return (L l (HsTyVarBndr tv Nothing (Just r)))
+        | isRdrTyVar tv    = return (L l (KindedTyVar tv k))
     chk (L l (HsTyVar tv))
-        | isRdrTyVar tv    = return (L l (HsTyVarBndr tv Nothing Nothing))
+        | isRdrTyVar tv    = return (L l (UserTyVar tv))
     chk t@(L l _)
         = parseErrorSDoc l $
           vcat [ sep [ ptext (sLit "Unexpected type") <+> quotes (ppr t)
index 7eb896c..fdcdd95 100644 (file)
@@ -20,7 +20,8 @@ module RnEnv (
         greRdrName,
         lookupSubBndrGREs, lookupConstructorFields,
         lookupSyntaxName, lookupSyntaxNames, lookupIfThenElse,
-        lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe,
+        lookupGreRn, lookupGreRn_maybe,
+        lookupGlobalOccInThisModule, lookupGreLocalRn_maybe, 
         getLookupOccRn, addUsedRdrNames,
 
         newLocalBndrRn, newLocalBndrsRn,
@@ -219,7 +220,7 @@ lookupTopBndrRn_maybe rdr_name
                (do { op_ok <- xoptM Opt_TypeOperators
                    ; unless op_ok (addErr (opDeclErr rdr_name)) })
 
-        ; mb_gre <- lookupGreLocalRn rdr_name
+        ; mb_gre <- lookupGreLocalRn_maybe rdr_name
         ; case mb_gre of
                 Nothing  -> return Nothing
                 Just gre -> return (Just $ gre_name gre) }
@@ -680,13 +681,26 @@ lookupGreRn rdr_name
         ; return (GRE { gre_name = name, gre_par = NoParent,
                         gre_prov = LocalDef }) }}}
 
-lookupGreLocalRn :: RdrName -> RnM (Maybe GlobalRdrElt)
+lookupGreLocalRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)
 -- Similar, but restricted to locally-defined things
-lookupGreLocalRn rdr_name
+lookupGreLocalRn_maybe rdr_name
   = lookupGreRn_help rdr_name lookup_fn
   where
     lookup_fn env = filter isLocalGRE (lookupGRE_RdrName rdr_name env)
 
+lookupGlobalOccInThisModule :: RdrName -> RnM Name
+-- If not found, add error message
+lookupGlobalOccInThisModule rdr_name
+  | Just n <- isExact_maybe rdr_name
+  = do { n' <- lookupExactOcc n; return n' }
+
+  | otherwise
+  = do { mb_gre <- lookupGreLocalRn_maybe rdr_name
+       ; case mb_gre of
+           Just gre -> return $ gre_name gre
+           Nothing -> do { traceRn (text "lookupGlobalInThisModule" <+> ppr rdr_name)
+                         ; unboundName WL_LocalTop rdr_name } }
+
 lookupGreRn_help :: RdrName                     -- Only used in error message
                  -> (GlobalRdrEnv -> [GlobalRdrElt])    -- Lookup function
                  -> RnM (Maybe GlobalRdrElt)
index dcf9c4f..058dbb8 100644 (file)
@@ -490,7 +490,7 @@ getLocalNonValBinders fixity_env
                 hs_instds = inst_decls,
                 hs_fords  = foreign_decls })
   = do  { -- Process all type/class decls *except* family instances
-        ; tc_avails <- mapM new_tc (concat tycl_decls)
+        ; tc_avails <- mapM new_tc (tyClGroupConcat tycl_decls)
         ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env
         ; setEnvs envs $ do {
             -- Bring these things into scope first
index 6a80e05..190d690 100644 (file)
@@ -28,6 +28,7 @@ import ForeignCall      ( CCallTarget(..) )
 import Module
 import HscTypes         ( Warnings(..), plusWarns )
 import Class            ( FunDep )
+import PrelNames        ( isUnboundName )
 import Name
 import NameSet
 import NameEnv
@@ -39,13 +40,14 @@ import FastString
 import SrcLoc
 import DynFlags
 import HscTypes         ( HscEnv, hsc_dflags )
-import ListSetOps       ( findDupsEq )
+import ListSetOps       ( findDupsEq, removeDups )
 import Digraph          ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
+import Util             ( mapSnd )
 
 import Control.Monad
-import Data.List( partition )
+import Data.List( partition, sortBy )
 import Data.Traversable (traverse)
-import Maybes( orElse )
+import Maybes( orElse, mapMaybe )
 \end{code}
 
 @rnSourceDecl@ `renames' declarations.
@@ -862,11 +864,12 @@ isInPackage pkgId nm = case nameModule_maybe nm of
 -- there is no module name. In that case we cannot have mutual dependencies,
 -- so it's fine to return False here.
 
-rnTyClDecls :: [Name] -> [[LTyClDecl RdrName]]
-            -> RnM ([[LTyClDecl Name]], FreeVars)
+rnTyClDecls :: [Name] -> [TyClGroup RdrName]
+            -> RnM ([TyClGroup Name], FreeVars)
 -- Rename the declarations and do depedency analysis on them
 rnTyClDecls extra_deps tycl_ds
-  = do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (concat tycl_ds)
+  = do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupConcat tycl_ds)
+       ; role_annot_env <- rnRoleAnnots (concatMap group_roles tycl_ds)
        ; thisPkg  <- fmap thisPackage getDynFlags
        ; let add_boot_deps :: FreeVars -> FreeVars
              -- See Note [Extra dependencies from .hs-boot files]
@@ -875,16 +878,23 @@ rnTyClDecls extra_deps tycl_ds
                                | otherwise
                                = fvs
 
-             ds_w_fvs' = map (\(ds, fvs) -> (ds, add_boot_deps fvs)) ds_w_fvs
+             ds_w_fvs' = mapSnd add_boot_deps ds_w_fvs
 
              sccs :: [SCC (LTyClDecl Name)]
              sccs = depAnalTyClDecls ds_w_fvs'
 
              all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs'
 
+             raw_groups = map flattenSCC sccs
+             -- See Note [Role annotations in the renamer]
+             groups = [ TyClGroup { group_tyclds = gp
+                                  , group_roles = roles }
+                      | gp <- raw_groups
+                      , let roles = mapMaybe ( lookupNameEnv role_annot_env
+                                             . tcdName
+                                             . unLoc ) gp ]
        ; traceRn (text "rnTycl"  <+> (ppr ds_w_fvs $$ ppr sccs))
-       ; return (map flattenSCC sccs, all_fvs) }
-
+       ; return (groups, all_fvs) }
 
 rnTyClDecl :: TyClDecl RdrName 
            -> RnM (TyClDecl Name, FreeVars)
@@ -993,6 +1003,48 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls,
 rnTySyn :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
 rnTySyn doc rhs = rnLHsType doc rhs
 
+-- Renames role annotations, returning them as the values in a NameEnv
+-- and checks for duplicate role annotations.
+-- It is quite convenient to do both of these in the same place.
+-- See also Note [Role annotations in the renamer]
+rnRoleAnnots :: [LRoleAnnotDecl RdrName]
+                -> RnM (NameEnv (LRoleAnnotDecl Name))
+rnRoleAnnots role_annots
+  = do {  -- check for duplicates *before* renaming, to avoid lumping
+          -- together all the unboundNames
+         let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots
+             role_annots_cmp (L _ annot1) (L _ annot2)
+               = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2
+       ; mapM_ dupRoleAnnotErr dup_annots
+       ; role_annots' <- mapM (wrapLocM rn_role_annot1) no_dups
+          -- some of the role annots will be unbound; we don't wish
+          -- to include these
+       ; return $ mkNameEnv [ (name, ra)
+                            | ra <- role_annots'
+                            , let name = roleAnnotDeclName (unLoc ra)
+                            , not (isUnboundName name) ] }
+  where
+    rn_role_annot1 (RoleAnnotDecl tycon roles)
+      = do {  -- the name is an *occurrence*
+             tycon' <- wrapLocM lookupGlobalOccInThisModule tycon
+           ; return $ RoleAnnotDecl tycon' roles }
+
+dupRoleAnnotErr :: [LRoleAnnotDecl RdrName] -> RnM ()
+dupRoleAnnotErr [] = panic "dupRoleAnnotErr"
+dupRoleAnnotErr list
+  = addErrAt loc $
+    hang (text "Duplicate role annotations for" <+>
+          quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
+       2 (vcat $ map pp_role_annot sorted_list)
+    where
+      sorted_list = sortBy cmp_annot list
+      (L loc first_decl : _) = sorted_list
+    
+      pp_role_annot (L loc decl) = hang (ppr decl)
+                                      4 (text "-- written at" <+> ppr loc)
+
+      cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2
+
 rnDataDefn :: HsDocContext -> HsDataDefn RdrName -> RnM (HsDataDefn Name, FreeVars)
 rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
                            , dd_ctxt = context, dd_cons = condecls 
@@ -1119,6 +1171,24 @@ check T first, (fixing its kind) and *then* S.  If you do kind
 inference together, you might get an error reported in S, which
 is jolly confusing.  See Trac #4875
 
+Note [Role annotations in the renamer]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must ensure that a type's role annotation is put in the same group as the
+proper type declaration. This is because role annotations are needed during
+type-checking when creating the type's TyCon. So, rnRoleAnnots builds a
+NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that
+type, if any. Then, this map can be used to add the role annotations to the
+groups after dependency analysis.
+
+This process checks for duplicate role annotations, where we must be careful
+to filter out the unbound annotations to avoid reporting spurious duplicates.
+We hold off doing other checks until validity checking in the type checker.
+
+Also, note that the tycon in a role annotation is renamed with
+lookupGlobalInThisModule. We want only annotations for local declarations.
+Because all of these are in scope by this point, this renaming technique
+also effectively identifies any orphan role annotations. Annotations on
+declarations that don't support them is checked for in the type-checker.
 
 %*********************************************************
 %*                                                      *
@@ -1277,7 +1347,7 @@ For example:
 Get the mapping from constructors to fields for this module.
 It's convenient to do this after the data type decls have been renamed
 \begin{code}
-extendRecordFieldEnv :: [[LTyClDecl RdrName]] -> [LInstDecl RdrName] -> TcM TcGblEnv
+extendRecordFieldEnv :: [TyClGroup RdrName] -> [LInstDecl RdrName] -> TcM TcGblEnv
 extendRecordFieldEnv tycl_decls inst_decls
   = do  { tcg_env <- getGblEnv
         ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
@@ -1287,7 +1357,7 @@ extendRecordFieldEnv tycl_decls inst_decls
     --  (a) a datatype constructor
     --  (b) a record field
     -- knowing that they're from this module.
-    -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn,
+    -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn_maybe,
     -- which keeps only the local ones.
     lookup x = do { x' <- lookupLocatedTopBndrRn x
                     ; return $ unLoc x'}
@@ -1295,7 +1365,7 @@ extendRecordFieldEnv tycl_decls inst_decls
     all_data_cons :: [ConDecl RdrName]
     all_data_cons = [con | HsDataDefn { dd_cons = cons } <- all_ty_defs
                          , L _ con <- cons ]
-    all_ty_defs = [ defn | L _ (DataDecl { tcdDataDefn = defn }) <- concat tycl_decls ]
+    all_ty_defs = [ defn | L _ (DataDecl { tcdDataDefn = defn }) <- tyClGroupConcat tycl_decls ]
                ++ map dfid_defn (instDeclDataFamInsts inst_decls)  -- Do not forget associated types!
 
     get_con (ConDecl { con_name = con, con_details = RecCon flds })
@@ -1398,6 +1468,10 @@ add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
 add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
   = addl (gp { hs_valds = add_bind (L l d) ts }) ds
 
+-- Role annotations: added to the TyClGroup
+add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD d) ds
+  = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds
+
 -- The rest are routine
 add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
   = addl (gp { hs_instds = L l d : ts }) ds
@@ -1418,9 +1492,15 @@ add gp@(HsGroup {hs_vects  = ts}) l (VectD d) ds
 add gp l (DocD d) ds
   = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds
 
-add_tycld :: LTyClDecl a -> [[LTyClDecl a]] -> [[LTyClDecl a]]
-add_tycld d []       = [[d]]
-add_tycld d (ds:dss) = (d:ds) : dss
+add_tycld :: LTyClDecl a -> [TyClGroup a] -> [TyClGroup a]
+add_tycld d []       = [TyClGroup { group_tyclds = [d], group_roles = [] }]
+add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
+  = ds { group_tyclds = d : tyclds } : dss
+
+add_role_annot :: LRoleAnnotDecl a -> [TyClGroup a] -> [TyClGroup a]
+add_role_annot d [] = [TyClGroup { group_tyclds = [], group_roles = [d] }]
+add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
+  = tycls { group_roles = d : roles } : rest
 
 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
index 368d975..0412995 100644 (file)
@@ -213,9 +213,6 @@ rnHsTyKi isType doc (HsKindSig ty k)
        ; (k', fvs2) <- rnLHsKind doc k
        ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) }
 
-rnHsTyKi _ doc (HsRoleAnnot ty _) 
-  = illegalRoleAnnotDoc doc ty >> failM
-
 rnHsTyKi isType doc (HsPArrTy ty)
   = ASSERT( isType )
     do { (ty', fvs) <- rnLHsType doc ty
@@ -365,7 +362,7 @@ bindHsTyVars :: HsDocContext
 bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
   = do { rdr_env <- getLocalRdrEnv
        ; let tvs = hsQTvBndrs tv_bndrs
-             kvs_from_tv_bndrs = [ kv | L _ (HsTyVarBndr _ (Just kind) _) <- tvs
+             kvs_from_tv_bndrs = [ kv | L _ (KindedTyVar _ kind) <- tvs
                                  , let (_, kvs) = extractHsTyRdrTyVars kind
                                  , kv <- kvs ]
              all_kvs = filterOut (`elemLocalRdrEnv` rdr_env) $
@@ -387,19 +384,15 @@ bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
     do { let tv_names_w_loc = hsLTyVarLocNames tv_bndrs
 
              rn_tv_bndr :: LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars)
-             rn_tv_bndr (L loc (HsTyVarBndr name mkind mrole))
-               = do { ksig_ok <- xoptM Opt_KindSignatures
-                    ; unless ksig_ok $
-                      whenIsJust mkind $ \k -> badSigErr False doc k
-                    ; rsig_ok <- xoptM Opt_RoleAnnotations
-                    ; unless rsig_ok $
-                      whenIsJust mrole $ \_ -> badRoleAnnotOpt loc doc
-                    ; nm <- newTyVarNameRn mb_assoc rdr_env loc name
-                    ; (mkind', fvs) <- case mkind of
-                                         Just k  -> do { (kind', fvs) <- rnLHsKind doc k
-                                                       ; return (Just kind', fvs) }
-                                         Nothing -> return (Nothing, emptyFVs)
-                    ; return (L loc (HsTyVarBndr nm mkind' mrole), fvs) }
+             rn_tv_bndr (L loc (UserTyVar rdr))
+               = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
+                    ; return (L loc (UserTyVar nm), emptyFVs) }
+             rn_tv_bndr (L loc (KindedTyVar rdr kind))
+               = do { sig_ok <- xoptM Opt_KindSignatures
+                    ; unless sig_ok (badSigErr False doc kind)
+                    ; nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
+                    ; (kind', fvs) <- rnLHsKind doc kind
+                    ; return (L loc (KindedTyVar nm kind'), fvs) }
 
        -- Check for duplicate or shadowed tyvar bindrs
        ; checkDupRdrNames tv_names_w_loc
@@ -474,19 +467,6 @@ dataKindsErr is_type thing
   where
     what | is_type   = ptext (sLit "type")
          | otherwise = ptext (sLit "kind")
-
-badRoleAnnotOpt :: SrcSpan -> HsDocContext -> TcM ()
-badRoleAnnotOpt loc doc
-  = setSrcSpan loc $ addErr $
-    vcat [ ptext (sLit "Illegal role annotation")
-         , ptext (sLit "Perhaps you intended to use RoleAnnotations")
-         , docOfHsDocContext doc ]
-
-illegalRoleAnnotDoc :: HsDocContext -> LHsType RdrName -> TcM ()
-illegalRoleAnnotDoc doc (L loc ty)
-  = setSrcSpan loc $ addErr $
-    vcat [ ptext (sLit "Illegal role annotation on") <+> (ppr ty)
-         , docOfHsDocContext doc ]
 \end{code}
 
 Note [Renaming associated types]
@@ -1033,7 +1013,6 @@ extract_lty (L _ ty) acc
       HsTyLit _                 -> acc
       HsWrapTy _ _              -> panic "extract_lty"
       HsKindSig ty ki           -> extract_lty ty (extract_lkind ki acc)
-      HsRoleAnnot ty _          -> extract_lty ty acc
       HsForAllTy _ tvs cx ty    -> extract_hs_tv_bndrs tvs acc $
                                    extract_lctxt cx   $
                                    extract_lty ty ([],[])
@@ -1050,7 +1029,7 @@ extract_hs_tv_bndrs (HsQTvs { hsq_tvs = tvs })
      acc_tvs ++ filterOut (`elem` local_tvs) body_tvs)
   where
     local_tvs = map hsLTyVarName tvs
-    (_, local_kvs) = foldr extract_lty ([], []) [k | L _ (HsTyVarBndr _ (Just k) _) <- tvs]
+    (_, local_kvs) = foldr extract_lty ([], []) [k | L _ (KindedTyVar _ k) <- tvs]
        -- These kind variables are bound here if not bound further out
 
 extract_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars
index f16206b..1b2d7f4 100644 (file)
@@ -20,7 +20,7 @@ module TcHsType (
                 -- Type checking type and class decls
        kcLookupKind, kcTyClTyVars, tcTyClTyVars,
         tcHsConArgType, tcDataKindSig, 
-        tcClassSigType, illegalRoleAnnot,
+        tcClassSigType,
 
                -- Kind-checking types
                 -- No kind generalisation, no checkValidType
@@ -75,7 +75,6 @@ import UniqSupply
 import Outputable
 import FastString
 import Util
-import Maybes
 
 import Control.Monad ( unless, when, zipWithM )
 import PrelNames( ipClassName, funTyConKey )
@@ -506,9 +505,6 @@ tc_hs_type (HsKindSig ty sig_k) exp_kind
     msg_fn pkind = ptext (sLit "The signature specified kind") 
                    <+> quotes (pprKind pkind)
 
-tc_hs_type ty@(HsRoleAnnot {}) _
-  = pprPanic "tc_hs_type HsRoleAnnot" (ppr ty)
-
 tc_hs_type (HsCoreTy ty) exp_kind
   = do { checkExpectedKind ty (typeKind ty) exp_kind
        ; return ty }
@@ -1110,15 +1106,14 @@ kcScopedKindVars kv_ns thing_inside
 kcHsTyVarBndrs :: KindCheckingStrategy
                -> LHsTyVarBndrs Name 
               -> TcM (Kind, r)   -- the result kind, possibly with other info
-              -> TcM (Kind, r, [Maybe Role])
--- See Note [Role annotations] in TcTyClsDecls about the last return value
+              -> TcM (Kind, r)
 -- Used in getInitialKind
 kcHsTyVarBndrs strat (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside
   = do { kvs <- if skolem_kvs
                 then mapM mkKindSigVar kv_ns
                 else mapM (\n -> newSigTyVar n superKind) kv_ns
        ; tcExtendTyVarEnv2 (kv_ns `zip` kvs) $
-    do { (nks, mroles) <- mapAndUnzipM (kc_hs_tv . unLoc) hs_tvs
+    do { nks <- mapM (kc_hs_tv . unLoc) hs_tvs
        ; (res_kind, stuff) <- tcExtendKindEnv nks thing_inside
        ; let full_kind = mkArrowKinds (map snd nks) res_kind
              kvs       = filter (not . isMetaTyVar) $
@@ -1126,7 +1121,7 @@ kcHsTyVarBndrs strat (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside
              gen_kind  = if generalise
                          then mkForAllTys kvs full_kind
                          else full_kind
-       ; return (gen_kind, stuff, mroles) } }
+       ; return (gen_kind, stuff) } }
   where
     -- See Note [Kind-checking strategies]
     (skolem_kvs, default_to_star, generalise) = case strat of
@@ -1134,22 +1129,25 @@ kcHsTyVarBndrs strat (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside
           NonParametricKinds -> (True,  False, True)
           FullKindSignature  -> (True,  True,  True)
 
-    kc_hs_tv :: HsTyVarBndr Name -> TcM ((Name, TcKind), Maybe Role)
-    kc_hs_tv (HsTyVarBndr n mk mr)
+    kc_hs_tv :: HsTyVarBndr Name -> TcM (Name, TcKind)
+    kc_hs_tv (UserTyVar n)
       = do { mb_thing <- tcLookupLcl_maybe n
-           ; kind <- case (mb_thing, mk) of
-               (Just (AThing k1), Just k2) -> do { k2' <- tcLHsKind k2
-                                                 ; checkKind k1 k2'
-                                                 ; return k1 }
-               (Just (AThing k),  Nothing) -> return k
-               (Nothing,          Just k)  -> tcLHsKind k
-               (_,                Nothing)
-                 | default_to_star         -> return liftedTypeKind
-                 | otherwise               -> newMetaKindVar
-               (Just thing,       Just _)  -> pprPanic "check_in_scope" (ppr thing)
-           ; is_boot <- tcIsHsBoot  -- in boot files, roles default to R
-           ; let default_role = if is_boot then Just Representational else Nothing
-           ; return ((n, kind), firstJust mr default_role) }
+           ; kind <- case mb_thing of
+                              Just (AThing k)     -> return k
+                              _ | default_to_star -> return liftedTypeKind
+                                | otherwise       -> newMetaKindVar
+           ; return (n, kind) }
+    kc_hs_tv (KindedTyVar n k) 
+      = do { kind <- tcLHsKind k
+               -- In an associated type decl, the type variable may already 
+               -- be in scope; in that case we want to make sure its kind
+               -- matches the one declared here
+           ; mb_thing <- tcLookupLcl_maybe n
+           ; case mb_thing of
+               Nothing          -> return ()
+               Just (AThing ks) -> checkKind kind ks
+               Just thing       -> pprPanic "check_in_scope" (ppr thing)
+           ; return (n, kind) }
 
 tcHsTyVarBndrs :: LHsTyVarBndrs Name 
               -> ([TcTyVar] -> TcM r)
@@ -1183,19 +1181,16 @@ tcHsTyVarBndr :: LHsTyVarBndr Name -> TcM TcTyVar
 --     type F (a,b) c = ...
 -- Here a,b will be in scope when processing the associated type instance for F.
 -- See Note [Associated type tyvar names] in Class
-tcHsTyVarBndr (L _ (HsTyVarBndr name mkind Nothing))
-  = do { mb_tv <- tcLookupLcl_maybe name
+tcHsTyVarBndr (L _ hs_tv)
+  = do { let name = hsTyVarName hs_tv
+       ; mb_tv <- tcLookupLcl_maybe name
        ; case mb_tv of {
            Just (ATyVar _ tv) -> return tv ;
            _ -> do
-       { kind <- case mkind of
-                   Nothing   -> newMetaKindVar
-                   Just kind -> tcLHsKind kind
-       ; return (mkTcTyVar name kind (SkolemTv False)) } } }
-
--- tcHsTyVarBndr is never called from a context where roles annotations are allowed
-tcHsTyVarBndr (L _ (HsTyVarBndr name _ _))
-  = addErrTc (illegalRoleAnnot name) >> failM
+       { kind <- case hs_tv of
+                   UserTyVar {}       -> newMetaKindVar
+                   KindedTyVar _ kind -> tcLHsKind kind
+       ; return ( mkTcTyVar name kind (SkolemTv False)) } } }
 
 ------------------
 kindGeneralize :: TyVarSet -> TcM [KindVar]
@@ -1281,11 +1276,12 @@ kcTyClTyVars name (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside
     -- to match the kind variables they mention against the ones 
     -- we've freshly brought into scope
     kc_tv :: LHsTyVarBndr Name -> Kind -> TcM (Name, Kind)
-    kc_tv (L _ (HsTyVarBndr n mkind _)) exp_k
-      | Just hs_k <- mkind = do { k <- tcLHsKind hs_k
-                                ; checkKind k exp_k
-                                ; return (n, exp_k) }
-      | otherwise          = return (n, exp_k)
+    kc_tv (L _ (UserTyVar n)) exp_k 
+      = return (n, exp_k)
+    kc_tv (L _ (KindedTyVar n hs_k)) exp_k
+      = do { k <- tcLHsKind hs_k
+           ; checkKind k exp_k
+           ; return (n, exp_k) }
 
 -----------------------
 tcTyClTyVars :: Name -> LHsTyVarBndrs Name     -- LHS of the type or class decl
@@ -1317,10 +1313,10 @@ tcTyClTyVars tycon (HsQTvs { hsq_kvs = hs_kvs, hsq_tvs = hs_tvs }) thing_inside
        ; tvs <- zipWithM tc_hs_tv hs_tvs kinds
        ; tcExtendTyVarEnv tvs (thing_inside (kvs ++ tvs) res) }
   where
-    tc_hs_tv (L _ (HsTyVarBndr n mkind _)) kind
-      = do { whenIsJust mkind $ \k -> do { tc_kind <- tcLHsKind k
-                                         ; checkKind kind tc_kind }
-           ; return $ mkTyVar n kind }
+    tc_hs_tv (L _ (UserTyVar n))        kind = return (mkTyVar n kind)
+    tc_hs_tv (L _ (KindedTyVar n hs_k)) kind = do { tc_kind <- tcLHsKind hs_k
+                                                  ; checkKind kind tc_kind
+                                                  ; return (mkTyVar n kind) }
 
 -----------------------------------
 tcDataKindSig :: Kind -> TcM [TyVar]
@@ -1676,10 +1672,6 @@ checkExpectedKind ty act_kind (EK exp_kind ek_ctxt)
       ; traceTc "checkExpectedKind 1" (ppr ty $$ ppr tidy_act_kind $$ ppr tidy_exp_kind $$ ppr env1 $$ ppr env2)
       ; failWithTcM (env2, err) } } }
 
-illegalRoleAnnot :: Name -> SDoc
-illegalRoleAnnot var
-  = ptext (sLit "Illegal role annotation on variable") <+> ppr var <> semi $$
-    ptext (sLit "role annotations are not allowed here")
 \end{code}
 
 %************************************************************************
index cd18faf..9962a0b 100644 (file)
@@ -37,6 +37,7 @@ import TcDeriv
 import TcEnv
 import TcHsType
 import TcUnify
+import TcTyDecls  ( emptyRoleAnnots )
 import MkCore     ( nO_METHOD_BINDING_ERROR_ID )
 import Type
 import TcEvidence
@@ -62,7 +63,6 @@ import Id
 import MkId
 import Name
 import NameSet
-import NameEnv
 import Outputable
 import SrcLoc
 import Util
@@ -709,7 +709,7 @@ tcDataFamInstDecl mb_clsinfo
               ; return (rep_tc, fam_inst) }
 
          -- Remember to check validity; no recursion to worry about here
-       ; let role_annots = unitNameEnv rep_tc_name (repeat Nothing)
+       ; let role_annots = emptyRoleAnnots
        ; checkValidTyCon rep_tc role_annots
        ; return fam_inst } }
   where
index 4818b76..e461bd7 100644 (file)
@@ -335,7 +335,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
                                               (mkFakeGroup ldecls) ;
    setEnvs tc_envs $ do {
 
-   (rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls [] [ldecls] ;
+   (rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls [] [mkTyClGroup ldecls] ;
    -- The empty list is for extra dependencies coming from .hs-boot files
    -- See Note [Extra dependencies from .hs-boot files] in RnSource
 
@@ -400,7 +400,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
 
 mkFakeGroup :: [LTyClDecl a] -> HsGroup a
 mkFakeGroup decls -- Rather clumsy; lots of unused fields
-  = emptyRdrGroup { hs_tyclds = [decls] }
+  = emptyRdrGroup { hs_tyclds = [mkTyClGroup decls] }
 \end{code}
 
 
@@ -1104,7 +1104,7 @@ tcTopSrcDecls boot_details
                 -- Second pass over class and instance declarations,
                 -- now using the kind-checked decls
         traceTc "Tc6" empty ;
-        inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
+        inst_binds <- tcInstDecls2 (tyClGroupConcat tycl_decls) inst_infos ;
 
                 -- Foreign exports
         traceTc "Tc7" empty ;
@@ -1177,7 +1177,7 @@ tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls
       -- Note [AFamDataCon: not promoting data family constructors]
    do { tcg_env <- tcTyAndClassDecls boot_details tycl_decls ;
       ; setGblEnv tcg_env $
-        tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls }
+        tcInstDecls1 (tyClGroupConcat tycl_decls) inst_decls deriv_decls }
   where
     -- get_cons extracts the *constructor* bindings of the declaration
     get_cons :: LInstDecl Name -> [Name]
@@ -1686,7 +1686,7 @@ getGhciStepIO = do
 
         stepTy :: LHsType Name    -- Renamed, so needs all binders in place
         stepTy = noLoc $ HsForAllTy Implicit
-                            (HsQTvs { hsq_tvs = [noLoc (HsTyVarBndr a_tv Nothing Nothing)]
+                            (HsQTvs { hsq_tvs = [noLoc (UserTyVar a_tv)]
                                     , hsq_kvs = [] })
                             (noLoc [])
                             (nlHsFunTy ghciM ioM)
index 2528e69..4a4a0f9 100644 (file)
@@ -76,7 +76,7 @@ import BasicTypes
 import DynFlags
 import Panic
 import FastString
-import Control.Monad    ( when, zipWithM )
+import Control.Monad    ( when )
 
 import qualified Language.Haskell.TH as TH
 -- THSyntax gives access to internal functions and data types
@@ -958,6 +958,7 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
   qLookupName     = lookupName
   qReify          = reify
   qReifyInstances = reifyInstances
+  qReifyRoles     = reifyRoles
 
         -- For qRecover, discard error messages if
         -- the recovery action is chosen.  Otherwise
@@ -1154,6 +1155,19 @@ notInEnv name = quotes (ppr name) <+>
                      ptext (sLit "is not in the type environment at a reify")
 
 ------------------------------
+reifyRoles :: TH.Name -> TcM [TH.Role]
+reifyRoles th_name
+  = do { thing <- getThing th_name
+       ; case thing of
+           AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc))
+           _ -> failWithTc (ptext (sLit "No roles associated with") <+> (ppr thing))
+       }
+  where
+    reify_role Nominal          = TH.NominalR
+    reify_role Representational = TH.RepresentationalR
+    reify_role Phantom          = TH.PhantomR
+
+------------------------------
 reifyThing :: TcTyThing -> TcM TH.Info
 -- The only reason this is monadic is for error reporting,
 -- which in turn is mainly for the case when TH can't express
@@ -1215,7 +1229,7 @@ reifyTyCon tc
        ; kind' <- if isLiftedTypeKind kind then return Nothing
                   else fmap Just (reifyKind kind)
 
-       ; tvs' <- reifyTyVars tvs Nothing
+       ; tvs' <- reifyTyVars tvs
        ; flav' <- reifyFamFlavour tc
        ; case flav' of
          { Left flav ->  -- open type/data family
@@ -1231,7 +1245,7 @@ reifyTyCon tc
 
   | Just (tvs, rhs) <- synTyConDefn_maybe tc  -- Vanilla type synonym
   = do { rhs' <- reifyType rhs
-       ; tvs' <- reifyTyVars tvs (Just $ tyConRoles tc)
+       ; tvs' <- reifyTyVars tvs
        ; return (TH.TyConI
                    (TH.TySynD (reifyName tc) tvs' rhs'))
        }
@@ -1240,7 +1254,7 @@ reifyTyCon tc
   = do  { cxt <- reifyCxt (tyConStupidTheta tc)
         ; let tvs = tyConTyVars tc
         ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
-        ; r_tvs <- reifyTyVars tvs (Just $ tyConRoles tc)
+        ; r_tvs <- reifyTyVars tvs
         ; let name = reifyName tc
               deriv = []        -- Don't know about deriving
               decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
@@ -1276,7 +1290,7 @@ reifyDataCon tys dc
              return main_con
          else do
          { cxt <- reifyCxt theta'
-         ; ex_tvs'' <- reifyTyVars ex_tvs' Nothing
+         ; ex_tvs'' <- reifyTyVars ex_tvs'
          ; return (TH.ForallC ex_tvs'' cxt main_con) } }
 
 ------------------------------
@@ -1286,7 +1300,7 @@ reifyClass cls
         ; inst_envs <- tcGetInstEnvs
         ; insts <- mapM reifyClassInstance (InstEnv.classInstances inst_envs cls)
         ; ops <- mapM reify_op op_stuff
-        ; tvs' <- reifyTyVars tvs (Just $ tyConRoles (classTyCon cls))
+        ; tvs' <- reifyTyVars tvs
         ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' ops
         ; return (TH.ClassI dec insts ) }
   where
@@ -1344,7 +1358,7 @@ reify_for_all :: TypeRep.Type -> TcM TH.Type
 reify_for_all ty
   = do { cxt' <- reifyCxt cxt;
        ; tau' <- reifyType tau
-       ; tvs' <- reifyTyVars tvs Nothing
+       ; tvs' <- reifyTyVars tvs
        ; return (TH.ForallT tvs' cxt' tau') }
   where
     (tvs, cxt, tau) = tcSplitSigmaTy ty
@@ -1403,9 +1417,9 @@ reifyFamFlavour tc
   | otherwise
   = panic "TcSplice.reifyFamFlavour: not a type family"
 
-reifyTyVars :: [TyVar] -> Maybe [Role]  -- use Nothing if role annot.s are not allowed
+reifyTyVars :: [TyVar]
             -> TcM [TH.TyVarBndr]
-reifyTyVars tvs Nothing = mapM reify_tv $ filter isTypeVar tvs
+reifyTyVars tvs = mapM reify_tv $ filter isTypeVar tvs
   where
     reify_tv tv | isLiftedTypeKind kind = return (TH.PlainTV  name)
                 | otherwise             = do kind' <- reifyKind kind
@@ -1414,23 +1428,6 @@ reifyTyVars tvs Nothing = mapM reify_tv $ filter isTypeVar tvs
         kind = tyVarKind tv
         name = reifyName tv
 
-reifyTyVars tvs (Just roles) = zipWithM reify_tv tvs' roles'
-  where
-    (kvs, tvs') = span isKindVar tvs
-    roles'      = dropList kvs roles
-
-    reify_tv tv role
-      | isLiftedTypeKind kind = return (TH.RoledTV name role')
-      | otherwise             = do kind' <- reifyKind kind
-                                   return (TH.KindedRoledTV name kind' role')
-      where
-        kind  = tyVarKind tv
-        name  = reifyName tv
-        role' = case role of
-                  CoAxiom.Nominal          -> TH.Nominal
-                  CoAxiom.Representational -> TH.Representational
-                  CoAxiom.Phantom          -> TH.Phantom
-
 reify_tc_app :: TyCon -> [TypeRep.Type] -> TcM TH.Type
 reify_tc_app tc tys
   = do { tys' <- reifyTypes (removeKinds (tyConKind tc) tys)
index 8b2b6d4..988d633 100644 (file)
@@ -123,15 +123,18 @@ tcTyClGroup boot_details tyclds
   = do {    -- Step 1: kind-check this group and returns the final
             -- (possibly-polymorphic) kind of each TyCon and Class
             -- See Note [Kind checking for type and class decls]
-            -- See also Note [Role annotations]
-         (names_w_poly_kinds, role_annots) <- checkNoErrs $ kcTyClGroup tyclds
+         names_w_poly_kinds <- checkNoErrs $ kcTyClGroup tyclds
        ; traceTc "tcTyAndCl generalized kinds" (ppr names_w_poly_kinds)
             -- the checkNoErrs is necessary to fix #7175.
 
             -- Step 2: type-check all groups together, returning
             -- the final TyCons and Classes
+       ; let role_annots = extractRoleAnnots tyclds
+             decls = group_tyclds tyclds
        ; tyclss <- fixM $ \ rec_tyclss -> do
-           { let rec_flags = calcRecFlags boot_details role_annots rec_tyclss
+           { is_boot <- tcIsHsBoot
+           ; let rec_flags = calcRecFlags boot_details is_boot
+                                          role_annots rec_tyclss
 
                  -- Populate environment with knot-tied ATyCon for TyCons
                  -- NB: if the decls mention any ill-staged data cons
@@ -145,7 +148,7 @@ tcTyClGroup boot_details tyclds
              tcExtendKindEnv names_w_poly_kinds              $
 
                  -- Kind and type check declarations for this group
-             concatMapM (tcTyClDecl rec_flags) tyclds }
+             concatMapM (tcTyClDecl rec_flags) decls }
 
            -- Step 3: Perform the validity check
            -- We can do this now because we are done with the recursive knot
@@ -153,7 +156,7 @@ tcTyClGroup boot_details tyclds
            -- expects well-formed TyCons
        ; tcExtendGlobalEnv tyclss $ do
        { traceTc "Starting validity check" (ppr tyclss)
-       ; mapM_ (recoverM (return ()) . addLocM (checkValidTyCl role_annots)) tyclds
+       ; mapM_ (recoverM (return ()) . addLocM (checkValidTyCl role_annots)) decls
            -- We recover, which allows us to report multiple validity errors
 
            -- Step 4: Add the implicit things;
@@ -248,30 +251,12 @@ instances of families altogether in the following. However, we need to include
 the kinds of *associated* families into the construction of the initial kind
 environment. (This is handled by `allDecls').
 
-Note [Role annotations]
-~~~~~~~~~~~~~~~~~~~~~~~
-Role processing is threaded through the kind- and type-checker. Here is the
-route:
-
-1. kcTyClGroup returns a list of (Name, Kind, [Maybe Role]) triples. The
-elements of the role list correspond to type variables associated with the Name.
-Nothing indicates no role annotation. Just r indicates an annotation r.
-
-2. The role annotations are passed into calcRecFlags, which among other things,
-performs role inference. The role annotations are used to initialize the role
-inference algorithm.
-
-3. During validity-checking (in checkRoleAnnot), the inferred roles are
-then checked against the annotations. If they don't match, an error is reported.
-This is also where the presence of the RoleAnnotations flag is checked.
-
 \begin{code}
-kcTyClGroup :: TyClGroup Name -> TcM ([(Name,Kind)], RoleAnnots)
+kcTyClGroup :: TyClGroup Name -> TcM [(Name,Kind)]
 -- Kind check this group, kind generalize, and return the resulting local env
 -- This bindds the TyCons and Classes of the group, but not the DataCons
 -- See Note [Kind checking for type and class decls]
--- Role annotation extraction is done here, too. See Note [Role annotations]
-kcTyClGroup decls
+kcTyClGroup (TyClGroup { group_tyclds = decls })
   = do  { mod <- getModule
         ; traceTc "kcTyClGroup" (ptext (sLit "module") <+> ppr mod $$ vcat (map ppr decls))
 
@@ -284,13 +269,12 @@ kcTyClGroup decls
 
           -- Step 1: Bind kind variables for non-synonyms
         ; let (syn_decls, non_syn_decls) = partition (isSynDecl . unLoc) decls
-        ; (initial_kinds, role_env) <- getInitialKinds non_syn_decls
+        ; initial_kinds <- getInitialKinds non_syn_decls
         ; traceTc "kcTyClGroup: initial kinds" (ppr initial_kinds)
 
         -- Step 2: Set initial envt, kind-check the synonyms
-        -- See Note [Role annotations]
-        ; (lcl_env, role_env') <- tcExtendTcTyThingEnv initial_kinds $
-                                  kcSynDecls (calcSynCycles syn_decls)
+        ; lcl_env <- tcExtendTcTyThingEnv initial_kinds $
+                     kcSynDecls (calcSynCycles syn_decls)
 
         -- Step 3: Set extended envt, kind-check the non-synonyms
         ; setLclEnv lcl_env $
@@ -302,7 +286,7 @@ kcTyClGroup decls
         ; res <- concatMapM (generaliseTCD (tcl_env lcl_env)) decls
 
         ; traceTc "kcTyClGroup result" (ppr res)
-        ; return (res, role_env `plusNameEnv` role_env') }
+        ; return res }
 
   where
     generalise :: TcTypeEnv -> Name -> TcM (Name, Kind)
@@ -351,14 +335,14 @@ mk_thing_env (decl : decls)
   = (tcdName (unLoc decl), APromotionErr TyConPE) :
     (mk_thing_env decls)
 
-getInitialKinds :: [LTyClDecl Name] -> TcM ([(Name, TcTyThing)], RoleAnnots)
+getInitialKinds :: [LTyClDecl Name] -> TcM [(Name, TcTyThing)]
 getInitialKinds decls
   = tcExtendTcTyThingEnv (mk_thing_env decls) $
-    do { (pairss, annots) <- mapAndUnzipM (addLocM getInitialKind) decls
-       ; return (concat pairss, mkNameEnv (zip (map (tcdName . unLoc) decls) annots)) }
+    do { pairss <- mapM (addLocM getInitialKind) decls
+       ; return (concat pairss) }
 
 -- See Note [Kind-checking strategies] in TcHsType
-getInitialKind :: TyClDecl Name -> TcM ([(Name, TcTyThing)], [Maybe Role])
+getInitialKind :: TyClDecl Name -> TcM [(Name, TcTyThing)]
 -- Allocate a fresh kind variable for each TyCon and Class
 -- For each tycon, return   (tc, AThing k)
 --                 where k is the kind of tc, derived from the LHS
@@ -377,37 +361,33 @@ getInitialKind :: TyClDecl Name -> TcM ([(Name, TcTyThing)], [Maybe Role])
 -- No family instances are passed to getInitialKinds
 
 getInitialKind decl@(ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs = ats })
-  = do { (cl_kind, inner_prs, role_annots) <-
+  = do { (cl_kind, inner_prs) <-
            kcHsTyVarBndrs (kcStrategy decl) ktvs $
            do { inner_prs <- getFamDeclInitialKinds ats
               ; return (constraintKind, inner_prs) }
        ; let main_pr = (name, AThing cl_kind)
-       ; return ((main_pr : inner_prs), role_annots) }
+       ; return (main_pr : inner_prs) }
 
 getInitialKind decl@(DataDecl { tcdLName = L _ name
                                 , tcdTyVars = ktvs
                                 , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
                                                            , dd_cons = cons } })
-  = do { (decl_kind, num_extra_tvs, role_annots) <-
+  = do { (decl_kind, _) <-
            kcHsTyVarBndrs (kcStrategy decl) ktvs $
            do { res_k <- case m_sig of
                            Just ksig -> tcLHsKind ksig
                            Nothing   -> return liftedTypeKind
-                 -- return the number of extra type arguments from the res_k so
-                 -- we can extend the role_annots list
-              ; return (res_k, length $ fst $ splitKindFunTys res_k) }
+              ; return (res_k, ()) }
        ; let main_pr = (name, AThing decl_kind)
              inner_prs = [ (unLoc (con_name con), APromotionErr RecDataConPE)
                          | L _ con <- cons ]
-             role_annots' = role_annots ++ replicate num_extra_tvs Nothing
-       ; return ((main_pr : inner_prs), role_annots') }
+       ; return (main_pr : inner_prs) }
 
 getInitialKind (FamDecl { tcdFam = decl }) 
-  = do { pairs <- getFamDeclInitialKind decl
-       ; return (pairs, []) }
+  = getFamDeclInitialKind decl
 
 getInitialKind (ForeignType { tcdLName = L _ name })
-  = return ([(name, AThing liftedTypeKind)], [])
+  = return [(name, AThing liftedTypeKind)]
 
 getInitialKind decl@(SynDecl {}) 
   = pprPanic "getInitialKind" (ppr decl)
@@ -424,7 +404,7 @@ getFamDeclInitialKind :: FamilyDecl Name
 getFamDeclInitialKind decl@(FamilyDecl { fdLName = L _ name
                                        , fdTyVars = ktvs
                                        , fdKindSig = ksig })
-  = do { (fam_kind, _, _) <-
+  = do { (fam_kind, _) <-
            kcHsTyVarBndrs (kcStrategyFamDecl decl) ktvs $
            do { res_k <- case ksig of
                            Just k  -> tcLHsKind k
@@ -438,33 +418,32 @@ getFamDeclInitialKind decl@(FamilyDecl { fdLName = L _ name
 
 ----------------
 kcSynDecls :: [SCC (LTyClDecl Name)]
-           -> TcM (TcLclEnv, RoleAnnots) -- Kind bindings and roles
-kcSynDecls [] = do { env <- getLclEnv
-                   ; return (env, emptyNameEnv) }
+           -> TcM TcLclEnv -- Kind bindings
+kcSynDecls [] = getLclEnv
 kcSynDecls (group : groups)
-  = do  { (n,k,mr) <- kcSynDecl1 group
-        ; (lcl_env, role_env) <- tcExtendKindEnv [(n,k)] (kcSynDecls groups)
-        ; return (lcl_env, extendNameEnv role_env n mr) }
+  = do  { (n,k) <- kcSynDecl1 group
+        ; lcl_env <- tcExtendKindEnv [(n,k)] (kcSynDecls groups)
+        ; return lcl_env }
 
 kcSynDecl1 :: SCC (LTyClDecl Name)
-           -> TcM (Name,TcKind,[Maybe Role]) -- Kind bindings with roles
+           -> TcM (Name,TcKind) -- Kind bindings
 kcSynDecl1 (AcyclicSCC (L _ decl)) = kcSynDecl decl
 kcSynDecl1 (CyclicSCC decls)       = do { recSynErr decls; failM }
                                      -- Fail here to avoid error cascade
                                      -- of out-of-scope tycons
 
-kcSynDecl :: TyClDecl Name -> TcM (Name, TcKind, [Maybe Role])
+kcSynDecl :: TyClDecl Name -> TcM (Name, TcKind)
 kcSynDecl decl@(SynDecl { tcdTyVars = hs_tvs, tcdLName = L _ name
-                       , tcdRhs = rhs })
+                        , tcdRhs = rhs })
   -- Returns a possibly-unzonked kind
   = tcAddDeclCtxt decl $
-    do { (syn_kind, _, mroles) <-
+    do { (syn_kind, _) <-
            kcHsTyVarBndrs (kcStrategy decl) hs_tvs $
            do { traceTc "kcd1" (ppr name <+> brackets (ppr hs_tvs))
               ; (_, rhs_kind) <- tcLHsType rhs
               ; traceTc "kcd2" (ppr name)
               ; return (rhs_kind, ()) }
-       ; return (name, syn_kind, mroles) }
+       ; return (name, syn_kind) }
 kcSynDecl decl = pprPanic "kcSynDecl" (ppr decl)
 
 ------------------------------------------------------------------------
@@ -475,7 +454,6 @@ kcLTyClDecl (L loc decl)
 
 kcTyClDecl :: TyClDecl Name -> TcM ()
 -- This function is used solely for its side effect on kind variables
--- and to extract role annotations
 -- NB kind signatures on the type variables and
 --    result kind signature have aready been dealt with
 --    by getInitialKind, so we can ignore them here.
@@ -686,7 +664,6 @@ tcFamDecl1 parent
   = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
   { traceTc "open type family:" (ppr tc_name)
   ; checkFamFlag tc_name
-  ; checkNoRoles tvs
   ; let roles = map (const Nominal) tvs'
   ; tycon <- buildSynTyCon tc_name tvs' roles OpenSynFamilyTyCon kind parent
   ; return [ATyCon tycon] }
@@ -703,7 +680,6 @@ tcFamDecl1 parent
                          return (tvs', kind)
 
        ; checkFamFlag tc_name -- make sure we have -XTypeFamilies
-       ; checkNoRoles tvs
 
          -- check to make sure all the names used in the equations are
          -- consistent
@@ -751,7 +727,6 @@ tcFamDecl1 parent
   = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
   { traceTc "data family:" (ppr tc_name)
   ; checkFamFlag tc_name
-  ; checkNoRoles tvs
   ; extra_tvs <- tcDataKindSig kind
   ; let final_tvs = tvs' ++ extra_tvs    -- we may not need these
         roles     = map (const Nominal) final_tvs
@@ -1244,6 +1219,8 @@ There are two ways out of this scenario:
      can't we look at the result of tcHsLiftedType? Because eventually, we'll
      need to look inside of a TyCon, and that's a no-no inside of the knot.
 
+We do #2.
+
 \begin{code}
 
 -- Example
@@ -1356,7 +1333,7 @@ checkClassCycleErrs cls
 
 checkValidDecl :: SDoc -- the context for error checking
                -> Located Name -> RoleAnnots -> TcM ()
-checkValidDecl ctxt lname mroles
+checkValidDecl ctxt lname role_annots
   = addErrCtxt ctxt $
     do  { traceTc "Validity of 1" (ppr lname)
         ; env <- getGblEnv
@@ -1367,7 +1344,7 @@ checkValidDecl ctxt lname mroles
         ; case thing of
             ATyCon tc -> do
                 traceTc "  of kind" (ppr (tyConKind tc))
-                checkValidTyCon tc mroles
+                checkValidTyCon tc role_annots
             AnId _    -> return ()  -- Generic default methods are checked
                                     -- with their parent class
             _         -> panic "checkValidTyCl"
@@ -1375,19 +1352,18 @@ checkValidDecl ctxt lname mroles
         }
                           
 checkValidTyCl :: RoleAnnots -> TyClDecl Name -> TcM ()
-checkValidTyCl mroles decl
-  = do { checkValidDecl (tcMkDeclCtxt decl) (tyClDeclLName decl) mroles
+checkValidTyCl role_annots decl
+  = do { checkValidDecl (tcMkDeclCtxt decl) (tyClDeclLName decl) role_annots
        ; case decl of
            ClassDecl { tcdATs = ats } ->
-             mapM_ (checkValidFamDecl . unLoc) ats
+             mapM_ (checkValidFamDecl role_annots . unLoc) ats
            _ -> return () }
 
-checkValidFamDecl :: FamilyDecl Name -> TcM ()
-checkValidFamDecl (FamilyDecl { fdLName = lname, fdInfo = flav })
+checkValidFamDecl :: RoleAnnots -> FamilyDecl Name -> TcM ()
+checkValidFamDecl role_annots (FamilyDecl { fdLName = lname, fdInfo = flav })
   = checkValidDecl (hsep [ptext (sLit "In the"), ppr flav,
                           ptext (sLit "declaration for"), quotes (ppr lname)])
-                   lname
-                   (pprPanic "checkValidFamDecl" (ppr lname)) -- no roles on families
+                   lname role_annots
 
 -------------------------
 -- For data types declared with record syntax, we require
@@ -1405,27 +1381,28 @@ checkValidFamDecl (FamilyDecl { fdLName = lname, fdInfo = flav })
 -- Here we do not complain about f1,f2 because they are existential
 
 checkValidTyCon :: TyCon -> RoleAnnots -> TcM ()
-checkValidTyCon tc mroles
+checkValidTyCon tc role_annots
   | Just cl <- tyConClass_maybe tc
   = do { check_roles
        ; checkValidClass cl }
 
   | Just syn_rhs <- synTyConRhs_maybe tc
-  = case syn_rhs of
-      ClosedSynFamilyTyCon ax      -> checkValidClosedCoAxiom ax
-      AbstractClosedSynFamilyTyCon ->
-        do { hsBoot <- tcIsHsBoot
-           ; checkTc hsBoot $
-             ptext (sLit "You may omit the equations in a closed type family") $$
-             ptext (sLit "only in a .hs-boot file") }
-      OpenSynFamilyTyCon           -> return ()
-      SynonymTyCon ty              -> 
-        do { check_roles
-           ; checkValidType syn_ctxt ty }
-      BuiltInSynFamTyCon _ -> return ()
+  = do { check_no_roles
+       ; case syn_rhs of
+       { ClosedSynFamilyTyCon ax      -> checkValidClosedCoAxiom ax
+       ; AbstractClosedSynFamilyTyCon ->
+         do { hsBoot <- tcIsHsBoot
+            ; checkTc hsBoot $
+              ptext (sLit "You may omit the equations in a closed type family") $$
+              ptext (sLit "only in a .hs-boot file") }
+       ; OpenSynFamilyTyCon           -> return ()
+       ; SynonymTyCon ty              -> checkValidType syn_ctxt ty
+       ; BuiltInSynFamTyCon _         -> return () } }
 
   | otherwise
-  = do { unless (isFamilyTyCon tc) $ check_roles -- don't check data families!
+  = do { if isFamilyTyCon tc
+         then check_no_roles
+         else check_roles
 
        -- Check the context on the data decl
        ; traceTc "cvtc1" (ppr tc)
@@ -1455,14 +1432,24 @@ checkValidTyCon tc mroles
     roles                  = tyConRoles tc
     type_roles             = dropList kind_vars roles
 
-    role_annots = case lookupNameEnv mroles name of
-                    Just rs -> rs
-                    Nothing -> pprPanic "checkValidTyCon role_annots" (ppr name)
+    role_annot_decl_maybe  = lookupNameEnv role_annots name
 
     check_roles
-      = do { _ <- zipWith3M checkRoleAnnot type_vars role_annots type_roles
+      = do { whenIsJust role_annot_decl_maybe $
+             \decl@(L loc (RoleAnnotDecl _ the_role_annots)) -> do
+           { _ <- zipWith3M checkRoleAnnot type_vars the_role_annots type_roles
+           ; setErrCtxt [] $
+             setSrcSpan loc $ do
+           { role_annots_ok <- xoptM Opt_RoleAnnotations
+           ; checkTc role_annots_ok $ needXRoleAnnotations tc
+           ; checkTc (type_vars `equalLength` the_role_annots)
+                     (wrongNumberOfRoles type_vars decl) }
+
            ; lint <- goptM Opt_DoCoreLinting
-           ; when lint $ checkValidRoles tc }
+           ; when lint $ checkValidRoles tc } }
+
+    check_no_roles
+      = whenIsJust role_annot_decl_maybe $ \decl -> illegalRoleAnnotDecl decl
 
     groups = equivClasses cmp_fld (concatMap get_fields data_cons)
     cmp_fld (f1,_) (f2,_) = f1 `compare` f2
@@ -1504,9 +1491,9 @@ checkValidTyCon tc mroles
                 fty2 = dataConFieldType con2 label
     check_fields [] = panic "checkValidTyCon/check_fields []"
 
-checkRoleAnnot :: TyVar -> Maybe Role -> Role -> TcM ()
-checkRoleAnnot _  Nothing   _  = return ()
-checkRoleAnnot tv (Just r1) r2
+checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM ()
+checkRoleAnnot _  (L _ Nothing)   _  = return ()
+checkRoleAnnot tv (L _ (Just r1)) r2
   = when (r1 /= r2) $
     addErrTc $ badRoleAnnot (tyVarName tv) r1 r2
 
@@ -1759,16 +1746,8 @@ checkFamFlag tc_name
   where
     err_msg = hang (ptext (sLit "Illegal family declaraion for") <+> quotes (ppr tc_name))
                  2 (ptext (sLit "Use TypeFamilies to allow indexed type families"))
-
-checkNoRoles :: LHsTyVarBndrs Name -> TcM ()
-checkNoRoles (HsQTvs { hsq_tvs = tvs })
-  = mapM_ check tvs
-  where
-    check (L _ (HsTyVarBndr _ _ Nothing))     = return ()
-    check (L _ (HsTyVarBndr name _ (Just _))) = addErrTc $ illegalRoleAnnot name
 \end{code}
 
-
 %************************************************************************
 %*                                                                      *
                 Building record selectors
@@ -2150,8 +2129,26 @@ inaccessibleCoAxBranch tc fi
 badRoleAnnot :: Name -> Role -> Role -> SDoc
 badRoleAnnot var annot inferred
   = hang (ptext (sLit "Role mismatch on variable") <+> ppr var <> colon)
-       2 (sep [ ptext (sLit "Annotation says"), pprFullRole annot
-              , ptext (sLit "but role"), pprFullRole inferred
+       2 (sep [ ptext (sLit "Annotation says"), ppr annot
+              , ptext (sLit "but role"), ppr inferred
               , ptext (sLit "is required") ])
 
+wrongNumberOfRoles :: [a] -> LRoleAnnotDecl Name -> SDoc
+wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ annots))
+  = hang (ptext (sLit "Wrong number of roles listed in role annotation;") $$
+          ptext (sLit "Expected") <+> (ppr $ length tyvars) <> comma <+>
+          ptext (sLit "got") <+> (ppr $ length annots) <> colon)
+       2 (ppr d)
+
+illegalRoleAnnotDecl :: LRoleAnnotDecl Name -> TcM ()
+illegalRoleAnnotDecl (L loc (RoleAnnotDecl tycon _))
+  = setErrCtxt [] $
+    setSrcSpan loc $
+    addErrTc (ptext (sLit "Illegal role annotation for") <+> ppr tycon <> char ';' $$
+              ptext (sLit "they are allowed only for datatypes and classes."))
+
+needXRoleAnnotations :: TyCon -> SDoc
+needXRoleAnnotations tc
+  = ptext (sLit "Illegal role annotation for") <+> ppr tc <> char ';' $$
+    ptext (sLit "did you intend to use RoleAnnotations?")
 \end{code}
index d873b25..50d9dfc 100644 (file)
@@ -19,7 +19,7 @@ files for imported data types.
 module TcTyDecls(
         calcRecFlags, RecTyInfo(..), 
         calcSynCycles, calcClassCycles,
-        RoleAnnots
+        extractRoleAnnots, emptyRoleAnnots, RoleAnnots
     ) where
 
 #include "HsVersions.h"
@@ -361,10 +361,11 @@ data RecTyInfo = RTI { rti_promotable :: Bool
                      , rti_roles      :: Name -> [Role]
                      , rti_is_rec     :: Name -> RecFlag }
 
-calcRecFlags :: ModDetails -> RoleAnnots -> [TyThing] -> RecTyInfo
+calcRecFlags :: ModDetails -> Bool  -- hs-boot file?
+             -> RoleAnnots -> [TyThing] -> RecTyInfo
 -- The 'boot_names' are the things declared in M.hi-boot, if M is the current module.
 -- Any type constructors in boot_names are automatically considered loop breakers
-calcRecFlags boot_details mrole_env tyclss
+calcRecFlags boot_details is_boot mrole_env tyclss
   = RTI { rti_promotable = is_promotable
         , rti_roles      = roles
         , rti_is_rec     = is_rec }
@@ -376,7 +377,7 @@ calcRecFlags boot_details mrole_env tyclss
 
     is_promotable = all (isPromotableTyCon rec_tycon_names) all_tycons
 
-    roles = inferRoles mrole_env all_tycons
+    roles = inferRoles is_boot mrole_env all_tycons
 
     ----------------- Recursion calculation ----------------
     is_rec n | n `elemNameSet` rec_names = Recursive
@@ -531,6 +532,25 @@ isPromotableType rec_tcs con_arg_ty
 
 %************************************************************************
 %*                                                                      *
+        Role annotations
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+type RoleAnnots = NameEnv (LRoleAnnotDecl Name)
+
+extractRoleAnnots :: TyClGroup Name -> RoleAnnots
+extractRoleAnnots (TyClGroup { group_roles = roles })
+  = mkNameEnv [ (tycon, role_annot)
+              | role_annot@(L _ (RoleAnnotDecl (L _ tycon) _)) <- roles ]
+
+emptyRoleAnnots :: RoleAnnots
+emptyRoleAnnots = emptyNameEnv
+
+\end{code}
+
+%************************************************************************
+%*                                                                      *
         Role inference
 %*                                                                      *
 %************************************************************************
@@ -631,41 +651,43 @@ so we need to take into account
 
 \begin{code}
 type RoleEnv    = NameEnv [Role]        -- from tycon names to roles
-type RoleAnnots = NameEnv [Maybe Role]  -- from tycon names to role annotations,
-                                        -- which may be left out
 
 -- This, and any of the functions it calls, must *not* look at the roles
 -- field of a tycon we are inferring roles about!
 -- See Note [Role inference]
-inferRoles :: RoleAnnots -> [TyCon] -> Name -> [Role]
-inferRoles annots tycons
-  = let role_env  = initialRoleEnv annots tycons
+inferRoles :: Bool -> RoleAnnots -> [TyCon] -> Name -> [Role]
+inferRoles is_boot annots tycons
+  = let role_env  = initialRoleEnv is_boot annots tycons
         role_env' = irGroup role_env tycons in
     \name -> case lookupNameEnv role_env' name of
       Just roles -> roles
       Nothing    -> pprPanic "inferRoles" (ppr name)
 
-initialRoleEnv :: RoleAnnots -> [TyCon] -> RoleEnv
-initialRoleEnv annots = extendNameEnvList emptyNameEnv .
-                        map (initialRoleEnv1 annots)
+initialRoleEnv :: Bool -> RoleAnnots -> [TyCon] -> RoleEnv
+initialRoleEnv is_boot annots = extendNameEnvList emptyNameEnv .
+                                map (initialRoleEnv1 is_boot annots)
 
-initialRoleEnv1 :: RoleAnnots -> TyCon -> (Name, [Role])
-initialRoleEnv1 annots_env tc
+initialRoleEnv1 :: Bool -> RoleAnnots -> TyCon -> (Name, [Role])
+initialRoleEnv1 is_boot annots_env tc
   | isFamilyTyCon tc = (name, map (const Nominal) tyvars)
   |  isAlgTyCon tc
   || isSynTyCon tc   = (name, default_roles)
   | otherwise        = pprPanic "initialRoleEnv1" (ppr tc)
   where name         = tyConName tc
         tyvars       = tyConTyVars tc
-
-         -- whether are not there are annotations, we're guaranteed that
-         -- the length of role_annots is appropriate
-        role_annots  = case lookupNameEnv annots_env name of
-                          Just annots -> annots
-                          Nothing     -> pprPanic "initialRoleEnv1 annots" (ppr name)
-        default_roles = let kvs = takeWhile isKindVar tyvars in
-                        map (const Nominal) kvs ++
-                        zipWith orElse role_annots (repeat Phantom)
+        (kvs, tvs)   = span isKindVar tyvars
+
+          -- if the number of annotations in the role annotation decl
+          -- is wrong, just ignore it. We check this in the validity check.
+        role_annots
+          = case lookupNameEnv annots_env name of
+              Just (L _ (RoleAnnotDecl _ annots))
+                | annots `equalLength` tvs -> map unLoc annots
+              _                            -> map (const Nothing) tvs
+        default_roles = map (const Nominal) kvs ++
+                        zipWith orElse role_annots (repeat default_role)
+
+        default_role = if is_boot then Representational else Phantom
 
 irGroup :: RoleEnv -> [TyCon] -> RoleEnv
 irGroup env tcs
index 671e857..aa01b13 100644 (file)
@@ -26,7 +26,7 @@ module CoAxiom (
        coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps,
        placeHolderIncomps,
 
-       Role(..), pprFullRole,
+       Role(..), fsFromRole,
 
        CoAxiomRule(..), Eqn
        ) where 
@@ -444,15 +444,17 @@ This is defined here to avoid circular dependencies.
 data Role = Nominal | Representational | Phantom
   deriving (Eq, Data.Data, Data.Typeable)
 
-pprFullRole :: Role -> SDoc
-pprFullRole Nominal          = ptext (sLit "Nominal")
-pprFullRole Representational = ptext (sLit "Representational")
-pprFullRole Phantom          = ptext (sLit "Phantom")
+-- These names are slurped into the parser code. Changing these strings
+-- will change the **surface syntax** that GHC accepts! If you want to
+-- change only the pretty-printing, do some replumbing. See
+-- mkRoleAnnotDecl in RdrHsSyn
+fsFromRole :: Role -> FastString
+fsFromRole Nominal          = fsLit "nominal"
+fsFromRole Representational = fsLit "representational"
+fsFromRole Phantom          = fsLit "phantom"
 
 instance Outputable Role where
-  ppr Nominal          = char 'N'
-  ppr Representational = char 'R'
-  ppr Phantom          = char 'P'
+  ppr = ftext . fsFromRole
 
 instance Binary Role where
   put_ bh Nominal          = putByte bh 1
index 8d593c6..f1c179b 100644 (file)
@@ -687,7 +687,11 @@ ppr_axiom_rule_co co ts ps = ppr (coaxrName co) <> ppTs ts $$ nest 2 (ppPs ps)
 
 
 ppr_role :: Role -> SDoc
-ppr_role r = underscore <> ppr r
+ppr_role r = underscore <> pp_role
+  where pp_role = case r of
+                    Nominal          -> char 'N'
+                    Representational -> char 'R'
+                    Phantom          -> char 'P'
 
 trans_co_list :: Coercion -> [Coercion] -> [Coercion]
 trans_co_list (TransCo co1 co2) cos = trans_co_list co1 (trans_co_list co2 cos)
index 7c765a7..d9b3a85 100644 (file)
@@ -280,11 +280,12 @@ Note [TyCon Role signatures]
 
 Every tycon has a role signature, assigning a role to each of the tyConTyVars
 (or of equal length to the tyConArity, if there are no tyConTyVars). An
-example demonstrates these best: say we have a tycon T, with parameters a@N,
-b@R, and c@P. Then, to prove representational equality between T a1 b1 c1 and
-T a2 b2 c2, we need to have nominal equality between a1 and a2, representational
-equality between b1 and b2, and nothing in particular (i.e., phantom equality)
-between c1 and c2. This might happen, say, with the following declaration:
+example demonstrates these best: say we have a tycon T, with parameters a at
+nominal, b at representational, and c at phantom. Then, to prove
+representational equality between T a1 b1 c1 and T a2 b2 c2, we need to have
+nominal equality between a1 and a2, representational equality between b1 and
+b2, and nothing in particular (i.e., phantom equality) between c1 and c2. This
+might happen, say, with the following declaration:
 
   data T a b c where
     MkT :: b -> T Int b c
index d27336b..b49ad9f 100644 (file)
@@ -3701,7 +3701,7 @@ where
                via this new mechanism.
 </para></listitem>
 <listitem><para>
-  The role of the last parameter of each of the <literal>ci</literal> is <emphasis>not</emphasis> <literal>N</literal>. (See <xref linkend="roles"/>.)</para></listitem>
+  The role of the last parameter of each of the <literal>ci</literal> is <emphasis>not</emphasis> <literal>nominal</literal>. (See <xref linkend="roles"/>.)</para></listitem>
 </itemizedlist>
 Then, for each <literal>ci</literal>, the derived instance
 declaration is:
@@ -10845,35 +10845,36 @@ about <literal>Age</literal> and <literal>Int</literal> in order to show that
 T Int Bool c</literal>).</para>
 
 <para>GHC supports three different roles for type parameters: nominal,
-representational, and phantom. If a type parameter has a nominal (N) role,
-then the two types that differ must not actually differ at all: they must be
+representational, and phantom. If a type parameter has a nominal role, then
+the two types that differ must not actually differ at all: they must be
 identical (after type family reduction). If a type parameter has a
-representational (R) role, then the two types must have the same
-representation. (If <literal>T</literal>'s first parameter's role is R, then
+representational role, then the two types must have the same representation.
+(If <literal>T</literal>'s first parameter's role is representational, then
 <literal>T Age Bool c</literal> and <literal>T Int Bool c</literal> would have
-the same representation, because <literal>Age</literal> and <literal>Int</literal>
-have the same representation.) If a type parameter has a phantom (P) role,
-then we need no further information.</para>
+the same representation, because <literal>Age</literal> and
+<literal>Int</literal> have the same representation.) If a type parameter has
+a phantom role, then we need no further information.</para>
 
 <para>Here are some examples:</para>
 
 <programlisting>
-  data Simple a = MkSimple a          -- a has role R
+  data Simple a = MkSimple a          -- a has role representational
 
   type family F
   type instance F Int = Bool
   type instance F Age = Char
 
-  data Complex a = MkComplex (F a)    -- a has role N
+  data Complex a = MkComplex (F a)    -- a has role nominal
 
-  data Phant a = MkPhant Bool         -- a has role P
+  data Phant a = MkPhant Bool         -- a has role phantom
 </programlisting>
 
-<para>The type <literal>Simple</literal> has its parameter at role R, which is
-generally the most common case. <literal>Simple Age</literal> would have the same
-representation as <literal>Simple Int</literal>. The type <literal>Complex</literal>,
-on the other hand, has its parameter at role N, because <literal>Simple Age</literal>
-and <literal>Simple Int</literal> are <emphasis>not</emphasis> the same. Lastly,
+<para>The type <literal>Simple</literal> has its parameter at role
+representational, which is generally the most common case. <literal>Simple
+Age</literal> would have the same representation as <literal>Simple
+Int</literal>. The type <literal>Complex</literal>, on the other hand, has its
+parameter at role nominal, because <literal>Simple Age</literal> and
+<literal>Simple Int</literal> are <emphasis>not</emphasis> the same. Lastly,
 <literal>Phant Age</literal> and <literal>Phant Bool</literal> have the same
 representation, even though <literal>Age</literal> and <literal>Bool</literal>
 are unrelated.</para>
@@ -10886,17 +10887,19 @@ are unrelated.</para>
 <para>
 What role should a given type parameter should have? GHC performs role
 inference to determine the correct role for every parameter. It starts with a
-few base facts: <literal>(->)</literal> has two R parameters;
-<literal>(~)</literal> has two N parameters; all type families' parameters are
-N; and all GADT-like parameters are N. Then, these facts are propagated to all
-places where these types are used. By defaulting parameters to role P, any
-parameters unused in the right-hand side (or used only in other types in P
-positions) will be P. Whenever a parameter is used in an R position (that is,
-used as a type argument to a constructor whose corresponding variable is at
-role R), we raise its role from P to R. Similarly, when a parameter is used in
-an N position, its role is upgraded to N. We never downgrade a role from N to
-P or R, or from R to P. In this way, we infer the most-general role for each
-parameter.
+few base facts: <literal>(->)</literal> has two representational parameters;
+<literal>(~)</literal> has two nominal parameters; all type families'
+parameters are nominal; and all GADT-like parameters are nominal. Then, these
+facts are propagated to all places where these types are used. By defaulting
+parameters to role phnatom, any parameters unused in the right-hand side (or
+used only in other types in phantom positions) will be phantom. Whenever a
+parameter is used in a representational position (that is, used as a type
+argument to a constructor whose corresponding variable is at role
+representational), we raise its role from phantom to representational.
+Similarly, when a parameter is used in a nominal position, its role is
+upgraded to nominal. We never downgrade a role from nominal to phantom or
+representational, or from representational to phantom. In this way, we infer
+the most-general role for each parameter.
 </para>
 
 <para>There is one particularly tricky case that should be explained:</para>
@@ -10905,20 +10908,22 @@ parameter.
   data Tricky a b = MkTricky (a b)
 </programlisting>
 
-<para>What should <literal>Tricky</literal>'s roles be? At first blush, it would
-seem that both <literal>a</literal> and <literal>b</literal> should be at role R,
-since both are used in the right-hand side and neither is involved in a type family.
-However, this would be wrong, as the following example shows:</para>
+<para>What should <literal>Tricky</literal>'s roles be? At first blush, it
+would seem that both <literal>a</literal> and <literal>b</literal> should be
+at role representational, since both are used in the right-hand side and
+neither is involved in a type family. However, this would be wrong, as the
+following example shows:</para>
 
 <programlisting>
   data Nom a = MkNom (F a)   -- type family F from example above
 </programlisting>
 
 <para>Is <literal>Tricky Nom Age</literal> representationally equal to
-<literal>Tricky Nom Int</literal>? No! The former stores a <literal>Char</literal>
-and the latter stores a <literal>Bool</literal>. The solution to this is
-to require all parameters to type variables to have role N. Thus, GHC would
-infer role R for <literal>a</literal> but role N for <literal>b</literal>.</para>
+<literal>Tricky Nom Int</literal>? No! The former stores a
+<literal>Char</literal> and the latter stores a <literal>Bool</literal>. The
+solution to this is to require all parameters to type variables to have role
+nominal. Thus, GHC would infer role representational for <literal>a</literal>
+but role nominal for <literal>b</literal>.</para>
 
 </sect2>
 
@@ -10937,35 +10942,38 @@ example, the base library contains the following definition:
 </programlisting>
 
 <para>
-The idea is that <literal>a</literal> should really be an R parameter, but
-role inference assigns it to P. This makes some level of sense: a pointer to
-an <literal>Int</literal> really is representationally the same as a pointer
-to a <literal>Bool</literal>. But, that's not at all how we want to use
-<literal>Ptr</literal>s! So, we want to be able to say</para>
+The idea is that <literal>a</literal> should really be a representational
+parameter, but role inference assigns it to phantom. This makes some level of
+sense: a pointer to an <literal>Int</literal> really is representationally the
+same as a pointer to a <literal>Bool</literal>. But, that's not at all how we
+want to use <literal>Ptr</literal>s! So, we want to be able to say</para>
 
 <programlisting>
-  data Ptr a@R = Ptr Addr#
+  type role Ptr representational
+  data Ptr a = Ptr Addr#
 </programlisting>
 
 <para>
-The <literal>@R</literal> (enabled with <option>-XRoleAnnotations</option>) annotation forces the
-parameter a to be at role R, not role P. GHC then checks
-the user-supplied roles to make sure they don't break any promises. It would
-be bad, for example, if the user could make <literal>BadIdea</literal>'s role be R.
+The <literal>type role</literal> (enabled with
+<option>-XRoleAnnotations</option>) declaration forces the parameter
+<literal>a</literal> to be at role representational, not role phantom. GHC
+then checks the user-supplied roles to make sure they don't break any
+promises. It would be bad, for example, if the user could make
+<literal>BadIdea</literal>'s role be representational.
 </para>
 
 <para>As another example, we can consider a type <literal>Set a</literal> that
 represents a set of data, ordered according to <literal>a</literal>'s
 <literal>Ord</literal> instance. While it would generally be type-safe to
-consider <literal>a</literal> to be at role R, it is possible that a
-<literal>newtype</literal> and its base type have
+consider <literal>a</literal> to be at role representational, it is possible
+that a <literal>newtype</literal> and its base type have
 <emphasis>different</emphasis> orderings encoded in their respective
 <literal>Ord</literal> instances. This would lead to misbehavior at runtime.
 So, the author of the <literal>Set</literal> datatype would like its parameter
-to be at role N. This would be done with a declaration</para>
+to be at role nominal. This would be done with a declaration</para>
 
 <programlisting>
-  data Set a@N = ...
+  type role Set nominal
 </programlisting>
 
 <para>The other place where role annotations may be necessary are in
@@ -10973,27 +10981,40 @@ to be at role N. This would be done with a declaration</para>
 the right-hand sides of definitions can be omitted. As usual, the
 types/classes declared in an <literal>hs-boot</literal> file must match up
 with the definitions in the <literal>hs</literal> file, including down to the
-roles. The default role is R in <literal>hs-boot</literal> files,
+roles. The default role is representational in <literal>hs-boot</literal> files,
 corresponding to the common use case.</para>
 
 <para>
-Role annotations are allowed on type variables in data, newtype, class,
-and type declarations. They are not allowed on type/data family
-declarations or in explicit foralls in function type signatures.
-The syntax for a role annotation is an <literal>@</literal> sign followed
-by one of <literal>N</literal>, <literal>R</literal>, or <literal>P</literal>,
-directly following a type variable. If the type variable has an explicit
-kind annotation, the role annotation goes after the kind annotation, outside
-the parentheses. Here are some examples:</para>
+Role annotations are allowed on data, newtype, and class declarations. A role
+annotation declaration starts with <literal>type role</literal> and is
+followed by one role listing for each parameter of the type. (This parameter
+count includes parameters implicitly specified by a kind signature in a
+GADT-style data or newtype declaration.) Each role listing is a role
+(<literal>nominal</literal>, <literal>representational</literal>, or
+<literal>phantom</literal>) or a <literal>_</literal>. Using a
+<literal>_</literal> says that GHC should infer that role. The role annotation
+may go anywhere in the same module as the datatype or class definition
+(much like a value-level type signature).
+Here are some examples:</para>
 
 <programlisting>
-  data T1 a b@P = MkT1 a     -- b is not used; annotation is fine but unnecessary
-  data T2 a b@P = MkT2 b     -- ERROR: b is used and cannot be P
-  data T3 a b@N = MkT3 a     -- OK: N is higher than necessary, but safe
-  data T4 (a :: * -> *)@N = MkT4 (a Int)    -- OK, but N is higher than necessary
-  class C a@R b where ...    -- OK
-  type X a@N = ...           -- OK
-  type family F a@R          -- ERROR: annotations not allowed on family declarations
+  type role T1 _ phantom
+  data T1 a b = MkT1 a     -- b is not used; annotation is fine but unnecessary
+
+  type role T2 _ phantom
+  data T2 a b = MkT2 b     -- ERROR: b is used and cannot be phantom
+
+  type role T3 _ nominal
+  data T3 a b = MkT3 a     -- OK: nominal is higher than necessary, but safe
+
+  type role T4 nominal
+  data T4 a = MkT4 (a Int)    -- OK, but N is higher than necessary
+
+  type role C representational _
+  class C a b where ...    -- OK
+
+  type role X nominal
+  type X a@N = ...           -- ERROR: role annotations not allowed for type synonyms
 </programlisting>
 
 </sect2>
index 2f8b9d6..c571c39 100644 (file)
@@ -878,6 +878,7 @@ methods entirely; but you must either omit them all or put them all in.
 </para></listitem>
 <listitem><para> You can include instance declarations just as in Haskell; but omit the "where" part.
  </para></listitem>
+<listitem><para>The default role for class and datatype parameters is now representational. To get another role, use a role annotation. (See <xref linkend="roles"/>.)
 </itemizedlist>
 </para>
     </sect2>
index a4cb302..0f9886f 100644 (file)
@@ -260,7 +260,7 @@ boundValues mod group =
                        , bind <- bagToList binds
                        , x <- boundThings mod bind ]
                _other -> error "boundValues"
-      tys = [ n | ns <- map hsLTyClDeclBinders (concat (hs_tyclds group))
+      tys = [ n | ns <- map hsLTyClDeclBinders (tyClGroupConcat (hs_tyclds group))
                 , n <- map found ns ]
       fors = concat $ map forBound (hs_fords group)
              where forBound lford = case unLoc lford of