Commit 431c05b3 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Deal with kind variables brought into scope by a kind signature

This fixes Trac #5937, where a kind variable is mentioned only
in the kind signature of a GADT
   data SMaybe :: (k -> *) -> Maybe k -> * where ...

The main change is that the tcdKindSig field of TyData and TyFamily
now has type Maybe (HsBndrSig (LHsKind name)), where the HsBndrSig
part deals with the kind variables that the signature may bind.

I also removed the now-unused PostTcKind field of UserTyVar and
KindedTyVar.
parent 3e904ffc
......@@ -452,7 +452,7 @@ data TyClDecl name
TyFamily { tcdFlavour :: FamilyFlavour, -- type or data
tcdLName :: Located name, -- type constructor
tcdTyVars :: [LHsTyVarBndr name], -- type variables
tcdKindSig :: Maybe (LHsKind name) -- result kind
tcdKindSig :: Maybe (HsBndrSig (LHsKind name)) -- result kind
}
......@@ -470,7 +470,7 @@ data TyClDecl name
tcdTyPats :: Maybe [LHsType name], -- ^ Type patterns.
-- See Note [tcdTyVars and tcdTyPats]
tcdKindSig:: Maybe (LHsKind name),
tcdKindSig:: Maybe (HsBndrSig (LHsKind name)),
-- ^ Optional kind signature.
--
-- @(Just k)@ for a GADT-style @data@, or @data
......@@ -667,7 +667,7 @@ instance OutputableBndr name
derivings
where
ppr_sigx Nothing = empty
ppr_sigx (Just kind) = dcolon <+> ppr kind
ppr_sigx (Just (HsBSig kind _)) = dcolon <+> ppr kind
ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
tcdFDs = fds,
......
......@@ -30,7 +30,6 @@ module HsTypes (
mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
hsTyVarName, hsTyVarNames,
hsTyVarKind, hsLTyVarKind, hsTyVarNameKind,
hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe,
splitHsForAllTy, splitLHsForAllTy,
......@@ -143,12 +142,10 @@ placeHolderBndrs = panic "placeHolderBndrs"
data HsTyVarBndr name
= UserTyVar -- No explicit kinding
name -- See Note [Printing KindedTyVars]
PostTcKind
| KindedTyVar
name
(HsBndrSig (LHsKind name)) -- The user-supplied kind signature
PostTcKind
-- *** NOTA BENE *** A "monotype" in a pragma can have
-- for-alls in it, (mostly to do with dictionaries). These
-- must be explicitly Kinded.
......@@ -374,19 +371,8 @@ hsExplicitTvs _ = []
---------------------
hsTyVarName :: HsTyVarBndr name -> name
hsTyVarName (UserTyVar n _) = n
hsTyVarName (KindedTyVar n _ _) = n
hsTyVarKind :: HsTyVarBndr name -> Kind
hsTyVarKind (UserTyVar _ k) = k
hsTyVarKind (KindedTyVar _ _ k) = k
hsLTyVarKind :: LHsTyVarBndr name -> Kind
hsLTyVarKind = hsTyVarKind . unLoc
hsTyVarNameKind :: HsTyVarBndr name -> (name, Kind)
hsTyVarNameKind (UserTyVar n k) = (n,k)
hsTyVarNameKind (KindedTyVar n _ k) = (n,k)
hsTyVarName (UserTyVar n) = n
hsTyVarName (KindedTyVar n _) = n
hsLTyVarName :: LHsTyVarBndr name -> name
hsLTyVarName = hsTyVarName . unLoc
......@@ -493,8 +479,8 @@ instance (Outputable sig) => Outputable (HsBndrSig sig) where
ppr (HsBSig ty _) = ppr ty
instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where
ppr (UserTyVar name _) = ppr name
ppr (KindedTyVar name kind _) = parens $ hsep [ppr name, dcolon, ppr kind]
ppr (UserTyVar name) = ppr name
ppr (KindedTyVar name kind) = parens $ hsep [ppr name, dcolon, ppr kind]
pprHsForAll :: OutputableBndr name => HsExplicitFlag -> [LHsTyVarBndr name] -> LHsContext name -> SDoc
pprHsForAll exp tvs cxt
......
......@@ -268,7 +268,7 @@ mkHsString s = HsString (mkFastString s)
-------------
userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
userHsTyVarBndrs bndrs = [ L loc (UserTyVar v placeHolderKind) | L loc v <- bndrs ]
userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ]
\end{code}
......
......@@ -722,9 +722,9 @@ data_or_newtype :: { Located NewOrData }
: 'data' { L1 DataType }
| 'newtype' { L1 NewType }
opt_kind_sig :: { Located (Maybe (LHsKind RdrName)) }
opt_kind_sig :: { Located (Maybe (HsBndrSig (LHsKind RdrName))) }
: { noLoc Nothing }
| '::' kind { LL (Just $2) }
| '::' kind { LL (Just (HsBSig $2 placeHolderBndrs)) }
-- tycl_hdr parses the header of a class or data type decl,
-- which takes the form
......@@ -1101,8 +1101,8 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
| {- empty -} { [] }
tv_bndr :: { LHsTyVarBndr RdrName }
: tyvar { L1 (UserTyVar (unLoc $1) placeHolderKind) }
| '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) (HsBSig $4 placeHolderBndrs) placeHolderKind) }
: tyvar { L1 (UserTyVar (unLoc $1)) }
| '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) (HsBSig $4 placeHolderBndrs)) }
fds :: { Located [Located (FunDep RdrName)] }
: {- empty -} { noLoc [] }
......
......@@ -375,7 +375,7 @@ ifaceUnliftedTypeKind = ifaceTcType (IfaceTc unliftedTypeKindTyConName)
ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig placeHolderKind
toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig
where
bsig = HsBSig (toHsKind k) placeHolderBndrs
......
......@@ -194,7 +194,7 @@ mkTyData :: SrcSpan
-> Bool -- True <=> data family instance
-> Maybe CType
-> Located (Maybe (LHsContext RdrName), LHsType RdrName)
-> Maybe (LHsKind RdrName)
-> Maybe (HsBndrSig (LHsKind RdrName))
-> [LConDecl RdrName]
-> Maybe [LHsType RdrName]
-> P (LTyClDecl RdrName)
......@@ -208,7 +208,8 @@ mkTyData loc new_or_data is_family cType (L _ (mcxt, tycl_hdr)) ksig data_cons m
tcdCtxt = cxt, tcdLName = tc,
tcdTyVars = tyvars, tcdTyPats = typats,
tcdCons = data_cons,
tcdKindSig = ksig, tcdDerivs = maybe_deriv })) }
tcdKindSig = ksig,
tcdDerivs = maybe_deriv })) }
mkTySynonym :: SrcSpan
-> Bool -- True <=> type family instances
......@@ -225,7 +226,7 @@ mkTySynonym loc is_family lhs rhs
mkTyFamily :: SrcSpan
-> FamilyFlavour
-> LHsType RdrName -- LHS
-> Maybe (LHsKind RdrName) -- Optional kind signature
-> Maybe (HsBndrSig (LHsKind RdrName)) -- Optional kind signature
-> P (LTyClDecl RdrName)
mkTyFamily loc flavour lhs ksig
= do { (tc, tparams) <- checkTyClHdr lhs
......@@ -501,9 +502,9 @@ checkTyVars tycl_hdr tparms = mapM chk tparms
where
-- Check that the name space is correct!
chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
| isRdrTyVar tv = return (L l (KindedTyVar tv (HsBSig k placeHolderBndrs) placeHolderKind))
| isRdrTyVar tv = return (L l (KindedTyVar tv (HsBSig k placeHolderBndrs)))
chk (L l (HsTyVar tv))
| isRdrTyVar tv = return (L l (UserTyVar tv placeHolderKind))
| isRdrTyVar tv = return (L l (UserTyVar tv))
chk t@(L l _)
= parseErrorSDoc l $
vcat [ sep [ ptext (sLit "Unexpected type") <+> quotes (ppr t)
......
......@@ -106,12 +106,13 @@ rnLHsType = rnLHsTyKi True
rnLHsKind :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars)
rnLHsKind = rnLHsTyKi False
rnLHsMaybeKind :: HsDocContext -> Maybe (LHsKind RdrName)
-> RnM (Maybe (LHsKind Name), FreeVars)
rnLHsMaybeKind _ Nothing = return (Nothing, emptyFVs)
rnLHsMaybeKind doc (Just k)
= do { (k', fvs) <- rnLHsKind doc k
; return (Just k', fvs) }
rnLHsMaybeKind :: HsDocContext -> Maybe (HsBndrSig (LHsKind RdrName))
-> RnM (Maybe (HsBndrSig (LHsKind Name)), FreeVars)
rnLHsMaybeKind _ Nothing
= return (Nothing, emptyFVs)
rnLHsMaybeKind doc (Just bsig)
= rnHsBndrSig False doc bsig $ \ bsig' ->
return (Just bsig', emptyFVs)
rnHsType :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
rnHsType = rnHsTyKi True
......@@ -404,14 +405,14 @@ bindTyVarsRn doc tv_bndrs names thing_inside
where
go [] [] thing_inside = thing_inside []
go (L loc (UserTyVar _ tck) : tvs) (n : ns) thing_inside
go (L loc (UserTyVar _) : tvs) (n : ns) thing_inside
= go tvs ns $ \ tvs' ->
thing_inside (L loc (UserTyVar n tck) : tvs')
thing_inside (L loc (UserTyVar n) : tvs')
go (L loc (KindedTyVar _ bsig tck) : tvs) (n : ns) thing_inside
go (L loc (KindedTyVar _ bsig) : tvs) (n : ns) thing_inside
= rnHsBndrSig False doc bsig $ \ bsig' ->
go tvs ns $ \ tvs' ->
thing_inside (L loc (KindedTyVar n bsig' tck) : tvs')
thing_inside (L loc (KindedTyVar n bsig') : tvs')
-- Lists of unequal length
go tvs names _ = pprPanic "bindTyVarsRn" (ppr tvs $$ ppr names)
......
......@@ -20,7 +20,7 @@ module TcEnv(
tcLookupLocatedClass, tcLookupInstance, tcLookupAxiom,
-- Local environment
tcExtendKindEnv, tcExtendKindEnvTvs, tcExtendTcTyThingEnv,
tcExtendKindEnv, tcExtendTcTyThingEnv,
tcExtendTyVarEnv, tcExtendTyVarEnv2,
tcExtendGhciEnv, tcExtendLetEnv,
tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
......@@ -340,11 +340,6 @@ tcExtendKindEnv things thing_inside
upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> ([LHsTyVarBndr Name] -> TcM r) -> TcM r
tcExtendKindEnvTvs bndrs thing_inside
= tcExtendKindEnv (map (hsTyVarNameKind . unLoc) bndrs)
(thing_inside bndrs)
-----------------------
-- Scoped type and kind variables
tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
......
......@@ -785,7 +785,7 @@ bindScopedKindVars hs_tvs thing_inside
where
kvs :: [KindVar] -- All skolems
kvs = [ mkKindSigVar kv
| L _ (KindedTyVar _ (HsBSig _ kvs) _) <- hs_tvs
| L _ (KindedTyVar _ (HsBSig _ kvs)) <- hs_tvs
, kv <- kvs ]
tcHsTyVarBndrs :: [LHsTyVarBndr Name]
......@@ -818,7 +818,7 @@ tcHsTyVarBndr (L _ hs_tv)
_ -> do
{ kind <- case hs_tv of
UserTyVar {} -> newMetaKindVar
KindedTyVar _ (HsBSig kind _) _ -> tcLHsKind kind
KindedTyVar _ (HsBSig kind _) -> tcLHsKind kind
; return (mkTyVar name kind) } } }
------------------
......@@ -908,7 +908,7 @@ kcLookupKind nm
_ -> pprPanic "kcLookupKind" (ppr tc_ty_thing) }
kcTyClTyVars :: Name -> [LHsTyVarBndr Name] -> (TcKind -> TcM a) -> TcM a
-- Used for the type varaibles of a type or class decl,
-- Used for the type variables of a type or class decl,
-- when doing the initial kind-check.
kcTyClTyVars name hs_tvs thing_inside
= bindScopedKindVars hs_tvs $
......@@ -920,10 +920,10 @@ kcTyClTyVars name hs_tvs thing_inside
; tcExtendKindEnv name_ks (thing_inside res_k) }
where
kc_tv :: LHsTyVarBndr Name -> Kind -> TcM (Name, Kind)
kc_tv (L _ (UserTyVar n _)) exp_k
kc_tv (L _ (UserTyVar n)) exp_k
= do { check_in_scope n exp_k
; return (n, exp_k) }
kc_tv (L _ (KindedTyVar n (HsBSig hs_k _) _)) exp_k
kc_tv (L _ (KindedTyVar n (HsBSig hs_k _))) exp_k
= do { k <- tcLHsKind hs_k
; _ <- unifyKind k exp_k
; check_in_scope n exp_k
......
......@@ -431,13 +431,14 @@ kcFamilyDecl (TySynonym {}) = return ()
kcFamilyDecl d = pprPanic "kcFamilyDecl" (ppr d)
------------------
kcResultKind :: Maybe (LHsKind Name) -> Kind -> TcM ()
kcResultKind :: Maybe (HsBndrSig (LHsKind Name)) -> Kind -> TcM ()
kcResultKind Nothing res_k
= discardResult (unifyKind res_k liftedTypeKind)
-- type family F a
-- defaults to type family F a :: *
kcResultKind (Just k) res_k
= do { k' <- tcLHsKind k
kcResultKind (Just (HsBSig k ns)) res_k
= do { let kvs = map mkKindSigVar ns
; k' <- tcExtendTyVarEnv kvs (tcLHsKind k)
; discardResult (unifyKind k' res_k) }
\end{code}
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment