Commit f4046b50 authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

Change role annotation syntax.

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

This change also removes the ability for a role annotation on type
synonyms, as noted in #8234.
parent 96421e06
......@@ -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 ;
......@@ -234,6 +235,15 @@ repTyClD (L loc d) = putSrcSpanDs loc $
do { warnDs (hang ds_msg 4 (ppr d))
; 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])
......@@ -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
......@@ -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' }
......
......@@ -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
......@@ -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)
......
......@@ -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)
-------------------
......
......@@ -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