diff options
| -rw-r--r-- | compiler/deSugar/DsMeta.hs | 43 | ||||
| -rw-r--r-- | compiler/hsSyn/Convert.lhs | 22 | ||||
| -rw-r--r-- | compiler/hsSyn/HsDecls.lhs | 32 | ||||
| -rw-r--r-- | compiler/hsSyn/HsPat.lhs | 4 | ||||
| -rw-r--r-- | compiler/hsSyn/HsTypes.lhs | 126 | ||||
| -rw-r--r-- | compiler/hsSyn/HsUtils.lhs | 5 | ||||
| -rw-r--r-- | compiler/parser/Parser.y.pp | 8 | ||||
| -rw-r--r-- | compiler/parser/ParserCore.y | 10 | ||||
| -rw-r--r-- | compiler/parser/RdrHsSyn.lhs | 25 | ||||
| -rw-r--r-- | compiler/rename/RnBinds.lhs | 2 | ||||
| -rw-r--r-- | compiler/rename/RnEnv.lhs | 17 | ||||
| -rw-r--r-- | compiler/rename/RnPat.lhs | 4 | ||||
| -rw-r--r-- | compiler/rename/RnSource.lhs | 81 | ||||
| -rw-r--r-- | compiler/rename/RnTypes.lhs | 264 | ||||
| -rw-r--r-- | compiler/typecheck/TcEvidence.lhs | 3 | ||||
| -rw-r--r-- | compiler/typecheck/TcHsType.lhs | 41 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnDriver.lhs | 9 | ||||
| -rw-r--r-- | compiler/typecheck/TcSMonad.lhs | 61 | ||||
| -rw-r--r-- | compiler/typecheck/TcTyClsDecls.lhs | 31 |
19 files changed, 422 insertions, 366 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 060b63d46e..98aec5f167 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -150,7 +150,8 @@ repTopDs group hsSigTvBinders :: HsValBinds Name -> [Name] -- See Note [Scoped type variables in bindings] hsSigTvBinders binds - = [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit tvs _ _))) <- sigs, tv <- tvs] + = [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit qtvs _ _))) <- sigs + , tv <- hsQTvBndrs qtvs] where sigs = case binds of ValBindsIn _ sigs -> sigs @@ -214,9 +215,8 @@ repTyClD (L loc (TyFamily { tcdFlavour = flavour, do { flav <- repFamilyFlavour flavour ; case opt_kind of Nothing -> repFamilyNoKind flav tc1 bndrs - Just (HsBSig ki _) - -> do { ki1 <- repKind ki - ; repFamilyKind flav tc1 bndrs ki1 } + Just ki -> do { ki1 <- repKind ki + ; repFamilyKind flav tc1 bndrs ki1 } } ; return $ Just (loc, dec) } @@ -272,15 +272,15 @@ repTyDefn tc bndrs opt_tys _ (TySynonym { td_synRhs = ty }) ; repTySyn tc bndrs opt_tys ty1 } ------------------------- -mk_extra_tvs :: Located Name -> [LHsTyVarBndr Name] - -> HsTyDefn Name -> DsM [LHsTyVarBndr Name] +mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name + -> HsTyDefn Name -> DsM (LHsTyVarBndrs Name) -- If there is a kind signature it must be of form -- k1 -> .. -> kn -> * -- Return type variables [tv1:k1, tv2:k2, .., tvn:kn] mk_extra_tvs tc tvs defn - | TyData { td_kindSig = Just (HsBSig hs_kind _) } <- defn + | TyData { td_kindSig = Just hs_kind } <- defn = do { extra_tvs <- go hs_kind - ; return (tvs ++ extra_tvs) } + ; return (mkHsQTvs (hsQTvBndrs tvs ++ extra_tvs)) } | otherwise = return tvs where @@ -289,7 +289,7 @@ mk_extra_tvs tc tvs defn = do { uniq <- newUnique ; let { occ = mkTyVarOccFS (fsLit "t") ; nm = mkInternalName uniq occ loc - ; hs_tv = L loc (KindedTyVar nm (mkHsBSig kind)) } + ; hs_tv = L loc (KindedTyVar nm kind) } ; hs_tvs <- go rest ; return (hs_tv : hs_tvs) } @@ -340,7 +340,7 @@ repInstD (L loc (ClsInstD { cid_poly_ty = ty, cid_binds = binds -- the selector Ids, not to fresh names (Trac #5410) -- do { cxt1 <- repContext cxt - ; cls_tcon <- repTy (HsTyVar cls) + ; cls_tcon <- repTy (HsTyVar (unLoc cls)) ; cls_tys <- repLTys tys ; inst_ty1 <- repTapps cls_tcon cls_tys ; binds1 <- rep_binds binds @@ -350,17 +350,17 @@ repInstD (L loc (ClsInstD { cid_poly_ty = ty, cid_binds = binds ; repInst cxt1 inst_ty1 decls } ; return (loc, dec) } where - Just (tvs, cxt, cls, tys) = splitHsInstDeclTy_maybe (unLoc ty) + Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty repFamInstD :: FamInstDecl Name -> DsM (Core TH.DecQ) repFamInstD (FamInstDecl { fid_tycon = tc_name - , fid_pats = HsBSig tys (kv_names, tv_names) + , fid_pats = HsWB { hswb_cts = tys, hswb_kvs = kv_names, hswb_tvs = tv_names } , fid_defn = defn }) = WARN( not (null kv_names), ppr kv_names ) -- We have not yet dealt with kind -- polymorphism in Template Haskell (sigh) do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] ; let loc = getLoc tc_name - hs_tvs = [ L loc (UserTyVar n) | n <- tv_names] -- Yuk + hs_tvs = mkHsQTvs (userHsTyVarBndrs loc tv_names) -- Yuk ; addTyClTyVarBinds hs_tvs $ \ bndrs -> do { tys1 <- repLTys tys ; tys2 <- coreList typeQTyConName tys1 @@ -419,8 +419,9 @@ ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:") ------------------------------------------------------- repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ) -repC _ (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ [] +repC _ (L _ (ConDecl { con_name = con, con_qvars = con_tvs, con_cxt = L _ [] , con_details = details, con_res = ResTyH98 })) + | null (hsQTvBndrs con_tvs) = do { con1 <- lookupLOcc con -- See note [Binders and occurrences] ; repConstr con1 details } repC tvs (L _ (ConDecl { con_name = con @@ -428,7 +429,7 @@ repC tvs (L _ (ConDecl { con_name = con , con_details = details , con_res = res_ty })) = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty - ; let ex_tvs = [ tv | tv <- con_tvs, not (hsLTyVarName tv `in_subst` con_tv_subst)] + ; let ex_tvs = mkHsQTvs [ tv | tv <- hsQTvBndrs con_tvs, not (hsLTyVarName tv `in_subst` con_tv_subst)] ; binds <- mapM dupBinder con_tv_subst ; dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs @@ -552,7 +553,7 @@ rep_ty_sig loc (L _ ty) nm rep_ty (HsForAllTy Explicit tvs ctxt ty) = do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) ; repTyVarBndrWithKind tv name } - ; bndrs1 <- mapM rep_in_scope_tv tvs + ; bndrs1 <- mapM rep_in_scope_tv (hsQTvBndrs tvs) ; bndrs2 <- coreList tyVarBndrTyConName bndrs1 ; ctxt1 <- repLContext ctxt ; ty1 <- repLTy ty @@ -616,7 +617,7 @@ rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inlin -- Types ------------------------------------------------------- -addTyVarBinds :: [LHsTyVarBndr Name] -- the binders to be added +addTyVarBinds :: LHsTyVarBndrs Name -- the binders to be added -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env -> DsM (Core (TH.Q a)) -- gensym a list of type variables and enter them into the meta environment; @@ -626,14 +627,14 @@ addTyVarBinds :: [LHsTyVarBndr Name] -- the binders to be addTyVarBinds tvs m = do { freshNames <- mkGenSyms (hsLTyVarNames tvs) ; term <- addBinds freshNames $ - do { kbs1 <- mapM mk_tv_bndr (tvs `zip` freshNames) + do { kbs1 <- mapM mk_tv_bndr (hsQTvBndrs tvs `zip` freshNames) ; kbs2 <- coreList tyVarBndrTyConName kbs1 ; m kbs2 } ; wrapGenSyms freshNames term } where mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) -addTyClTyVarBinds :: [LHsTyVarBndr Name] +addTyClTyVarBinds :: LHsTyVarBndrs Name -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -> DsM (Core (TH.Q a)) @@ -650,7 +651,7 @@ addTyClTyVarBinds tvs m -- This makes things work for family declarations ; term <- addBinds freshNames $ - do { kbs1 <- mapM mk_tv_bndr tvs + do { kbs1 <- mapM mk_tv_bndr (hsQTvBndrs tvs) ; kbs2 <- coreList tyVarBndrTyConName kbs1 ; m kbs2 } @@ -665,7 +666,7 @@ repTyVarBndrWithKind :: LHsTyVarBndr Name -> Core TH.Name -> DsM (Core TH.TyVarBndr) repTyVarBndrWithKind (L _ (UserTyVar {})) nm = repPlainTV nm -repTyVarBndrWithKind (L _ (KindedTyVar _ (HsBSig ki _))) nm +repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm = repKind ki >>= repKindedTV nm -- represent a type context diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 7e8ceb6695..8d5ad6b4f0 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -275,7 +275,7 @@ cvt_ci_decs doc decs cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr] -> CvtM ( LHsContext RdrName , Located RdrName - , [LHsTyVarBndr RdrName]) + , LHsTyVarBndrs RdrName) cvt_tycl_hdr cxt tc tvs = do { cxt' <- cvtContext cxt ; tc' <- tconNameL tc @@ -286,12 +286,12 @@ cvt_tycl_hdr cxt tc tvs cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type] -> CvtM ( LHsContext RdrName , Located RdrName - , HsBndrSig [LHsType RdrName]) + , HsWithBndrs [LHsType RdrName]) cvt_tyinst_hdr cxt tc tys = do { cxt' <- cvtContext cxt ; tc' <- tconNameL tc ; tys' <- mapM cvtType tys - ; return (cxt', tc', mkHsBSig tys') } + ; return (cxt', tc', mkHsWithBndrs tys') } ------------------------------------------------------------------- -- Partitioning declarations @@ -348,7 +348,7 @@ cvtConstr (ForallC tvs ctxt con) = do { tvs' <- cvtTvs tvs ; L loc ctxt' <- cvtContext ctxt ; L _ con' <- cvtConstr con - ; returnL $ con' { con_qvars = tvs' ++ con_qvars con' + ; returnL $ con' { con_qvars = mkHsQTvs (hsQTvBndrs tvs' ++ hsQTvBndrs (con_qvars con')) , con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } } cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName) @@ -759,7 +759,7 @@ cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void } cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t - ; return $ SigPatIn p' (mkHsBSig t') } + ; return $ SigPatIn p' (mkHsWithBndrs t') } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void } cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName)) @@ -784,8 +784,8 @@ cvtOpAppP x op y ----------------------------------------------------------- -- Types and type variables -cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName] -cvtTvs tvs = mapM cvt_tv tvs +cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsTyVarBndrs RdrName) +cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') } cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName) cvt_tv (TH.PlainTV nm) @@ -794,7 +794,7 @@ cvt_tv (TH.PlainTV nm) cvt_tv (TH.KindedTV nm ki) = do { nm' <- tName nm ; ki' <- cvtKind ki - ; returnL $ KindedTyVar nm' (mkHsBSig ki') } + ; returnL $ KindedTyVar nm' ki' } cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName) cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' } @@ -845,7 +845,7 @@ cvtType ty -> do { tvs' <- cvtTvs tvs ; cxt' <- cvtContext cxt ; ty' <- cvtType ty - ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty' + ; returnL $ mkExplicitHsForAllTy (hsQTvBndrs tvs') cxt' ty' } SigT ty ki @@ -875,10 +875,10 @@ cvtKind (ArrowK k1 k2) = do k2' <- cvtKind k2 returnL (HsFunTy k1' k2') -cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (HsBndrSig (LHsKind RdrName))) +cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (LHsKind RdrName)) cvtMaybeKind Nothing = return Nothing cvtMaybeKind (Just ki) = do { ki' <- cvtKind ki - ; return (Just (mkHsBSig ki')) } + ; return (Just ki') } ----------------------------------------------------------- cvtFixity :: TH.Fixity -> Hs.Fixity diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index c789a9efdc..cf1c2c9a8e 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -428,20 +428,20 @@ data TyClDecl name | -- | @type/data family T :: *->*@ TyFamily { tcdFlavour :: FamilyFlavour, -- type or data tcdLName :: Located name, -- type constructor - tcdTyVars :: [LHsTyVarBndr name], -- type variables - tcdKindSig :: Maybe (HsBndrSig (LHsKind name)) -- result kind + tcdTyVars :: LHsTyVarBndrs name, -- type variables + tcdKindSig :: Maybe (LHsKind name) -- result kind } | -- | @type/data declaration TyDecl { tcdLName :: Located name -- ^ Type constructor - , tcdTyVars :: [LHsTyVarBndr name] + , tcdTyVars :: LHsTyVarBndrs name , tcdTyDefn :: HsTyDefn name , tcdFVs :: NameSet } | ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context... tcdLName :: Located name, -- ^ Name of the class - tcdTyVars :: [LHsTyVarBndr name], -- ^ Class type variables + tcdTyVars :: LHsTyVarBndrs name, -- ^ Class type variables tcdFDs :: [Located (FunDep name)], -- ^ Functional deps tcdSigs :: [LSig name], -- ^ Methods' signatures tcdMeths :: LHsBinds name, -- ^ Default methods @@ -468,7 +468,7 @@ data HsTyDefn name -- The payload of a type synonym or data type defn TyData { td_ND :: NewOrData, td_ctxt :: LHsContext name, -- ^ Context td_cType :: Maybe CType, - td_kindSig:: Maybe (HsBndrSig (LHsKind name)), + td_kindSig:: Maybe (LHsKind name), -- ^ Optional kind signature. -- -- @(Just k)@ for a GADT-style @data@, or @data @@ -619,18 +619,18 @@ instance OutputableBndr name pp_vanilla_decl_head :: OutputableBndr name => Located name - -> [LHsTyVarBndr name] + -> LHsTyVarBndrs name -> HsContext name -> SDoc pp_vanilla_decl_head thing tyvars context - = hsep [pprHsContext context, pprPrefixOcc (unLoc thing), interppSP tyvars] + = hsep [pprHsContext context, pprPrefixOcc (unLoc thing), ppr tyvars] pp_fam_inst_head :: OutputableBndr name => Located name - -> HsBndrSig [LHsType name] + -> HsWithBndrs [LHsType name] -> HsContext name -> SDoc -pp_fam_inst_head thing (HsBSig typats _) context -- explicit type patterns +pp_fam_inst_head thing (HsWB { hswb_cts = typats }) context -- explicit type patterns = hsep [ ptext (sLit "instance"), pprHsContext context, pprPrefixOcc (unLoc thing) , hsep (map (pprParendHsType.unLoc) typats)] @@ -660,8 +660,8 @@ pp_ty_defn pp_hdr (TyData { td_ND = new_or_data, td_ctxt = L _ context 2 (pp_condecls condecls $$ pp_derivings) where pp_sig = case mb_sig of - Nothing -> empty - Just (HsBSig kind _) -> dcolon <+> ppr kind + Nothing -> empty + Just kind -> dcolon <+> ppr kind pp_derivings = case derivings of Nothing -> empty Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)] @@ -715,7 +715,7 @@ data ConDecl name , con_explicit :: HsExplicitFlag -- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy') - , con_qvars :: [LHsTyVarBndr name] + , con_qvars :: LHsTyVarBndrs name -- ^ Type variables. Depending on 'con_res' this describes the -- following entities -- @@ -808,8 +808,8 @@ type LFamInstDecl name = Located (FamInstDecl name) data FamInstDecl name = FamInstDecl { fid_tycon :: Located name - , fid_pats :: HsBndrSig [LHsType name] -- ^ Type patterns (with bndrs) - , fid_defn :: HsTyDefn name -- Type or data family instance + , fid_pats :: HsWithBndrs [LHsType name] -- ^ Type patterns (with kind and type bndrs) + , fid_defn :: HsTyDefn name -- Type or data family instance , fid_fvs :: NameSet } deriving( Typeable, Data ) @@ -1060,10 +1060,10 @@ data RuleDecl name data RuleBndr name = RuleBndr (Located name) - | RuleBndrSig (Located name) (HsBndrSig (LHsType name)) + | RuleBndrSig (Located name) (HsWithBndrs (LHsType name)) deriving (Data, Typeable) -collectRuleBndrSigTys :: [RuleBndr name] -> [HsBndrSig (LHsType name)] +collectRuleBndrSigTys :: [RuleBndr name] -> [HsWithBndrs (LHsType name)] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] instance OutputableBndr name => Outputable (RuleDecl name) where diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index 1a5e206a54..64bda890db 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -131,8 +131,8 @@ data Pat id (SyntaxExpr id) -- Name of '-' (see RnEnv.lookupSyntaxName) ------------ Pattern type signatures --------------- - | SigPatIn (LPat id) -- Pattern with a type signature - (HsBndrSig (LHsType id)) + | SigPatIn (LPat id) -- Pattern with a type signature + (HsWithBndrs (LHsType id)) -- Signature can bind both kind and type vars | SigPatOut (LPat id) -- Pattern with a type signature Type diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 9a6679a68e..2504ad892e 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -17,7 +17,9 @@ HsTypes: Abstract syntax: user-defined types module HsTypes ( HsType(..), LHsType, HsKind, LHsKind, - HsBndrSig(..), HsTyVarBndr(..), LHsTyVarBndr, + HsTyVarBndr(..), LHsTyVarBndr, + LHsTyVarBndrs(..), + HsWithBndrs(..), HsTupleSort(..), HsExplicitFlag(..), HsContext, LHsContext, HsQuasiQuote(..), @@ -29,15 +31,14 @@ module HsTypes ( ConDeclField(..), pprConDeclFields, + mkHsQTvs, hsQTvBndrs, mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs, - hsTyVarName, hsTyVarNames, + hsTyVarName, hsTyVarNames, mkHsWithBndrs, hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, - splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe, - splitHsForAllTy, splitLHsForAllTy, + splitLHsInstDeclTy_maybe, splitHsClassTy_maybe, splitLHsClassTy_maybe, splitHsFunType, splitHsAppTys, mkHsAppTys, mkHsOpTy, - placeHolderBndrs, -- Printing pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, @@ -112,6 +113,17 @@ getBangStrictness _ = HsNoBang This is the syntax for types as seen in type signatures. +Note [HsBSig binder lists] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a binder (or pattern) decoarated with a type or kind, + \ (x :: a -> a). blah + forall (a :: k -> *) (b :: k). blah +Then we use a LHsBndrSig on the binder, so that the +renamer can decorate it with the variables bound +by the pattern ('a' in the first example, 'k' in the second), +assuming that neither of them is in scope already +See also Note [Kind and type-variable binders] in RnTypes + \begin{code} type LHsContext name = Located (HsContext name) @@ -123,29 +135,29 @@ type LHsKind name = Located (HsKind name) type LHsTyVarBndr name = Located (HsTyVarBndr name) -data HsBndrSig sig - = HsBSig - sig -- The signature; typically a type - ([Name], [Name]) -- The *binding* (kind, type) names of - -- this signature - -- See Note [HsBSig binder lists] - +data LHsTyVarBndrs name + = HsQTvs { hsq_kvs :: [Name] -- Kind variables + , hsq_tvs :: [LHsTyVarBndr name] -- Type variables + -- See Note [HsForAllTy tyvar binders] + } + deriving( Data, Typeable ) + +mkHsQTvs :: [LHsTyVarBndr name] -> LHsTyVarBndrs name +mkHsQTvs tvs = HsQTvs { hsq_kvs = panic "mkHsQTvs", hsq_tvs = tvs } + +hsQTvBndrs :: LHsTyVarBndrs name -> [LHsTyVarBndr name] +hsQTvBndrs = hsq_tvs + +data HsWithBndrs thing + = HsWB { hswb_cts :: thing -- Main payload (type or list of types) + , hswb_kvs :: [Name] -- Kind vars + , hswb_tvs :: [Name] -- Type vars + } deriving (Data, Typeable) --- Note [HsBSig binder lists] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Consider a binder (or pattern) decoarated with a type or kind, --- \ (x :: a -> a). blah --- forall (a :: k -> *) (b :: k). blah --- Then we use a LHsBndrSig on the binder, so that the --- renamer can decorate it with the variables bound --- by the pattern ('a' in the first example, 'k' in the second), --- assuming that neither of them is in scope already --- See also Note [Kind and type-variable binders] in RnTypes - -placeHolderBndrs :: [Name] --- Used for the NameSet in FunBind and PatBind prior to the renamer -placeHolderBndrs = panic "placeHolderBndrs" +mkHsWithBndrs :: thing -> HsWithBndrs thing +mkHsWithBndrs x = HsWB { hswb_cts = x, hswb_kvs = panic "mkHsTyWithBndrs:kvs" + , hswb_tvs = panic "mkHsTyWithBndrs:tvs" } data HsTyVarBndr name = UserTyVar -- No explicit kinding @@ -153,17 +165,18 @@ data HsTyVarBndr name | KindedTyVar name - (HsBndrSig (LHsKind name)) -- The user-supplied kind signature + (LHsKind name) -- The user-supplied kind signature -- *** NOTA BENE *** A "monotype" in a pragma can have -- for-alls in it, (mostly to do with dictionaries). These -- must be explicitly Kinded. deriving (Data, Typeable) + data HsType name = HsForAllTy HsExplicitFlag -- Renamer leaves this flag unchanged, to record the way -- the user wrote it originally, so that the printer can -- print it as the user wrote it - [LHsTyVarBndr name] -- See Note [HsForAllTy tyvar binders] + (LHsTyVarBndrs name) (LHsContext name) (LHsType name) @@ -252,11 +265,11 @@ After renaming * Implicit => the *type* variables free in the type Explicit => the variables the user wrote (renamed) -Note that in neither case do we inclde the kind variables. -In the explicit case, the [HsTyVarBndr] can bring kind variables -into scope: f :: forall (a::k->*) (b::k). a b -> Int -but we do not record them explicitly, similar to the case -for the type variables in a pattern type signature. +The kind variables bound in the hsq_kvs field come both + a) from the kind signatures on the kind vars (eg k1) + b) from the scope of the forall (eg k2) +Example: f :: forall (a::k1) b. T a (b::k2) + Note [Unit tuples] ~~~~~~~~~~~~~~~~~~ @@ -357,19 +370,19 @@ data ConDeclField name -- Record fields have Haddoc docs on them mkImplicitHsForAllTy :: LHsContext name -> LHsType name -> HsType name mkExplicitHsForAllTy :: [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name -mkImplicitHsForAllTy ctxt ty = mkHsForAllTy Implicit [] ctxt ty +mkImplicitHsForAllTy ctxt ty = mkHsForAllTy Implicit [] ctxt ty mkExplicitHsForAllTy tvs ctxt ty = mkHsForAllTy Explicit tvs ctxt ty mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name -- Smart constructor for HsForAllTy mkHsForAllTy exp tvs (L _ []) ty = mk_forall_ty exp tvs ty -mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp tvs ctxt ty +mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp (mkHsQTvs tvs) ctxt ty -- mk_forall_ty makes a pure for-all type (no context) mk_forall_ty :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsType name -> HsType name -mk_forall_ty exp tvs (L _ (HsParTy ty)) = mk_forall_ty exp tvs ty -mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 tvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ tvs2) ctxt ty -mk_forall_ty exp tvs ty = HsForAllTy exp tvs (noLoc []) ty +mk_forall_ty exp tvs (L _ (HsParTy ty)) = mk_forall_ty exp tvs ty +mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 qtvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ hsq_tvs qtvs2) ctxt ty +mk_forall_ty exp tvs ty = HsForAllTy exp (mkHsQTvs tvs) (noLoc []) ty -- Even if tvs is empty, we still make a HsForAll! -- In the Implicit case, this signals the place to do implicit quantification -- In the Explicit case, it prevents implicit quantification @@ -396,14 +409,14 @@ hsLTyVarName = hsTyVarName . unLoc hsTyVarNames :: [HsTyVarBndr name] -> [name] hsTyVarNames tvs = map hsTyVarName tvs -hsLTyVarNames :: [LHsTyVarBndr name] -> [name] -hsLTyVarNames = map hsLTyVarName +hsLTyVarNames :: LHsTyVarBndrs name -> [name] +hsLTyVarNames qtvs = map hsLTyVarName (hsQTvBndrs qtvs) hsLTyVarLocName :: LHsTyVarBndr name -> Located name hsLTyVarLocName = fmap hsTyVarName -hsLTyVarLocNames :: [LHsTyVarBndr name] -> [Located name] -hsLTyVarLocNames = map hsLTyVarLocName +hsLTyVarLocNames :: LHsTyVarBndrs name -> [Located name] +hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvBndrs qtvs) \end{code} @@ -421,31 +434,23 @@ mkHsAppTys fun_ty (arg_ty:arg_tys) -- Add noLocs for inner nodes of the application; -- they are never used -splitHsInstDeclTy_maybe :: HsType name - -> Maybe ([LHsTyVarBndr name], HsContext name, name, [LHsType name]) -splitHsInstDeclTy_maybe ty - = fmap (\(tvs, cxt, L _ n, tys) -> (tvs, cxt, n, tys)) $ splitLHsInstDeclTy_maybe (noLoc ty) - splitLHsInstDeclTy_maybe :: LHsType name - -> Maybe ([LHsTyVarBndr name], HsContext name, Located name, [LHsType name]) + -> Maybe (LHsTyVarBndrs name, HsContext name, Located name, [LHsType name]) -- Split up an instance decl type, returning the pieces splitLHsInstDeclTy_maybe inst_ty = do let (tvs, cxt, ty) = splitLHsForAllTy inst_ty (cls, tys) <- splitLHsClassTy_maybe ty return (tvs, cxt, cls, tys) -splitHsForAllTy :: HsType name -> ([LHsTyVarBndr name], HsContext name, HsType name) -splitHsForAllTy ty = case splitLHsForAllTy (noLoc ty) of (tvs, cxt, L _ ty) -> (tvs, cxt, ty) - splitLHsForAllTy :: LHsType name - -> ([LHsTyVarBndr name], HsContext name, LHsType name) + -> (LHsTyVarBndrs name, HsContext name, LHsType name) splitLHsForAllTy poly_ty = case unLoc poly_ty of HsParTy ty -> splitLHsForAllTy ty HsForAllTy _ tvs cxt ty -> (tvs, unLoc cxt, ty) - _ -> ([], [], poly_ty) + _ -> (mkHsQTvs [], [], poly_ty) -- The type vars should have been computed by now, even if they were implicit splitHsClassTy_maybe :: HsType name -> Maybe (name, [LHsType name]) @@ -494,22 +499,25 @@ instance (OutputableBndr name) => Outputable (HsType name) where instance Outputable HsTyLit where ppr = ppr_tylit -instance (Outputable sig) => Outputable (HsBndrSig sig) where - ppr (HsBSig ty _) = ppr ty +instance (OutputableBndr name) => Outputable (LHsTyVarBndrs name) where + ppr qtvs = interppSP (hsQTvBndrs qtvs) instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where 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 +instance (Outputable thing) => Outputable (HsWithBndrs thing) where + ppr (HsWB { hswb_cts = ty }) = ppr ty + +pprHsForAll :: OutputableBndr name => HsExplicitFlag -> LHsTyVarBndrs name -> LHsContext name -> SDoc +pprHsForAll exp qtvs cxt | show_forall = forall_part <+> pprHsContext (unLoc cxt) | otherwise = pprHsContext (unLoc cxt) where show_forall = opt_PprStyle_Debug - || (not (null tvs) && is_explicit) + || (not (null (hsQTvBndrs qtvs)) && is_explicit) is_explicit = case exp of {Explicit -> True; Implicit -> False} - forall_part = ptext (sLit "forall") <+> interppSP tvs <> dot + forall_part = ptext (sLit "forall") <+> ppr qtvs <> dot pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc pprHsContext [] = empty diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 8ac04761fe..32fe487609 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -33,7 +33,7 @@ module HsUtils( nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, - mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, mkHsBSig, + mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, -- Bindings mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind, @@ -265,9 +265,6 @@ unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote")) mkHsString :: String -> HsLit mkHsString s = HsString (mkFastString s) -mkHsBSig :: a -> HsBndrSig a -mkHsBSig x = HsBSig x (placeHolderBndrs, placeHolderBndrs) - ------------- userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)] -- Caller sets location diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index a9cb1d34b7..759d5449f9 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -728,9 +728,9 @@ data_or_newtype :: { Located NewOrData } : 'data' { L1 DataType } | 'newtype' { L1 NewType } -opt_kind_sig :: { Located (Maybe (HsBndrSig (LHsKind RdrName))) } +opt_kind_sig :: { Located (Maybe (LHsKind RdrName)) } : { noLoc Nothing } - | '::' kind { LL (Just (mkHsBSig $2)) } + | '::' kind { LL (Just $2) } -- tycl_hdr parses the header of a class or data type decl, -- which takes the form @@ -877,7 +877,7 @@ rule_var_list :: { [RuleBndr RdrName] } rule_var :: { RuleBndr RdrName } : varid { RuleBndr $1 } - | '(' varid '::' ctype ')' { RuleBndrSig $2 (mkHsBSig $4) } + | '(' varid '::' ctype ')' { RuleBndrSig $2 (mkHsWithBndrs $4) } ----------------------------------------------------------------------------- -- Warnings and deprecations (c.f. rules) @@ -1113,7 +1113,7 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] } tv_bndr :: { LHsTyVarBndr RdrName } : tyvar { L1 (UserTyVar (unLoc $1)) } - | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) (mkHsBSig $4)) } + | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) $4) } fds :: { Located [Located (FunDep RdrName)] } : {- empty -} { noLoc [] } diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index eee8831065..0382fcae7d 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -128,14 +128,14 @@ tdefs :: { [TyClDecl RdrName] } tdef :: { TyClDecl RdrName } : '%data' q_tc_name tv_bndrs '=' '{' cons '}' ';' { TyDecl { tcdLName = noLoc (ifaceExtRdrName $2) - , tcdTyVars = map toHsTvBndr $3 + , tcdTyVars = mkHsQTvs (map toHsTvBndr $3) , tcdTyDefn = TyData { td_ND = DataType, td_ctxt = noLoc [] , td_kindSig = Nothing , td_cons = $6, td_derivs = Nothing } } } | '%newtype' q_tc_name tv_bndrs trep ';' { let tc_rdr = ifaceExtRdrName $2 in TyDecl { tcdLName = noLoc tc_rdr - , tcdTyVars = map toHsTvBndr $3 + , tcdTyVars = mkHsQTvs (map toHsTvBndr $3) , tcdTyDefn = TyData { td_ND = NewType, td_ctxt = noLoc [] , td_kindSig = Nothing , td_cons = $4 (rdrNameOcc tc_rdr), td_derivs = Nothing } } } @@ -377,16 +377,16 @@ ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig where - bsig = mkHsBSig (toHsKind k) + bsig = toHsKind k ifaceExtRdrName :: Name -> RdrName ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name) ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other) add_forall tv (L _ (HsForAllTy exp tvs cxt t)) - = noLoc $ HsForAllTy exp (tv:tvs) cxt t + = noLoc $ HsForAllTy exp (mkHsQTvs (tv : hsQTvBndrs tvs)) cxt t add_forall tv t - = noLoc $ HsForAllTy Explicit [tv] (noLoc []) t + = noLoc $ HsForAllTy Explicit (mkHsQTvs [tv]) (noLoc []) t happyError :: P a happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 95b65de192..350aedb6f0 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -122,7 +122,7 @@ mkTyData :: SrcSpan -> NewOrData -> Maybe CType -> Located (Maybe (LHsContext RdrName), LHsType RdrName) - -> Maybe (HsBndrSig (LHsKind RdrName)) + -> Maybe (LHsKind RdrName) -> [LConDecl RdrName] -> Maybe [LHsType RdrName] -> P (LTyClDecl RdrName) @@ -138,20 +138,20 @@ mkFamInstData :: SrcSpan -> NewOrData -> Maybe CType -> Located (Maybe (LHsContext RdrName), LHsType RdrName) - -> Maybe (HsBndrSig (LHsKind RdrName)) + -> Maybe (LHsKind RdrName) -> [LConDecl RdrName] -> Maybe [LHsType RdrName] -> P (LFamInstDecl RdrName) mkFamInstData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams) <- checkTyClHdr tycl_hdr ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - ; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsBSig tparams + ; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsWithBndrs tparams , fid_defn = defn, fid_fvs = placeHolderNames })) } mkDataDefn :: NewOrData -> Maybe CType -> Maybe (LHsContext RdrName) - -> Maybe (HsBndrSig (LHsKind RdrName)) + -> Maybe (LHsKind RdrName) -> [LConDecl RdrName] -> Maybe [LHsType RdrName] -> P (HsTyDefn RdrName) @@ -181,14 +181,14 @@ mkFamInstSynonym :: SrcSpan -> P (LFamInstDecl RdrName) mkFamInstSynonym loc lhs rhs = do { (tc, tparams) <- checkTyClHdr lhs - ; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsBSig tparams + ; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsWithBndrs tparams , fid_defn = TySynonym { td_synRhs = rhs } , fid_fvs = placeHolderNames })) } mkTyFamily :: SrcSpan -> FamilyFlavour -> LHsType RdrName -- LHS - -> Maybe (HsBndrSig (LHsKind RdrName)) -- Optional kind signature + -> Maybe (LHsKind RdrName) -- Optional kind signature -> P (LTyClDecl RdrName) mkTyFamily loc flavour lhs ksig = do { (tc, tparams) <- checkTyClHdr lhs @@ -367,7 +367,7 @@ mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty ; return (L loc (ConDecl { con_old_rec = True , con_name = data_con , con_explicit = Implicit - , con_qvars = [] + , con_qvars = mkHsQTvs [] , con_cxt = noLoc [] , con_details = RecCon flds , con_res = ResTyGADT res_ty @@ -381,7 +381,7 @@ mkSimpleConDecl name qvars cxt details = ConDecl { con_old_rec = False , con_name = name , con_explicit = Explicit - , con_qvars = qvars + , con_qvars = mkHsQTvs qvars , con_cxt = cxt , con_details = details , con_res = ResTyH98 @@ -444,17 +444,18 @@ we can bring x,y into scope. So: * For RecCon we do not \begin{code} -checkTyVars :: LHsType RdrName -> [LHsType RdrName] -> P [LHsTyVarBndr RdrName] +checkTyVars :: LHsType RdrName -> [LHsType RdrName] -> P (LHsTyVarBndrs RdrName) -- Check whether the given list of type parameters are all type variables -- (possibly with a kind signature). If the second argument is `False', -- only type variables are allowed and we raise an error on encountering a -- non-variable; otherwise, we allow non-variable arguments and return the -- entire list of parameters. -checkTyVars tycl_hdr tparms = mapM chk tparms +checkTyVars tycl_hdr tparms = do { tvs <- mapM chk tparms + ; return (mkHsQTvs tvs) } where -- Check that the name space is correct! chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) - | isRdrTyVar tv = return (L l (KindedTyVar tv (mkHsBSig k))) + | isRdrTyVar tv = return (L l (KindedTyVar tv k)) chk (L l (HsTyVar tv)) | isRdrTyVar tv = return (L l (UserTyVar tv)) chk t@(L l _) @@ -579,7 +580,7 @@ checkAPat dynflags loc e0 = case e0 of let t' = case t of L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty other -> other - return (SigPatIn e (mkHsBSig t')) + return (SigPatIn e (mkHsWithBndrs t')) -- n+k patterns OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index a8f882a48d..79ccb2179a 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -539,7 +539,7 @@ mkSigTvFn sigs = \n -> lookupNameEnv env n `orElse` [] where env :: NameEnv [Name] - env = mkNameEnv [ (name, map hsLTyVarName ltvs) + env = mkNameEnv [ (name, hsLTyVarNames ltvs) | L _ (TypeSig names (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs , (L _ name) <- names] diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 9cb04ff47f..b1f393baaf 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -36,7 +36,7 @@ module RnEnv ( bindLocatedLocalsFV, bindLocatedLocalsRn, extendTyVarEnvFVRn, - checkDupRdrNames, checkDupAndShadowedRdrNames, + checkDupRdrNames, checkShadowedRdrNames, checkDupNames, checkDupAndShadowedNames, addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS, warnUnusedMatches, @@ -1185,7 +1185,8 @@ bindLocatedLocalsRn :: [Located RdrName] -> ([Name] -> RnM a) -> RnM a bindLocatedLocalsRn rdr_names_w_loc enclosed_scope - = do { checkDupAndShadowedRdrNames rdr_names_w_loc + = do { checkDupRdrNames rdr_names_w_loc + ; checkShadowedRdrNames rdr_names_w_loc -- Make fresh Names and extend the environment ; names <- newLocalBndrsRn rdr_names_w_loc @@ -1243,11 +1244,10 @@ checkDupNames names -- See Note [Binders in Template Haskell] in Convert --------------------- -checkDupAndShadowedRdrNames :: [Located RdrName] -> RnM () -checkDupAndShadowedRdrNames loc_rdr_names - = do { checkDupRdrNames loc_rdr_names - ; envs <- getRdrEnvs - ; checkShadowedOccs envs loc_occs } +checkShadowedRdrNames :: [Located RdrName] -> RnM () +checkShadowedRdrNames loc_rdr_names + = do { envs <- getRdrEnvs + ; checkShadowedOccs envs loc_occs } where loc_occs = [(loc,rdrNameOcc rdr) | L loc rdr <- loc_rdr_names] @@ -1645,8 +1645,10 @@ data HsDocContext | SpliceTypeCtx (LHsType RdrName) | ClassInstanceCtx | VectDeclCtx (Located RdrName) + | GenericCtx SDoc -- Maybe we want to use this more! docOfHsDocContext :: HsDocContext -> SDoc +docOfHsDocContext (GenericCtx doc) = doc docOfHsDocContext (TypeSigCtx doc) = text "In the type signature for" <+> doc docOfHsDocContext PatCtx = text "In a pattern type-signature" docOfHsDocContext SpecInstSigCtx = text "In a SPECIALISE instance pragma" @@ -1666,5 +1668,4 @@ docOfHsDocContext GHCiCtx = ptext (sLit "In GHCi input") docOfHsDocContext (SpliceTypeCtx hs_ty) = ptext (sLit "In the spliced type") <+> ppr hs_ty docOfHsDocContext ClassInstanceCtx = ptext (sLit "TcSplice.reifyInstances") docOfHsDocContext (VectDeclCtx tycon) = ptext (sLit "In the VECTORISE pragma for type constructor") <+> quotes (ppr tycon) - \end{code} diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index d0302a19a2..3e3c2b66d2 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -162,9 +162,9 @@ matchNameMaker ctxt = LamMk report_unused StmtCtxt GhciStmt -> False _ -> True -rnHsSigCps :: HsBndrSig (LHsType RdrName) -> CpsRn (HsBndrSig (LHsType Name)) +rnHsSigCps :: HsWithBndrs (LHsType RdrName) -> CpsRn (HsWithBndrs (LHsType Name)) rnHsSigCps sig - = CpsRn (rnHsBndrSig True PatCtx sig) + = CpsRn (rnHsBndrSig PatCtx sig) newPatName :: NameMaker -> Located RdrName -> CpsRn Name newPatName (LamMk report_unused) rdr_name diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 8c338c810a..9509b0a4b2 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -43,7 +43,6 @@ import Outputable import Bag import BasicTypes ( RuleName ) import FastString -import Util ( filterOut ) import SrcLoc import DynFlags import HscTypes ( HscEnv, hsc_dflags ) @@ -485,7 +484,9 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds -- to remove the context). rnFamInstDecl :: Maybe (Name, [Name]) -> FamInstDecl RdrName -> RnM (FamInstDecl Name, FreeVars) -rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon, fid_pats = HsBSig pats _, fid_defn = defn }) +rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon + , fid_pats = HsWB { hswb_cts = pats } + , fid_defn = defn }) = do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon ; let loc = case pats of [] -> pprPanic "rnFamInstDecl" (ppr tycon) @@ -494,8 +495,9 @@ rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon, fid_pats = HsBSig pats _, (kv_rdr_names, tv_rdr_names) = extractHsTysRdrTyVars pats - ; kv_names <- mkTyVarBndrNames mb_cls (map (L loc) kv_rdr_names) - ; tv_names <- mkTyVarBndrNames mb_cls (map (L loc) tv_rdr_names) + ; rdr_env <- getLocalRdrEnv + ; kv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) kv_rdr_names + ; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names -- All the free vars of the family patterns -- with a sensible binding location ; ((pats', defn'), fvs) @@ -516,8 +518,8 @@ rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon, fid_pats = HsBSig pats _, ; let all_fvs = fvs `addOneFV` unLoc tycon' ; return ( FamInstDecl { fid_tycon = tycon' - , fid_pats = HsBSig pats' (kv_names, tv_names) - , fid_defn = defn', fid_fvs = all_fvs } + , fid_pats = HsWB { hswb_cts = pats', hswb_kvs = kv_names, hswb_tvs = tv_names } + , fid_defn = defn', fid_fvs = all_fvs } , all_fvs ) } -- type instance => use, hence addOneFV \end{code} @@ -543,13 +545,13 @@ For the method bindings in class and instance decls, we extend the type variable environment iff -fglasgow-exts \begin{code} -extendTyVarEnvForMethodBinds :: [LHsTyVarBndr Name] +extendTyVarEnvForMethodBinds :: LHsTyVarBndrs Name -> RnM (Bag (LHsBind Name), FreeVars) -> RnM (Bag (LHsBind Name), FreeVars) extendTyVarEnvForMethodBinds tyvars thing_inside = do { scoped_tvs <- xoptM Opt_ScopedTypeVariables ; if scoped_tvs then - extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside + extendTyVarEnvFVRn (hsLTyVarNames tyvars) thing_inside else thing_inside } \end{code} @@ -584,7 +586,8 @@ standaloneDerivErr rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars) rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs) = do { let rdr_names_w_loc = map get_var vars - ; checkDupAndShadowedRdrNames rdr_names_w_loc + ; checkDupRdrNames rdr_names_w_loc + ; checkShadowedRdrNames rdr_names_w_loc ; names <- newLocalBndrsRn rdr_names_w_loc ; bindHsRuleVars rule_name vars names $ \ vars' -> do { (lhs', fv_lhs') <- rnLExpr lhs @@ -610,7 +613,7 @@ bindHsRuleVars rule_name vars names thing_inside thing_inside (RuleBndr (L loc n) : vars') go (RuleBndrSig (L loc _) bsig : vars) (n : ns) thing_inside - = rnHsBndrSig True doc bsig $ \ bsig' -> + = rnHsBndrSig doc bsig $ \ bsig' -> go vars ns $ \ vars' -> thing_inside (RuleBndrSig (L loc n) bsig' : vars') @@ -841,38 +844,40 @@ rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name}) -- in a class decl rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars , tcdFlavour = flav, tcdKindSig = kind }) - = do { let tv_rdr_names = hsLTyVarLocNames tyvars - ; checkDupRdrNames tv_rdr_names -- Check for duplicated bindings - ; tv_names <- mkTyVarBndrNames mb_cls tv_rdr_names - ; bindTyVarsRn fmly_doc tyvars tv_names $ \tyvars' -> + = bindHsTyVars fmly_doc mb_cls kvs tyvars $ \tyvars' -> do { tycon' <- lookupLocatedTopBndrRn tycon ; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind ; return ( TyFamily { tcdLName = tycon', tcdTyVars = tyvars' , tcdFlavour = flav, tcdKindSig = kind' } - , fv_kind) } } + , fv_kind ) } where fmly_doc = TyFamilyCtx tycon + kvs = extractRdrKindSigVars kind -- "data", "newtype" declarations -- both top level and (for an associated type) in an instance decl -rnTyClDecl _ (TyDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdTyDefn = defn }) +rnTyClDecl mb_cls (TyDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdTyDefn = defn }) = do { tycon' <- lookupLocatedTopBndrRn tycon - ; ((tyvars', defn'), fvs) <- bindHsTyVars (TyDataCtx tycon) tyvars $ \ tyvars' -> + ; let kvs = extractTyDefnKindVars defn + ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs) + ; ((tyvars', defn'), fvs) <- bindHsTyVars (TyDataCtx tycon) mb_cls kvs tyvars $ \ tyvars' -> do { (defn', fvs) <- rnTyDefn tycon defn ; return ((tyvars', defn'), fvs) } ; return (TyDecl { tcdLName = tycon', tcdTyVars = tyvars' , tcdTyDefn = defn', tcdFVs = fvs }, fvs) } -rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls, - tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, - tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs, - tcdDocs = docs}) +rnTyClDecl mb_cls (ClassDecl {tcdCtxt = context, tcdLName = lcls, + tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, + tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs, + tcdDocs = docs}) = do { lcls' <- lookupLocatedTopBndrRn lcls ; let cls' = unLoc lcls' + kvs = [] -- No scoped kind vars except those in + -- kind signatures on the tyvars -- Tyvars scope over superclass context and method signatures ; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs) - <- bindHsTyVars cls_doc tyvars $ \ tyvars' -> do + <- bindHsTyVars cls_doc mb_cls kvs tyvars $ \ tyvars' -> do -- Checks for distinct tyvars { (context', cxt_fvs) <- rnContext cls_doc context ; fds' <- rnFds (docOfHsDocContext cls_doc) fds @@ -1043,21 +1048,6 @@ is jolly confusing. See Trac #4875 \begin{code} --------------- -mkTyVarBndrNames :: Maybe a -> [Located RdrName] -> RnM [Name] -mkTyVarBndrNames Nothing tv_rdr_names - = newLocalBndrsRn tv_rdr_names -mkTyVarBndrNames (Just _) tv_rdr_names - = do { rdr_env <- getLocalRdrEnv - ; let mk_tv_name :: Located RdrName -> RnM Name - -- Use the same Name as the parent class decl - mk_tv_name (L l tv_rdr) - = case lookupLocalRdrEnv rdr_env tv_rdr of - Just n -> return n - Nothing -> newLocalBndrRn (L l tv_rdr) - - ; mapM mk_tv_name tv_rdr_names } - ---------------- badAssocRhs :: [Name] -> RnM () badAssocRhs ns = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable") @@ -1082,22 +1072,21 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs -- For GADT syntax, the tvs are all the quantified tyvars -- Hence the 'filter' in the ResTyH98 case only ; rdr_env <- getLocalRdrEnv - ; let in_scope tv = tv `elemLocalRdrEnv` rdr_env - arg_tys = hsConDeclArgTys details - mentioned_tvs = case res_ty of - ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys) - ResTyGADT ty -> get_rdr_tvs (ty : arg_tys) + ; let arg_tys = hsConDeclArgTys details + (free_kvs, free_tvs) = case res_ty of + ResTyH98 -> filterInScope rdr_env (get_rdr_tvs arg_tys) + ResTyGADT ty -> get_rdr_tvs (ty : arg_tys) -- With an Explicit forall, check for unused binders -- With Implicit, find the mentioned ones, and use them as binders ; new_tvs <- case expl of - Implicit -> return (userHsTyVarBndrs loc mentioned_tvs) - Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs mentioned_tvs + Implicit -> return (mkHsQTvs (userHsTyVarBndrs loc free_tvs)) + Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs free_tvs ; return tvs } ; mb_doc' <- rnMbLHsDoc mb_doc - ; bindHsTyVars doc new_tvs $ \new_tyvars -> do + ; bindHsTyVars doc Nothing free_kvs new_tvs $ \new_tyvars -> do { (new_context, fvs1) <- rnContext doc lcxt ; (new_details, fvs2) <- rnConDeclDetails doc details ; (new_details', new_res_ty, fvs3) <- rnConResult doc (unLoc new_name) new_details res_ty @@ -1106,7 +1095,7 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs fvs1 `plusFV` fvs2 `plusFV` fvs3) }} where doc = ConDeclCtx name - get_rdr_tvs tys = snd (extractHsTysRdrTyVars (cxt ++ tys)) + get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys) rnConResult :: HsDocContext -> Name -> HsConDetails (LHsType Name) [ConDeclField Name] diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 99401faefc..1b2e8417f3 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -16,7 +16,7 @@ module RnTypes ( rnHsType, rnLHsType, rnLHsTypes, rnContext, rnHsKind, rnLHsKind, rnLHsMaybeKind, rnHsSigType, rnLHsInstType, rnConDeclFields, - rnIPName, + rnIPName, newTyVarNameRn, -- Precence related stuff mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, @@ -26,9 +26,9 @@ module RnTypes ( rnSplice, checkTH, -- Binding related stuff - bindSigTyVarsFV, bindHsTyVars, bindTyVarsRn, rnHsBndrSig, - extractHsTyRdrTyVars, extractHsTysRdrTyVars - + bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig, + extractHsTyRdrTyVars, extractHsTysRdrTyVars, + extractRdrKindSigVars, extractTyDefnKindVars, filterInScope ) where import {-# SOURCE #-} RnExpr( rnLExpr ) @@ -54,8 +54,9 @@ import BasicTypes ( IPName(..), ipNameName, compareFixity, funTyFixity, negateFi Fixity(..), FixityDirection(..) ) import Outputable import FastString +import Maybes import Data.List ( nub ) -import Control.Monad ( unless ) +import Control.Monad ( unless, when ) #include "HsVersions.h" \end{code} @@ -78,7 +79,7 @@ rnHsSigType doc_str ty = rnLHsType (TypeSigCtx doc_str) ty rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars) -- Rename the type in an instance or standalone deriving decl rnLHsInstType doc_str ty - = do { (ty', fvs) <- rnLHsType (TypeSigCtx doc_str) ty + = do { (ty', fvs) <- rnLHsType (GenericCtx doc_str) ty ; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty)) ; return (ty', fvs) } where @@ -108,13 +109,13 @@ rnLHsType = rnLHsTyKi True rnLHsKind :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars) rnLHsKind = rnLHsTyKi False -rnLHsMaybeKind :: HsDocContext -> Maybe (HsBndrSig (LHsKind RdrName)) - -> RnM (Maybe (HsBndrSig (LHsKind Name)), FreeVars) +rnLHsMaybeKind :: HsDocContext -> Maybe (LHsKind RdrName) + -> RnM (Maybe (LHsKind Name), FreeVars) rnLHsMaybeKind _ Nothing = return (Nothing, emptyFVs) -rnLHsMaybeKind doc (Just bsig) - = rnHsBndrSig False doc bsig $ \ bsig' -> - return (Just bsig', emptyFVs) +rnLHsMaybeKind doc (Just kind) + = do { (kind', fvs) <- rnLHsKind doc kind + ; return (Just kind', fvs) } rnHsType :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) rnHsType = rnHsTyKi True @@ -128,33 +129,33 @@ rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty) -- Implicit quantifiction in source code (no kinds on tyvars) -- Given the signature C => T we universally quantify -- over FV(T) \ {in-scope-tyvars} - name_env <- getLocalRdrEnv + rdr_env <- getLocalRdrEnv loc <- getSrcSpanM let - (_kvs, mentioned) = extractHsTysRdrTyVars (ty:ctxt) + (forall_kvs, forall_tvs) = filterInScope rdr_env $ + extractHsTysRdrTyVars (ty:ctxt) -- In for-all types we don't bring in scope -- kind variables mentioned in kind signatures -- (Well, not yet anyway....) -- f :: Int -> T (a::k) -- Not allowed - -- Don't quantify over type variables that are in scope; - -- when GlasgowExts is off, there usually won't be any, except for - -- class signatures: - -- class C a where { op :: a -> a } - forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env)) mentioned - tyvar_bndrs = userHsTyVarBndrs loc forall_tyvars + -- The filterInScope is to ensure that we don't quantify over + -- type variables that are in scope; when GlasgowExts is off, + -- there usually won't be any, except for class signatures: + -- class C a where { op :: a -> a } + tyvar_bndrs = userHsTyVarBndrs loc forall_tvs - rnForAll doc Implicit tyvar_bndrs lctxt ty + rnForAll doc Implicit forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars lctxt@(L _ ctxt) tau) = ASSERT ( isType ) do { -- Explicit quantification. -- Check that the forall'd tyvars are actually -- mentioned in the type, and produce a warning if not - let (_kvs, mentioned) = extractHsTysRdrTyVars (tau:ctxt) + let (kvs, mentioned) = extractHsTysRdrTyVars (tau:ctxt) in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty) ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned - ; rnForAll doc Explicit forall_tyvars lctxt tau } + ; rnForAll doc Explicit kvs forall_tyvars lctxt tau } rnHsTyKi isType _ (HsTyVar rdr_name) = do { name <- rnTyVar isType rdr_name @@ -310,11 +311,15 @@ rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys \begin{code} -rnForAll :: HsDocContext -> HsExplicitFlag -> [LHsTyVarBndr RdrName] +rnForAll :: HsDocContext -> HsExplicitFlag + -> [RdrName] -- Kind variables + -> LHsTyVarBndrs RdrName -- Type variables -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name, FreeVars) -rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty +rnForAll doc exp kvs forall_tyvars ctxt ty + | null kvs, null (hsQTvBndrs forall_tyvars), null (unLoc ctxt) + = rnHsType doc (unLoc ty) -- One reason for this case is that a type like Int# -- starts off as (HsForAllTy Nothing [] Int), in case -- there is some quantification. Now that we have quantified @@ -323,8 +328,8 @@ rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty -- get an error, because the body of a genuine for-all is -- of kind *. -rnForAll doc exp forall_tyvars ctxt ty - = bindHsTyVars doc forall_tyvars $ \ new_tyvars -> + | otherwise + = bindHsTyVars doc Nothing kvs forall_tyvars $ \ new_tyvars -> do { (new_ctxt, fvs1) <- rnContext doc ctxt ; (new_ty, fvs2) <- rnLHsType doc ty ; return (HsForAllTy exp new_tyvars new_ctxt new_ty, fvs1 `plusFV` fvs2) } @@ -346,51 +351,70 @@ bindSigTyVarsFV tvs thing_inside bindLocalNamesFV tvs thing_inside } --------------- -bindHsTyVars :: HsDocContext -> [LHsTyVarBndr RdrName] - -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -bindHsTyVars doc tv_bndrs thing_inside - = do { checkDupAndShadowedRdrNames rdr_names_w_loc - ; names <- newLocalBndrsRn rdr_names_w_loc - ; bindTyVarsRn doc tv_bndrs names thing_inside } - where - rdr_names_w_loc = hsLTyVarLocNames tv_bndrs - ---------------- -bindTyVarsRn :: HsDocContext -> [LHsTyVarBndr RdrName] -> [Name] - -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) --- Rename the HsTyVarBndrs, giving them the specified names --- *and* bringing into scope the kind variables bound in --- any kind signatures - -bindTyVarsRn doc tv_bndrs names thing_inside - = go tv_bndrs names $ \ tv_bndrs' -> - bindLocalNamesFV names (thing_inside tv_bndrs') - where - go [] [] thing_inside = thing_inside [] - - go (L loc (UserTyVar _) : tvs) (n : ns) thing_inside - = go tvs ns $ \ tvs' -> - thing_inside (L loc (UserTyVar n) : tvs') - - 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') : tvs') +bindHsTyVars :: HsDocContext + -> Maybe a -- Just _ => an associated type decl + -> [RdrName] -- Kind variables from scope + -> LHsTyVarBndrs RdrName -- Type variables + -> (LHsTyVarBndrs Name -> RnM (b, FreeVars)) + -> RnM (b, FreeVars) +-- (a) Bring kind variables into scope +-- both (i) passed in (kv_bndrs) and (ii) mentioned in the kinds of tv_bndrs +-- (b) Bring type variables into scope +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 _ (KindedTyVar _ kind) <- tvs + , let (_, kvs) = extractHsTyRdrTyVars kind + , kv <- kvs ] + all_kvs = filterOut (`elemLocalRdrEnv` rdr_env) $ + nub (kv_bndrs ++ kvs_from_tv_bndrs) + ; poly_kind <- xoptM Opt_PolyKinds + ; unless (poly_kind || null all_kvs) + (addErr (badKindBndrs doc all_kvs)) + ; loc <- getSrcSpanM + ; kv_names <- mapM (newLocalBndrRn . L loc) all_kvs + ; bindLocalNamesFV kv_names $ + do { let tv_names_w_loc = hsLTyVarLocNames tv_bndrs + + rn_tv_bndr :: LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars) + 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 + ; when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc) + + ; (tv_bndrs', fvs1) <- mapFvRn rn_tv_bndr tvs + ; (res, fvs2) <- bindLocalNamesFV (map hsLTyVarName tv_bndrs') $ + do { env <- getLocalRdrEnv + ; traceRn (text "bhtv" <+> (ppr tvs $$ ppr all_kvs $$ ppr env)) + ; thing_inside (HsQTvs { hsq_tvs = tv_bndrs', hsq_kvs = kv_names }) } + ; return (res, fvs1 `plusFV` fvs2) } } - -- Lists of unequal length - go tvs names _ = pprPanic "bindTyVarsRn" (ppr tvs $$ ppr names) +newTyVarNameRn :: Maybe a -> LocalRdrEnv -> SrcSpan -> RdrName -> RnM Name +newTyVarNameRn mb_assoc rdr_env loc rdr + | Just _ <- mb_assoc -- Use the same Name as the parent class decl + , Just n <- lookupLocalRdrEnv rdr_env rdr + = return n + | otherwise + = newLocalBndrRn (L loc rdr) -------------------------------- -rnHsBndrSig :: Bool -- True <=> type sig, False <=> kind sig - -> HsDocContext - -> HsBndrSig (LHsType RdrName) - -> (HsBndrSig (LHsType Name) -> RnM (a, FreeVars)) +rnHsBndrSig :: HsDocContext + -> HsWithBndrs (LHsType RdrName) + -> (HsWithBndrs (LHsType Name) -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -rnHsBndrSig is_type doc (HsBSig ty@(L loc _) _) thing_inside - = do { let (kv_bndrs, tv_bndrs) = extractHsTyRdrTyVars ty - ; checkHsBndrFlags is_type doc ty tv_bndrs +rnHsBndrSig doc (HsWB { hswb_cts = ty@(L loc _) }) thing_inside + = do { sig_ok <- xoptM Opt_ScopedTypeVariables + ; unless sig_ok (badSigErr True doc ty) + ; let (kv_bndrs, tv_bndrs) = extractHsTyRdrTyVars ty ; name_env <- getLocalRdrEnv ; tv_names <- newLocalBndrsRn [L loc tv | tv <- tv_bndrs , not (tv `elemLocalRdrEnv` name_env) ] @@ -398,26 +422,13 @@ rnHsBndrSig is_type doc (HsBSig ty@(L loc _) _) thing_inside , not (kv `elemLocalRdrEnv` name_env) ] ; bindLocalNamesFV kv_names $ bindLocalNamesFV tv_names $ - do { (ty', fvs1) <- rnLHsTyKi is_type doc ty - ; (res, fvs2) <- thing_inside (HsBSig ty' (kv_names, tv_names)) + do { (ty', fvs1) <- rnLHsType doc ty + ; (res, fvs2) <- thing_inside (HsWB { hswb_cts = ty', hswb_kvs = kv_names, hswb_tvs = tv_names }) ; return (res, fvs1 `plusFV` fvs2) } } -checkHsBndrFlags :: Bool -> HsDocContext - -> LHsType RdrName -> [RdrName] -> RnM () -checkHsBndrFlags is_type doc ty tv_bndrs - | is_type -- Type - = do { sig_ok <- xoptM Opt_ScopedTypeVariables - ; unless sig_ok (badSigErr True doc ty) } - | otherwise -- Kind - = do { sig_ok <- xoptM Opt_KindSignatures - ; unless sig_ok (badSigErr False doc ty) - ; poly_kind <- xoptM Opt_PolyKinds - ; unless (poly_kind || null tv_bndrs) - (addErr (badKindBndrs doc ty tv_bndrs)) } - -badKindBndrs :: HsDocContext -> LHsKind RdrName -> [RdrName] -> SDoc -badKindBndrs doc _kind kvs - = vcat [ hang (ptext (sLit "Kind signature mentions kind variable") <> plural kvs +badKindBndrs :: HsDocContext -> [RdrName] -> SDoc +badKindBndrs doc kvs + = vcat [ hang (ptext (sLit "Unexpected kind variable") <> plural kvs <+> pprQuotedList kvs) 2 (ptext (sLit "Perhaps you intended to use -XPolyKinds")) , docOfHsDocContext doc ] @@ -779,7 +790,7 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) %********************************************************* \begin{code} -warnUnusedForAlls :: SDoc -> [LHsTyVarBndr RdrName] -> [RdrName] -> TcM () +warnUnusedForAlls :: SDoc -> LHsTyVarBndrs RdrName -> [RdrName] -> TcM () warnUnusedForAlls in_doc bound mentioned_rdrs = ifWOptM Opt_WarnUnusedMatches $ mapM_ add_warn bound_but_not_used @@ -868,8 +879,6 @@ checkTH e what -- Raise an error in a stage-1 compiler %* * %************************************************************************ -extractHsTyRdrNames finds the free variables of a HsType -It's used when making the for-alls explicit. Note [Kind and type-variable binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -902,7 +911,16 @@ See also Note [HsBSig binder lists] in HsTypes \begin{code} type FreeKiTyVars = ([RdrName], [RdrName]) +filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars +filterInScope rdr_env (kvs, tvs) + = (filterOut in_scope kvs, filterOut in_scope tvs) + where + in_scope tv = tv `elemLocalRdrEnv` rdr_env + extractHsTyRdrTyVars :: LHsType RdrName -> FreeKiTyVars +-- extractHsTyRdrNames finds the free (kind, type) variables of a HsType +-- or the free (sort, kind) variables of a HsKind +-- It's used when making the for-alls explicit. -- See Note [Kind and type-variable binders] extractHsTyRdrTyVars ty = case extract_lty ty ([],[]) of @@ -914,12 +932,46 @@ extractHsTysRdrTyVars ty = case extract_ltys ty ([],[]) of (kvs, tvs) -> (nub kvs, nub tvs) +extractRdrKindSigVars :: Maybe (LHsKind RdrName) -> [RdrName] +extractRdrKindSigVars Nothing = [] +extractRdrKindSigVars (Just k) = nub (fst (extract_lkind k ([],[]))) + +extractTyDefnKindVars :: HsTyDefn RdrName -> [RdrName] +-- Get the scoped kind variables mentioned free in the constructor decls +-- Eg data T a = T1 (S (a :: k) | forall (b::k). T2 (S b) +-- Here k should scope over the whole definition +extractTyDefnKindVars (TySynonym { td_synRhs = ty}) + = fst (extractHsTyRdrTyVars ty) +extractTyDefnKindVars (TyData { td_ctxt = ctxt, td_kindSig = ksig + , td_cons = cons, td_derivs = derivs }) + = fst $ extract_lctxt ctxt $ + extract_mb extract_lkind ksig $ + extract_mb extract_ltys derivs $ + foldr (extract_con . unLoc) ([],[]) cons + where + extract_con (ConDecl { con_res = ResTyGADT {} }) acc = acc + extract_con (ConDecl { con_res = ResTyH98, con_qvars = qvs + , con_cxt = ctxt, con_details = details }) acc + = extract_hs_tv_bndrs qvs acc $ + extract_lctxt ctxt $ + extract_ltys (hsConDeclArgTys details) ([],[]) + + extract_lctxt :: LHsContext RdrName -> FreeKiTyVars -> FreeKiTyVars -extract_lctxt ctxt acc = foldr extract_lty acc (unLoc ctxt) +extract_lctxt ctxt = extract_ltys (unLoc ctxt) extract_ltys :: [LHsType RdrName] -> FreeKiTyVars -> FreeKiTyVars extract_ltys tys acc = foldr extract_lty acc tys +extract_mb :: (a -> FreeKiTyVars -> FreeKiTyVars) -> Maybe a -> FreeKiTyVars -> FreeKiTyVars +extract_mb _ Nothing acc = acc +extract_mb f (Just x) acc = f x acc + +extract_lkind :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars +extract_lkind kind (acc_kvs, acc_tvs) = case extract_lty kind ([], acc_kvs) of + (_, res_kvs) -> (res_kvs, acc_tvs) + -- Kinds shouldn't have sort signatures! + extract_lty :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars extract_lty (L _ ty) acc = case ty of @@ -943,19 +995,27 @@ extract_lty (L _ ty) acc HsExplicitTupleTy _ tys -> extract_ltys tys acc HsTyLit _ -> acc HsWrapTy _ _ -> panic "extract_lty" - HsKindSig ty ki -> case extract_lty ty acc of { (kvs1, tvs) -> - case extract_lty ki ([],kvs1) of { (_, kvs2) -> - -- Kinds shouldn't have sort signatures! - (kvs2, tvs) }} - HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc) - HsForAllTy _ tvs cx ty -> (acc_kvs ++ body_kvs, - acc_tvs ++ filterOut (`elem` locals_tvs) body_tvs) - where - (body_kvs, body_tvs) = extract_lctxt cx (extract_lty ty ([],[])) - (acc_kvs, acc_tvs) = acc - locals_tvs = hsLTyVarNames tvs - -- Currently we don't have a syntax to explicity bind - -- kind variables, so these are all type variables + HsKindSig ty ki -> extract_lty ty (extract_lkind ki acc) + HsForAllTy _ tvs cx ty -> extract_hs_tv_bndrs tvs acc $ + extract_lctxt cx $ + extract_lty ty ([],[]) + +extract_hs_tv_bndrs :: LHsTyVarBndrs RdrName -> FreeKiTyVars + -> FreeKiTyVars -> FreeKiTyVars +extract_hs_tv_bndrs (HsQTvs { hsq_tvs = tvs }) + acc@(acc_kvs, acc_tvs) -- Note accumulator comes first + (body_kvs, body_tvs) + | null tvs + = (body_kvs ++ acc_kvs, body_tvs ++ acc_tvs) + | otherwise + = (outer_kvs ++ body_kvs, + outer_tvs ++ filterOut (`elem` local_tvs) body_tvs) + where + local_tvs = map hsLTyVarName tvs + -- Currently we don't have a syntax to explicitly bind + -- kind variables, so these are all type variables + + (outer_kvs, outer_tvs) = foldr extract_lkind acc [k | L _ (KindedTyVar _ k) <- tvs] extract_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars extract_tv tv acc diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs index 83ecd8b70a..09704fbfd1 100644 --- a/compiler/typecheck/TcEvidence.lhs +++ b/compiler/typecheck/TcEvidence.lhs @@ -242,7 +242,8 @@ coVarsOfTcCo tc_co go (TcNthCo _ co) = go co go (TcLetCo (EvBinds bs) co) = foldrBag (unionVarSet . go_bind) (go co) bs `minusVarSet` get_bndrs bs - go (TcLetCo {}) = pprPanic "coVarsOfTcCo called on non-zonked TcCoercion" (ppr tc_co) + go (TcLetCo {}) = emptyVarSet -- Harumph. This does legitimately happen in the call + -- to evVarsOfTerm in the DEBUG check of setEvBind -- We expect only coercion bindings go_bind :: EvBind -> VarSet diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 24cd4422c5..b780c3b2e0 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -783,24 +783,19 @@ then we'd also need since we only have BOX for a super kind) \begin{code} -bindScopedKindVars :: [LHsTyVarBndr Name] -> TcM a -> TcM a +bindScopedKindVars :: [Name] -> TcM a -> TcM a -- Given some tyvar binders like [a (b :: k -> *) (c :: k)] -- bind each scoped kind variable (k in this case) to a fresh -- kind skolem variable -bindScopedKindVars hs_tvs thing_inside - = tcExtendTyVarEnv kvs thing_inside - where - kvs :: [KindVar] -- All skolems - kvs = [ mkKindSigVar kv - | L _ (KindedTyVar _ (HsBSig _ (_, kvs))) <- hs_tvs - , kv <- kvs ] +bindScopedKindVars kvs thing_inside + = tcExtendTyVarEnv (map mkKindSigVar kvs) thing_inside -tcHsTyVarBndrs :: [LHsTyVarBndr Name] +tcHsTyVarBndrs :: LHsTyVarBndrs Name -> ([TyVar] -> TcM r) -> TcM r -- Bind the type variables to skolems, each with a meta-kind variable kind -tcHsTyVarBndrs hs_tvs thing_inside - = bindScopedKindVars hs_tvs $ +tcHsTyVarBndrs (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside + = bindScopedKindVars kvs $ do { tvs <- mapM tcHsTyVarBndr hs_tvs ; traceTc "tcHsTyVarBndrs" (ppr hs_tvs $$ ppr tvs) ; tcExtendTyVarEnv tvs (thing_inside tvs) } @@ -825,7 +820,7 @@ tcHsTyVarBndr (L _ hs_tv) _ -> do { kind <- case hs_tv of UserTyVar {} -> newMetaKindVar - KindedTyVar _ (HsBSig kind _) -> tcLHsKind kind + KindedTyVar _ kind -> tcLHsKind kind ; return (mkTcTyVar name kind (SkolemTv False)) } } } ------------------ @@ -896,11 +891,11 @@ kcLookupKind nm AGlobal (ATyCon tc) -> return (tyConKind tc) _ -> pprPanic "kcLookupKind" (ppr tc_ty_thing) } -kcTyClTyVars :: Name -> [LHsTyVarBndr Name] -> (TcKind -> TcM a) -> TcM a +kcTyClTyVars :: Name -> LHsTyVarBndrs Name -> (TcKind -> TcM a) -> TcM a -- 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 $ +kcTyClTyVars name (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside + = bindScopedKindVars kvs $ do { tc_kind <- kcLookupKind name ; let (arg_ks, res_k) = splitKindFunTysN (length hs_tvs) tc_kind -- There should be enough arrows, because @@ -912,7 +907,7 @@ kcTyClTyVars name hs_tvs thing_inside 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 hs_k)) exp_k = do { k <- tcLHsKind hs_k ; _ <- unifyKind k exp_k ; check_in_scope n exp_k @@ -930,7 +925,7 @@ kcTyClTyVars name hs_tvs thing_inside Just thing -> pprPanic "check_in_scope" (ppr thing) } ----------------------- -tcTyClTyVars :: Name -> [LHsTyVarBndr Name] -- LHS of the type or class decl +tcTyClTyVars :: Name -> LHsTyVarBndrs Name -- LHS of the type or class decl -> ([TyVar] -> Kind -> TcM a) -> TcM a -- Used for the type variables of a type or class decl, -- on the second pass when constructing the final result @@ -1051,16 +1046,16 @@ Historical note: \begin{code} tcHsPatSigType :: UserTypeCtxt - -> HsBndrSig (LHsType Name) -- The type signature - -> TcM ( Type -- The signature - , [(Name, TcTyVar)] ) -- The new bit of type environment, binding - -- the scoped type variables + -> HsWithBndrs (LHsType Name) -- The type signature + -> TcM ( Type -- The signature + , [(Name, TcTyVar)] ) -- The new bit of type environment, binding + -- the scoped type variables -- Used for type-checking type signatures in -- (a) patterns e.g f (x::Int) = e -- (b) result signatures e.g. g x :: Int = e -- (c) RULE forall bndrs e.g. forall (x::Int). f x = x -tcHsPatSigType ctxt (HsBSig hs_ty (sig_kvs, sig_tvs)) +tcHsPatSigType ctxt (HsWB { hswb_cts = hs_ty, hswb_kvs = sig_kvs, hswb_tvs = sig_tvs }) = addErrCtxt (pprHsSigCtxt ctxt hs_ty) $ do { kvs <- mapM new_kv sig_kvs ; tvs <- mapM new_tv sig_tvs @@ -1081,7 +1076,7 @@ tcHsPatSigType ctxt (HsBSig hs_ty (sig_kvs, sig_tvs)) _ -> newSigTyVar name kind -- See Note [Unifying SigTvs] tcPatSig :: UserTypeCtxt - -> HsBndrSig (LHsType Name) + -> HsWithBndrs (LHsType Name) -> TcSigmaType -> TcM (TcType, -- The type to use for "inside" the signature [(Name, TcTyVar)], -- The new bit of type environment, binding diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 80c792f85d..2a9f6df3ec 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1430,10 +1430,13 @@ getGhciStepIO = do let a_tv = mkTcTyVarName fresh_a (fsLit "a") ghciM = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv) ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv) + + stepTy :: LHsType Name -- Renamed, so needs all binders in place stepTy = noLoc $ HsForAllTy Implicit - ([noLoc $ UserTyVar a_tv]) - (noLoc []) - (nlHsFunTy ghciM ioM) + (HsQTvs { hsq_tvs = [noLoc (UserTyVar a_tv)] + , hsq_kvs = [] }) + (noLoc []) + (nlHsFunTy ghciM ioM) step = noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy return step diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 7d86d157a0..287783cb88 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -137,6 +137,9 @@ import TcRnTypes import Unique import UniqFM +#ifdef DEBUG +import Digraph +#endif import Maybes ( orElse, catMaybes ) @@ -960,10 +963,32 @@ runTcS context untouch is wl tcs } -- And return ; ev_binds <- TcM.getTcEvBinds ev_binds_var + ; checkForCyclicBinds ev_binds ; return (res, ev_binds) } where do_unification (tv,ty) = TcM.writeMetaTyVar tv ty +checkForCyclicBinds :: Bag EvBind -> TcM () +#ifndef DEBUG +checkForCyclicBinds _ = return () +#else +checkForCyclicBinds ev_binds + | null cycles + = return () + | null coercion_cycles + = TcM.traceTc "Cycle in evidence binds" $ ppr cycles + | otherwise + = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles + where + cycles :: [[EvBind]] + cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVertices edges] + + coercion_cycles = [c | c <- cycles, any is_co_bind c] + is_co_bind (EvBind b _) = isEqVar b + + edges :: [(EvBind, EvVar, [EvVar])] + edges = [(bind, bndr, varSetElems (evVarsOfTerm rhs)) | bind@(EvBind bndr rhs) <- bagToList ev_binds] +#endif doWithInert :: InertSet -> TcS a -> TcS a doWithInert inert (TcS action) @@ -1368,36 +1393,11 @@ freshGoals :: [MaybeNew] -> [CtEvidence] freshGoals mns = [ ctev | Fresh ctev <- mns ] setEvBind :: EvVar -> EvTerm -> TcS () -setEvBind the_ev t - = do { tc_evbinds <- getTcEvBinds - ; wrapTcS $ TcM.addTcEvBind tc_evbinds the_ev t - - ; traceTcS "setEvBind" $ vcat [ text "ev =" <+> ppr the_ev - , text "t =" <+> ppr t ] - -#ifndef DEBUG - ; return () } -#else - ; binds <- getTcEvBindsMap - ; let cycle = reaches_tm binds t - ; when cycle (fail_if_co_loop binds) } - - where fail_if_co_loop binds - = do { traceTcS "Cycle in evidence binds" $ vcat [ text "evvar =" <+> ppr the_ev - , ppr (evBindMapBinds binds) ] - ; when (isEqVar the_ev) (pprPanic "setEvBind" (text "BUG: Coercion loop!")) } - - reaches_tm :: EvBindMap -> EvTerm -> Bool - -- Does any free variable of 'tm' reach 'the_ev' - reaches_tm ebm tm = foldVarSet ((||) . reaches ebm) False (evVarsOfTerm tm) - - reaches :: EvBindMap -> Var -> Bool - -- Does this evvar reach the_ev? - reaches ebm ev - | ev == the_ev = True - | Just (EvBind _ evtrm) <- lookupEvBind ebm ev = reaches_tm ebm evtrm - | otherwise = False -#endif +setEvBind the_ev tm + = do { traceTcS "setEvBind" $ vcat [ text "ev =" <+> ppr the_ev + , text "tm =" <+> ppr tm ] + ; tc_evbinds <- getTcEvBinds + ; wrapTcS $ TcM.addTcEvBind tc_evbinds the_ev tm } newGivenEvVar :: GivenLoc -> TcPredType -> EvTerm -> TcS CtEvidence -- Make a new variable of the given PredType, @@ -1684,6 +1684,7 @@ getCtCoercion _bs ct = ASSERT( not (isDerivedCt ct) ) evTermCoercion (ctEvTerm (ctEvidence ct)) {- ToDo: check with Dimitrios that we can dump this stuff + WARNING: if we *do* need this stuff, we need to think again about cyclic bindings. = case lookupEvBind bs cc_id of -- Given and bound to a coercion term Just (EvBind _ (EvCoercion co)) -> co diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index b88029433b..114140c8d1 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -335,9 +335,9 @@ getInitialKinds (L _ decl) -- data T :: *->* where { ... } -- with *no* tvs in the HsTyDefn - get_tvs (TyFamily {tcdTyVars = tvs}) = tvs - get_tvs (ClassDecl {tcdTyVars = tvs}) = tvs - get_tvs (TyDecl {tcdTyVars = tvs}) = tvs + get_tvs (TyFamily {tcdTyVars = tvs}) = hsQTvBndrs tvs + get_tvs (ClassDecl {tcdTyVars = tvs}) = hsQTvBndrs tvs + get_tvs (TyDecl {tcdTyVars = tvs}) = hsQTvBndrs tvs get_tvs (ForeignType {}) = [] ---------------- @@ -431,17 +431,13 @@ kcConDecl new_or_data (ConDecl { con_name = name, con_qvars = ex_tvs ; return () } ------------------ -kcResultKind :: Maybe (HsBndrSig (LHsKind Name)) -> Kind -> TcM () +kcResultKind :: Maybe (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 (HsBSig k (ss, ns))) res_k - = ASSERT( null ss ) -- Parser ensures that - -- type family F a :: (k :: s) - -- is illegal - do { let kvs = map mkKindSigVar ns - ; k' <- tcExtendTyVarEnv kvs (tcLHsKind k) +kcResultKind (Just k ) res_k + = do { k' <- tcLHsKind k ; discardResult (unifyKind k' res_k) } \end{code} @@ -727,7 +723,7 @@ tcSynFamInstDecl _ decl = pprPanic "tcSynFamInstDecl" (ppr decl) ----------------- tcFamTyPats :: TyCon - -> HsBndrSig [LHsType Name] -- Patterns + -> HsWithBndrs [LHsType Name] -- Patterns -> (TcKind -> TcM ()) -- Kind checker for RHS -- result is ignored -> ([TKVar] -> [TcType] -> Kind -> TcM a) @@ -743,7 +739,8 @@ tcFamTyPats :: TyCon -- In that case, the type variable 'a' will *already be in scope* -- (and, if C is poly-kinded, so will its kind parameter). -tcFamTyPats fam_tc (HsBSig arg_pats (kvars, tvars)) kind_checker thing_inside +tcFamTyPats fam_tc (HsWB { hswb_cts = arg_pats, hswb_kvs = kvars, hswb_tvs = tvars }) + kind_checker thing_inside = do { -- A family instance must have exactly the same number of type -- parameters as the family declaration. You can't write -- type family F a :: * -> * @@ -756,14 +753,16 @@ tcFamTyPats fam_tc (HsBSig arg_pats (kvars, tvars)) kind_checker thing_inside -- Instantiate with meta kind vars ; fam_arg_kinds <- mapM (const newMetaKindVar) fam_kvs + ; loc <- getSrcSpanM ; let (arg_kinds, res_kind) = splitKindFunTysN fam_arity $ substKiWith fam_kvs fam_arg_kinds fam_body + hs_tvs = HsQTvs { hsq_kvs = kvars + , hsq_tvs = userHsTyVarBndrs loc tvars } -- Kind-check and quantify -- See Note [Quantifying over family patterns] - ; typats <- tcExtendTyVarEnv (map mkKindSigVar kvars) $ - tcHsTyVarBndrs (map (noLoc . UserTyVar) tvars) $ \ _ -> + ; typats <- tcHsTyVarBndrs hs_tvs $ \ _ -> do { kind_checker res_kind ; tcHsArgTys (quotes (ppr fam_tc)) arg_pats arg_kinds } ; let all_args = fam_arg_kinds ++ typats @@ -1106,10 +1105,10 @@ consUseH98Syntax _ = True conRepresentibleWithH98Syntax :: ConDecl Name -> Bool conRepresentibleWithH98Syntax (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyH98 }) - = null tvs && null (unLoc ctxt) + = null (hsQTvBndrs tvs) && null (unLoc ctxt) conRepresentibleWithH98Syntax (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyGADT (L _ t) }) - = null (unLoc ctxt) && f t (map (hsTyVarName . unLoc) tvs) + = null (unLoc ctxt) && f t (hsLTyVarNames tvs) where -- Each type variable should be used exactly once in the -- result type, and the result type must just be the type -- constructor applied to type variables |