diff options
56 files changed, 2324 insertions, 2377 deletions
diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 3f747f94f3..3ab3fd820f 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -563,7 +563,7 @@ mkDataCon name declared_infix mkTyConApp rep_tycon (mkTyVarTys univ_tvs) eqSpecPreds :: [(TyVar,Type)] -> ThetaType -eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv, ty) | (tv,ty) <- spec ] +eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ] mk_pred_strict_mark :: PredType -> HsBang mk_pred_strict_mark pred diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 7487c66025..d98a4ad734 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -29,7 +29,6 @@ import Demand import DataCon import TyCon import Type -import Kind import Coercion import StaticFlags import BasicTypes @@ -312,12 +311,7 @@ pprTypedLetBinder binder pprKindedTyVarBndr :: TyVar -> SDoc -- Print a type variable binder with its kind (but not if *) pprKindedTyVarBndr tyvar - = ptext (sLit "@") <+> ppr tyvar <> opt_kind - where - opt_kind -- Print the kind if not * - | isLiftedTypeKind kind = empty - | otherwise = dcolon <> pprKind kind - kind = tyVarKind tyvar + = ptext (sLit "@") <+> pprTvBndr tyvar -- pprIdBndr does *not* print the type -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 7daa037395..bef7b5da8d 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -252,8 +252,8 @@ repTyFamily :: LTyClDecl Name -> ProcessTyVarBinds TH.Dec -> DsM (Maybe (SrcSpan, Core TH.DecQ)) repTyFamily (L loc (TyFamily { tcdFlavour = flavour, - tcdLName = tc, tcdTyVars = tvs, - tcdKind = opt_kind })) + tcdLName = tc, tcdTyVars = tvs, + tcdKindSig = opt_kind })) tyVarBinds = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; dec <- tyVarBinds tvs $ \bndrs -> @@ -403,7 +403,7 @@ in_subst _ [] = False in_subst n ((n',_):ns) = n==n' || in_subst n ns mkGadtCtxt :: [Name] -- Tyvars of the data type - -> ResType Name + -> ResType (LHsType Name) -> DsM (HsContext Name, [(Name,Name)]) -- Given a data type in GADT syntax, figure out the equality -- context, so that we can represent it with an explicit @@ -607,7 +607,7 @@ repTyVarBndrWithKind :: LHsTyVarBndr Name -> Core TH.Name -> DsM (Core TH.TyVarBndr) repTyVarBndrWithKind (L _ (UserTyVar {})) nm = repPlainTV nm -repTyVarBndrWithKind (L _ (KindedTyVar _ ki _)) nm +repTyVarBndrWithKind (L _ (KindedTyVar _ (HsBSig ki _) _)) nm = repKind ki >>= repKindedTV nm -- represent a type context diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index cdacbf4b37..20a2e47a6b 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -356,7 +356,6 @@ Library RnEnv RnExpr RnHsDoc - RnHsSyn RnNames RnPat RnSource diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 068a9eeec2..4bff46c853 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -161,7 +161,9 @@ cvtDec (PragmaD prag) cvtDec (TySynD tc tvs rhs) = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs ; rhs' <- cvtType rhs - ; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') } + ; returnL $ TyClD (TySynonym { tcdLName = tc' + , tcdTyVars = tvs', tcdTyPats = Nothing + , tcdSynRhs = rhs', tcdFVs = placeHolderNames }) } cvtDec (DataD ctxt tc tvs constrs derivs) = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs @@ -235,7 +237,9 @@ cvtDec (TySynInstD tc tys rhs) = do { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys ; rhs' <- cvtType rhs ; returnL $ InstD $ FamInstDecl $ - TySynonym tc' tvs' tys' rhs' } + TySynonym { tcdLName = tc' + , tcdTyVars = tvs', tcdTyPats = tys' + , tcdSynRhs = rhs', tcdFVs = placeHolderNames } } ---------------- cvt_ci_decs :: MsgDoc -> [TH.Dec] @@ -753,9 +757,10 @@ cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' } cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' } cvtp TH.WildP = return $ WildPat void cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs - ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } + ; 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' t' } +cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t + ; return $ SigPatIn p' (HsBSig t' placeHolderBndrs) } 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)) @@ -791,8 +796,7 @@ cvt_tv (TH.PlainTV nm) cvt_tv (TH.KindedTV nm ki) = do { nm' <- tName nm ; ki' <- cvtKind ki - ; returnL $ KindedTyVar nm' ki' placeHolderKind - } + ; returnL $ KindedTyVar nm' (HsBSig ki' placeHolderBndrs) placeHolderKind } cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName) cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' } diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 49a5b91717..26d49f726c 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -449,10 +449,10 @@ data TyClDecl name | -- | @type/data family T :: *->*@ - TyFamily { tcdFlavour:: FamilyFlavour, -- type or data - tcdLName :: Located name, -- type constructor - tcdTyVars :: [LHsTyVarBndr name], -- type variables - tcdKind :: Maybe (LHsKind name) -- result kind + TyFamily { tcdFlavour :: FamilyFlavour, -- type or data + tcdLName :: Located name, -- type constructor + tcdTyVars :: [LHsTyVarBndr name], -- type variables + tcdKindSig :: Maybe (LHsKind name) -- result kind } @@ -501,7 +501,9 @@ data TyClDecl name tcdTyPats :: Maybe [LHsType name], -- ^ Type patterns -- See Note [tcdTyVars and tcdTyPats] - tcdSynRhs :: LHsType name -- ^ synonym expansion + tcdSynRhs :: LHsType name, -- ^ synonym expansion + tcdFVs :: NameSet -- ^ Free tycons of the decl + -- (Used for cycle detection) } | ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context... @@ -634,7 +636,7 @@ instance OutputableBndr name = hsep [ptext (sLit "foreign import type dotnet"), ppr ltycon] ppr (TyFamily {tcdFlavour = flavour, tcdLName = ltycon, - tcdTyVars = tyvars, tcdKind = mb_kind}) + tcdTyVars = tyvars, tcdKindSig = mb_kind}) = pp_flavour <+> pp_decl_head [] ltycon tyvars Nothing <+> pp_kind where pp_flavour = case flavour of @@ -766,7 +768,7 @@ data ConDecl name , con_details :: HsConDeclDetails name -- ^ The main payload - , con_res :: ResType name + , con_res :: ResType (LHsType name) -- ^ Result type of the constructor , con_doc :: Maybe LHsDocString @@ -786,16 +788,16 @@ hsConDeclArgTys (PrefixCon tys) = tys hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] hsConDeclArgTys (RecCon flds) = map cd_fld_type flds -data ResType name +data ResType ty = ResTyH98 -- Constructor was declared using Haskell 98 syntax - | ResTyGADT (LHsType name) -- Constructor was declared using GADT-style syntax, - -- and here is its result type + | ResTyGADT ty -- Constructor was declared using GADT-style syntax, + -- and here is its result type deriving (Data, Typeable) -instance OutputableBndr name => Outputable (ResType name) where +instance Outputable ty => Outputable (ResType ty) where -- Debugging only - ppr ResTyH98 = ptext (sLit "ResTyH98") - ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> pprParendHsType (unLoc ty) + ppr ResTyH98 = ptext (sLit "ResTyH98") + ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> ppr ty \end{code} @@ -1061,10 +1063,10 @@ data RuleDecl name data RuleBndr name = RuleBndr (Located name) - | RuleBndrSig (Located name) (LHsType name) + | RuleBndrSig (Located name) (HsBndrSig (LHsType name)) deriving (Data, Typeable) -collectRuleBndrSigTys :: [RuleBndr name] -> [LHsType name] +collectRuleBndrSigTys :: [RuleBndr name] -> [HsBndrSig (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 2241d7bd0a..1a5e206a54 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -132,7 +132,7 @@ data Pat id ------------ Pattern type signatures --------------- | SigPatIn (LPat id) -- Pattern with a type signature - (LHsType id) + (HsBndrSig (LHsType id)) | SigPatOut (LPat id) -- Pattern with a type signature Type diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index acd4df9f5c..696b48f0a1 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -17,7 +17,7 @@ HsTypes: Abstract syntax: user-defined types module HsTypes ( HsType(..), LHsType, HsKind, LHsKind, - HsTyVarBndr(..), LHsTyVarBndr, + HsBndrSig(..), HsTyVarBndr(..), LHsTyVarBndr, HsTupleSort(..), HsExplicitFlag(..), HsContext, LHsContext, HsQuasiQuote(..), @@ -29,7 +29,7 @@ module HsTypes ( ConDeclField(..), pprConDeclFields, mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs, - hsTyVarName, hsTyVarNames, replaceTyVarName, replaceLTyVarName, + hsTyVarName, hsTyVarNames, hsTyVarKind, hsLTyVarKind, hsTyVarNameKind, hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe, @@ -37,6 +37,7 @@ module HsTypes ( splitHsClassTy_maybe, splitLHsClassTy_maybe, splitHsFunType, splitHsAppTys, mkHsAppTys, mkHsOpTy, + placeHolderBndrs, -- Printing pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, @@ -47,6 +48,7 @@ import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) import HsLit import NameSet( FreeVars ) +import Name( Name ) import Type import HsDoc import BasicTypes @@ -119,12 +121,44 @@ type LHsType name = Located (HsType name) type HsKind name = HsType name type LHsKind name = Located (HsKind name) +type LHsTyVarBndr name = Located (HsTyVarBndr name) + +data HsBndrSig sig + = HsBSig + sig + [Name] -- The *binding* type/kind names of this signature + deriving (Data, Typeable) +-- 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 + +placeHolderBndrs :: [Name] +-- Used for the NameSet in FunBind and PatBind prior to the renamer +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. + 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] -- With ImplicitForAll, this is the empty list - -- until the renamer fills in the variables + [LHsTyVarBndr name] -- See Note [HsForAllTy tyvar binders] (LHsContext name) (LHsType name) @@ -195,6 +229,22 @@ mkHsOpTy :: LHsType name -> Located name -> LHsType name -> HsType name mkHsOpTy ty1 op ty2 = HsOpTy ty1 (WpKiApps [], op) ty2 \end{code} +Note [HsForAllTy tyvar binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +After parsing: + * Implicit => empty + Explicit => the varibles the user wrote + +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. + Note [Unit tuples] ~~~~~~~~~~~~~~~~~~ Consider the type @@ -323,22 +373,6 @@ hsExplicitTvs (L _ (HsForAllTy Explicit tvs _ _)) = hsLTyVarNames tvs hsExplicitTvs _ = [] --------------------- -type LHsTyVarBndr name = Located (HsTyVarBndr name) - -data HsTyVarBndr name - = UserTyVar -- No explicit kinding - name -- See Note [Printing KindedTyVars] - PostTcKind - - | KindedTyVar - name - (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. - deriving (Data, Typeable) - hsTyVarName :: HsTyVarBndr name -> name hsTyVarName (UserTyVar n _) = n hsTyVarName (KindedTyVar n _ _) = n @@ -368,19 +402,6 @@ hsLTyVarLocName = fmap hsTyVarName hsLTyVarLocNames :: [LHsTyVarBndr name] -> [Located name] hsLTyVarLocNames = map hsLTyVarLocName - -replaceTyVarName :: (Monad m) => HsTyVarBndr name1 -> name2 -- new type name - -> (LHsKind name1 -> m (LHsKind name2)) -- kind renaming - -> m (HsTyVarBndr name2) -replaceTyVarName (UserTyVar _ k) n' _ = return $ UserTyVar n' k -replaceTyVarName (KindedTyVar _ k tck) n' rn = do - k' <- rn k - return $ KindedTyVar n' k' tck - -replaceLTyVarName :: (Monad m) => LHsTyVarBndr name1 -> name2 - -> (LHsKind name1 -> m (LHsKind name2)) - -> m (LHsTyVarBndr name2) -replaceLTyVarName (L loc n1) n2 rn = replaceTyVarName n1 n2 rn >>= return . L loc \end{code} @@ -468,6 +489,9 @@ splitHsFunType other = ([], other) instance (OutputableBndr name) => Outputable (HsType name) where ppr ty = pprHsType ty +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] diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 293f5b05a6..f7a1a10a5b 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -761,17 +761,17 @@ lPatImplicits = hs_lpat %************************************************************************ \begin{code} -collectSigTysFromPats :: [InPat name] -> [LHsType name] +collectSigTysFromPats :: [InPat name] -> [HsBndrSig (LHsType name)] collectSigTysFromPats pats = foldr collect_sig_lpat [] pats -collectSigTysFromPat :: InPat name -> [LHsType name] +collectSigTysFromPat :: InPat name -> [HsBndrSig (LHsType name)] collectSigTysFromPat pat = collect_sig_lpat pat [] -collect_sig_lpat :: InPat name -> [LHsType name] -> [LHsType name] +collect_sig_lpat :: InPat name -> [HsBndrSig (LHsType name)] -> [HsBndrSig (LHsType name)] collect_sig_lpat pat acc = collect_sig_pat (unLoc pat) acc -collect_sig_pat :: Pat name -> [LHsType name] -> [LHsType name] -collect_sig_pat (SigPatIn pat ty) acc = collect_sig_lpat pat (ty:acc) +collect_sig_pat :: Pat name -> [HsBndrSig (LHsType name)] -> [HsBndrSig (LHsType name)] +collect_sig_pat (SigPatIn pat ty) acc = collect_sig_lpat pat (ty:acc) collect_sig_pat (LazyPat pat) acc = collect_sig_lpat pat acc collect_sig_pat (BangPat pat) acc = collect_sig_lpat pat acc diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index ff98b748c9..8de1e0b03f 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -871,7 +871,7 @@ rule_var_list :: { [RuleBndr RdrName] } rule_var :: { RuleBndr RdrName } : varid { RuleBndr $1 } - | '(' varid '::' ctype ')' { RuleBndrSig $2 $4 } + | '(' varid '::' ctype ')' { RuleBndrSig $2 (HsBSig $4 placeHolderBndrs) } ----------------------------------------------------------------------------- -- Warnings and deprecations (c.f. rules) @@ -1102,7 +1102,7 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] } tv_bndr :: { LHsTyVarBndr RdrName } : tyvar { L1 (UserTyVar (unLoc $1) placeHolderKind) } - | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) $4 placeHolderKind) } + | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) (HsBSig $4 placeHolderBndrs) placeHolderKind) } fds :: { Located [Located (FunDep RdrName)] } : {- empty -} { noLoc [] } @@ -1135,6 +1135,7 @@ akind :: { LHsKind RdrName } : '*' { L1 $ HsTyVar (nameRdrName liftedTypeKindTyConName) } | '(' kind ')' { LL $ HsParTy $2 } | pkind { $1 } + | tyvar { L1 $ HsTyVar (unLoc $1) } pkind :: { LHsKind RdrName } -- promoted type, see Note [Promotion] : qtycon { L1 $ HsTyVar $ unLoc $1 } diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index 80d49430eb..872bcdefc0 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -375,7 +375,9 @@ ifaceUnliftedTypeKind = ifaceTcType (IfaceTc unliftedTypeKindTyConName) ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName -toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) (toHsKind k) placeHolderKind +toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig placeHolderKind + where + bsig = HsBSig (toHsKind k) placeHolderBndrs ifaceExtRdrName :: Name -> RdrName ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name) diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 59e6727535..be1f5c4f4b 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -218,7 +218,9 @@ mkTySynonym :: SrcSpan mkTySynonym loc is_family lhs rhs = do { (tc, tparams) <- checkTyClHdr lhs ; (tyvars, typats) <- checkTParams is_family lhs tparams - ; return (L loc (TySynonym tc tyvars typats rhs)) } + ; return (L loc (TySynonym { tcdLName = tc + , tcdTyVars = tyvars, tcdTyPats = typats + , tcdSynRhs = rhs, tcdFVs = placeHolderNames })) } mkTyFamily :: SrcSpan -> FamilyFlavour @@ -499,7 +501,7 @@ 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 k placeHolderKind)) + | isRdrTyVar tv = return (L l (KindedTyVar tv (HsBSig k placeHolderBndrs) placeHolderKind)) chk (L l (HsTyVar tv)) | isRdrTyVar tv = return (L l (UserTyVar tv placeHolderKind)) chk t@(L l _) @@ -636,7 +638,7 @@ checkAPat dynflags loc e0 = case e0 of let t' = case t of L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty other -> other - return (SigPatIn e t') + return (SigPatIn e (HsBSig t' placeHolderBndrs)) -- n+k patterns OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index 02e2e47534..04bda6b0fe 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -477,7 +477,7 @@ keep different state threads separate. It is represented by nothing at all. \begin{code} mkStatePrimTy :: Type -> Type -mkStatePrimTy ty = mkTyConApp statePrimTyCon [ty] +mkStatePrimTy ty = mkNakedTyConApp statePrimTyCon [ty] statePrimTyCon :: TyCon -- See Note [The State# TyCon] statePrimTyCon = pcPrimTyCon statePrimTyConName 1 VoidRep @@ -523,17 +523,17 @@ arrayArrayPrimTyCon = pcPrimTyCon0 arrayArrayPrimTyConName PtrRe mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName 1 PtrRep mkArrayPrimTy :: Type -> Type -mkArrayPrimTy elt = mkTyConApp arrayPrimTyCon [elt] +mkArrayPrimTy elt = mkNakedTyConApp arrayPrimTyCon [elt] byteArrayPrimTy :: Type byteArrayPrimTy = mkTyConTy byteArrayPrimTyCon mkArrayArrayPrimTy :: Type mkArrayArrayPrimTy = mkTyConTy arrayArrayPrimTyCon mkMutableArrayPrimTy :: Type -> Type -> Type -mkMutableArrayPrimTy s elt = mkTyConApp mutableArrayPrimTyCon [s, elt] +mkMutableArrayPrimTy s elt = mkNakedTyConApp mutableArrayPrimTyCon [s, elt] mkMutableByteArrayPrimTy :: Type -> Type -mkMutableByteArrayPrimTy s = mkTyConApp mutableByteArrayPrimTyCon [s] +mkMutableByteArrayPrimTy s = mkNakedTyConApp mutableByteArrayPrimTyCon [s] mkMutableArrayArrayPrimTy :: Type -> Type -mkMutableArrayArrayPrimTy s = mkTyConApp mutableArrayArrayPrimTyCon [s] +mkMutableArrayArrayPrimTy s = mkNakedTyConApp mutableArrayArrayPrimTyCon [s] \end{code} %************************************************************************ @@ -547,7 +547,7 @@ mutVarPrimTyCon :: TyCon mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName 2 PtrRep mkMutVarPrimTy :: Type -> Type -> Type -mkMutVarPrimTy s elt = mkTyConApp mutVarPrimTyCon [s, elt] +mkMutVarPrimTy s elt = mkNakedTyConApp mutVarPrimTyCon [s, elt] \end{code} %************************************************************************ @@ -561,7 +561,7 @@ mVarPrimTyCon :: TyCon mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName 2 PtrRep mkMVarPrimTy :: Type -> Type -> Type -mkMVarPrimTy s elt = mkTyConApp mVarPrimTyCon [s, elt] +mkMVarPrimTy s elt = mkNakedTyConApp mVarPrimTyCon [s, elt] \end{code} %************************************************************************ @@ -575,7 +575,7 @@ tVarPrimTyCon :: TyCon tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName 2 PtrRep mkTVarPrimTy :: Type -> Type -> Type -mkTVarPrimTy s elt = mkTyConApp tVarPrimTyCon [s, elt] +mkTVarPrimTy s elt = mkNakedTyConApp tVarPrimTyCon [s, elt] \end{code} %************************************************************************ @@ -589,7 +589,7 @@ stablePtrPrimTyCon :: TyCon stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName 1 AddrRep mkStablePtrPrimTy :: Type -> Type -mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty] +mkStablePtrPrimTy ty = mkNakedTyConApp stablePtrPrimTyCon [ty] \end{code} %************************************************************************ @@ -603,7 +603,7 @@ stableNamePrimTyCon :: TyCon stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName 1 PtrRep mkStableNamePrimTy :: Type -> Type -mkStableNamePrimTy ty = mkTyConApp stableNamePrimTyCon [ty] +mkStableNamePrimTy ty = mkNakedTyConApp stableNamePrimTyCon [ty] \end{code} %************************************************************************ @@ -630,7 +630,7 @@ weakPrimTyCon :: TyCon weakPrimTyCon = pcPrimTyCon weakPrimTyConName 1 PtrRep mkWeakPrimTy :: Type -> Type -mkWeakPrimTy v = mkTyConApp weakPrimTyCon [v] +mkWeakPrimTy v = mkNakedTyConApp weakPrimTyCon [v] \end{code} %************************************************************************ @@ -731,5 +731,5 @@ anyTyCon = mkLiftedPrimTyCon anyTyConName kind 1 PtrRep where kind = ForAllTy kKiVar (mkTyVarTy kKiVar) anyTypeOfKind :: Kind -> Type -anyTypeOfKind kind = mkTyConApp anyTyCon [kind] +anyTypeOfKind kind = mkNakedTyConApp anyTyCon [kind] \end{code} diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 7d4edfd40d..4b7f043adb 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -54,8 +54,8 @@ module TysWiredIn ( -- * Tuples mkTupleTy, mkBoxedTupleTy, - tupleTyCon, promotedTupleTyCon, - tupleCon, + tupleTyCon, tupleCon, + promotedTupleTyCon, promotedTupleDataCon, unitTyCon, unitDataCon, unitDataConId, pairTyCon, unboxedUnitTyCon, unboxedUnitDataCon, unboxedSingletonTyCon, unboxedSingletonDataCon, @@ -88,6 +88,7 @@ import TysPrim import Coercion import Constants ( mAX_TUPLE_SIZE ) import Module ( Module ) +import Type ( mkTyConApp ) import DataCon import Var import TyCon @@ -328,6 +329,9 @@ tupleTyCon ConstraintTuple i = fst (factTupleArr ! i) promotedTupleTyCon :: TupleSort -> Arity -> TyCon promotedTupleTyCon sort i = buildPromotedTyCon (tupleTyCon sort i) +promotedTupleDataCon :: TupleSort -> Arity -> TyCon +promotedTupleDataCon sort i = buildPromotedDataCon (tupleCon sort i) + tupleCon :: TupleSort -> Arity -> DataCon tupleCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i) -- Build one specially tupleCon BoxedTuple i = snd (boxedTupleArr ! i) diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 969a517629..6a7bfbea9a 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -33,10 +33,9 @@ module RnBinds ( import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) import HsSyn -import RnHsSyn import TcRnMonad import TcEvidence ( emptyTcEvBinds ) -import RnTypes ( rnIPName, rnHsSigType, rnLHsType, checkPrecMatch ) +import RnTypes ( bindSigTyVarsFV, rnIPName, rnHsSigType, rnLHsType, checkPrecMatch ) import RnPat import RnEnv import DynFlags @@ -184,8 +183,8 @@ rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) -- Return a single HsBindGroup with empty binds and renamed signatures rnTopBindsBoot (ValBindsIn mbinds sigs) = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds) - ; sigs' <- renameSigs HsBootCtxt sigs - ; return (ValBindsOut [] sigs', usesOnly (hsSigsFVs sigs')) } + ; (sigs', fvs) <- renameSigs HsBootCtxt sigs + ; return (ValBindsOut [] sigs', usesOnly fvs) } rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b) \end{code} @@ -291,13 +290,13 @@ rnValBindsRHS :: HsSigCtxt -> RnM (HsValBinds Name, DefUses) rnValBindsRHS ctxt (ValBindsIn mbinds sigs) - = do { sigs' <- renameSigs ctxt sigs + = do { (sigs', sig_fvs) <- renameSigs ctxt sigs ; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs')) mbinds ; case depAnalBinds binds_w_dus of (anal_binds, anal_dus) -> return (valbind', valbind'_dus) where valbind' = ValBindsOut anal_binds sigs' - valbind'_dus = anal_dus `plusDU` usesOnly (hsSigsFVs sigs') + valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs -- Put the sig uses *after* the bindings -- so that the binders are removed from -- the uses in the sigs @@ -649,7 +648,7 @@ signatures. We'd only need this if we wanted to report unused tyvars. \begin{code} renameSigs :: HsSigCtxt -> [LSig RdrName] - -> RnM [LSig Name] + -> RnM ([LSig Name], FreeVars) -- Renames the signatures and performs error checks renameSigs ctxt sigs = do { mapM_ dupSigDeclErr (findDupsEq overlapHsSig sigs) -- Duplicate @@ -662,12 +661,12 @@ renameSigs ctxt sigs -- op :: a -> a -- default op :: Eq a => a -> a - ; sigs' <- mapM (wrapLocM (renameSig ctxt)) sigs + ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs' ; mapM_ misplacedSigErr bad_sigs -- Misplaced - ; return good_sigs } + ; return (good_sigs, sig_fvs) } ---------------------- -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory @@ -679,26 +678,26 @@ renameSigs ctxt sigs -- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) -- Doesn't seem worth much trouble to sort this. -renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name) +renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name, FreeVars) -- FixitySig is renamed elsewhere. renameSig _ (IdSig x) - = return (IdSig x) -- Actually this never occurs + = return (IdSig x, emptyFVs) -- Actually this never occurs renameSig ctxt sig@(TypeSig vs ty) = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs - ; new_ty <- rnHsSigType (ppr_sig_bndrs vs) ty - ; return (TypeSig new_vs new_ty) } + ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty + ; return (TypeSig new_vs new_ty, fvs) } renameSig ctxt sig@(GenericSig vs ty) = do { defaultSigs_on <- xoptM Opt_DefaultSignatures ; unless defaultSigs_on (addErr (defaultSigErr sig)) ; new_v <- mapM (lookupSigOccRn ctxt sig) vs - ; new_ty <- rnHsSigType (ppr_sig_bndrs vs) ty - ; return (GenericSig new_v new_ty) } + ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty + ; return (GenericSig new_v new_ty, fvs) } renameSig _ (SpecInstSig ty) - = do { new_ty <- rnLHsType SpecInstSigCtx ty - ; return (SpecInstSig new_ty) } + = do { (new_ty, fvs) <- rnLHsType SpecInstSigCtx ty + ; return (SpecInstSig new_ty,fvs) } -- {-# SPECIALISE #-} pragmas can refer to imported Ids -- so, in the top-level case (when mb_names is Nothing) @@ -708,16 +707,16 @@ renameSig ctxt sig@(SpecSig v ty inl) = do { new_v <- case ctxt of TopSigCtxt -> lookupLocatedOccRn v _ -> lookupSigOccRn ctxt sig v - ; new_ty <- rnHsSigType (quotes (ppr v)) ty - ; return (SpecSig new_v new_ty inl) } + ; (new_ty, fvs) <- rnHsSigType (quotes (ppr v)) ty + ; return (SpecSig new_v new_ty inl, fvs) } renameSig ctxt sig@(InlineSig v s) = do { new_v <- lookupSigOccRn ctxt sig v - ; return (InlineSig new_v s) } + ; return (InlineSig new_v s, emptyFVs) } renameSig ctxt sig@(FixSig (FixitySig v f)) = do { new_v <- lookupSigOccRn ctxt sig v - ; return (FixSig (FixitySig new_v f)) } + ; return (FixSig (FixitySig new_v f), emptyFVs) } ppr_sig_bndrs :: [Located RdrName] -> SDoc ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) @@ -778,7 +777,6 @@ rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss) { (grhss', grhss_fvs) <- rnGRHSs ctxt grhss ; return (Match pats' Nothing grhss', grhss_fvs) }} - -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs resSigErr :: HsMatchContext Name -> Match RdrName -> HsType RdrName -> SDoc resSigErr ctxt match ty diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index ecd2cd3147..f1adba6bd3 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -14,13 +14,16 @@ module RnEnv ( newTopSrcBinder, lookupLocatedTopBndrRn, lookupTopBndrRn, - lookupLocatedOccRn, lookupOccRn, lookupLocalOccRn_maybe, lookupPromotedOccRn, + lookupLocatedOccRn, lookupOccRn, + lookupLocalOccRn_maybe, + lookupTypeOccRn, lookupKindOccRn, lookupGlobalOccRn, lookupGlobalOccRn_maybe, HsSigCtxt(..), lookupLocalDataTcNames, lookupSigOccRn, lookupFixityRn, lookupTyFixityRn, - lookupInstDeclBndr, lookupSubBndrOcc, greRdrName, + lookupInstDeclBndr, lookupSubBndrOcc, lookupTcdName, + greRdrName, lookupSubBndrGREs, lookupConstructorFields, lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse, lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe, @@ -31,7 +34,6 @@ module RnEnv ( MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv, addLocalFixities, bindLocatedLocalsFV, bindLocatedLocalsRn, - bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV, extendTyVarEnvFVRn, checkDupRdrNames, checkDupAndShadowedRdrNames, @@ -40,7 +42,6 @@ module RnEnv ( warnUnusedMatches, warnUnusedTopBinds, warnUnusedLocalBinds, dataTcOccs, unknownNameErr, kindSigErr, dataKindsErr, perhapsForallMsg, - HsDocContext(..), docOfHsDocContext ) where @@ -49,7 +50,6 @@ module RnEnv ( import LoadIface ( loadInterfaceForName, loadSrcInterface ) import IfaceEnv import HsSyn -import RdrHsSyn ( extractHsTyRdrTyVars ) import RdrName import HscTypes import TcEnv ( tcLookupDataCon, tcLookupField, isBrackStage ) @@ -72,7 +72,6 @@ import ListSetOps ( removeDups ) import DynFlags import FastString import Control.Monad -import Data.List import qualified Data.Set as Set \end{code} @@ -271,6 +270,25 @@ lookupInstDeclBndr cls what rdr where doc = what <+> ptext (sLit "of class") <+> quotes (ppr cls) + +----------------------------------------------- +lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name) +-- Used for TyData and TySynonym only, +-- both ordinary ones and family instances +-- See Note [Family instance binders] +lookupTcdName mb_cls tc_decl + | not (isFamInstDecl tc_decl) -- The normal case + = ASSERT2( isNothing mb_cls, ppr tc_rdr ) -- Parser prevents this + lookupLocatedTopBndrRn tc_rdr + + | Just cls <- mb_cls -- Associated type; c.f RnBinds.rnMethodBind + = wrapLocM (lookupInstDeclBndr cls (ptext (sLit "associated type"))) tc_rdr + + | otherwise -- Family instance; tc_rdr is an *occurrence* + = lookupLocatedOccRn tc_rdr + where + tc_rdr = tcdLName tc_decl + ----------------------------------------------- lookupConstructorFields :: Name -> RnM [Name] -- Look up the fields of a given constructor @@ -374,6 +392,40 @@ lookupSubBndrGREs env parent rdr_name parent_is _ _ = False \end{code} +Note [Family instance binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family F a + data instance F T = X1 | X2 + +The 'data instance' decl has an *occurrence* of F (and T), and *binds* +X1 and X2. (This is unlike a normal data type declaration which would +bind F too.) So we want an AvailTC F [X1,X2]. + +Now consider a similar pair: + class C a where + data G a + instance C S where + data G S = Y1 | Y2 + +The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G. + +But there is a small complication: in an instance decl, we don't use +qualified names on the LHS; instead we use the class to disambiguate. +Thus: + module M where + import Blib( G ) + class C a where + data G a + instance C S where + data G S = Y1 | Y2 +Even though there are two G's in scope (M.G and Blib.G), the occurence +of 'G' in the 'instance C S' decl is unambiguous, becuase C has only +one associated type called G. This is exactly what happens for methods, +and it is only consistent to do the same thing for types. That's the +role of the function lookupTcdName; the (Maybe Name) give the class of +the encloseing instance decl, if any. + Note [Looking up Exact RdrNames] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Exact RdrNames are generated by Template Haskell. See Note [Binders @@ -452,10 +504,18 @@ lookupOccRn rdr_name = do opt_name <- lookupOccRn_maybe rdr_name maybe (unboundName WL_Any rdr_name) return opt_name +lookupKindOccRn :: RdrName -> RnM Name +-- Looking up a name occurring in a kind +lookupKindOccRn rdr_name + = do { mb_name <- lookupOccRn_maybe rdr_name + ; case mb_name of + Just name -> return name + Nothing -> unboundName WL_Any rdr_name } + -- lookupPromotedOccRn looks up an optionally promoted RdrName. -lookupPromotedOccRn :: RdrName -> RnM Name +lookupTypeOccRn :: RdrName -> RnM Name -- see Note [Demotion] -lookupPromotedOccRn rdr_name +lookupTypeOccRn rdr_name = do { mb_name <- lookupOccRn_maybe rdr_name ; case mb_name of { Just name -> return name ; @@ -1018,42 +1078,6 @@ bindLocatedLocalsFV rdr_names enclosed_scope return (thing, delFVs names fvs) ------------------------------------- -bindPatSigTyVars :: [LHsType RdrName] -> ([Name] -> RnM a) -> RnM a - -- Find the type variables in the pattern type - -- signatures that must be brought into scope -bindPatSigTyVars tys thing_inside - = do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables - ; if not scoped_tyvars then - thing_inside [] - else - do { name_env <- getLocalRdrEnv - ; let locd_tvs = [ tv | ty <- tys - , tv <- extractHsTyRdrTyVars ty - , not (unLoc tv `elemLocalRdrEnv` name_env) ] - nubbed_tvs = nubBy eqLocated locd_tvs - -- The 'nub' is important. For example: - -- f (x :: t) (y :: t) = .... - -- We don't want to complain about binding t twice! - - ; bindLocatedLocalsRn nubbed_tvs thing_inside }} - -bindPatSigTyVarsFV :: [LHsType RdrName] - -> RnM (a, FreeVars) - -> RnM (a, FreeVars) -bindPatSigTyVarsFV tys thing_inside - = bindPatSigTyVars tys $ \ tvs -> - thing_inside `thenM` \ (result,fvs) -> - return (result, fvs `delListFromNameSet` tvs) - -bindSigTyVarsFV :: [Name] - -> RnM (a, FreeVars) - -> RnM (a, FreeVars) -bindSigTyVarsFV tvs thing_inside - = do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables - ; if not scoped_tyvars then - thing_inside - else - bindLocalNamesFV tvs thing_inside } extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) -- This function is used only in rnSourceDecl on InstDecl @@ -1148,24 +1172,19 @@ unboundName wl rdr = unboundNameX wl rdr empty unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name unboundNameX where_look rdr_name extra = do { show_helpful_errors <- doptM Opt_HelpfulErrors - ; let err = unknownNameErr rdr_name $$ extra + ; let what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) + err = unknownNameErr what rdr_name $$ extra ; if not show_helpful_errors then addErr err else do { suggestions <- unknownNameSuggestErr where_look rdr_name ; addErr (err $$ suggestions) } - ; env <- getGlobalRdrEnv; - ; traceRn (vcat [unknownNameErr rdr_name, - ptext (sLit "Global envt is:"), - nest 3 (pprGlobalRdrEnv env)]) - ; return (mkUnboundName rdr_name) } -unknownNameErr :: RdrName -> SDoc -unknownNameErr rdr_name +unknownNameErr :: SDoc -> RdrName -> SDoc +unknownNameErr what rdr_name = vcat [ hang (ptext (sLit "Not in scope:")) - 2 (pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) - <+> quotes (ppr rdr_name)) + 2 (what <+> quotes (ppr rdr_name)) , extra ] where extra | rdr_name == forall_tv_RDR = perhapsForallMsg diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 7caae61027..b884d4abde 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -34,8 +34,7 @@ import HsSyn import TcRnMonad import TcEnv ( thRnBrack ) import RnEnv -import RnTypes ( rnHsTypeFVs, rnSplice, rnIPName, checkTH, - mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec) +import RnTypes import RnPat import DynFlags import BasicTypes ( FixityDirection(..) ) @@ -270,7 +269,7 @@ rnExpr (RecordUpd expr rbinds _ _ _) fvExpr `plusFV` fvRbinds) } rnExpr (ExprWithTySig expr pty) - = do { (pty', fvTy) <- rnHsTypeFVs ExprWithTySigCtx pty + = do { (pty', fvTy) <- rnLHsType ExprWithTySigCtx pty ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $ rnLExpr expr ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) } @@ -283,7 +282,7 @@ rnExpr (HsIf _ p b1 b2) ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } rnExpr (HsType a) - = rnHsTypeFVs HsTypeCtx a `thenM` \ (t, fvT) -> + = rnLHsType HsTypeCtx a `thenM` \ (t, fvT) -> return (HsType t, fvT) rnExpr (ArithSeq _ seq) @@ -607,7 +606,7 @@ rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs) -rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs TypBrCtx t +rnBracket (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t ; return (TypBr t', fvs) } rnBracket (DecBrL decls) diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs deleted file mode 100644 index e2369bb776..0000000000 --- a/compiler/rename/RnHsSyn.lhs +++ /dev/null @@ -1,159 +0,0 @@ -% -% (c) The AQUA Project, Glasgow University, 1996-1998 -% -\section[RnHsSyn]{Specialisations of the @HsSyn@ syntax for the renamer} - -\begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module RnHsSyn( - -- Names - charTyCon_name, listTyCon_name, parrTyCon_name, tupleTyCon_name, - extractHsTyVars, extractHsTyNames, extractHsTyNames_s, - extractFunDepNames, extractHsCtxtTyNames, - extractHsTyVarBndrNames, extractHsTyVarBndrNames_s, - - -- Free variables - hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs - ) where - -#include "HsVersions.h" - -import HsSyn -import Class ( FunDep ) -import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, charTyCon ) -import Name ( Name, getName, isTyVarName ) -import NameSet -import BasicTypes ( TupleSort ) -import SrcLoc -import Panic ( panic ) -\end{code} - -%************************************************************************ -%* * -\subsection{Free variables} -%* * -%************************************************************************ - -These free-variable finders returns tycons and classes too. - -\begin{code} -charTyCon_name, listTyCon_name, parrTyCon_name :: Name -charTyCon_name = getName charTyCon -listTyCon_name = getName listTyCon -parrTyCon_name = getName parrTyCon - -tupleTyCon_name :: TupleSort -> Int -> Name -tupleTyCon_name sort n = getName (tupleTyCon sort n) - -extractHsTyVars :: LHsType Name -> NameSet -extractHsTyVars x = filterNameSet isTyVarName (extractHsTyNames x) - -extractFunDepNames :: FunDep Name -> NameSet -extractFunDepNames (ns1, ns2) = mkNameSet ns1 `unionNameSets` mkNameSet ns2 - -extractHsTyNames :: LHsType Name -> NameSet --- Also extract names in kinds. -extractHsTyNames ty - = getl ty - where - getl (L _ ty) = get ty - - get (HsAppTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 - get (HsListTy ty) = unitNameSet listTyCon_name `unionNameSets` getl ty - get (HsPArrTy ty) = unitNameSet parrTyCon_name `unionNameSets` getl ty - get (HsTupleTy _ tys) = extractHsTyNames_s tys - get (HsFunTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 - get (HsIParamTy _ ty) = getl ty - get (HsEqTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 - get (HsOpTy ty1 (_, op) ty2) = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op) - get (HsParTy ty) = getl ty - get (HsBangTy _ ty) = getl ty - get (HsRecTy flds) = extractHsTyNames_s (map cd_fld_type flds) - get (HsTyVar tv) = unitNameSet tv - get (HsSpliceTy _ fvs _) = fvs - get (HsQuasiQuoteTy {}) = emptyNameSet - get (HsKindSig ty ki) = getl ty `unionNameSets` getl ki - get (HsForAllTy _ tvs - ctxt ty) = extractHsTyVarBndrNames_s tvs - (extractHsCtxtTyNames ctxt - `unionNameSets` getl ty) - get (HsDocTy ty _) = getl ty - get (HsCoreTy {}) = emptyNameSet -- This probably isn't quite right - -- but I don't think it matters - get (HsExplicitListTy _ tys) = extractHsTyNames_s tys - get (HsExplicitTupleTy _ tys) = extractHsTyNames_s tys - get (HsWrapTy {}) = panic "extractHsTyNames" - -extractHsTyNames_s :: [LHsType Name] -> NameSet -extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys - -extractHsCtxtTyNames :: LHsContext Name -> NameSet -extractHsCtxtTyNames (L _ ctxt) - = foldr (unionNameSets . extractHsTyNames) emptyNameSet ctxt - -extractHsTyVarBndrNames :: LHsTyVarBndr Name -> NameSet -extractHsTyVarBndrNames (L _ (UserTyVar _ _)) = emptyNameSet -extractHsTyVarBndrNames (L _ (KindedTyVar _ ki _)) = extractHsTyNames ki - -extractHsTyVarBndrNames_s :: [LHsTyVarBndr Name] -> NameSet -> NameSet --- Update the name set 'body' by adding the names in the binders --- kinds and handling scoping. -extractHsTyVarBndrNames_s [] body = body -extractHsTyVarBndrNames_s (b:bs) body = - (extractHsTyVarBndrNames_s bs body `delFromNameSet` hsTyVarName (unLoc b)) - `unionNameSets` extractHsTyVarBndrNames b -\end{code} - - -%************************************************************************ -%* * -\subsection{Free variables of declarations} -%* * -%************************************************************************ - -Return the Names that must be in scope if we are to use this declaration. -In all cases this is set up for interface-file declarations: - - for class decls we ignore the bindings - - for instance decls likewise, plus the pragmas - - for rule decls, we ignore HsRules - - for data decls, we ignore derivings - - *** See "THE NAMING STORY" in HsDecls **** - -\begin{code} ----------------- -hsSigsFVs :: [LSig Name] -> FreeVars -hsSigsFVs sigs = plusFVs (map (hsSigFVs.unLoc) sigs) - -hsSigFVs :: Sig Name -> FreeVars -hsSigFVs (TypeSig _ ty) = extractHsTyNames ty -hsSigFVs (GenericSig _ ty) = extractHsTyNames ty -hsSigFVs (SpecInstSig ty) = extractHsTyNames ty -hsSigFVs (SpecSig _ ty _) = extractHsTyNames ty -hsSigFVs _ = emptyFVs - ----------------- -conDeclFVs :: LConDecl Name -> FreeVars -conDeclFVs (L _ (ConDecl { con_qvars = tyvars, con_cxt = context, - con_details = details, con_res = res_ty})) - = extractHsTyVarBndrNames_s tyvars $ - extractHsCtxtTyNames context `plusFV` - conDetailsFVs details `plusFV` - conResTyFVs res_ty - -conResTyFVs :: ResType Name -> FreeVars -conResTyFVs ResTyH98 = emptyFVs -conResTyFVs (ResTyGADT ty) = extractHsTyNames ty - -conDetailsFVs :: HsConDeclDetails Name -> FreeVars -conDetailsFVs details = plusFVs (map bangTyFVs (hsConDeclArgTys details)) - -bangTyFVs :: LHsType Name -> FreeVars -bangTyFVs bty = extractHsTyNames (getBangType bty) -\end{code} diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index b1a61db2a2..553c3ef81a 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -7,7 +7,7 @@ module RnNames ( rnImports, getLocalNonValBinders, rnExports, extendGlobalRdrEnvRn, - gresFromAvails, lookupTcdName, + gresFromAvails, reportUnusedNames, finishWarnings, ) where @@ -528,6 +528,18 @@ getLocalNonValBinders fixity_env ; names@(main_name : _) <- mapM newTopSrcBinder bndrs ; return (AvailTC main_name names) } + new_assoc :: LInstDecl RdrName -> RnM [AvailInfo] + new_assoc (L _ (FamInstDecl d)) + = do { avail <- new_ti Nothing d + ; return [avail] } + new_assoc (L _ (ClsInstDecl inst_ty _ _ ats)) + | Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty + = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr + ; mapM (new_ti (Just cls_nm) . unLoc) ats } + | otherwise + = return [] -- Do not crash on ill-formed instances + -- Eg instance !Show Int Trac #3811c + new_ti :: Maybe Name -> FamInstDecl RdrName -> RnM AvailInfo new_ti mb_cls ti_decl -- ONLY for type/data instances = ASSERT( isFamInstDecl ti_decl ) @@ -535,37 +547,6 @@ getLocalNonValBinders fixity_env ; sub_names <- mapM newTopSrcBinder (hsTyClDeclBinders ti_decl) ; return (AvailTC (unLoc main_name) sub_names) } -- main_name is not bound here! - - new_assoc :: LInstDecl RdrName -> RnM [AvailInfo] - new_assoc (L _ (FamInstDecl d)) - = do { avail <- new_ti Nothing d - ; return [avail] } - new_assoc (L _ (ClsInstDecl inst_ty _ _ ats)) - = do { mb_cls_nm <- get_cls_parent inst_ty - ; mapM (new_ti mb_cls_nm . unLoc) ats } - where - get_cls_parent inst_ty - | Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty - = setSrcSpan loc $ do { nm <- lookupGlobalOccRn cls_rdr; return (Just nm) } - | otherwise - = return Nothing - -lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name) --- Used for TyData and TySynonym only, --- both ordinary ones and family instances --- See Note [Family instance binders] -lookupTcdName mb_cls tc_decl - | not (isFamInstDecl tc_decl) -- The normal case - = ASSERT2( isNothing mb_cls, ppr tc_rdr ) -- Parser prevents this - lookupLocatedTopBndrRn tc_rdr - - | Just cls <- mb_cls -- Associated type; c.f RnBinds.rnMethodBind - = wrapLocM (lookupInstDeclBndr cls (ptext (sLit "associated type"))) tc_rdr - - | otherwise -- Family instance; tc_rdr is an *occurrence* - = lookupLocatedOccRn tc_rdr - where - tc_rdr = tcdLName tc_decl \end{code} Note [Looking up family names in family instances] @@ -586,41 +567,6 @@ Solution is simple: process the type family declarations first, extend the environment, and then process the type instances. -Note [Family instance binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data family F a - data instance F T = X1 | X2 - -The 'data instance' decl has an *occurrence* of F (and T), and *binds* -X1 and X2. (This is unlike a normal data type declaration which would -bind F too.) So we want an AvailTC F [X1,X2]. - -Now consider a similar pair: - class C a where - data G a - instance C S where - data G S = Y1 | Y2 - -The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G. - -But there is a small complication: in an instance decl, we don't use -qualified names on the LHS; instead we use the class to disambiguate. -Thus: - module M where - import Blib( G ) - class C a where - data G a - instance C S where - data G S = Y1 | Y2 -Even though there are two G's in scope (M.G and Blib.G), the occurence -of 'G' in the 'instance C S' decl is unambiguous, becuase C has only -one associated type called G. This is exactly what happens for methods, -and it is only consistent to do the same thing for types. That's the -role of the function lookupTcdName; the (Maybe Name) give the class of -the encloseing instance decl, if any. - - %************************************************************************ %* * \subsection{Filtering imports} diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 7dd76bd4e6..162ce22775 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -162,6 +162,10 @@ matchNameMaker ctxt = LamMk report_unused StmtCtxt GhciStmt -> False _ -> True +rnHsSigCps :: HsBndrSig (LHsType RdrName) -> CpsRn (HsBndrSig (LHsType Name)) +rnHsSigCps sig + = CpsRn (rnHsBndrSig True PatCtx sig) + newPatName :: NameMaker -> Located RdrName -> CpsRn Name newPatName (LamMk report_unused) rdr_name = CpsRn (\ thing_inside -> @@ -232,11 +236,9 @@ rnPats :: HsMatchContext Name -- for error messages rnPats ctxt pats thing_inside = do { envs_before <- getRdrEnvs - -- (0) bring into scope all of the type variables bound by the patterns -- (1) rename the patterns, bringing into scope all of the term variables -- (2) then do the thing inside. - ; bindPatSigTyVarsFV (collectSigTysFromPats pats) $ - unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do + ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do { -- Check for duplicated and shadowed names -- Must do this *after* renaming the patterns -- See Note [Collect binders only after renaming] in HsUtils @@ -310,15 +312,10 @@ rnPatAndThen mk (VarPat rdr) = do { loc <- liftCps getSrcSpanM -- we need to bind pattern variables for view pattern expressions -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) -rnPatAndThen mk (SigPatIn pat ty) - = do { patsigs <- liftCps (xoptM Opt_ScopedTypeVariables) - ; if patsigs - then do { pat' <- rnLPatAndThen mk pat - ; ty' <- liftCpsFV (rnHsTypeFVs PatCtx ty) - ; return (SigPatIn pat' ty') } - else do { liftCps (addErr (patSigErr ty)) - ; rnPatAndThen mk (unLoc pat) } } - +rnPatAndThen mk (SigPatIn pat sig) + = do { pat' <- rnLPatAndThen mk pat + ; sig' <- rnHsSigCps sig + ; return (SigPatIn pat' sig') } rnPatAndThen mk (LitPat lit) | HsString s <- lit diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 1969229321..a4a734cca1 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -25,7 +25,6 @@ import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl ) import HsSyn import RdrName import RdrHsSyn ( extractHsRhoRdrTyVars ) -import RnHsSyn import RnTypes import RnBinds import RnEnv @@ -43,6 +42,7 @@ import NameEnv import Avail import Outputable import Bag +import BasicTypes ( RuleName ) import FastString import Util ( filterOut ) import SrcLoc @@ -54,7 +54,6 @@ import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices ) import Control.Monad import Data.List( partition ) import Maybes( orElse ) -import Data.Maybe( isNothing ) \end{code} @rnSourceDecl@ `renames' declarations. @@ -356,7 +355,7 @@ rnAnnProvenance provenance = do \begin{code} rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars) rnDefaultDecl (DefaultDecl tys) - = do { (tys', fvs) <- mapFvRn (rnHsTypeFVs doc_str) tys + = do { (tys', fvs) <- rnLHsTypes doc_str tys ; return (DefaultDecl tys', fvs) } where doc_str = DefaultDeclCtx @@ -373,7 +372,7 @@ rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars) rnHsForeignDecl (ForeignImport name ty _ spec) = do { topEnv :: HscEnv <- getTopEnv ; name' <- lookupLocatedTopBndrRn name - ; (ty', fvs) <- rnHsTypeFVs (ForeignDeclCtx name) ty + ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty -- Mark any PackageTarget style imports as coming from the current package ; let packageId = thisPackage $ hsc_dflags topEnv @@ -383,7 +382,7 @@ rnHsForeignDecl (ForeignImport name ty _ spec) rnHsForeignDecl (ForeignExport name ty _ spec) = do { name' <- lookupLocatedOccRn name - ; (ty', fvs) <- rnHsTypeFVs (ForeignDeclCtx name) ty + ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty ; return (ForeignExport name' ty' noForeignExportCoercionYet spec, fvs `addOneFV` unLoc name') } -- NB: a foreign export is an *occurrence site* for name, so -- we add it to the free-variable list. It might, for example, @@ -430,18 +429,19 @@ rnSrcInstDecl (FamInstDecl ty_decl) rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats) -- Used for both source and interface file decls - = do { inst_ty' <- rnLHsInstType (text "In an instance declaration") inst_ty + = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty ; let Just (inst_tyvars, _, L _ cls,_) = splitLHsInstDeclTy_maybe inst_ty' (spec_inst_prags, other_sigs) = partition isSpecInstLSig uprags + tv_names = hsLTyVarNames inst_tyvars -- Rename the associated types, and type signatures -- Both need to have the instance type variables in scope ; ((ats', other_sigs'), more_fvs) - <- extendTyVarEnvFVRn (map hsLTyVarName inst_tyvars) $ - do { (ats', at_fvs) <- rnATInsts cls ats - ; other_sigs' <- renameSigs (InstDeclCtxt cls) other_sigs + <- extendTyVarEnvFVRn tv_names $ + do { (ats', at_fvs) <- rnATDecls cls tv_names ats + ; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs ; return ( (ats', other_sigs') - , at_fvs `plusFV` hsSigsFVs other_sigs') } + , at_fvs `plusFV` sig_fvs) } -- Rename the bindings -- The typechecker (not the renamer) checks that all @@ -458,16 +458,14 @@ rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats) -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-} -- works OK. That's why we did the partition game above -- - -- But the (unqualified) method names are in scope --- ; let binders = collectHsBindsBinders mbinds' - ; spec_inst_prags' <- -- bindLocalNames binders $ - renameSigs (InstDeclCtxt cls) spec_inst_prags + ; (spec_inst_prags', spec_inst_fvs) + <- renameSigs (InstDeclCtxt cls) spec_inst_prags ; let uprags' = spec_inst_prags' ++ other_sigs' ; return (ClsInstDecl inst_ty' mbinds' uprags' ats', meth_fvs `plusFV` more_fvs - `plusFV` hsSigsFVs spec_inst_prags' - `plusFV` extractHsTyNames inst_ty') } + `plusFV` spec_inst_fvs + `plusFV` inst_fvs) } -- We return the renamed associated data type declarations so -- that they can be entered into the list of type declarations -- for the binding group, but we also keep a copy in the instance. @@ -483,15 +481,18 @@ rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats) Renaming of the associated types in instances. \begin{code} -rnATInsts :: Name -> [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars) - -- NB: We allow duplicate associated-type decls; - -- See Note [Associated type instances] in TcInstDcls -rnATInsts cls atDecls = rnList rnATInst atDecls - where - rnATInst tydecl@TyData {} = rnTyClDecl (Just cls) tydecl - rnATInst tydecl@TySynonym {} = rnTyClDecl (Just cls) tydecl - rnATInst tydecl = pprPanic "RnSource.rnATInsts: invalid AT instance" - (ppr (tcdName tydecl)) +rnATDecls :: Name -- Class + -> [Name] -- Type variable binders (but NOT kind variables) + -- See Note [Renaming associated types] in RnTypes + -> [LTyClDecl RdrName] + -> RnM ([LTyClDecl Name], FreeVars) +-- Used for the family declarations and defaults in a class decl +-- and the family instance declarations in an instance +-- +-- NB: We allow duplicate associated-type decls; +-- See Note [Associated type instances] in TcInstDcls +rnATDecls cls tvs atDecls + = rnList (rnTyClDecl (Just (cls, tvs))) atDecls \end{code} For the method bindings in class and instance decls, we extend the @@ -520,8 +521,7 @@ rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars) rnSrcDerivDecl (DerivDecl ty) = do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving ; unless standalone_deriv_ok (addErr standaloneDerivErr) - ; ty' <- rnLHsInstType (text "In a deriving declaration") ty - ; let fvs = extractHsTyNames ty' + ; (ty', fvs) <- rnLHsInstType (text "In a deriving declaration") ty ; return (DerivDecl ty', fvs) } standaloneDerivErr :: SDoc @@ -539,36 +539,39 @@ standaloneDerivErr \begin{code} rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars) rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs) - = bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $ - bindLocatedLocalsFV (map get_var vars) $ \ ids -> - do { (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids) - -- NB: The binders in a rule are always Ids - -- We don't (yet) support type variables - - ; (lhs', fv_lhs') <- rnLExpr lhs - ; (rhs', fv_rhs') <- rnLExpr rhs - - ; checkValidRule rule_name ids lhs' fv_lhs' - - ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs', - fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') } + = do { let rdr_names_w_loc = map get_var vars + ; checkDupAndShadowedRdrNames rdr_names_w_loc + ; names <- newLocalBndrsRn rdr_names_w_loc + ; bindHsRuleVars rule_name vars names $ \ vars' -> + do { (lhs', fv_lhs') <- rnLExpr lhs + ; (rhs', fv_rhs') <- rnLExpr rhs + ; checkValidRule rule_name names lhs' fv_lhs' + ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs', + fv_lhs' `plusFV` fv_rhs') } } where - doc = RuleCtx rule_name - - get_var (RuleBndr v) = v get_var (RuleBndrSig v _) = v + get_var (RuleBndr v) = v + +bindHsRuleVars :: RuleName -> [RuleBndr RdrName] -> [Name] + -> ([RuleBndr Name] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +bindHsRuleVars rule_name vars names thing_inside + = go vars names $ \ vars' -> + bindLocalNamesFV names (thing_inside vars') + where + doc = RuleCtx rule_name - rn_var (RuleBndr (L loc _), id) - = return (RuleBndr (L loc id), emptyFVs) - rn_var (RuleBndrSig (L loc _) t, id) - = do { (t', fvs) <- rnHsTypeFVs doc t - ; return (RuleBndrSig (L loc id) t', fvs) } + go (RuleBndr (L loc _) : vars) (n : ns) thing_inside + = go vars ns $ \ vars' -> + thing_inside (RuleBndr (L loc n) : vars') -badRuleVar :: FastString -> Name -> SDoc -badRuleVar name var - = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon, - ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+> - ptext (sLit "does not appear on left hand side")] + go (RuleBndrSig (L loc _) bsig : vars) (n : ns) thing_inside + = rnHsBndrSig True doc bsig $ \ bsig' -> + go vars ns $ \ vars' -> + thing_inside (RuleBndrSig (L loc n) bsig' : vars') + + go [] [] thing_inside = thing_inside [] + go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names) \end{code} Note [Rule LHS validity checking] @@ -628,6 +631,12 @@ validRuleLhs foralls lhs checkl_es es = foldr (mplus . checkl_e) Nothing es -} +badRuleVar :: FastString -> Name -> SDoc +badRuleVar name var + = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon, + ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+> + ptext (sLit "does not appear on left hand side")] + badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc badRuleLhsErr name lhs bad_e = sep [ptext (sLit "Rule") <+> ftext name <> colon, @@ -685,8 +694,8 @@ rnHsVectDecl (HsVectClassIn cls) rnHsVectDecl (HsVectClassOut _) = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'" rnHsVectDecl (HsVectInstIn instTy) - = do { instTy' <- rnLHsInstType (text "In a VECTORISE pragma") instTy - ; return (HsVectInstIn instTy', extractHsTyNames instTy') + = do { (instTy', fvs) <- rnLHsInstType (text "In a VECTORISE pragma") instTy + ; return (HsVectInstIn instTy', fvs) } rnHsVectDecl (HsVectInstOut _) = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'" @@ -772,9 +781,10 @@ rnTyClDecls extra_deps tycl_ds ; return (map flattenSCC sccs, all_fvs) } -rnTyClDecl :: Maybe Name -- Just cls => this TyClDecl is nested - -- inside an *instance decl* for cls - -- used for associated types +rnTyClDecl :: Maybe (Name, [Name]) + -- Just (cls,tvs) => this TyClDecl is nested + -- inside an *instance decl* for cls + -- used for associated types -> TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars) rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name}) @@ -786,16 +796,15 @@ rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name}) -- and "data family"), both top level and (for an associated type) -- in a class decl rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars - , tcdFlavour = flav, tcdKind = kind }) - = bindQTvs fmly_doc mb_cls tyvars $ \tyvars' -> + , tcdFlavour = flav, tcdKindSig = kind }) + = bindTyClTyVars fmly_doc mb_cls tyvars $ \tyvars' -> do { tycon' <- lookupLocatedTopBndrRn tycon - ; kind' <- rnLHsMaybeKind fmly_doc kind - ; let fv_kind = maybe emptyFVs extractHsTyNames kind' - fvs = extractHsTyVarBndrNames_s tyvars' fv_kind + ; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind ; return ( TyFamily { tcdLName = tycon', tcdTyVars = tyvars' - , tcdFlavour = flav, tcdKind = kind' } - , fvs) } - where fmly_doc = TyFamilyCtx tycon + , tcdFlavour = flav, tcdKindSig = kind' } + , fv_kind) } + where + fmly_doc = TyFamilyCtx tycon -- "data", "newtype", "data instance, and "newtype instance" declarations -- both top level and (for an associated type) in an instance decl @@ -804,40 +813,35 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCType = cType, tcdLName = tycon, tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = condecls, tcdKindSig = sig, tcdDerivs = derivs} - = do { tycon' <- lookupTcdName mb_cls tydecl - ; sig' <- rnLHsMaybeKind data_doc sig + = bindTyClTyVars data_doc mb_cls tyvars $ \ tyvars' -> + -- Checks for distinct tyvars + do { tycon' <- lookupTcdName (fmap fst mb_cls) tydecl ; checkTc (h98_style || null (unLoc context)) (badGadtStupidTheta tycon) - ; ((tyvars', context', typats', derivs'), stuff_fvs) - <- bindQTvs data_doc mb_cls tyvars $ \ tyvars' -> do - -- Checks for distinct tyvars - { context' <- rnContext data_doc context - ; (typats', fvs1) <- rnTyPats data_doc tycon' typats - ; (derivs', fvs2) <- rn_derivs derivs - ; let fvs = fvs1 `plusFV` fvs2 `plusFV` - extractHsCtxtTyNames context' - `plusFV` maybe emptyFVs extractHsTyNames sig' - ; return ((tyvars', context', typats', derivs'), fvs) } - - -- For the constructor declarations, bring into scope the tyvars - -- bound by the header, but *only* in the H98 case - -- Reason: for GADTs, the type variables in the declaration - -- do not scope over the constructor signatures - -- data T a where { T1 :: forall b. b-> b } - ; let tc_tvs_in_scope | h98_style = hsLTyVarNames tyvars' - | otherwise = [] - ; (condecls', con_fvs) <- bindLocalNamesFV tc_tvs_in_scope $ + ; (sig', sig_fvs) <- rnLHsMaybeKind data_doc sig + ; (context', fvs1) <- rnContext data_doc context + ; (typats', fvs2) <- rnTyPats data_doc tycon' typats + ; (derivs', fvs3) <- rn_derivs derivs + + -- For the constructor declarations, drop the LocalRdrEnv + -- in the GADT case, where the type variables in the declaration + -- do not scope over the constructor signatures + -- data T a where { T1 :: forall b. b-> b } + ; let { zap_lcl_env | h98_style = \ thing -> thing + | otherwise = setLocalRdrEnv emptyLocalRdrEnv } + ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls - -- No need to check for duplicate constructor decls - -- since that is done by RnNames.extendGlobalRdrEnvRn - - ; return (TyData {tcdND = new_or_data, tcdCType = cType, - tcdCtxt = context', - tcdLName = tycon', tcdTyVars = tyvars', - tcdTyPats = typats', tcdKindSig = sig', - tcdCons = condecls', tcdDerivs = derivs'}, - con_fvs `plusFV` stuff_fvs) + -- No need to check for duplicate constructor decls + -- since that is done by RnNames.extendGlobalRdrEnvRn + + ; return ( TyData { tcdND = new_or_data, tcdCType = cType + , tcdCtxt = context' + , tcdLName = tycon', tcdTyVars = tyvars' + , tcdTyPats = typats', tcdKindSig = sig' + , tcdCons = condecls', tcdDerivs = derivs'} + , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` + con_fvs `plusFV` sig_fvs ) } where h98_style = case condecls of -- Note [Stupid theta] @@ -847,22 +851,23 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCType = cType, data_doc = TyDataCtx tycon rn_derivs Nothing = return (Nothing, emptyFVs) - rn_derivs (Just ds) = do { ds' <- rnLHsTypes data_doc ds - ; return (Just ds', extractHsTyNames_s ds') } + rn_derivs (Just ds) = do { (ds', fvs) <- rnLHsTypes data_doc ds + ; return (Just ds', fvs) } -- "type" and "type instance" declarations -rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars, - tcdLName = name, - tcdTyPats = typats, tcdSynRhs = ty}) - = bindQTvs syn_doc mb_cls tyvars $ \ tyvars' -> do - { -- Checks for distinct tyvars - name' <- lookupTcdName mb_cls tydecl - ; (typats',fvs1) <- rnTyPats syn_doc name' typats - ; (ty', fvs2) <- rnHsTypeFVs syn_doc ty - ; return (TySynonym { tcdLName = name' - , tcdTyVars = tyvars' - , tcdTyPats = typats', tcdSynRhs = ty'} - , extractHsTyVarBndrNames_s tyvars' (fvs1 `plusFV` fvs2)) } +rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars + , tcdLName = name + , tcdTyPats = typats, tcdSynRhs = ty}) + = do { name' <- lookupTcdName (fmap fst mb_cls) tydecl + ; ((tyvars', typats', ty'), fvs) + <- bindTyClTyVars syn_doc mb_cls tyvars $ \ tyvars' -> do + do { (typats',fvs1) <- rnTyPats syn_doc name' typats + ; (ty', fvs2) <- rnLHsType syn_doc ty + ; return ((tyvars', typats', ty'), fvs1 `plusFV` fvs2) } + ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars' + , tcdTyPats = typats', tcdSynRhs = ty' + , tcdFVs = fvs } + , fvs) } where syn_doc = TySynCtx name @@ -875,19 +880,19 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls, -- Tyvars scope over superclass context and method signatures ; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs) - <- bindTyVarsFV cls_doc tyvars $ \ tyvars' -> do + <- bindHsTyVars cls_doc tyvars $ \ tyvars' -> do -- Checks for distinct tyvars - { context' <- rnContext cls_doc context + { (context', cxt_fvs) <- rnContext cls_doc context ; fds' <- rnFds (docOfHsDocContext cls_doc) fds - ; let rn_at = rnTyClDecl (Just cls') - ; (ats', fv_ats) <- mapAndUnzipM (wrapLocFstM rn_at) ats - ; sigs' <- renameSigs (ClsDeclCtxt cls') sigs - ; (at_defs', fv_at_defs) <- mapAndUnzipM (wrapLocFstM rn_at) at_defs - ; let fvs = extractHsCtxtTyNames context' `plusFV` - hsSigsFVs sigs' `plusFV` - plusFVs fv_ats `plusFV` - plusFVs fv_at_defs -- The fundeps have no free variables + ; let tv_ns = hsLTyVarNames tyvars' + ; (ats', fv_ats) <- rnATDecls cls' tv_ns ats + ; (at_defs', fv_at_defs) <- rnATDecls cls' tv_ns at_defs + ; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs + ; let fvs = cxt_fvs `plusFV` + sig_fvs `plusFV` + fv_ats `plusFV` + fv_at_defs ; return ((tyvars', context', fds', ats', at_defs', sigs'), fvs) } -- No need to check for duplicate associated type decls @@ -924,64 +929,11 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls, tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', tcdDocs = docs'}, - extractHsTyVarBndrNames_s tyvars' (meth_fvs `plusFV` stuff_fvs)) } + meth_fvs `plusFV` stuff_fvs) } where cls_doc = ClassDeclCtx lcls -bindQTvs :: HsDocContext -> Maybe Name -> [LHsTyVarBndr RdrName] - -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -bindQTvs doc mb_cls tyvars thing_inside - | isNothing mb_cls -- Not associated - = bindTyVarsFV doc tyvars thing_inside - | otherwise -- Associated - = do { let tv_rdr_names = map hsLTyVarLocName tyvars - -- *All* the free vars of the family patterns - - -- Check for duplicated bindings - -- This test is irrelevant for data/type *instances*, where the tyvars - -- are the free tyvars of the patterns, and hence have no duplicates - -- But it's needed for data/type *family* decls - ; mapM_ dupBoundTyVar (findDupRdrNames tv_rdr_names) - - ; rdr_env <- getLocalRdrEnv - - ; tv_ns <- mapM (mk_tv_name rdr_env) tv_rdr_names - ; tyvars' <- zipWithM (\old new -> replaceLTyVarName old new (rnLHsKind doc)) tyvars tv_ns - ; (thing, fvs) <- bindLocalNamesFV tv_ns $ thing_inside tyvars' - - -- Check that the RHS of the decl mentions only type variables - -- bound on the LHS. For example, this is not ok - -- class C a b where - -- type F a x :: * - -- instance C (p,q) r where - -- type F (p,q) x = (x, r) -- BAD: mentions 'r' - -- c.f. Trac #5515 - ; let bad_tvs = filterNameSet (isTvOcc . nameOccName) fvs - ; unless (isEmptyNameSet bad_tvs) (badAssocRhs (nameSetToList bad_tvs)) - - ; return (thing, fvs) } - where - mk_tv_name :: LocalRdrEnv -> Located RdrName -> RnM Name - mk_tv_name rdr_env (L l tv_rdr) - = case lookupLocalRdrEnv rdr_env tv_rdr of - Just n -> return n - Nothing -> newLocalBndrRn (L l tv_rdr) - -badAssocRhs :: [Name] -> RnM () -badAssocRhs ns - = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable") - <> plural ns - <+> pprWithCommas (quotes . ppr) ns) - 2 (ptext (sLit "All such variables must be bound on the LHS"))) - -dupBoundTyVar :: [Located RdrName] -> RnM () -dupBoundTyVar (L loc tv : _) - = setSrcSpan loc $ - addErr (ptext (sLit "Illegal repeated type variable") <+> quotes (ppr tv)) -dupBoundTyVar [] = panic "dupBoundTyVar" - badGadtStupidTheta :: Located RdrName -> SDoc badGadtStupidTheta _ = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"), @@ -1049,24 +1001,22 @@ is jolly confusing. See Trac #4875 %********************************************************* \begin{code} -rnTyPats :: HsDocContext -> Located Name -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name], FreeVars) +rnTyPats :: HsDocContext -> Located Name -> Maybe [LHsType RdrName] + -> RnM (Maybe [LHsType Name], FreeVars) -- Although, we are processing type patterns here, all type variables will -- already be in scope (they are the same as in the 'tcdTyVars' field of the -- type declaration to which these patterns belong) rnTyPats _ _ Nothing = return (Nothing, emptyFVs) rnTyPats doc tc (Just typats) - = do { typats' <- rnLHsTypes doc typats - ; let fvs = addOneFV (extractHsTyNames_s typats') (unLoc tc) + = do { (typats', fvs) <- rnLHsTypes doc typats + ; return (Just typats', addOneFV fvs (unLoc tc)) } -- type instance => use, hence addOneFV - ; return (Just typats', fvs) } rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars) -rnConDecls condecls - = do { condecls' <- mapM (wrapLocM rnConDecl) condecls - ; return (condecls', plusFVs (map conDeclFVs condecls')) } +rnConDecls = mapFvRn (wrapLocFstM rnConDecl) -rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name) +rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars) rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs , con_cxt = cxt, con_details = details , con_res = res_ty, con_doc = mb_doc @@ -1094,24 +1044,25 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs ; mb_doc' <- rnMbLHsDoc mb_doc - ; bindTyVarsRn doc new_tvs $ \new_tyvars -> do - { new_context <- rnContext doc cxt - ; new_details <- rnConDeclDetails doc details - ; (new_details', new_res_ty) <- rnConResult doc (unLoc new_name) new_details res_ty + ; bindHsTyVars doc new_tvs $ \new_tyvars -> do + { (new_context, fvs1) <- rnContext doc cxt + ; (new_details, fvs2) <- rnConDeclDetails doc details + ; (new_details', new_res_ty, fvs3) <- rnConResult doc (unLoc new_name) new_details res_ty ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context - , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }} + , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }, + fvs1 `plusFV` fvs2 `plusFV` fvs3) }} where doc = ConDeclCtx name get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy HsBoxedTuple tys)) rnConResult :: HsDocContext -> Name -> HsConDetails (LHsType Name) [ConDeclField Name] - -> ResType RdrName + -> ResType (LHsType RdrName) -> RnM (HsConDetails (LHsType Name) [ConDeclField Name], - ResType Name) -rnConResult _ _ details ResTyH98 = return (details, ResTyH98) + ResType (LHsType Name), FreeVars) +rnConResult _ _ details ResTyH98 = return (details, ResTyH98, emptyFVs) rnConResult doc con details (ResTyGADT ty) - = do { ty' <- rnLHsType doc ty + = do { (ty', fvs) <- rnLHsType doc ty ; let (arg_tys, res_ty) = splitHsFunType ty' -- We can finally split it up, -- now the renamer has dealt with fixities @@ -1123,7 +1074,7 @@ rnConResult doc con details (ResTyGADT ty) RecCon {} -> do { unless (null arg_tys) (addErr (badRecResTy (docOfHsDocContext doc))) - ; return (details, ResTyGADT res_ty) } + ; return (details, ResTyGADT res_ty, fvs) } PrefixCon {} | isSymOcc (getOccName con) -- See Note [Infix GADT cons] , [ty1,ty2] <- arg_tys @@ -1131,27 +1082,27 @@ rnConResult doc con details (ResTyGADT ty) ; return (if con `elemNameEnv` fix_env then InfixCon ty1 ty2 else PrefixCon arg_tys - , ResTyGADT res_ty) } + , ResTyGADT res_ty, fvs) } | otherwise - -> return (PrefixCon arg_tys, ResTyGADT res_ty) } + -> return (PrefixCon arg_tys, ResTyGADT res_ty, fvs) } rnConDeclDetails :: HsDocContext -> HsConDetails (LHsType RdrName) [ConDeclField RdrName] - -> RnM (HsConDetails (LHsType Name) [ConDeclField Name]) + -> RnM (HsConDetails (LHsType Name) [ConDeclField Name], FreeVars) rnConDeclDetails doc (PrefixCon tys) - = do { new_tys <- mapM (rnLHsType doc) tys - ; return (PrefixCon new_tys) } + = do { (new_tys, fvs) <- rnLHsTypes doc tys + ; return (PrefixCon new_tys, fvs) } rnConDeclDetails doc (InfixCon ty1 ty2) - = do { new_ty1 <- rnLHsType doc ty1 - ; new_ty2 <- rnLHsType doc ty2 - ; return (InfixCon new_ty1 new_ty2) } + = do { (new_ty1, fvs1) <- rnLHsType doc ty1 + ; (new_ty2, fvs2) <- rnLHsType doc ty2 + ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } rnConDeclDetails doc (RecCon fields) - = do { new_fields <- rnConDeclFields doc fields + = do { (new_fields, fvs) <- rnConDeclFields doc fields -- No need to check for duplicate fields -- since that is done by RnNames.extendGlobalRdrEnvRn - ; return (RecCon new_fields) } + ; return (RecCon new_fields, fvs) } ------------------------------------------------- deprecRecSyntax :: ConDecl RdrName -> SDoc diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 3b86d0b38c..15e5501fe0 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -15,7 +15,7 @@ module RnTypes ( -- Type related stuff rnHsType, rnLHsType, rnLHsTypes, rnContext, rnHsKind, rnLHsKind, rnLHsMaybeKind, - rnHsSigType, rnLHsInstType, rnHsTypeFVs, rnConDeclFields, + rnHsSigType, rnLHsInstType, rnConDeclFields, rnIPName, -- Precence related stuff @@ -26,7 +26,7 @@ module RnTypes ( rnSplice, checkTH, -- Binding related stuff - bindTyVarsRn, bindTyVarsFV + bindSigTyVarsFV, bindHsTyVars, bindTyClTyVars, rnHsBndrSig ) where import {-# SOURCE #-} RnExpr( rnLExpr ) @@ -36,8 +36,7 @@ import {-# SOURCE #-} TcSplice( runQuasiQuoteType ) import DynFlags import HsSyn -import RdrHsSyn ( extractHsRhoRdrTyVars ) -import RnHsSyn ( extractHsTyNames, extractHsTyVarBndrNames_s ) +import RdrHsSyn ( extractHsRhoRdrTyVars, extractHsTyRdrTyVars ) import RnHsDoc ( rnLHsDoc, rnMbLHsDoc ) import RnEnv import TcRnMonad @@ -54,7 +53,7 @@ import BasicTypes ( IPName(..), ipNameName, compareFixity, funTyFixity, negateFi Fixity(..), FixityDirection(..) ) import Outputable import FastString -import Control.Monad ( unless, zipWithM ) +import Control.Monad ( unless ) #include "HsVersions.h" \end{code} @@ -69,23 +68,17 @@ to break several loop. %********************************************************* \begin{code} -rnHsTypeFVs :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) -rnHsTypeFVs doc_str ty = do - ty' <- rnLHsType doc_str ty - return (ty', extractHsTyNames ty') - -rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name) +rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars) -- rnHsSigType is used for source-language type signatures, -- which use *implicit* universal quantification. -rnHsSigType doc_str ty - = rnLHsType (TypeSigCtx doc_str) ty +rnHsSigType doc_str ty = rnLHsType (TypeSigCtx doc_str) ty -rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name) +rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars) -- Rename the type in an instance or standalone deriving decl rnLHsInstType doc_str ty - = do { ty' <- rnLHsType (TypeSigCtx doc_str) ty + = do { (ty', fvs) <- rnLHsType (TypeSigCtx doc_str) ty ; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty)) - ; return ty' } + ; return (ty', fvs) } where good_inst_ty | Just (_, _, L _ cls, _) <- splitLHsInstDeclTy_maybe ty @@ -101,27 +94,34 @@ want a gratuitous knot. \begin{code} rnLHsTyKi :: Bool -- True <=> renaming a type, False <=> a kind - -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name) -rnLHsTyKi isType doc = wrapLocM (rnHsTyKi isType doc) + -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) +rnLHsTyKi isType doc (L loc ty) + = setSrcSpan loc $ + do { (ty', fvs) <- rnHsTyKi isType doc ty + ; return (L loc ty', fvs) } -rnLHsType :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name) +rnLHsType :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) rnLHsType = rnLHsTyKi True -rnLHsKind :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name) + +rnLHsKind :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars) rnLHsKind = rnLHsTyKi False -rnLHsMaybeKind :: HsDocContext -> Maybe (LHsKind RdrName) -> RnM (Maybe (LHsKind Name)) -rnLHsMaybeKind _ Nothing = return Nothing -rnLHsMaybeKind doc (Just k) = do - k' <- rnLHsKind doc k - return (Just k') -rnHsType :: HsDocContext -> HsType RdrName -> RnM (HsType Name) +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) } + +rnHsType :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) rnHsType = rnHsTyKi True -rnHsKind :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name) +rnHsKind :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars) rnHsKind = rnHsTyKi False -rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name) +rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) -rnHsTyKi isType doc (HsForAllTy Implicit _ ctxt ty) = ASSERT ( isType ) do +rnHsTyKi isType doc (HsForAllTy Implicit _ ctxt ty) + = ASSERT ( isType ) do -- Implicit quantifiction in source code (no kinds on tyvars) -- Given the signature C => T we universally quantify -- over FV(T) \ {in-scope-tyvars} @@ -146,14 +146,11 @@ rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars ctxt tau) in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty) ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned - ; -- rnForAll does the rest - rnForAll doc Explicit forall_tyvars ctxt tau } + ; rnForAll doc Explicit forall_tyvars ctxt tau } -rnHsTyKi isType _ (HsTyVar rdr_name) = do - -- We use lookupOccRn in kinds because all the names are in - -- TcClsName, and we don't want to look in DataName. - name <- (if isType then lookupPromotedOccRn else lookupOccRn) rdr_name - return (HsTyVar name) +rnHsTyKi isType _ (HsTyVar rdr_name) + = do { name <- rnTyVar isType rdr_name + ; return (HsTyVar name, unitFV name) } -- If we see (forall a . ty), without foralls on, the forall will give -- a sensible error message, but we don't want to complain about the dot too @@ -162,118 +159,144 @@ rnHsTyKi isType doc ty@(HsOpTy ty1 (wrapper, L loc op) ty2) = ASSERT ( isType ) setSrcSpan loc $ do { ops_ok <- xoptM Opt_TypeOperators ; op' <- if ops_ok - then lookupPromotedOccRn op + then rnTyVar isType op else do { addErr (opTyErr op ty) ; return (mkUnboundName op) } -- Avoid double complaint ; let l_op' = L loc op' ; fix <- lookupTyFixityRn l_op' - ; ty1' <- rnLHsType doc ty1 - ; ty2' <- rnLHsType doc ty2 - ; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2) op' fix ty1' ty2' } + ; (ty1', fvs1) <- rnLHsType doc ty1 + ; (ty2', fvs2) <- rnLHsType doc ty2 + ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2) + op' fix ty1' ty2' + ; return (res_ty, (fvs1 `plusFV` fvs2) `addOneFV` op') } -rnHsTyKi isType doc (HsParTy ty) = do - ty' <- rnLHsTyKi isType doc ty - return (HsParTy ty') +rnHsTyKi isType doc (HsParTy ty) + = do { (ty', fvs) <- rnLHsTyKi isType doc ty + ; return (HsParTy ty', fvs) } rnHsTyKi isType doc (HsBangTy b ty) - = ASSERT ( isType ) do { ty' <- rnLHsType doc ty - ; return (HsBangTy b ty') } + = ASSERT ( isType ) + do { (ty', fvs) <- rnLHsType doc ty + ; return (HsBangTy b ty', fvs) } rnHsTyKi isType doc (HsRecTy flds) - = ASSERT ( isType ) do { flds' <- rnConDeclFields doc flds - ; return (HsRecTy flds') } + = ASSERT ( isType ) + do { (flds', fvs) <- rnConDeclFields doc flds + ; return (HsRecTy flds', fvs) } -rnHsTyKi isType doc (HsFunTy ty1 ty2) = do - ty1' <- rnLHsTyKi isType doc ty1 +rnHsTyKi isType doc (HsFunTy ty1 ty2) + = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1 -- Might find a for-all as the arg of a function type - ty2' <- rnLHsTyKi isType doc ty2 + ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2 -- Or as the result. This happens when reading Prelude.hi -- when we find return :: forall m. Monad m -> forall a. a -> m a -- Check for fixity rearrangements - if isType - then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2' - else return (HsFunTy ty1' ty2') + ; res_ty <- if isType + then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2' + else return (HsFunTy ty1' ty2') + ; return (res_ty, fvs1 `plusFV` fvs2) } -rnHsTyKi isType doc listTy@(HsListTy ty) = do - data_kinds <- xoptM Opt_DataKinds - unless (data_kinds || isType) (addErr (dataKindsErr listTy)) - ty' <- rnLHsTyKi isType doc ty - return (HsListTy ty') +rnHsTyKi isType doc listTy@(HsListTy ty) + = do { data_kinds <- xoptM Opt_DataKinds + ; unless (data_kinds || isType) (addErr (dataKindsErr listTy)) + ; (ty', fvs) <- rnLHsTyKi isType doc ty + ; return (HsListTy ty', fvs) } rnHsTyKi isType doc (HsKindSig ty k) - = ASSERT ( isType ) do { - ; kind_sigs_ok <- xoptM Opt_KindSignatures - ; unless kind_sigs_ok (addErr (kindSigErr ty)) - ; ty' <- rnLHsType doc ty - ; k' <- rnLHsKind doc k - ; return (HsKindSig ty' k') } + = ASSERT ( isType ) + do { kind_sigs_ok <- xoptM Opt_KindSignatures + ; unless kind_sigs_ok (badSigErr False doc ty) + ; (ty', fvs1) <- rnLHsType doc ty + ; (k', fvs2) <- rnLHsKind doc k + ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) } -rnHsTyKi isType doc (HsPArrTy ty) = ASSERT ( isType ) do - ty' <- rnLHsType doc ty - return (HsPArrTy ty') +rnHsTyKi isType doc (HsPArrTy ty) + = ASSERT ( isType ) + do { (ty', fvs) <- rnLHsType doc ty + ; return (HsPArrTy ty', fvs) } -- Unboxed tuples are allowed to have poly-typed arguments. These -- sometimes crop up as a result of CPR worker-wrappering dictionaries. -rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) = do - data_kinds <- xoptM Opt_DataKinds - unless (data_kinds || isType) (addErr (dataKindsErr tupleTy)) - tys' <- mapM (rnLHsTyKi isType doc) tys - return (HsTupleTy tup_con tys') - -rnHsTyKi isType doc (HsAppTy ty1 ty2) = do - ty1' <- rnLHsTyKi isType doc ty1 - ty2' <- rnLHsTyKi isType doc ty2 - return (HsAppTy ty1' ty2') - -rnHsTyKi isType doc (HsIParamTy n ty) = ASSERT( isType ) do - ty' <- rnLHsType doc ty - n' <- rnIPName n - return (HsIParamTy n' ty') - -rnHsTyKi isType doc (HsEqTy ty1 ty2) = ASSERT( isType ) do - ty1' <- rnLHsType doc ty1 - ty2' <- rnLHsType doc ty2 - return (HsEqTy ty1' ty2') +rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) + = do { data_kinds <- xoptM Opt_DataKinds + ; unless (data_kinds || isType) (addErr (dataKindsErr tupleTy)) + ; (tys', fvs) <- mapFvRn (rnLHsTyKi isType doc) tys + ; return (HsTupleTy tup_con tys', fvs) } + +rnHsTyKi isType doc (HsAppTy ty1 ty2) + = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1 + ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2 + ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) } + +rnHsTyKi isType doc (HsIParamTy n ty) + = ASSERT( isType ) + do { (ty', fvs) <- rnLHsType doc ty + ; n' <- rnIPName n + ; return (HsIParamTy n' ty', fvs) } + +rnHsTyKi isType doc (HsEqTy ty1 ty2) + = ASSERT( isType ) + do { (ty1', fvs1) <- rnLHsType doc ty1 + ; (ty2', fvs2) <- rnLHsType doc ty2 + ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) } rnHsTyKi isType _ (HsSpliceTy sp _ k) - = ASSERT ( isType ) do { (sp', fvs) <- rnSplice sp -- ToDo: deal with fvs - ; return (HsSpliceTy sp' fvs k) } + = ASSERT ( isType ) + do { (sp', fvs) <- rnSplice sp -- ToDo: deal with fvs + ; return (HsSpliceTy sp' fvs k, fvs) } -rnHsTyKi isType doc (HsDocTy ty haddock_doc) = ASSERT ( isType ) do - ty' <- rnLHsType doc ty - haddock_doc' <- rnLHsDoc haddock_doc - return (HsDocTy ty' haddock_doc') +rnHsTyKi isType doc (HsDocTy ty haddock_doc) + = ASSERT ( isType ) + do { (ty', fvs) <- rnLHsType doc ty + ; haddock_doc' <- rnLHsDoc haddock_doc + ; return (HsDocTy ty' haddock_doc', fvs) } #ifndef GHCI rnHsTyKi _ _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty) #else -rnHsTyKi isType doc (HsQuasiQuoteTy qq) = ASSERT ( isType ) do { ty <- runQuasiQuoteType qq - ; rnHsType doc (unLoc ty) } +rnHsTyKi isType doc (HsQuasiQuoteTy qq) + = ASSERT ( isType ) + do { ty <- runQuasiQuoteType qq + ; rnHsType doc (unLoc ty) } #endif -rnHsTyKi isType _ (HsCoreTy ty) = ASSERT ( isType ) return (HsCoreTy ty) -rnHsTyKi _ _ (HsWrapTy {}) = panic "rnHsTyKi" -rnHsTyKi isType doc (HsExplicitListTy k tys) = - ASSERT( isType ) - do tys' <- mapM (rnLHsType doc) tys - return (HsExplicitListTy k tys') +rnHsTyKi isType _ (HsCoreTy ty) + = ASSERT ( isType ) + return (HsCoreTy ty, emptyFVs) + -- The emptyFVs probably isn't quite right + -- but I don't think it matters + +rnHsTyKi _ _ (HsWrapTy {}) + = panic "rnHsTyKi" + +rnHsTyKi isType doc (HsExplicitListTy k tys) + = ASSERT( isType ) + do { (tys', fvs) <- rnLHsTypes doc tys + ; return (HsExplicitListTy k tys', fvs) } + +rnHsTyKi isType doc (HsExplicitTupleTy kis tys) + = ASSERT( isType ) + do { (tys', fvs) <- rnLHsTypes doc tys + ; return (HsExplicitTupleTy kis tys', fvs) } -rnHsTyKi isType doc (HsExplicitTupleTy kis tys) = - ASSERT( isType ) - do tys' <- mapM (rnLHsType doc) tys - return (HsExplicitTupleTy kis tys') +-------------- +rnTyVar :: Bool -> RdrName -> RnM Name +rnTyVar is_type rdr_name + | is_type = lookupTypeOccRn rdr_name + | otherwise = lookupKindOccRn rdr_name -------------- rnLHsTypes :: HsDocContext -> [LHsType RdrName] - -> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name] -rnLHsTypes doc tys = mapM (rnLHsType doc) tys + -> RnM ([LHsType Name], FreeVars) +rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys \end{code} \begin{code} rnForAll :: HsDocContext -> HsExplicitFlag -> [LHsTyVarBndr RdrName] - -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name) + -> LHsContext RdrName -> LHsType RdrName + -> RnM (HsType Name, FreeVars) rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty -- One reason for this case is that a type like Int# @@ -285,48 +308,190 @@ rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty -- of kind *. rnForAll doc exp forall_tyvars ctxt ty - = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> do - new_ctxt <- rnContext doc ctxt - new_ty <- rnLHsType doc ty - return (HsForAllTy exp new_tyvars new_ctxt new_ty) + = bindHsTyVars doc 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) } -- Retain the same implicit/explicit flag as before -- so that we can later print it correctly -bindTyVarsFV :: HsDocContext -> [LHsTyVarBndr RdrName] +--------------- +bindSigTyVarsFV :: [Name] + -> RnM (a, FreeVars) + -> RnM (a, FreeVars) +-- Used just before renaming the defn of a function +-- with a separate type signature, to bring its tyvars into scope +-- With no -XScopedTypeVariables, this is a no-op +bindSigTyVarsFV tvs thing_inside + = do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables + ; if not scoped_tyvars then + thing_inside + else + bindLocalNamesFV tvs thing_inside } + +--------------- +bindTyClTyVars + :: HsDocContext + -> Maybe (Name, [Name]) -- Parent class and its tyvars + -- (but not kind vars) + -> [LHsTyVarBndr RdrName] + -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +-- Used for tyvar binders in type/class declarations +-- Just like bindHsTyVars, but deals with the case of associated +-- types, where the type variables may be already in scope +bindTyClTyVars doc mb_cls tyvars thing_inside + | Just (_, cls_tvs) <- mb_cls -- Associated type family or type instance + = do { let tv_rdr_names = map hsLTyVarLocName tyvars + -- *All* the free vars of the family patterns + + -- Check for duplicated bindings + -- This test is irrelevant for data/type *instances*, where the tyvars + -- are the free tyvars of the patterns, and hence have no duplicates + -- But it's needed for data/type *family* decls + ; checkDupRdrNames tv_rdr_names + + -- Make the Names for the tyvars + ; 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) + ; tv_ns <- mapM mk_tv_name tv_rdr_names + + ; (thing, fvs) <- bindTyVarsRn doc tyvars tv_ns thing_inside + + -- See Note [Renaming associated types] + ; let bad_tvs = fvs `intersectNameSet` mkNameSet cls_tvs + ; unless (isEmptyNameSet bad_tvs) (badAssocRhs (nameSetToList bad_tvs)) + + ; return (thing, fvs) } + + | otherwise -- Not associated, just fall through to bindHsTyVars + = bindHsTyVars doc tyvars thing_inside + +badAssocRhs :: [Name] -> RnM () +badAssocRhs ns + = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable") + <> plural ns + <+> pprWithCommas (quotes . ppr) ns) + 2 (ptext (sLit "All such variables must be bound on the LHS"))) + +--------------- +bindHsTyVars :: HsDocContext -> [LHsTyVarBndr RdrName] -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -bindTyVarsFV doc tyvars thing_inside - = bindTyVarsRn doc tyvars $ \ tyvars' -> - do { (res, fvs) <- thing_inside tyvars' - ; return (res, extractHsTyVarBndrNames_s tyvars' fvs) } - -bindTyVarsRn :: HsDocContext -> [LHsTyVarBndr RdrName] - -> ([LHsTyVarBndr Name] -> RnM a) - -> RnM a --- Haskell-98 binding of type variables; e.g. within a data type decl -bindTyVarsRn doc tyvar_names enclosed_scope - = bindLocatedLocalsRn located_tyvars $ \ names -> - do { kind_sigs_ok <- xoptM Opt_KindSignatures - ; unless (null kinded_tyvars || kind_sigs_ok) - (mapM_ (addErr . kindSigErr) kinded_tyvars) - ; tyvar_names' <- zipWithM replace tyvar_names names - ; enclosed_scope tyvar_names' } +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 - replace (L loc n1) n2 = replaceTyVarName n1 n2 (rnLHsKind doc) >>= return . L loc - located_tyvars = hsLTyVarLocNames tyvar_names - kinded_tyvars = [n | L _ (KindedTyVar n _ _) <- tyvar_names] + rdr_names_w_loc = hsLTyVarLocNames tv_bndrs -rnConDeclFields :: HsDocContext -> [ConDeclField RdrName] -> RnM [ConDeclField Name] -rnConDeclFields doc fields = mapM (rnField doc) fields - -rnField :: HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name) -rnField doc (ConDeclField name ty haddock_doc) - = do { new_name <- lookupLocatedTopBndrRn name - ; new_ty <- rnLHsType doc ty - ; new_haddock_doc <- rnMbLHsDoc haddock_doc - ; return (ConDeclField new_name new_ty new_haddock_doc) } +--------------- +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 _ tck) : tvs) (n : ns) thing_inside + = go tvs ns $ \ tvs' -> + thing_inside (L loc (UserTyVar n tck) : tvs') + + go (L loc (KindedTyVar _ bsig tck) : tvs) (n : ns) thing_inside + = rnHsBndrSig False doc bsig $ \ bsig' -> + go tvs ns $ \ tvs' -> + thing_inside (L loc (KindedTyVar n bsig' tck) : tvs') + + -- Lists of unequal length + go tvs names _ = pprPanic "bindTyVarsRn" (ppr tvs $$ ppr names) + +-------------------------------- +rnHsBndrSig :: Bool -- True <=> type sig, False <=> kind sig + -> HsDocContext + -> HsBndrSig (LHsType RdrName) + -> (HsBndrSig (LHsType Name) -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnHsBndrSig is_type doc (HsBSig ty _) thing_inside + = do { name_env <- getLocalRdrEnv + ; let tv_bndrs = [ tv | tv <- extractHsTyRdrTyVars ty + , not (unLoc tv `elemLocalRdrEnv` name_env) ] + + ; checkHsBndrFlags is_type doc ty tv_bndrs + ; bindLocatedLocalsFV tv_bndrs $ \ tv_names -> do + { (ty', fvs1) <- rnLHsTyKi is_type doc ty + ; (res, fvs2) <- thing_inside (HsBSig ty' tv_names) + ; return (res, fvs1 `plusFV` fvs2) } } + +checkHsBndrFlags :: Bool -> HsDocContext + -> LHsType RdrName -> [Located 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 -> [Located RdrName] -> SDoc +badKindBndrs doc _kind kvs + = vcat [ hang (ptext (sLit "Kind signature mentions kind variable") <> plural kvs + <+> pprQuotedList kvs) + 2 (ptext (sLit "Perhaps you intended to use -XPolyKinds")) + , docOfHsDocContext doc ] + +badSigErr :: Bool -> HsDocContext -> LHsType RdrName -> TcM () +badSigErr is_type doc (L loc ty) + = setSrcSpan loc $ addErr $ + vcat [ hang (ptext (sLit "Illegal") <+> what + <+> ptext (sLit "signature:") <+> quotes (ppr ty)) + 2 (ptext (sLit "Perhaps you intended to use") <+> flag) + , docOfHsDocContext doc ] + where + what | is_type = ptext (sLit "type") + | otherwise = ptext (sLit "kind") + flag | is_type = ptext (sLit "-XScopedTypeVariable") + | otherwise = ptext (sLit "-XKindSignatures") \end{code} +Note [Renaming associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Check that the RHS of the decl mentions only type variables +bound on the LHS. For example, this is not ok + class C a b where + type F a x :: * + instance C (p,q) r where + type F (p,q) x = (x, r) -- BAD: mentions 'r' +c.f. Trac #5515 + +What makes it tricky is that the *kind* variable from the class *are* +in scope (Trac #5862): + class Category (x :: k -> k -> *) where + type Ob x :: k -> Constraint + id :: Ob x a => x a a + (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c +Here 'k' is in scope in the kind signature even though it's not +explicitly mentioned on the LHS of the type Ob declaration. + +We could force you to mention k explicitly, thus + class Category (x :: k -> k -> *) where + type Ob (x :: k -> k -> *) :: k -> Constraint +but it seems tiresome to do so. + + %********************************************************* %* * \subsection{Contexts and predicates} @@ -334,11 +499,21 @@ rnField doc (ConDeclField name ty haddock_doc) %********************************************************* \begin{code} -rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name) -rnContext doc = wrapLocM (rnContext' doc) +rnConDeclFields :: HsDocContext -> [ConDeclField RdrName] + -> RnM ([ConDeclField Name], FreeVars) +rnConDeclFields doc fields = mapFvRn (rnField doc) fields + +rnField :: HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name, FreeVars) +rnField doc (ConDeclField name ty haddock_doc) + = do { new_name <- lookupLocatedTopBndrRn name + ; (new_ty, fvs) <- rnLHsType doc ty + ; new_haddock_doc <- rnMbLHsDoc haddock_doc + ; return (ConDeclField new_name new_ty new_haddock_doc, fvs) } -rnContext' :: HsDocContext -> HsContext RdrName -> RnM (HsContext Name) -rnContext' doc ctxt = mapM (rnLHsType doc) ctxt +rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars) +rnContext doc (L loc cxt) + = do { (cxt', fvs) <- rnLHsTypes doc cxt + ; return (L loc cxt', fvs) } rnIPName :: IPName RdrName -> RnM (IPName Name) rnIPName n = newIPName (occNameFS (rdrNameOcc (ipNameName n))) diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs index ea1fab7eea..9ccdfc32ed 100644 --- a/compiler/stgSyn/StgLint.lhs +++ b/compiler/stgSyn/StgLint.lhs @@ -121,10 +121,10 @@ lint_binds_help (binder, rhs) (mkUnLiftedTyMsg binder rhs) -- Check match to RHS type - -- Actually we *can't* check the RHS type, because - -- unsafeCoerce means it really might not match at all - -- notably; eg x::Int = (error @Bool "urk") |> unsafeCoerce... - -- case maybe_rhs_ty of + -- Actually we *can't* check the RHS type, because + -- unsafeCoerce means it really might not match at all + -- notably; eg x::Int = (error @Bool "urk") |> unsafeCoerce... + -- case maybe_rhs_ty of -- Nothing -> return () -- Just rhs_ty -> checkTys binder_ty -- rhs_ty @@ -237,8 +237,8 @@ lintStgAlts alts scrut_ty = do return (Just first_ty) where -- check ty = checkTys first_ty ty (mkCaseAltMsg alts) - -- We can't check that the alternatives have the - -- same type, becuase they don't, with unsafeCoerce# + -- We can't check that the alternatives have the + -- same type, becuase they don't, with unsafeCoerce# lintAlt :: Type -> (AltCon, [Id], [Bool], StgExpr) -> LintM (Maybe Type) lintAlt _ (DEFAULT, _, _, rhs) @@ -398,8 +398,8 @@ checkFunApp fun_ty arg_tys msg where (mb_ty, mb_msg) = cfa True fun_ty arg_tys - cfa :: Bool -> Type -> [Type] -> (Maybe Type -- Accurate result? - , Maybe MsgDoc) -- Errors? + cfa :: Bool -> Type -> [Type] -> (Maybe Type -- Accurate result? + , Maybe MsgDoc) -- Errors? cfa accurate fun_ty [] -- Args have run out; that's fine = (if accurate then Just fun_ty else Nothing, Nothing) @@ -446,12 +446,12 @@ stgEqType orig_ty1 orig_ty2 | Just (tc1, tc_args1) <- splitTyConApp_maybe ty1 , Just (tc2, tc_args2) <- splitTyConApp_maybe ty2 , let res = if tc1 == tc2 - then equalLength tc_args1 tc_args2 - && and (zipWith go tc_args1 tc_args2) - else -- TyCons don't match; but don't bleat if either is a - -- family TyCon because a coercion might have made it - -- equal to something else - (isFamilyTyCon tc1 || isFamilyTyCon tc2) + then equalLength tc_args1 tc_args2 + && and (zipWith go tc_args1 tc_args2) + else -- TyCons don't match; but don't bleat if either is a + -- family TyCon because a coercion might have made it + -- equal to something else + (isFamilyTyCon tc1 || isFamilyTyCon tc2) = if res then True else pprTrace "stgEqType: unequal" (vcat [ppr orig_ty1, ppr orig_ty2, ppr rep_ty1 @@ -459,7 +459,7 @@ stgEqType orig_ty1 orig_ty2 False | otherwise = True -- Conservatively say "fine". - -- Type variables in particular + -- Type variables in particular checkInScope :: Id -> LintM () checkInScope id = LintM $ \loc scope errs diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index c873c631da..1e24a530aa 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -27,8 +27,8 @@ import Module import SrcLoc import Outputable import UniqFM +import VarSet import FastString -import VarSet ( varSetElems ) import Util( filterOut ) import Maybes import Control.Monad @@ -174,11 +174,12 @@ tcLookupFamInst tycon tys = return Nothing | otherwise = do { instEnv <- tcGetFamInstEnvs - ; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ ppr instEnv) - ; case lookupFamInstEnv instEnv tycon tys of - [] -> return Nothing + ; let mb_match = lookupFamInstEnv instEnv tycon tys + ; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ pprTvBndrs (varSetElems (tyVarsOfTypes tys)) $$ ppr mb_match $$ ppr instEnv) + ; case mb_match of + [] -> return Nothing ((fam_inst, rep_tys):_) - -> return $ Just (fam_inst, rep_tys) + -> return $ Just (fam_inst, rep_tys) } tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type]) @@ -263,18 +264,15 @@ addLocalFamInst (home_fie, my_fis) fam_inst -- Load imported instances, so that we report -- overlaps correctly ; eps <- getEps - ; skol_tvs <- tcInstSkolTyVars (varSetElems (famInstTyVars fam_inst)) ; let inst_envs = (eps_fam_inst_env eps, home_fie') - conflicts = lookupFamInstEnvConflicts inst_envs fam_inst skol_tvs home_fie'' = extendFamInstEnv home_fie fam_inst -- Check for conflicting instance decls - ; traceTc "checkForConflicts" (ppr conflicts $$ ppr fam_inst $$ ppr inst_envs) - ; case conflicts of - [] -> return (home_fie'', fam_inst : my_fis') - dup : _ -> do { conflictInstErr fam_inst (fst dup) - ; return (home_fie, my_fis) } - } + ; no_conflict <- checkForConflicts inst_envs fam_inst + ; if no_conflict then + return (home_fie'', fam_inst : my_fis') + else + return (home_fie, my_fis) } \end{code} %************************************************************************ @@ -287,8 +285,8 @@ Check whether a single family instance conflicts with those in two instance environments (one for the EPS and one for the HPT). \begin{code} -checkForConflicts :: FamInstEnvs -> FamInst -> TcM () -checkForConflicts inst_envs famInst +checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool +checkForConflicts inst_envs fam_inst = do { -- To instantiate the family instance type, extend the instance -- envt with completely fresh template variables -- This is important because the template variables must @@ -297,11 +295,13 @@ checkForConflicts inst_envs famInst -- We use tcInstSkolType because we don't want to allocate -- fresh *meta* type variables. - ; skol_tvs <- tcInstSkolTyVars (varSetElems (famInstTyVars famInst)) - ; let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs - ; unless (null conflicts) $ - conflictInstErr famInst (fst (head conflicts)) - } + ; (_, skol_tvs) <- tcInstSkolTyVars (coAxiomTyVars (famInstAxiom fam_inst)) + ; let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst skol_tvs + no_conflicts = null conflicts + ; traceTc "checkForConflicts" (ppr conflicts $$ ppr fam_inst $$ ppr inst_envs) + ; unless no_conflicts $ + conflictInstErr fam_inst (fst (head conflicts)) + ; return no_conflicts } conflictInstErr :: FamInst -> FamInst -> TcRn () conflictInstErr famInst conflictingFamInst diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index a194d748ed..0833a7c7cf 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -152,8 +152,7 @@ deeplySkolemise deeplySkolemise ty | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty = do { ids1 <- newSysLocalIds (fsLit "dk") arg_tys - ; tvs1 <- tcInstSkolTyVars tvs - ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs1) + ; (subst, tvs1) <- tcInstSkolTyVars tvs ; ev_vars1 <- newEvVars (substTheta subst theta) ; (wrap, tvs2, ev_vars2, rho) <- deeplySkolemise (substTy subst ty') ; return ( mkWpLams ids1 @@ -219,7 +218,7 @@ instCallConstraints _ [] = return idHsWrapper instCallConstraints origin (pred : preds) | Just (ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut - = do { traceTc "instCallConstraints" $ ppr (mkEqPred (ty1, ty2)) + = do { traceTc "instCallConstraints" $ ppr (mkEqPred ty1 ty2) ; co <- unifyType ty1 ty2 ; co_fn <- instCallConstraints origin preds ; return (co_fn <.> WpEvApp (EvCoercion co)) } diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index 2934cda94b..e15b2adc6e 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -138,7 +138,7 @@ tc_cmd env (HsIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r -- because we're going to apply it to the environment, not -- the return value. - ; [r_tv] <- tcInstSkolTyVars [alphaTyVar] + ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar] ; let r_ty = mkTyVarTy r_tv ; let if_ty = mkFunTys [pred_ty, r_ty, r_ty] r_ty ; checkTc (not (r_tv `elemVarSet` tyVarsOfType pred_ty)) @@ -245,7 +245,7 @@ tc_cmd env cmd@(HsDo do_or_lc stmts _) (cmd_stk, res_ty) tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..] - ; [w_tv] <- tcInstSkolTyVars [alphaTyVar] + ; (_, [w_tv]) <- tcInstSkolTyVars [alphaTyVar] ; let w_ty = mkTyVarTy w_tv -- Just a convenient starting point -- a ((w,t1) .. tn) t diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 66c3b716af..1cc97de8d3 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -6,9 +6,10 @@ \begin{code} module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds, - tcHsBootSigs, tcPolyBinds, + tcHsBootSigs, tcPolyBinds, tcPolyCheck, PragFun, tcSpecPrags, tcVectDecls, mkPragFun, - TcSigInfo(..), SigFun, mkSigFun, + TcSigInfo(..), TcSigFun, + instTcTySig, instTcTySigFromId, badBootDeclErr ) where import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) @@ -82,6 +83,65 @@ type-checking the LHS of course requires that the binder is in scope. At the top-level the LIE is sure to contain nothing but constant dictionaries, which we resolve at the module level. +Note [Polymorphic recursion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The game plan for polymorphic recursion in the code above is + + * Bind any variable for which we have a type signature + to an Id with a polymorphic type. Then when type-checking + the RHSs we'll make a full polymorphic call. + +This fine, but if you aren't a bit careful you end up with a horrendous +amount of partial application and (worse) a huge space leak. For example: + + f :: Eq a => [a] -> [a] + f xs = ...f... + +If we don't take care, after typechecking we get + + f = /\a -> \d::Eq a -> let f' = f a d + in + \ys:[a] -> ...f'... + +Notice the the stupid construction of (f a d), which is of course +identical to the function we're executing. In this case, the +polymorphic recursion isn't being used (but that's a very common case). +This can lead to a massive space leak, from the following top-level defn +(post-typechecking) + + ff :: [Int] -> [Int] + ff = f Int dEqInt + +Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but +f' is another thunk which evaluates to the same thing... and you end +up with a chain of identical values all hung onto by the CAF ff. + + ff = f Int dEqInt + + = let f' = f Int dEqInt in \ys. ...f'... + + = let f' = let f' = f Int dEqInt in \ys. ...f'... + in \ys. ...f'... + +Etc. + +NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...), +which would make the space leak go away in this case + +Solution: when typechecking the RHSs we always have in hand the +*monomorphic* Ids for each binding. So we just need to make sure that +if (Method f a d) shows up in the constraints emerging from (...f...) +we just use the monomorphic Id. We achieve this by adding monomorphic Ids +to the "givens" when simplifying constraints. That's what the "lies_avail" +is doing. + +Then we get + + f = /\a -> \d::Eq a -> letrec + fm = \ys:[a] -> ...fm... + in + fm + \begin{code} tcTopBinds :: HsValBinds Name -> TcM (TcGblEnv, TcLclEnv) -- The TcGblEnv contains the new tcg_binds and tcg_spects @@ -191,16 +251,9 @@ tcValBinds :: TopLevelFlag tcValBinds top_lvl binds sigs thing_inside = do { -- Typecheck the signature - ; let { prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds) - ; ty_sigs = filter isTypeLSig sigs - ; sig_fn = mkSigFun ty_sigs } + (poly_ids, sig_fn) <- tcTySigs sigs - ; poly_ids <- concat <$> checkNoErrs (mapAndRecoverM tcTySig ty_sigs) - -- No recovery from bad signatures, because the type sigs - -- may bind type variables, so proceeding without them - -- can lead to a cascade of errors - -- ToDo: this means we fall over immediately if any type sig - -- is wrong, which is over-conservative, see Trac bug #745 + ; let prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds) -- Extend the envt right away with all -- the Ids declared with type signatures @@ -211,7 +264,7 @@ tcValBinds top_lvl binds sigs thing_inside ; return (binds', thing) } ------------------------ -tcBindGroups :: TopLevelFlag -> SigFun -> PragFun +tcBindGroups :: TopLevelFlag -> TcSigFun -> PragFun -> [(RecFlag, LHsBinds Name)] -> TcM thing -> TcM ([(RecFlag, LHsBinds TcId)], thing) -- Typecheck a whole lot of value bindings, @@ -232,7 +285,7 @@ tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside ------------------------ tc_group :: forall thing. - TopLevelFlag -> SigFun -> PragFun + TopLevelFlag -> TcSigFun -> PragFun -> (RecFlag, LHsBinds Name) -> TcM thing -> TcM ([(RecFlag, LHsBinds TcId)], thing) @@ -276,7 +329,7 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive ------------------------ -mkEdges :: SigFun -> LHsBinds Name +mkEdges :: TcSigFun -> LHsBinds Name -> [(LHsBind Name, BKey, [BKey])] type BKey = Int -- Just number off the bindings @@ -303,7 +356,7 @@ bindersOfHsBind (AbsBinds {}) = panic "bindersOfHsBind AbsBinds" bindersOfHsBind (VarBind {}) = panic "bindersOfHsBind VarBind" ------------------------ -tcPolyBinds :: TopLevelFlag -> SigFun -> PragFun +tcPolyBinds :: TopLevelFlag -> TcSigFun -> PragFun -> RecFlag -- Whether the group is really recursive -> RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures @@ -328,18 +381,18 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list { traceTc "------------------------------------------------" empty ; traceTc "Bindings for" (ppr binder_names) - -- Instantiate the polytypes of any binders that have signatures - -- (as determined by sig_fn), returning a TcSigInfo for each - ; tc_sig_fn <- tcInstSigs sig_fn binder_names +-- -- Instantiate the polytypes of any binders that have signatures +-- -- (as determined by sig_fn), returning a TcSigInfo for each +-- ; tc_sig_fn <- tcInstSigs sig_fn binder_names ; dflags <- getDynFlags ; type_env <- getLclTypeEnv ; let plan = decideGeneralisationPlan dflags type_env - binder_names bind_list tc_sig_fn + binder_names bind_list sig_fn ; traceTc "Generalisation plan" (ppr plan) ; result@(_, poly_ids, _) <- case plan of - NoGen -> tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list - InferGen mn cl -> tcPolyInfer mn cl tc_sig_fn prag_fn rec_tc bind_list + NoGen -> tcPolyNoGen sig_fn prag_fn rec_tc bind_list + InferGen mn cl -> tcPolyInfer mn cl sig_fn prag_fn rec_tc bind_list CheckGen sig -> tcPolyCheck sig prag_fn rec_tc bind_list -- Check whether strict bindings are ok @@ -390,16 +443,17 @@ tcPolyCheck :: TcSigInfo -> PragFun -- There is just one binding, -- it binds a single variable, -- it has a signature, -tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs, sig_scoped = scoped - , sig_theta = theta, sig_tau = tau }) +tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped + , sig_theta = theta, sig_tau = tau, sig_loc = loc }) prag_fn rec_tc bind_list - = do { loc <- getSrcSpanM - ; ev_vars <- newEvVars theta + = do { ev_vars <- newEvVars theta ; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau) prag_sigs = prag_fn (idName poly_id) + ; tvs <- mapM (skolemiseSigTv . snd) tvs_w_scoped ; (ev_binds, (binds', [mono_info])) - <- checkConstraints skol_info tvs ev_vars $ - tcExtendTyVarEnv2 (scoped `zip` tvs) $ + <- setSrcSpan loc $ + checkConstraints skol_info tvs ev_vars $ + tcExtendTyVarEnv2 [(n,tv) | (Just n, tv) <- tvs_w_scoped] $ tcMonoBinds (\_ -> Just sig) LetLclBndr rec_tc bind_list ; spec_prags <- tcSpecPrags poly_id prag_sigs @@ -747,7 +801,7 @@ scalarTyConMustBeNullary = ptext (sLit "VECTORISE SCALAR type constructor must b -- If typechecking the binds fails, then return with each -- signature-less binder given type (forall a.a), to minimise -- subsequent error messages -recoveryCode :: [Name] -> SigFun -> TcM (LHsBinds TcId, [Id], TopLevelFlag) +recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id], TopLevelFlag) recoveryCode binder_names sig_fn = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names) ; poly_ids <- mapM mk_dummy binder_names @@ -945,161 +999,6 @@ getMonoBindInfo tc_binds \end{code} -%************************************************************************ -%* * - Generalisation -%* * -%************************************************************************ - -unifyCtxts checks that all the signature contexts are the same -The type signatures on a mutually-recursive group of definitions -must all have the same context (or none). - -The trick here is that all the signatures should have the same -context, and we want to share type variables for that context, so that -all the right hand sides agree a common vocabulary for their type -constraints - -We unify them because, with polymorphic recursion, their types -might not otherwise be related. This is a rather subtle issue. - -\begin{code} -{- -unifyCtxts :: [TcSigInfo] -> TcM () --- Post-condition: the returned Insts are full zonked -unifyCtxts [] = return () -unifyCtxts (sig1 : sigs) - = do { traceTc "unifyCtxts" (ppr (sig1 : sigs)) - ; mapM_ unify_ctxt sigs } - where - theta1 = sig_theta sig1 - unify_ctxt :: TcSigInfo -> TcM () - unify_ctxt sig@(TcSigInfo { sig_theta = theta }) - = setSrcSpan (sig_loc sig) $ - addErrCtxt (sigContextsCtxt sig1 sig) $ - do { mk_cos <- unifyTheta theta1 theta - ; -- Check whether all coercions are identity coercions - -- That can happen if we have, say - -- f :: C [a] => ... - -- g :: C (F a) => ... - -- where F is a type function and (F a ~ [a]) - -- Then unification might succeed with a coercion. But it's much - -- much simpler to require that such signatures have identical contexts - checkTc (isReflMkCos mk_cos) - (ptext (sLit "Mutually dependent functions have syntactically distinct contexts")) - } - ------------------------------------------------ -sigContextsCtxt :: TcSigInfo -> TcSigInfo -> SDoc -sigContextsCtxt sig1 sig2 - = vcat [ptext (sLit "When matching the contexts of the signatures for"), - nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1), - ppr id2 <+> dcolon <+> ppr (idType id2)]), - ptext (sLit "The signature contexts in a mutually recursive group should all be identical")] - where - id1 = sig_id sig1 - id2 = sig_id sig2 --} -\end{code} - - -@getTyVarsToGen@ decides what type variables to generalise over. - -For a "restricted group" -- see the monomorphism restriction -for a definition -- we bind no dictionaries, and -remove from tyvars_to_gen any constrained type variables - -*Don't* simplify dicts at this point, because we aren't going -to generalise over these dicts. By the time we do simplify them -we may well know more. For example (this actually came up) - f :: Array Int Int - f x = array ... xs where xs = [1,2,3,4,5] -We don't want to generate lots of (fromInt Int 1), (fromInt Int 2) -stuff. If we simplify only at the f-binding (not the xs-binding) -we'll know that the literals are all Ints, and we can just produce -Int literals! - -Find all the type variables involved in overloading, the -"constrained_tyvars". These are the ones we *aren't* going to -generalise. We must be careful about doing this: - - (a) If we fail to generalise a tyvar which is not actually - constrained, then it will never, ever get bound, and lands - up printed out in interface files! Notorious example: - instance Eq a => Eq (Foo a b) where .. - Here, b is not constrained, even though it looks as if it is. - Another, more common, example is when there's a Method inst in - the LIE, whose type might very well involve non-overloaded - type variables. - [NOTE: Jan 2001: I don't understand the problem here so I'm doing - the simple thing instead] - - (b) On the other hand, we mustn't generalise tyvars which are constrained, - because we are going to pass on out the unmodified LIE, with those - tyvars in it. They won't be in scope if we've generalised them. - -So we are careful, and do a complete simplification just to find the -constrained tyvars. We don't use any of the results, except to -find which tyvars are constrained. - -Note [Polymorphic recursion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The game plan for polymorphic recursion in the code above is - - * Bind any variable for which we have a type signature - to an Id with a polymorphic type. Then when type-checking - the RHSs we'll make a full polymorphic call. - -This fine, but if you aren't a bit careful you end up with a horrendous -amount of partial application and (worse) a huge space leak. For example: - - f :: Eq a => [a] -> [a] - f xs = ...f... - -If we don't take care, after typechecking we get - - f = /\a -> \d::Eq a -> let f' = f a d - in - \ys:[a] -> ...f'... - -Notice the the stupid construction of (f a d), which is of course -identical to the function we're executing. In this case, the -polymorphic recursion isn't being used (but that's a very common case). -This can lead to a massive space leak, from the following top-level defn -(post-typechecking) - - ff :: [Int] -> [Int] - ff = f Int dEqInt - -Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but -f' is another thunk which evaluates to the same thing... and you end -up with a chain of identical values all hung onto by the CAF ff. - - ff = f Int dEqInt - - = let f' = f Int dEqInt in \ys. ...f'... - - = let f' = let f' = f Int dEqInt in \ys. ...f'... - in \ys. ...f'... - -Etc. - -NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...), -which would make the space leak go away in this case - -Solution: when typechecking the RHSs we always have in hand the -*monomorphic* Ids for each binding. So we just need to make sure that -if (Method f a d) shows up in the constraints emerging from (...f...) -we just use the monomorphic Id. We achieve this by adding monomorphic Ids -to the "givens" when simplifying constraints. That's what the "lies_avail" -is doing. - -Then we get - - f = /\a -> \d::Eq a -> letrec - fm = \ys:[a] -> ...fm... - in - fm %************************************************************************ %* * @@ -1142,7 +1041,6 @@ However, we do *not* support this Currently, we simply make Opt_ScopedTypeVariables imply Opt_RelaxedPolyRec - Note [More instantiated than scoped] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There may be more instantiated type variables than lexically-scoped @@ -1194,70 +1092,65 @@ For example: it's all cool; each signature has distinct type variables from the renamer.) \begin{code} -type SigFun = Name -> Maybe ([Name], SrcSpan) - -- Maps a let-binder to the list of - -- type variables brought into scope - -- by its type signature, plus location - -- Nothing => no type signature - -mkSigFun :: [LSig Name] -> SigFun --- Search for a particular type signature --- Precondition: the sigs are all type sigs --- Precondition: no duplicates -mkSigFun sigs = lookupNameEnv env +tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun) +tcTySigs hs_sigs + = do { ty_sigs <- concat <$> checkNoErrs (mapAndRecoverM tcTySig hs_sigs) + -- No recovery from bad signatures, because the type sigs + -- may bind type variables, so proceeding without them + -- can lead to a cascade of errors + -- ToDo: this means we fall over immediately if any type sig + -- is wrong, which is over-conservative, see Trac bug #745 + ; let env = mkNameEnv [(idName (sig_id sig), sig) | sig <- ty_sigs] + ; return (map sig_id ty_sigs, lookupNameEnv env) } + +tcTySig :: LSig Name -> TcM [TcSigInfo] +tcTySig (L loc (IdSig id)) + = do { sig <- instTcTySigFromId loc id + ; return [sig] } +tcTySig (L loc (TypeSig names@(L _ name1 : _) hs_ty)) + = setSrcSpan loc $ + do { sigma_ty <- tcHsSigType (FunSigCtxt name1) hs_ty + ; mapM (instTcTySig hs_ty sigma_ty) (map unLoc names) } +tcTySig _ = return [] + +instTcTySigFromId :: SrcSpan -> Id -> TcM TcSigInfo +instTcTySigFromId loc id + = do { (tvs, theta, tau) <- tcInstType inst_sig_tyvars (idType id) + ; return (TcSigInfo { sig_id = id, sig_loc = loc + , sig_tvs = [(Nothing, tv) | tv <- tvs] + , sig_theta = theta, sig_tau = tau }) } where - env = mkNameEnv (concatMap mk_pair sigs) - mk_pair (L loc (IdSig id)) = [(idName id, ([], loc))] - mk_pair (L loc (TypeSig lnames lhs_ty)) = map f lnames + -- Hack: in an instance decl we use the selector id as + -- the template; but we do *not* want the SrcSpan on the Name of + -- those type variables to refer to the class decl, rather to + -- the instance decl + inst_sig_tyvars tvs = tcInstSigTyVars (map set_loc tvs) + set_loc tv = setTyVarName tv (mkInternalName (nameUnique n) (nameOccName n) loc) where - f (L _ name) = (name, (hsExplicitTvs lhs_ty, loc)) - mk_pair _ = [] - -- The scoped names are the ones explicitly mentioned - -- in the HsForAll. (There may be more in sigma_ty, because - -- of nested type synonyms. See Note [More instantiated than scoped].) - -- See Note [Only scoped tyvars are in the TyVarEnv] -\end{code} + n = tyVarName tv + +instTcTySig :: LHsType Name -> TcType -- HsType and corresponding TcType + -> Name -> TcM TcSigInfo +instTcTySig hs_ty@(L loc _) sigma_ty name + = do { (inst_tvs, theta, tau) <- tcInstType tcInstSigTyVars sigma_ty + ; return (TcSigInfo { sig_id = poly_id, sig_loc = loc + , sig_tvs = zipEqual "instTcTySig" scoped_tvs inst_tvs + , sig_theta = theta, sig_tau = tau }) } + where + poly_id = mkLocalId name sigma_ty -\begin{code} -tcTySig :: LSig Name -> TcM [TcId] -tcTySig (L span (TypeSig names@(L _ name1 : _) ty)) - = setSrcSpan span $ - do { sigma_ty <- tcHsSigType (FunSigCtxt name1) ty - ; return [ mkLocalId name sigma_ty | L _ name <- names ] } -tcTySig (L _ (IdSig id)) - = return [id] -tcTySig s = pprPanic "tcTySig" (ppr s) + scoped_names = hsExplicitTvs hs_ty + (sig_tvs,_) = tcSplitForAllTys sigma_ty -------------------- -tcInstSigs :: SigFun -> [Name] -> TcM TcSigFun -tcInstSigs sig_fn bndrs - = do { prs <- mapMaybeM (tcInstSig sig_fn use_skols) bndrs - ; return (lookupNameEnv (mkNameEnv prs)) } - where - use_skols = isSingleton bndrs -- See Note [Signature skolems] + scoped_tvs :: [Maybe Name] + scoped_tvs = mk_scoped scoped_names sig_tvs -tcInstSig :: SigFun -> Bool -> Name -> TcM (Maybe (Name, TcSigInfo)) --- For use_skols :: Bool see Note [Signature skolems] --- --- We must instantiate with fresh uniques, --- (see Note [Instantiate sig with fresh variables]) --- although we keep the same print-name. - -tcInstSig sig_fn use_skols name - | Just (scoped_tvs, loc) <- sig_fn name - = do { poly_id <- tcLookupId name -- Cannot fail; the poly ids are put into - -- scope when starting the binding group - ; let poly_ty = idType poly_id - ; (tvs, theta, tau) <- if use_skols - then tcInstType tcInstSkolTyVars poly_ty - else tcInstType tcInstSigTyVars poly_ty - ; let sig = TcSigInfo { sig_id = poly_id - , sig_scoped = scoped_tvs - , sig_tvs = tvs, sig_theta = theta, sig_tau = tau - , sig_loc = loc } - ; return (Just (name, sig)) } - | otherwise - = return Nothing + mk_scoped :: [Name] -> [TyVar] -> [Maybe Name] + mk_scoped [] tvs = [Nothing | _ <- tvs] + mk_scoped (n:ns) (tv:tvs) + | n == tyVarName tv = Just n : mk_scoped ns tvs + | otherwise = Nothing : mk_scoped (n:ns) tvs + mk_scoped (n:ns) [] = pprPanic "mk_scoped" (ppr name $$ ppr (n:ns) $$ ppr hs_ty $$ ppr sigma_ty) ------------------------------- data GeneralisationPlan @@ -1268,7 +1161,8 @@ data GeneralisationPlan Bool -- True <=> bindings mention only variables with closed types -- See Note [Bindings with closed types] in TcRnTypes - | CheckGen TcSigInfo -- Explicit generalisation; there is an AbsBinds + | CheckGen TcSigInfo -- One binding with a signature + -- Explicit generalisation; there is an AbsBinds -- A consequence of the no-AbsBinds choice (NoGen) is that there is -- no "polymorphic Id" and "monmomorphic Id"; there is just the one diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index c765dde358..d0323a58b0 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -939,14 +939,17 @@ emitKindConstraint ct , cc_fun = fn, cc_tyargs = xis1 , cc_rhs = xi2 } -> emit_kind_constraint ev d fl (mkTyConApp fn xis1) xi2 + _ -> continueWith ct where emit_kind_constraint eqv d fl ty1 ty2 - | compatKind k1 k2 - = continueWith ct + | compatKind k1 k2 -- True when ty1,ty2 are themselves kinds, + = continueWith ct -- because then k1, k2 are BOX + | otherwise - = do { keqv <- forceNewEvVar kind_co_fl (mkEqPred (k1,k2)) - ; eqv' <- forceNewEvVar fl (mkEqPred (ty1,ty2)) + = ASSERT( isKind k1 && isKind k2 ) + do { keqv <- forceNewEvVar kind_co_fl (mkNakedEqPred superKind k1 k2) + ; eqv' <- forceNewEvVar fl (mkTcEqPred ty1 ty2) ; _fl <- case fl of Wanted {}-> setEvBind eqv (mkEvKindCast eqv' (mkTcCoVarCo keqv)) fl @@ -955,7 +958,7 @@ emitKindConstraint ct Derived {} -> return fl ; traceTcS "Emitting kind constraint" $ - vcat [ ppr keqv <+> dcolon <+> ppr (mkEqPred (k1,k2)) + vcat [ ppr keqv <+> dcolon <+> ppr (mkEqPred k1 k2) , ppr eqv, ppr eqv' ] ; addToWork (canEq d kind_co_fl keqv k1 k2) -- Emit kind equality ; continueWith (ct { cc_id = eqv' }) } @@ -1215,7 +1218,7 @@ canEqLeaf d fl eqv s1 s2 else return Stop } | otherwise - = do { traceTcS "canEqLeaf" $ ppr (mkEqPred (s1,s2)) + = do { traceTcS "canEqLeaf" $ ppr (mkEqPred s1 s2) ; canEqLeafOriented d fl eqv s1 s2 } where re_orient = reOrient fl @@ -1408,7 +1411,8 @@ canEqLeafTyVarLeft d fl eqv tv s2 -- eqv : tv ~ s2 ; if no_flattening_happened then if isNothing occ_check_result then - canEqFailure d fl (setVarType eqv $ mkEqPred (mkTyVarTy tv, xi2')) + canEqFailure d fl (setVarType eqv $ + mkTcEqPred (mkTyVarTy tv) xi2') else continueWith $ CTyEqCan { cc_id = eqv , cc_flavor = fl diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index ac1895fe35..f2f6059cee 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -16,6 +16,7 @@ Typechecking class declarations module TcClassDcl ( tcClassSigs, tcClassDecl2, findMethodBind, instantiateMethod, tcInstanceMethodBody, mkGenericDefMethBind, + HsSigFun, mkHsSigFun, lookupHsSig, emptyHsSigs, tcAddDeclCtxt, badMethodErr ) where @@ -98,7 +99,9 @@ tcClassSigs :: Name -- Name of the class -> TcM ([TcMethInfo], -- Exactly one for each method NameEnv Type) -- Types of the generic-default methods tcClassSigs clas sigs def_methods - = do { gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs + = do { traceTc "tcClassSigs 1" (ppr clas) + + ; gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs ; let gen_dm_env = mkNameEnv gen_dm_prs ; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs @@ -112,6 +115,7 @@ tcClassSigs clas sigs def_methods | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ] -- Generic signature without value binding + ; traceTc "tcClassSigs 2" (ppr clas) ; return (op_info, gen_dm_env) } where vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig nm ty) <- sigs] @@ -120,7 +124,9 @@ tcClassSigs clas sigs def_methods dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] tc_sig genop_env (op_names, op_hs_ty) - = do { op_ty <- tcHsType op_hs_ty -- Class tyvars already in scope + = do { traceTc "ClsSig 1" (ppr op_names) + ; op_ty <- tcClassSigType op_hs_ty -- Class tyvars already in scope + ; traceTc "ClsSig 2" (ppr op_names) ; return [ (op_name, f op_name, op_ty) | L _ op_name <- op_names ] } where f nm | nm `elemNameEnv` genop_env = GenericDM @@ -128,7 +134,7 @@ tcClassSigs clas sigs def_methods | otherwise = NoDM tc_gen_sig (op_names, gen_hs_ty) - = do { gen_op_ty <- tcHsType gen_hs_ty + = do { gen_op_ty <- tcClassSigType gen_hs_ty ; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] } \end{code} @@ -160,8 +166,8 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, ; let (tyvars, _, _, op_items) = classBigSig clas prag_fn = mkPragFun sigs default_binds - sig_fn = mkSigFun sigs - clas_tyvars = tcSuperSkolTyVars tyvars + sig_fn = mkHsSigFun sigs + clas_tyvars = snd (tcSuperSkolTyVars tyvars) pred = mkClassPred clas (mkTyVarTys clas_tyvars) ; this_dict <- newEvVar pred @@ -178,7 +184,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name - -> SigFun -> PragFun -> ClassOpItem + -> HsSigFun -> PragFun -> ClassOpItem -> TcM (LHsBinds TcId) -- Generate code for polymorphic default methods only (hence DefMeth) -- (Generic default methods have turned into instance decls by now.) @@ -186,7 +192,7 @@ tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name -- default method for every class op, regardless of whether or not -- the programmer supplied an explicit default decl for the class. -- (If necessary we can fix that, but we don't have a convenient Id to hand.) -tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info) +tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn (sel_id, dm_info) = case dm_info of NoDefMeth -> do { mapM_ (addLocM (badDmPrag sel_id)) prags ; return emptyBag } @@ -195,7 +201,6 @@ tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info) where sel_name = idName sel_id prags = prag_fn sel_name - dm_sig_fn _ = sig_fn sel_name dm_bind = findMethodBind sel_name binds_in `orElse` pprPanic "tcDefMeth" (ppr sel_id) @@ -212,44 +217,44 @@ tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info) -- Base the local_dm_name on the selector name, because -- type errors from tcInstanceMethodBody come from here - ; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars) - local_dm_id = mkLocalId local_dm_name local_dm_ty ; dm_id_w_inline <- addInlinePrags dm_id prags ; spec_prags <- tcSpecPrags dm_id prags + ; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars) + hs_ty = lookupHsSig hs_sig_fn sel_name + `orElse` pprPanic "tc_dm" (ppr sel_name) + + ; local_dm_sig <- instTcTySig hs_ty local_dm_ty local_dm_name ; warnTc (not (null spec_prags)) (ptext (sLit "Ignoring SPECIALISE pragmas on default method") <+> quotes (ppr sel_name)) ; tc_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict] - dm_id_w_inline local_dm_id dm_sig_fn + dm_id_w_inline local_dm_sig IsDefaultMethod dm_bind ; return (unitBag tc_bind) } --------------- tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar] - -> Id -> Id - -> SigFun -> TcSpecPrags -> LHsBind Name + -> Id -> TcSigInfo + -> TcSpecPrags -> LHsBind Name -> TcM (LHsBind Id) tcInstanceMethodBody skol_info tyvars dfun_ev_vars - meth_id local_meth_id - meth_sig_fn specs - (L loc bind) + meth_id local_meth_sig + specs (L loc bind) = do { -- Typecheck the binding, first extending the envt -- so that when tcInstSig looks up the local_meth_id to find -- its signature, we'll find it in the environment - let lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) }) + let local_meth_id = sig_id local_meth_sig + lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) }) -- Substitute the local_meth_name for the binder -- NB: the binding is always a FunBind - ; traceTc "TIM" (ppr local_meth_id $$ ppr (meth_sig_fn (idName local_meth_id))) ; (ev_binds, (tc_bind, _, _)) <- checkConstraints skol_info tyvars dfun_ev_vars $ tcExtendIdEnv [local_meth_id] $ - tcPolyBinds TopLevel meth_sig_fn no_prag_fn - NonRecursive NonRecursive - [lm_bind] + tcPolyCheck local_meth_sig no_prag_fn NonRecursive [lm_bind] ; let export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id , abe_mono = local_meth_id, abe_prags = specs } @@ -289,6 +294,20 @@ instantiateMethod clas sel_id inst_tys --------------------------- +type HsSigFun = NameEnv (LHsType Name) + +emptyHsSigs :: HsSigFun +emptyHsSigs = emptyNameEnv + +mkHsSigFun :: [LSig Name] -> HsSigFun +mkHsSigFun sigs = mkNameEnv [(n, hs_ty) + | L _ (TypeSig ns hs_ty) <- sigs + , L _ n <- ns ] + +lookupHsSig :: HsSigFun -> Name -> Maybe (LHsType Name) +lookupHsSig = lookupNameEnv + +--------------------------- findMethodBind :: Name -- Selector name -> LHsBinds Name -- A group of bindings -> Maybe (LHsBind Name) -- The binding diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 7751ae49d2..e8691a4996 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -23,6 +23,7 @@ import DynFlags import TcRnMonad import FamInst import TcEnv +import TcTyClsDecls( tcFamTyPats ) import TcClassDcl( tcAddDeclCtxt ) -- Small helper import TcGenDeriv -- Deriv stuff import TcGenGenerics @@ -498,7 +499,7 @@ deriveStandalone (L loc (DerivDecl deriv_ty)) deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM EarlyDerivSpec -- The deriving clause of a data or newtype declaration deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, - tcdTyVars = tv_names, + tcdTyVars = hs_tvs, tcdTyPats = ty_pats })) = setSrcSpan loc $ -- Use the location of the 'deriving' item tcAddDeclCtxt decl $ @@ -512,8 +513,8 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, -- Given data T a b c = ... deriving( C d ), -- we want to drop type variables from T so that (C d (T a)) is well-kinded - ; let cls_tyvars = classTyVars cls - kind = tyVarKind (last cls_tyvars) + ; let cls_tyvars = classTyVars cls + kind = tyVarKind (last cls_tyvars) (arg_kinds, _) = splitKindFunTys kind n_args_to_drop = length arg_kinds n_args_to_keep = tyConArity tc - n_args_to_drop @@ -522,7 +523,9 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, inst_ty_kind = typeKind inst_ty dropped_tvs = mkVarSet (mapCatMaybes getTyVar_maybe args_to_drop) univ_tvs = (mkVarSet tvs `extendVarSetList` deriv_tvs) - `minusVarSet` dropped_tvs + `minusVarSet` dropped_tvs + + ; traceTc "derivTyData" (pprTvBndrs tvs $$ ppr tc $$ ppr tc_args $$ pprTvBndrs (varSetElems $ tyVarsOfTypes tc_args) $$ ppr inst_ty) -- Check that the result really is well-kinded ; checkTc (n_args_to_keep >= 0 && (inst_ty_kind `eqKind` kind)) @@ -556,11 +559,10 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, get_lhs Nothing = do { tc <- tcLookupTyCon tycon_name ; let tvs = tyConTyVars tc ; return (tvs, tc, mkTyVarTys tvs) } - -- JPM: to fix - get_lhs (Just pats) = do { let hs_app = nlHsTyConApp tycon_name pats - ; (tvs, tc_app) <- tcHsQuantifiedType tv_names hs_app - ; let (tc, tc_args) = tcSplitTyConApp tc_app - ; return (tvs, tc, tc_args) } + get_lhs (Just pats) = do { fam_tc <- tcLookupTyCon tycon_name + ; tcFamTyPats fam_tc hs_tvs pats (\_ -> return ()) $ + \ tvs' pats' _ -> + return (tvs', fam_tc, pats') } deriveTyData _other = panic "derivTyData" -- Caller ensures that only TyData can happen diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index a94663e67b..d97a0884f9 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -25,8 +25,9 @@ module TcEnv( tcExtendGhciEnv, tcExtendLetEnv, tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, tcLookup, tcLookupLocated, tcLookupLocalIds, - tcLookupId, tcLookupTyVar, getScopedTyVarBinds, - getInLocalScope, + tcLookupId, tcLookupTyVar, + tcLookupLcl_maybe, + getScopedTyVarBinds, getInLocalScope, wrongThingErr, pprBinders, tcExtendRecEnv, -- For knot-tying @@ -104,29 +105,27 @@ tcLookupGlobal :: Name -> TcM TyThing -- In GHCi, we may make command-line bindings (ghci> let x = True) -- that bind a GlobalId, but with an InternalName tcLookupGlobal name - = do { env <- getGblEnv - - -- Try local envt + = do { -- Try local envt + env <- getGblEnv ; case lookupNameEnv (tcg_type_env env) name of { Just thing -> return thing ; - Nothing -> do + Nothing -> - -- Try global envt - { hsc_env <- getTopEnv - ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name) - ; case mb_thing of { - Just thing -> return thing ; - Nothing -> do - -- Should it have been in the local envt? - { case nameModule_maybe name of - Nothing -> notFound name -- Internal names can happen in GHCi + case nameModule_maybe name of { + Nothing -> notFound name ; -- Internal names can happen in GHCi Just mod | mod == tcg_mod env -- Names from this module - -> notFound name -- should be in tcg_type_env - | otherwise - -> tcImportDecl name -- Go find it in an interface - }}}}} + -> notFound name -- should be in tcg_type_env + | otherwise -> do + + -- Try home package table and external package table + { hsc_env <- getTopEnv + ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name) + ; case mb_thing of + Just thing -> return thing + Nothing -> tcImportDecl name -- Go find it in an interface + }}}} tcLookupField :: Name -> TcM Id -- Returns the selector Id tcLookupField name @@ -276,6 +275,11 @@ tcExtendRecEnv gbl_stuff thing_inside tcLookupLocated :: Located Name -> TcM TcTyThing tcLookupLocated = addLocM tcLookup +tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing) +tcLookupLcl_maybe name + = do { local_env <- getLclTypeEnv + ; return (lookupNameEnv local_env name) } + tcLookup :: Name -> TcM TcTyThing tcLookup name = do local_env <- getLclTypeEnv @@ -284,11 +288,11 @@ tcLookup name = do Nothing -> AGlobal <$> tcLookupGlobal name tcLookupTyVar :: Name -> TcM TcTyVar -tcLookupTyVar name = do - thing <- tcLookup name - case thing of - ATyVar _ tv -> return tv - _ -> pprPanic "tcLookupTyVar" (ppr name) +tcLookupTyVar name + = do { thing <- tcLookup name + ; case thing of + ATyVar _ tv -> return tv + _ -> pprPanic "tcLookupTyVar" (ppr name) } tcLookupId :: Name -> TcM Id -- Used when we aren't interested in the binding level, nor refinement. @@ -455,7 +459,9 @@ tc_extend_local_env extra_env thing_inside NotTopLevel -> id_tvs where id_tvs = tyVarsOfType (idType id) - get_tvs (_, ATyVar _ tv) = unitVarSet tv -- See Note [Global TyVars] + get_tvs (_, ATyVar _ tv) -- See Note [Global TyVars] + = tyVarsOfType (tyVarKind tv) `extendVarSet` tv + get_tvs other = pprPanic "get_tvs" (ppr other) -- Note [Global TyVars] @@ -465,6 +471,8 @@ tc_extend_local_env extra_env thing_inside -- Here, g mustn't be generalised. This is also important during -- class and instance decls, when we mustn't generalise the class tyvars -- when typechecking the methods. + -- + -- Nor must we generalise g over any kind variables free in r's kind tcExtendGlobalTyVars :: IORef VarSet -> VarSet -> TcM (IORef VarSet) tcExtendGlobalTyVars gtv_var extra_global_tvs diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index cb388ff057..79492fe494 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -39,13 +39,14 @@ import VarEnv import Bag import Maybes import ErrUtils ( ErrMsg, makeIntoWarning, pprLocErrMsg ) +import SrcLoc ( noSrcSpan ) import Util import FastString import Outputable import DynFlags import Data.List ( partition, mapAccumL ) import Data.Either ( partitionEithers ) --- import Control.Monad ( when ) + \end{code} %************************************************************************ @@ -576,7 +577,7 @@ misMatchOrCND ctxt ct oriented ty1 ty2 -- or there is no context, don't report the context = misMatchMsg oriented ty1 ty2 | otherwise - = couldNotDeduce givens ([mkEqPred (ty1, ty2)], orig) + = couldNotDeduce givens ([mkEqPred ty1 ty2], orig) where givens = getUserGivens ctxt orig = TypeEqOrigin (UnifyOrigin ty1 ty2) @@ -621,11 +622,14 @@ tyVarExtraInfoMsg implics ty | otherwise -- Normal case = empty - where - ppr_skol UnkSkol _ = ptext (sLit "is an unknown type variable") -- Unhelpful - ppr_skol info loc = sep [ptext (sLit "is a rigid type variable bound by"), - sep [ppr info, ptext (sLit "at") <+> ppr loc]] + ppr_skol given_loc tv_loc + = case skol_info of + UnkSkol -> ptext (sLit "is an unknown type variable") + _ -> sep [ ptext (sLit "is a rigid type variable bound by"), + sep [ppr skol_info, ptext (sLit "at") <+> ppr tv_loc]] + where + skol_info = ctLocOrigin given_loc kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy kindErrorMsg ty1 ty2 @@ -938,14 +942,15 @@ mkAmbigMsg ctxt cts -- if it is not already set! ] -getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo +getSkolemInfo :: [Implication] -> TcTyVar -> GivenLoc -- Get the skolem info for a type variable -- from the implication constraint that binds it getSkolemInfo [] tv = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv ) - UnkSkol + CtLoc UnkSkol noSrcSpan [] + getSkolemInfo (implic:implics) tv - | tv `elem` ic_skols implic = ctLocOrigin (ic_loc implic) + | tv `elem` ic_skols implic = ic_loc implic | otherwise = getSkolemInfo implics tv ----------------------- diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index d99bd81bfc..b514dc1adc 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -27,17 +27,14 @@ module TcHsSyn ( TcId, TcIdSet, zonkTopDecls, zonkTopExpr, zonkTopLExpr, mkZonkTcTyVar, - zonkId, zonkTopBndrs + zonkId, zonkTopBndrs, + emptyZonkEnv, mkTyVarZonkEnv, zonkTcTypeToType, zonkTcTypeToTypes ) where #include "HsVersions.h" --- friends: -import HsSyn -- oodles of it - --- others: +import HsSyn import Id - import TcRnMonad import PrelNames import TcType @@ -224,6 +221,9 @@ extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) ty = ZonkEnv zonk_ty (extendVarEnv ty_env ty ty) id_env +mkTyVarZonkEnv :: [TyVar] -> ZonkEnv +mkTyVarZonkEnv tvs = ZonkEnv zonkTypeZapping (mkVarEnv [(tv,tv) | tv <- tvs]) emptyVarEnv + setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv setZonkType (ZonkEnv _ ty_env id_env) zonk_ty = ZonkEnv zonk_ty ty_env id_env @@ -292,14 +292,12 @@ zonkTyBndrsX :: ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar]) zonkTyBndrsX = mapAccumLM zonkTyBndrX zonkTyBndrX :: ZonkEnv -> TyVar -> TcM (ZonkEnv, TyVar) +-- This guarantees to return a TyVar (not a TcTyVar) +-- then we add it to the envt, so all occurrences are replaced zonkTyBndrX env tv - = do { tv' <- zonkTyBndr env tv - ; return (extendTyZonkEnv1 env tv', tv') } - -zonkTyBndr :: ZonkEnv -> TyVar -> TcM TyVar -zonkTyBndr env tv = do { ki <- zonkTcTypeToType env (tyVarKind tv) - ; return (setVarType tv ki) } + ; let tv' = mkTyVar (tyVarName tv) ki + ; return (extendTyZonkEnv1 env tv', tv') } \end{code} @@ -1152,7 +1150,7 @@ zonkEvBind env (EvBind var term) | Just ty <- isTcReflCo_maybe co -> do { zty <- zonkTcTypeToType env ty - ; let var' = setVarType var (mkEqPred (zty,zty)) + ; let var' = setVarType var (mkEqPred zty zty) ; return (EvBind var' (EvCoercion (mkTcReflCo zty))) } -- Fast path for variable-variable bindings @@ -1277,9 +1275,10 @@ zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type zonkTcTypeToType (ZonkEnv zonk_unbound_tyvar tv_env _id_env) = zonkType (mkZonkTcTyVar zonk_unbound_tyvar zonk_bound_tyvar) where - zonk_bound_tyvar tv = case lookupVarEnv tv_env tv of - Nothing -> mkTyVarTy tv - Just tv' -> mkTyVarTy tv' + zonk_bound_tyvar tv -- Look up in the env just as we do for Ids + = case lookupVarEnv tv_env tv of + Nothing -> mkTyVarTy tv + Just tv' -> mkTyVarTy tv' zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type] zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index f26bfbbf9a..7394f4f3cd 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -14,24 +14,26 @@ module TcHsType ( tcHsSigType, tcHsSigTypeNC, tcHsDeriv, tcHsVectInst, - tcHsInstHead, tcHsQuantifiedType, + tcHsInstHead, UserTypeCtxt(..), - -- Kind checking - kcHsTyVars, kcHsSigType, kcHsLiftedSigType, - kcLHsType, kcCheckLHsType, kcHsContext, kcApps, - kindGeneralizeKind, kindGeneralizeKinds, - - -- Sort checking - scDsLHsKind, scDsLHsMaybeKind, + -- Type checking type and class decls + kcTyClTyVars, tcTyClTyVars, + tcHsConArgType, tcDataKindSig, + tcClassSigType, - -- Typechecking kinded types - tcHsType, tcCheckHsType, - tcHsKindedContext, tcHsKindedType, tcHsBangType, - tcTyVarBndrs, tcTyVarBndrsKindGen, dsHsType, - tcDataKindSig, tcTyClTyVars, + -- Kind-checking types + -- No kind generalisation, no checkValidType + tcHsTyVarBndrs, tcHsTyVarBndrsGen , + tcHsLiftedType, + tcLHsType, tcCheckLHsType, + tcHsContext, tcInferApps, tcHsArgTys, ExpKind(..), ekConstraint, expArgKind, checkExpectedKind, + kindGeneralizeKind, kindGeneralizeKinds, + + -- Sort-checking kinds + tcLHsKind, -- Pattern type signatures tcHsPatSigType, tcPatSig @@ -40,31 +42,30 @@ module TcHsType ( #include "HsVersions.h" #ifdef GHCI /* Only if bootstrapped */ -import {-# SOURCE #-} TcSplice( kcSpliceType ) +import {-# SOURCE #-} TcSplice( tcSpliceType ) #endif import HsSyn -import RnHsSyn +import TcHsSyn ( zonkTcTypeToType, emptyZonkEnv ) import TcRnMonad import RnEnv ( dataKindsErr ) -import TcHsSyn ( mkZonkTcTyVar ) import TcEvidence( HsWrapper ) import TcEnv import TcMType import TcUnify import TcIface import TcType -import {- Kind parts of -} Type +import Type import Kind +import TypeRep( mkNakedTyConApp ) import Var import VarSet import TyCon import DataCon import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName ) import Class -import RdrName ( rdrNameSpace, nameRdrName ) import Name -import NameSet +import NameEnv import TysWiredIn import BasicTypes import SrcLoc @@ -73,7 +74,7 @@ import Util import UniqSupply import Outputable import FastString -import Control.Monad ( unless ) +import Control.Monad ( unless, when, zipWithM ) \end{code} @@ -155,105 +156,68 @@ the TyCon being defined. %************************************************************************ %* * -\subsection{Checking types} + Check types AND do validity checking %* * %************************************************************************ \begin{code} tcHsSigType, tcHsSigTypeNC :: UserTypeCtxt -> LHsType Name -> TcM Type - -- Do kind checking, and hoist for-alls to the top -- NB: it's important that the foralls that come from the top-level -- HsForAllTy in hs_ty occur *first* in the returned type. -- See Note [Scoped] with TcSigInfo -tcHsSigType ctxt hs_ty +tcHsSigType ctxt hs_ty = addErrCtxt (pprHsSigCtxt ctxt hs_ty) $ tcHsSigTypeNC ctxt hs_ty -tcHsSigTypeNC ctxt hs_ty - = do { kinded_ty <- case expectedKindInCtxt ctxt of - Nothing -> fmap fst (kc_lhs_type_fresh hs_ty) - Just k -> kc_lhs_type hs_ty (EK k (ptext (sLit "Expected"))) +tcHsSigTypeNC ctxt (L loc hs_ty) + = setSrcSpan loc $ -- The "In the type..." context + -- comes from the caller; hence "NC" + do { kind <- case expectedKindInCtxt ctxt of + Nothing -> newMetaKindVar + Just k -> return k -- The kind is checked by checkValidType, and isn't necessarily -- of kind * in a Template Haskell quote eg [t| Maybe |] - ; ty <- tcHsKindedType kinded_ty - ; checkValidType ctxt ty - ; return ty } --- Like tcHsType, but takes an expected kind -tcCheckHsType :: LHsType Name -> Kind -> TcM Type -tcCheckHsType hs_ty exp_kind - = do { kinded_ty <- kcCheckLHsType hs_ty (EK exp_kind (ptext (sLit "Expected"))) - ; ty <- tcHsKindedType kinded_ty - ; return ty } + ; ty <- tcCheckHsTypeAndGen hs_ty kind + -- Generalise here: see Note [Kind generalisation] -tcHsType :: LHsType Name -> TcM Type --- kind check and desugar --- no validity checking because of knot-tying -tcHsType hs_ty - = do { (kinded_ty, _) <- kc_lhs_type_fresh hs_ty - ; ty <- tcHsKindedType kinded_ty - ; return ty } + -- Zonk to expose kind information to checkValidType + ; ty <- zonkTcType ty + ; checkValidType ctxt ty + ; return ty } +----------------- tcHsInstHead :: UserTypeCtxt -> LHsType Name -> TcM ([TyVar], ThetaType, Class, [Type]) --- Typecheck an instance head. We can't use --- tcHsSigType, because it's not a valid user type. +-- Like tcHsSigTypeNC, but for an instance head. tcHsInstHead ctxt lhs_ty@(L loc hs_ty) - = setSrcSpan loc $ -- No need for an "In the type..." context - -- because that comes from the caller - do { kinded_ty <- kc_hs_type hs_ty ekConstraint - ; ty <- ds_type kinded_ty - ; let (tvs, theta, tau) = tcSplitSigmaTy ty - ; case getClassPredTys_maybe tau of - Nothing -> failWithTc (ptext (sLit "Malformed instance type")) - Just (clas,tys) -> do { checkValidInstance ctxt lhs_ty tvs theta clas tys - ; return (tvs, theta, clas, tys) } } - -tcHsQuantifiedType :: [LHsTyVarBndr Name] -> LHsType Name -> TcM ([TyVar], Type) --- Behave very like type-checking (HsForAllTy sig_tvs hs_ty), --- except that we want to keep the tvs separate -tcHsQuantifiedType tv_names hs_ty - = kcHsTyVars tv_names $ \ tv_names' -> - do { kc_ty <- kcHsSigType hs_ty - ; tcTyVarBndrs tv_names' $ \ tvs -> - do { ty <- dsHsType kc_ty - ; return (tvs, ty) } } - --- Used for the deriving(...) items -tcHsDeriv :: HsType Name -> TcM ([TyVar], Class, [Type]) -tcHsDeriv = tc_hs_deriv [] - -tc_hs_deriv :: [LHsTyVarBndr Name] -> HsType Name - -> TcM ([TyVar], Class, [Type]) -tc_hs_deriv tv_names1 (HsForAllTy _ tv_names2 (L _ []) (L _ ty)) - = -- Funny newtype deriving form - -- forall a. C [a] - -- where C has arity 2. Hence can't use regular functions - tc_hs_deriv (tv_names1 ++ tv_names2) ty - -tc_hs_deriv tv_names ty - | Just (cls_name, hs_tys) <- splitHsClassTy_maybe ty - = kcHsTyVars tv_names $ \ tv_names' -> - do { cls_kind <- kcClass cls_name - ; (tys, _res_kind) <- kcApps cls_name cls_kind hs_tys - ; tcTyVarBndrsKindGen tv_names' $ \ tyvars -> - do { arg_tys <- dsHsTypes tys - ; cls <- tcLookupClass cls_name - ; return (tyvars, cls, arg_tys) }} + = setSrcSpan loc $ -- The "In the type..." context comes from the caller + do { ty <- tcCheckHsTypeAndGen hs_ty constraintKind + ; ty <- zonkTcType ty + ; checkValidInstance ctxt lhs_ty ty } - | otherwise - = failWithTc (ptext (sLit "Illegal deriving item") <+> ppr ty) +----------------- +tcHsDeriv :: HsType Name -> TcM ([TyVar], Class, [Type]) +-- Like tcHsSigTypeNC, but for the ...deriving( ty ) clause +tcHsDeriv hs_ty + = do { kind <- newMetaKindVar + ; ty <- tcCheckHsTypeAndGen hs_ty kind + -- Funny newtype deriving form + -- forall a. C [a] + -- where C has arity 2. Hence any-kinded result + ; ty <- zonkTcType ty + ; let (tvs, pred) = splitForAllTys ty + ; case getClassPredTys_maybe pred of + Just (cls, tys) -> return (tvs, cls, tys) + Nothing -> failWithTc (ptext (sLit "Illegal deriving item") <+> ppr hs_ty) } -- Used for 'VECTORISE [SCALAR] instance' declarations -- tcHsVectInst :: LHsType Name -> TcM (Class, [Type]) tcHsVectInst ty | Just (L _ cls_name, tys) <- splitLHsClassTy_maybe ty - = do { cls_kind <- kcClass cls_name - ; (tys, _res_kind) <- kcApps cls_name cls_kind tys - ; arg_tys <- dsHsTypes tys - ; cls <- tcLookupClass cls_name - ; return (cls, arg_tys) - } + = do { (cls, cls_kind) <- tcClass cls_name + ; (arg_tys, _res_kind) <- tcInferApps cls_name cls_kind tys + ; return (cls, arg_tys) } | otherwise = failWithTc $ ptext (sLit "Malformed instance type") \end{code} @@ -262,365 +226,473 @@ tcHsVectInst ty type and class declarations, when we have to separate kind-checking, desugaring, and validity checking -\begin{code} -kcHsSigType, kcHsLiftedSigType :: LHsType Name -> TcM (LHsType Name) - -- Used for type signatures -kcHsSigType ty = addKcTypeCtxt ty $ kcArgType ty -kcHsLiftedSigType ty = addKcTypeCtxt ty $ kcLiftedType ty - -tcHsKindedType :: LHsType Name -> TcM Type - -- Don't do kind checking, nor validity checking. - -- This is used in type and class decls, where kinding is - -- done in advance, and validity checking is done later - -- [Validity checking done later because of knot-tying issues.] -tcHsKindedType hs_ty = dsHsType hs_ty - -tcHsBangType :: LHsType Name -> TcM Type --- Permit a bang, but discard it --- Input type has already been kind-checked -tcHsBangType (L _ (HsBangTy _ ty)) = tcHsKindedType ty -tcHsBangType ty = tcHsKindedType ty - -tcHsKindedContext :: LHsContext Name -> TcM ThetaType --- Used when we are expecting a ClassContext (i.e. no implicit params) --- Does not do validity checking, like tcHsKindedType -tcHsKindedContext hs_theta = addLocM (mapM dsHsType) hs_theta -\end{code} - %************************************************************************ %* * - The main kind checker: kcHsType + The main kind checker: no validity checks here %* * %************************************************************************ First a couple of simple wrappers for kcHsType \begin{code} +tcClassSigType :: LHsType Name -> TcM Type +tcClassSigType lhs_ty@(L _ hs_ty) + = addTypeCtxt lhs_ty $ + do { ty <- tcCheckHsTypeAndGen hs_ty liftedTypeKind + ; zonkTcTypeToType emptyZonkEnv ty } + +tcHsConArgType :: NewOrData -> LHsType Name -> TcM Type +-- Permit a bang, but discard it +tcHsConArgType NewType bty = tcHsLiftedType (getBangType bty) + -- Newtypes can't have bangs, but we don't check that + -- until checkValidDataCon, so do not want to crash here + +tcHsConArgType DataType bty = tcHsArgType (getBangType bty) + -- Can't allow an unlifted type for newtypes, because we're effectively + -- going to remove the constructor while coercing it to a lifted type. + -- And newtypes can't be bang'd + --------------------------- -kcLiftedType :: LHsType Name -> TcM (LHsType Name) --- The type ty must be a *lifted* *type* -kcLiftedType ty = kc_lhs_type ty ekLifted - -kcArgs :: SDoc -> [LHsType Name] -> Kind -> TcM [LHsType Name] -kcArgs what tys kind - = sequence [ kc_lhs_type ty (expArgKind what kind n) - | (ty,n) <- tys `zip` [1..] ] +tcHsArgTys :: SDoc -> [LHsType Name] -> [Kind] -> TcM [TcType] +tcHsArgTys what tys kinds + = sequence [ addTypeCtxt ty $ + tc_lhs_type ty (expArgKind what kind n) + | (ty,kind,n) <- zip3 tys kinds [1..] ] + +tc_hs_arg_tys :: SDoc -> [LHsType Name] -> [Kind] -> TcM [TcType] +-- Just like tcHsArgTys but without the addTypeCtxt +tc_hs_arg_tys what tys kinds + = sequence [ tc_lhs_type ty (expArgKind what kind n) + | (ty,kind,n) <- zip3 tys kinds [1..] ] --------------------------- -kcArgType :: LHsType Name -> TcM (LHsType Name) --- The type ty must be an *arg* *type* (lifted or unlifted) -kcArgType ty = kc_lhs_type ty ekArg +tcHsArgType, tcHsLiftedType :: LHsType Name -> TcM TcType +-- Used for type signatures +-- Do not do validity checking +tcHsArgType ty = addTypeCtxt ty $ tc_lhs_type ty ekArg +tcHsLiftedType ty = addTypeCtxt ty $ tc_lhs_type ty ekLifted + +-- Like tcHsType, but takes an expected kind +tcCheckLHsType :: LHsType Name -> Kind -> TcM Type +tcCheckLHsType hs_ty exp_kind + = addTypeCtxt hs_ty $ + tc_lhs_type hs_ty (EK exp_kind (ptext (sLit "Expected"))) + +tcLHsType :: LHsType Name -> TcM (TcType, TcKind) +-- Called from outside: set the context +tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type ty) --------------------------- -kcCheckLHsType :: LHsType Name -> ExpKind -> TcM (LHsType Name) -kcCheckLHsType ty kind = addKcTypeCtxt ty $ kc_lhs_type ty kind +tcCheckHsTypeAndGen :: HsType Name -> Kind -> TcM Type +-- Input type is HsType, not LhsType; the caller adds the context +-- Typecheck a type signature, and kind-generalise it +-- The result is not necessarily zonked, and has not been checked for validity +tcCheckHsTypeAndGen hs_ty kind + = do { ty <- tc_hs_type hs_ty (EK kind (ptext (sLit "Expected"))) + ; kvs <- kindGeneralize (tyVarsOfType ty) + ; return (mkForAllTys kvs ty) } \end{code} -Like tcExpr, kc_hs_type takes an expected kind which it unifies with +Like tcExpr, tc_hs_type takes an expected kind which it unifies with the kind it figures out. When we don't know what kind to expect, we use -kc_lhs_type_fresh, to first create a new meta kind variable and use that as +tc_lhs_type_fresh, to first create a new meta kind variable and use that as the expected kind. \begin{code} -kcLHsType :: LHsType Name -> TcM (LHsType Name, TcKind) --- Called from outside: set the context -kcLHsType ty = addKcTypeCtxt ty (kc_lhs_type_fresh ty) - -kc_lhs_type_fresh :: LHsType Name -> TcM (LHsType Name, TcKind) -kc_lhs_type_fresh ty = do - kv <- newMetaKindVar - r <- kc_lhs_type ty (EK kv (ptext (sLit "Expected"))) - return (r, kv) - -kc_lhs_types :: [(LHsType Name, ExpKind)] -> TcM [LHsType Name] -kc_lhs_types tys_w_kinds = mapM (uncurry kc_lhs_type) tys_w_kinds - -kc_lhs_type :: LHsType Name -> ExpKind -> TcM (LHsType Name) -kc_lhs_type (L span ty) exp_kind +tc_infer_lhs_type :: LHsType Name -> TcM (TcType, TcKind) +tc_infer_lhs_type ty = + do { kv <- newMetaKindVar + ; r <- tc_lhs_type ty (EK kv (ptext (sLit "Expected"))) + ; return (r, kv) } + +tc_lhs_type :: LHsType Name -> ExpKind -> TcM TcType +tc_lhs_type (L span ty) exp_kind = setSrcSpan span $ - do { traceTc "kc_lhs_type" (ppr ty <+> ppr exp_kind) - ; ty' <- kc_hs_type ty exp_kind - ; return (L span ty') } - -kc_hs_type :: HsType Name -> ExpKind -> TcM (HsType Name) -kc_hs_type (HsParTy ty) exp_kind = do - ty' <- kc_lhs_type ty exp_kind - return (HsParTy ty') - -kc_hs_type (HsTyVar name) exp_kind = do - (ty, k) <- kcTyVar name - checkExpectedKind ty k exp_kind - return ty - -kc_hs_type (HsListTy ty) exp_kind = do - ty' <- kcLiftedType ty - checkExpectedKind ty liftedTypeKind exp_kind - return (HsListTy ty') - -kc_hs_type (HsPArrTy ty) exp_kind = do - ty' <- kcLiftedType ty - checkExpectedKind ty liftedTypeKind exp_kind - return (HsPArrTy ty') - -kc_hs_type (HsKindSig ty sig_k) exp_kind = do - sig_k' <- scDsLHsKind sig_k - ty' <- kc_lhs_type ty - (EK sig_k' (ptext (sLit "An enclosing kind signature specified"))) - checkExpectedKind ty sig_k' exp_kind - return (HsKindSig ty' sig_k) + do { traceTc "tc_lhs_type:" (ppr ty $$ ppr exp_kind) + ; tc_hs_type ty exp_kind } + +tc_lhs_types :: [(LHsType Name, ExpKind)] -> TcM [TcType] +tc_lhs_types tys_w_kinds = mapM (uncurry tc_lhs_type) tys_w_kinds + +------------------------------------------ +tc_hs_type :: HsType Name -> ExpKind -> TcM TcType +tc_hs_type (HsParTy ty) exp_kind = tc_lhs_type ty exp_kind +tc_hs_type (HsDocTy ty _) exp_kind = tc_lhs_type ty exp_kind +tc_hs_type (HsQuasiQuoteTy {}) _ = panic "tc_hs_type: qq" -- Eliminated by renamer +tc_hs_type (HsBangTy {}) _ = panic "tc_hs_type: bang" -- Unwrapped by con decls +tc_hs_type (HsRecTy _) _ = panic "tc_hs_type: record" -- Unwrapped by con decls + -- Record types (which only show up temporarily in constructor + -- signatures) should have been removed by now + +---------- Functions and applications +tc_hs_type hs_ty@(HsTyVar name) exp_kind + = do { (ty, k) <- tcTyVar name + ; checkExpectedKind hs_ty k exp_kind + ; return ty } + +tc_hs_type ty@(HsFunTy ty1 ty2) exp_kind@(EK _ ctxt) + = do { ty1' <- tc_lhs_type ty1 (EK argTypeKind ctxt) + ; ty2' <- tc_lhs_type ty2 (EK openTypeKind ctxt) + ; checkExpectedKind ty liftedTypeKind exp_kind + ; return (mkFunTy ty1' ty2') } + +tc_hs_type hs_ty@(HsOpTy ty1 (_, l_op@(L _ op)) ty2) exp_kind + = do { (op', op_kind) <- tcTyVar op + ; tys' <- tcCheckApps hs_ty l_op op_kind [ty1,ty2] exp_kind + ; return (mkNakedAppTys op' tys') } + -- mkNakedAppTys: see Note [Zonking inside the knot] + +tc_hs_type hs_ty@(HsAppTy ty1 ty2) exp_kind + = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] + ; (fun_ty', fun_kind) <- tc_infer_lhs_type fun_ty + ; arg_tys' <- tcCheckApps hs_ty fun_ty fun_kind arg_tys exp_kind + ; return (mkNakedAppTys fun_ty' arg_tys') } + -- mkNakedAppTys: see Note [Zonking inside the knot] + +--------- Foralls +tc_hs_type (HsForAllTy _ hs_tvs context ty) exp_kind + = tcHsTyVarBndrs hs_tvs $ \ tvs' -> + -- Do not kind-generalise here! See Note [Kind generalisation] + do { ctxt' <- tcHsContext context + ; ty' <- tc_lhs_type ty exp_kind + -- Why exp_kind? See Note [Body kind of forall] + ; return (mkSigmaTy tvs' ctxt' ty') } + +--------- Lists, arrays, and tuples +tc_hs_type hs_ty@(HsListTy elt_ty) exp_kind + = do { tau_ty <- tc_lhs_type elt_ty ekLifted + ; checkExpectedKind hs_ty liftedTypeKind exp_kind + ; checkWiredInTyCon listTyCon + ; return (mkListTy tau_ty) } + +tc_hs_type hs_ty@(HsPArrTy elt_ty) exp_kind + = do { tau_ty <- tc_lhs_type elt_ty ekLifted + ; checkExpectedKind hs_ty liftedTypeKind exp_kind + ; checkWiredInTyCon parrTyCon + ; return (mkPArrTy tau_ty) } -- See Note [Distinguishing tuple kinds] in HsTypes -kc_hs_type ty@(HsTupleTy HsBoxedOrConstraintTuple tys) exp_kind@(EK exp_k _ctxt) - | isConstraintOrLiftedKind exp_k -- (NB: not zonking, to avoid left-right bias) - = do { tys' <- kcArgs (ptext (sLit "a tuple")) tys exp_k - ; return $ if isConstraintKind exp_k - then HsTupleTy HsConstraintTuple tys' - else HsTupleTy HsBoxedTuple tys' } +-- See Note [Inferring tuple kinds] +tc_hs_type hs_ty@(HsTupleTy HsBoxedOrConstraintTuple tys) exp_kind@(EK exp_k _ctxt) + -- (NB: not zonking before looking at exp_k, to avoid left-right bias) + | isConstraintKind exp_k = tc_tuple hs_ty HsConstraintTuple tys exp_kind + | isLiftedTypeKind exp_k = tc_tuple hs_ty HsBoxedTuple tys exp_kind | otherwise - -- It is not clear from the context if it's * or Constraint, - -- so we infer the kind from the arguments = do { k <- newMetaKindVar - ; tys' <- kcArgs (ptext (sLit "a tuple")) tys k + ; tau_tys <- tc_hs_arg_tys (ptext (sLit "a tuple")) tys (repeat k) ; k' <- zonkTcKind k - ; if isConstraintKind k' - then do { checkExpectedKind ty k' exp_kind - ; return (HsTupleTy HsConstraintTuple tys') } - -- If it's not clear from the arguments that it's Constraint, then - -- it must be *. Check the arguments again to give good error messages + ; if isConstraintKind k' then + finish_tuple hs_ty HsConstraintTuple tau_tys exp_kind + else if isLiftedTypeKind k' then + finish_tuple hs_ty HsBoxedTuple tau_tys exp_kind + else + tc_tuple hs_ty HsBoxedTuple tys exp_kind } + -- It's not clear what the kind is, so assume *, and + -- check the arguments again to give good error messages -- in eg. `(Maybe, Maybe)` - else do { tys'' <- kcArgs (ptext (sLit "a tuple")) tys liftedTypeKind - ; checkExpectedKind ty liftedTypeKind exp_kind - ; return (HsTupleTy HsBoxedTuple tys'') } } -{- -Note that we will still fail to infer the correct kind in this case: - type T a = ((a,a), D a) - type family D :: Constraint -> Constraint +tc_hs_type hs_ty@(HsTupleTy tup_sort tys) exp_kind + = tc_tuple hs_ty tup_sort tys exp_kind + +--------- Promoted lists and tuples +tc_hs_type hs_ty@(HsExplicitListTy _k tys) exp_kind + = do { tks <- mapM tc_infer_lhs_type tys + ; let taus = map fst tks + ; kind <- unifyKinds (ptext (sLit "In a promoted list")) tks + ; checkExpectedKind hs_ty (mkPromotedListTy kind) exp_kind + ; return (foldr (mk_cons kind) (mk_nil kind) taus) } + where + mk_cons k a b = mkTyConApp (buildPromotedDataCon consDataCon) [k, a, b] + mk_nil k = mkTyConApp (buildPromotedDataCon nilDataCon) [k] + +tc_hs_type hs_ty@(HsExplicitTupleTy _ tys) exp_kind + = do { tks <- mapM tc_infer_lhs_type tys + ; let n = length tys + kind_con = promotedTupleTyCon BoxedTuple n + ty_con = promotedTupleDataCon BoxedTuple n + (taus, ks) = unzip tks + tup_k = mkTyConApp kind_con ks + ; checkExpectedKind hs_ty tup_k exp_kind + ; return (mkTyConApp ty_con (ks ++ taus)) } + +--------- Constraint types +tc_hs_type ipTy@(HsIParamTy n ty) exp_kind + = do { ty' <- tc_lhs_type ty + (EK liftedTypeKind (ptext (sLit "The type argument of the implicit parameter had"))) + ; checkExpectedKind ipTy constraintKind exp_kind + ; return (mkIPPred n ty') } + +tc_hs_type ty@(HsEqTy ty1 ty2) exp_kind + = do { (ty1', kind1) <- tc_infer_lhs_type ty1 + ; (ty2', kind2) <- tc_infer_lhs_type ty2 + ; checkExpectedKind ty2 kind2 + (EK kind1 (ptext (sLit "The left argument of the equality predicate had"))) + ; checkExpectedKind ty constraintKind exp_kind + ; return (mkNakedTyConApp eqTyCon [kind1, ty1', ty2']) } + +--------- Misc +tc_hs_type (HsKindSig ty sig_k) exp_kind + = do { sig_k' <- tcLHsKind sig_k + ; checkExpectedKind ty sig_k' exp_kind + ; tc_lhs_type ty + (EK sig_k' (ptext (sLit "An enclosing kind signature specified"))) } + +tc_hs_type (HsCoreTy ty) exp_kind + = do { checkExpectedKind ty (typeKind ty) exp_kind + ; return ty } -While kind checking T, we do not yet know the kind of D, so we will default the -kind of T to * -> *. It works if we annotate `a` with kind `Constraint`. --} -kc_hs_type ty@(HsTupleTy tup_sort tys) exp_kind - = do { tys' <- kcArgs cxt_doc tys arg_kind - ; checkExpectedKind ty out_kind exp_kind - ; return (HsTupleTy tup_sort tys') } +#ifdef GHCI /* Only if bootstrapped */ +-- This looks highly bogus to me +tc_hs_type hs_ty@(HsSpliceTy sp fvs _) exp_kind + = do { (ty, kind) <- tcSpliceType sp fvs + ; checkExpectedKind hs_ty kind exp_kind + +-- ; kind' <- zonkType (mkZonkTcTyVar (\ _ -> return liftedTypeKind) mkTyVarTy) +-- kind +-- -- See Note [Kind of a type splice] + ; return ty } +#else +tc_hs_type ty@(HsSpliceTy {}) _exp_kind + = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty) +#endif + +tc_hs_type (HsWrapTy {}) _exp_kind + = panic "tc_hs_type HsWrapTy" -- We kind checked something twice + +--------------------------- +tc_tuple :: HsType Name -> HsTupleSort -> [LHsType Name] -> ExpKind -> TcM TcType +-- Invariant: tup_sort is not HsBoxedOrConstraintTuple +tc_tuple hs_ty tup_sort tys exp_kind + = do { tau_tys <- tc_hs_arg_tys cxt_doc tys (repeat arg_kind) + ; finish_tuple hs_ty tup_sort tau_tys exp_kind } where arg_kind = case tup_sort of HsBoxedTuple -> liftedTypeKind HsUnboxedTuple -> argTypeKind HsConstraintTuple -> constraintKind - _ -> panic "kc_hs_type arg_kind" - out_kind = case tup_sort of - HsUnboxedTuple -> ubxTupleKind - _ -> arg_kind + _ -> panic "tc_hs_type arg_kind" cxt_doc = case tup_sort of HsBoxedTuple -> ptext (sLit "a tuple") HsUnboxedTuple -> ptext (sLit "an unboxed tuple") HsConstraintTuple -> ptext (sLit "a constraint tuple") - _ -> panic "kc_hs_type tup_sort" - -kc_hs_type ty@(HsFunTy ty1 ty2) exp_kind@(EK _ ctxt) = do - ty1' <- kc_lhs_type ty1 (EK argTypeKind ctxt) - ty2' <- kc_lhs_type ty2 (EK openTypeKind ctxt) - checkExpectedKind ty liftedTypeKind exp_kind - return (HsFunTy ty1' ty2') - -kc_hs_type ty@(HsOpTy ty1 (_, l_op@(L loc op)) ty2) exp_kind = do - (wop, op_kind) <- kcTyVar op - [ty1',ty2'] <- kcCheckApps l_op op_kind [ty1,ty2] ty exp_kind - let op' = case wop of - HsTyVar name -> (WpKiApps [], L loc name) - HsWrapTy wrap (HsTyVar name) -> (wrap, L loc name) - _ -> panic "kc_hs_type HsOpTy" - return (HsOpTy ty1' op' ty2') - -kc_hs_type ty@(HsAppTy ty1 ty2) exp_kind = do - let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] - (fun_ty', fun_kind) <- kc_lhs_type_fresh fun_ty - arg_tys' <- kcCheckApps fun_ty fun_kind arg_tys ty exp_kind - return (mkHsAppTys fun_ty' arg_tys') - -kc_hs_type ipTy@(HsIParamTy n ty) exp_kind = do - ty' <- kc_lhs_type ty - (EK liftedTypeKind - (ptext (sLit "The type argument of the implicit parameter had"))) - checkExpectedKind ipTy constraintKind exp_kind - return (HsIParamTy n ty') - -kc_hs_type ty@(HsEqTy ty1 ty2) exp_kind = do - (ty1', kind1) <- kc_lhs_type_fresh ty1 - (ty2', kind2) <- kc_lhs_type_fresh ty2 - checkExpectedKind ty2 kind2 - (EK kind1 (ptext (sLit "The left argument of the equality predicate had"))) - checkExpectedKind ty constraintKind exp_kind - return (HsEqTy ty1' ty2') - -kc_hs_type (HsCoreTy ty) exp_kind = do - checkExpectedKind ty (typeKind ty) exp_kind - return (HsCoreTy ty) - -kc_hs_type (HsForAllTy exp tv_names context ty) exp_kind - = kcHsTyVars tv_names $ \ tv_names' -> - do { ctxt' <- kcHsContext context - ; ty' <- kc_lhs_type ty exp_kind - -- The body of a forall is usually a type, but in principle - -- there's no reason to prohibit *unlifted* types. - -- In fact, GHC can itself construct a function with an - -- unboxed tuple inside a for-all (via CPR analyis; see - -- typecheck/should_compile/tc170). - -- - -- Moreover in instance heads we get forall-types with - -- kind Constraint. - -- - -- Really we should check that it's a type of value kind - -- {*, Constraint, #}, but I'm not doing that yet - -- Example that should be rejected: - -- f :: (forall (a:*->*). a) Int - ; return (HsForAllTy exp tv_names' ctxt' ty') } - -kc_hs_type (HsBangTy b ty) exp_kind - = do { ty' <- kc_lhs_type ty exp_kind - ; return (HsBangTy b ty') } - -kc_hs_type ty@(HsRecTy _) _exp_kind - = failWithTc (ptext (sLit "Unexpected record type") <+> ppr ty) - -- Record types (which only show up temporarily in constructor signatures) - -- should have been removed by now - -#ifdef GHCI /* Only if bootstrapped */ -kc_hs_type (HsSpliceTy sp fvs _) exp_kind = do - (ty, k) <- kcSpliceType sp fvs - checkExpectedKind ty k exp_kind - return ty -#else -kc_hs_type ty@(HsSpliceTy {}) _exp_kind = - failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty) -#endif - -kc_hs_type (HsQuasiQuoteTy {}) _exp_kind = - panic "kc_hs_type" -- Eliminated by renamer - --- Remove the doc nodes here, no need to worry about the location since --- it's the same for a doc node and its child type node -kc_hs_type (HsDocTy ty _) exp_kind - = kc_hs_type (unLoc ty) exp_kind - -kc_hs_type ty@(HsExplicitListTy _k tys) exp_kind - = do { ty_k_s <- mapM kc_lhs_type_fresh tys - ; kind <- unifyKinds (ptext (sLit "In a promoted list")) ty_k_s - ; checkExpectedKind ty (mkPromotedListTy kind) exp_kind - ; return (HsExplicitListTy kind (map fst ty_k_s)) } + _ -> panic "tc_hs_type tup_sort" -kc_hs_type ty@(HsExplicitTupleTy _ tys) exp_kind = do - ty_k_s <- mapM kc_lhs_type_fresh tys - let tycon = promotedTupleTyCon BoxedTuple (length tys) - tupleKi = mkTyConApp tycon (map snd ty_k_s) - checkExpectedKind ty tupleKi exp_kind - return (HsExplicitTupleTy (map snd ty_k_s) (map fst ty_k_s)) - -kc_hs_type (HsWrapTy {}) _exp_kind = - panic "kc_hs_type HsWrapTy" -- We kind checked something twice +finish_tuple :: HsType Name -> HsTupleSort -> [TcType] -> ExpKind -> TcM TcType +finish_tuple hs_ty tup_sort tau_tys exp_kind + = do { checkExpectedKind hs_ty res_kind exp_kind + ; checkWiredInTyCon tycon + ; return (mkTyConApp tycon tau_tys) } + where + tycon = tupleTyCon con (length tau_tys) + con = case tup_sort of + HsUnboxedTuple -> UnboxedTuple + HsBoxedTuple -> BoxedTuple + HsConstraintTuple -> ConstraintTuple + _ -> panic "tc_hs_type HsTupleTy" + + res_kind = case tup_sort of + HsUnboxedTuple -> ubxTupleKind + HsBoxedTuple -> liftedTypeKind + HsConstraintTuple -> constraintKind + _ -> panic "tc_hs_type arg_kind" --------------------------- -kcApps :: Outputable a +tcInferApps :: Outputable a => a -> TcKind -- Function kind -> [LHsType Name] -- Arg types - -> TcM ([LHsType Name], TcKind) -- Kind-checked args -kcApps the_fun fun_kind args - = do { (args_w_kinds, res_kind) <- splitFunKind (ppr the_fun) 1 fun_kind args - ; args' <- kc_lhs_types args_w_kinds + -> TcM ([TcType], TcKind) -- Kind-checked args +tcInferApps the_fun fun_kind args + = do { (args_w_kinds, res_kind) <- splitFunKind (ppr the_fun) fun_kind args + ; args' <- tc_lhs_types args_w_kinds ; return (args', res_kind) } -kcCheckApps :: Outputable a => a -> TcKind -> [LHsType Name] - -> HsType Name -- The type being checked (for err messages only) - -> ExpKind -- Expected kind - -> TcM ([LHsType Name]) -kcCheckApps the_fun fun_kind args ty exp_kind - = do { (args_w_kinds, res_kind) <- splitFunKind (ppr the_fun) 1 fun_kind args - ; args_w_kinds' <- kc_lhs_types args_w_kinds - ; checkExpectedKind ty res_kind exp_kind - ; return args_w_kinds' } - +tcCheckApps :: Outputable a + => HsType Name -- The type being checked (for err messages only) + -> a -- The function + -> TcKind -> [LHsType Name] -- Fun kind and arg types + -> ExpKind -- Expected kind + -> TcM [TcType] +tcCheckApps hs_ty the_fun fun_kind args exp_kind + = do { (arg_tys, res_kind) <- tcInferApps the_fun fun_kind args + ; checkExpectedKind hs_ty res_kind exp_kind + ; return arg_tys } --------------------------- -splitFunKind :: SDoc -> Int -> TcKind -> [b] -> TcM ([(b,ExpKind)], TcKind) -splitFunKind _ _ fk [] = return ([], fk) -splitFunKind the_fun arg_no fk (arg:args) - = do { mb_fk <- matchExpectedFunKind fk - ; case mb_fk of - Nothing -> failWithTc too_many_args - Just (ak,fk') -> do { (aks, rk) <- splitFunKind the_fun (arg_no+1) fk' args - ; return ((arg - ,expArgKind (quotes the_fun) ak arg_no) - :aks ,rk) } } +splitFunKind :: SDoc -> TcKind -> [b] -> TcM ([(b,ExpKind)], TcKind) +splitFunKind the_fun fun_kind args + = go 1 fun_kind args where + go _ fk [] = return ([], fk) + go arg_no fk (arg:args) + = do { mb_fk <- matchExpectedFunKind fk + ; case mb_fk of + Nothing -> failWithTc too_many_args + Just (ak,fk') -> do { (aks, rk) <- go (arg_no+1) fk' args + ; let exp_kind = expArgKind (quotes the_fun) ak arg_no + ; return ((arg, exp_kind) : aks, rk) } } + too_many_args = quotes the_fun <+> ptext (sLit "is applied to too many type arguments") + --------------------------- -kcHsContext :: LHsContext Name -> TcM (LHsContext Name) -kcHsContext ctxt = wrapLocM (mapM kcHsLPredType) ctxt +tcHsContext :: LHsContext Name -> TcM [PredType] +tcHsContext ctxt = mapM tcHsLPredType (unLoc ctxt) -kcHsLPredType :: LHsType Name -> TcM (LHsType Name) -kcHsLPredType pred = kc_lhs_type pred ekConstraint +tcHsLPredType :: LHsType Name -> TcM PredType +tcHsLPredType pred = tc_lhs_type pred ekConstraint --------------------------- -kcTyVar :: Name -> TcM (HsType Name, TcKind) +tcTyVar :: Name -> TcM (TcType, TcKind) -- See Note [Type checking recursive type and class declarations] -- in TcTyClsDecls -kcTyVar name -- Could be a tyvar, a tycon, or a datacon +tcTyVar name -- Could be a tyvar, a tycon, or a datacon = do { traceTc "lk1" (ppr name) ; thing <- tcLookup name ; traceTc "lk2" (ppr name <+> ppr thing) ; case thing of - ATyVar _ tv -> wrap_mono (tyVarKind tv) - AThing kind -> wrap_poly kind - AGlobal (ATyCon tc) -> wrap_poly (tyConKind tc) - AGlobal (ADataCon dc) -> kcDataCon dc >>= wrap_poly - _ -> wrongThingErr "type" thing name } + ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv) + + AThing kind -> do { tc <- get_loopy_tc name + ; inst_tycon (mkNakedTyConApp tc) kind } + -- mkNakedTyConApp: see Note [Zonking inside the knot] + + AGlobal (ATyCon tc) -> inst_tycon (mkTyConApp tc) (tyConKind tc) + + AGlobal (ADataCon dc) + | isPromotableType ty -> inst_tycon (mkTyConApp tc) (tyConKind tc) + | otherwise -> failWithTc (quotes (ppr dc) <+> ptext (sLit "of type") + <+> quotes (ppr ty) <+> ptext (sLit "is not promotable")) + where + ty = dataConUserType dc + tc = buildPromotedDataCon dc + + ANothing -> failWithTc (ptext (sLit "Promoted kind") <+> + quotes (ppr name) <+> + ptext (sLit "used in a mutually recursive group")) + + _ -> wrongThingErr "type" thing name } where - wrap_mono kind = do { traceTc "lk3" (ppr name <+> dcolon <+> ppr kind) - ; return (HsTyVar name, kind) } - wrap_poly kind - | null kvs = wrap_mono kind + get_loopy_tc name + = do { env <- getGblEnv + ; case lookupNameEnv (tcg_type_env env) name of + Just (ATyCon tc) -> return tc + _ -> return (aThingErr "tcTyVar" name) } + + inst_tycon :: ([Type] -> Type) -> Kind -> TcM (Type, Kind) + -- Instantiate the polymorphic kind + -- Lazy in the TyCon + inst_tycon mk_tc_app kind + | null kvs + = return (mk_tc_app [], ki_body) | otherwise = do { traceTc "lk4" (ppr name <+> dcolon <+> ppr kind) - ; kvs' <- mapM (const newMetaKindVar) kvs - ; let ki = substKiWith kvs kvs' ki_body - ; return (HsWrapTy (WpKiApps kvs') (HsTyVar name), ki) } - where (kvs, ki_body) = splitForAllTys kind - --- IA0_TODO: this function should disapear, and use the dcPromoted field of DataCon -kcDataCon :: DataCon -> TcM TcKind -kcDataCon dc = do - let ty = dataConUserType dc - unless (isPromotableType ty) $ promoteErr dc ty - let ki = promoteType ty - traceTc "prm" (ppr ty <+> ptext (sLit "~~>") <+> ppr ki) - return ki - where - promoteErr dc ty = failWithTc (quotes (ppr dc) <+> ptext (sLit "of type") - <+> quotes (ppr ty) <+> ptext (sLit "is not promotable")) - -kcClass :: Name -> TcM TcKind -kcClass cls = do -- Must be a class - thing <- tcLookup cls - case thing of - AThing kind -> return kind - AGlobal (ATyCon tc) - | Just cls <- tyConClass_maybe tc -> return (tyConKind (classTyCon cls)) - _ -> wrongThingErr "class" thing cls + ; ks <- mapM (const newMetaKindVar) kvs + ; return (mk_tc_app ks, substKiWith kvs ks ki_body) } + where + (kvs, ki_body) = splitForAllTys kind + +tcClass :: Name -> TcM (Class, TcKind) +tcClass cls -- Must be a class + = do { thing <- tcLookup cls + ; case thing of + AThing kind -> return (aThingErr "tcClass" cls, kind) + AGlobal (ATyCon tc) + | Just cls <- tyConClass_maybe tc + -> return (cls, tyConKind tc) + _ -> wrongThingErr "class" thing cls } + + +aThingErr :: String -> Name -> b +-- The type checker for types is sometimes called simply to +-- do *kind* checking; and in that case it ignores the type +-- returned. Which is a good thing since it may not be available yet! +aThingErr str x = pprPanic "AThing evaluated unexpectedly" (text str <+> ppr x) \end{code} +Note [Zonking inside the knot] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are checking the argument types of a data constructor. We +must zonk the types before making the DataCon, because once built we +can't change it. So we must traverse the type. -%************************************************************************ -%* * - Desugaring -%* * -%************************************************************************ +BUT the parent TyCon is knot-tied, so we can't look at it yet. + +So we must be careful not to use "smart constructors" for types that +look at the TyCon or Class involved. Hence the use of mkNakedXXX +functions. + +This is sadly delicate. + +Note [Body kind of a forall] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The body of a forall is usually a type, but in principle +there's no reason to prohibit *unlifted* types. +In fact, GHC can itself construct a function with an +unboxed tuple inside a for-all (via CPR analyis; see +typecheck/should_compile/tc170). + +Moreover in instance heads we get forall-types with +kind Constraint. + +Moreover if we have a signature + f :: Int# +then we represent it as (HsForAll Implicit [] [] Int#). And this must +be legal! We can't drop the empty forall until *after* typechecking +the body because of kind polymorphism: + Typeable :: forall k. k -> Constraint + data Apply f t = Apply (f t) + -- Apply :: forall k. (k -> *) -> k -> * + instance Typeable Apply where ... +Then the dfun has type + df :: forall k. Typeable ((k->*) -> k -> *) (Apply k) + + f :: Typeable Apply + + f :: forall (t:k->*) (a:k). t a -> t a + + class C a b where + op :: a b -> Typeable Apply + + data T a = MkT (Typeable Apply) + | T2 a + T :: * -> * + MkT :: forall k. (Typeable ((k->*) -> k -> *) (Apply k)) -> T a + + f :: (forall (k:BOX). forall (t:: k->*) (a:k). t a -> t a) -> Int + f :: (forall a. a -> Typeable Apply) -> Int + +So we *must* keep the HsForAll on the instance type + HsForAll Implicit [] [] (Typeable Apply) +so that we do kind generalisation on it. + +Really we should check that it's a type of value kind +{*, Constraint, #}, but I'm not doing that yet +Example that should be rejected: + f :: (forall (a:*->*). a) Int + +Note [Inferring tuple kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple, +we try to figure out whether it's a tuple of kind * or Constraint. + Step 1: look at the expected kind + Step 2: infer argument kinds + +If after Step 2 it's not clear from the arguments that it's +Constraint, then it must be *. Once having decided that we re-check +the Check the arguments again to give good error messages +in eg. `(Maybe, Maybe)` + +Note that we will still fail to infer the correct kind in this case: + + type T a = ((a,a), D a) + type family D :: Constraint -> Constraint + +While kind checking T, we do not yet know the kind of D, so we will default the +kind of T to * -> *. It works if we annotate `a` with kind `Constraint`. Note [Desugaring types] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -654,116 +726,6 @@ Moreover (a) spurious ! annotations. (b) a class used as a type -\begin{code} - -zonkTcKindToKind :: TcKind -> TcM Kind --- When zonking a TcKind to a kind we instantiate kind variables to AnyK -zonkTcKindToKind = zonkType (mkZonkTcTyVar (\ _ -> return anyKind) mkTyVarTy) - -dsHsType :: LHsType Name -> TcM Type --- All HsTyVarBndrs in the intput type are kind-annotated --- See Note [Desugaring types] -dsHsType ty = ds_type (unLoc ty) - -ds_type :: HsType Name -> TcM Type --- See Note [Desugaring types] -ds_type ty@(HsTyVar _) - = ds_app ty [] - -ds_type (HsParTy ty) -- Remove the parentheses markers - = dsHsType ty - -ds_type ty@(HsBangTy {}) -- No bangs should be here - = failWithTc (ptext (sLit "Unexpected strictness annotation:") <+> ppr ty) - -ds_type ty@(HsRecTy {}) -- No bangs should be here - = failWithTc (ptext (sLit "Unexpected record type:") <+> ppr ty) - -ds_type (HsKindSig ty _) - = dsHsType ty -- Kind checking done already - -ds_type (HsListTy ty) = do - tau_ty <- dsHsType ty - checkWiredInTyCon listTyCon - return (mkListTy tau_ty) - -ds_type (HsPArrTy ty) = do - tau_ty <- dsHsType ty - checkWiredInTyCon parrTyCon - return (mkPArrTy tau_ty) - -ds_type (HsTupleTy hs_con tys) = do - con <- case hs_con of - HsUnboxedTuple -> return UnboxedTuple - HsBoxedTuple -> return BoxedTuple - HsConstraintTuple -> return ConstraintTuple - _ -> panic "ds_type HsTupleTy" - -- failWithTc (ptext (sLit "Unexpected tuple component kind:") <+> ppr kind') - let tycon = tupleTyCon con (length tys) - tau_tys <- dsHsTypes tys - checkWiredInTyCon tycon - return (mkTyConApp tycon tau_tys) - -ds_type (HsFunTy ty1 ty2) = do - tau_ty1 <- dsHsType ty1 - tau_ty2 <- dsHsType ty2 - return (mkFunTy tau_ty1 tau_ty2) - -ds_type (HsOpTy ty1 (wrap, (L span op)) ty2) = - setSrcSpan span (ds_app (HsWrapTy wrap (HsTyVar op)) [ty1,ty2]) - -ds_type ty@(HsAppTy _ _) - = ds_app ty [] - -ds_type (HsIParamTy n ty) = do - tau_ty <- dsHsType ty - return (mkIPPred n tau_ty) - -ds_type (HsEqTy ty1 ty2) = do - tau_ty1 <- dsHsType ty1 - tau_ty2 <- dsHsType ty2 - return (mkEqPred (tau_ty1, tau_ty2)) - -ds_type (HsForAllTy _ tv_names ctxt ty) - = tcTyVarBndrsKindGen tv_names $ \ tyvars -> do - theta <- mapM dsHsType (unLoc ctxt) - tau <- dsHsType ty - return (mkSigmaTy tyvars theta tau) - -ds_type (HsDocTy ty _) -- Remove the doc comment - = dsHsType ty - -ds_type (HsSpliceTy _ _ kind) - = do { kind' <- zonkType (mkZonkTcTyVar (\ _ -> return liftedTypeKind) mkTyVarTy) - kind - -- See Note [Kind of a type splice] - ; newFlexiTyVarTy kind' } - -ds_type (HsQuasiQuoteTy {}) = panic "ds_type" -- Eliminated by renamer -ds_type (HsCoreTy ty) = return ty - -ds_type (HsExplicitListTy kind tys) = do - kind' <- zonkTcKindToKind kind - ds_tys <- mapM dsHsType tys - return $ - foldr (\a b -> mkTyConApp (buildPromotedDataCon consDataCon) [kind', a, b]) - (mkTyConApp (buildPromotedDataCon nilDataCon) [kind']) ds_tys - -ds_type (HsExplicitTupleTy kis tys) = do - MASSERT( length kis == length tys ) - kis' <- mapM zonkTcKindToKind kis - tys' <- mapM dsHsType tys - return $ mkTyConApp (buildPromotedDataCon (tupleCon BoxedTuple (length kis'))) (kis' ++ tys') - -ds_type (HsWrapTy (WpKiApps kappas) ty) = do - tau <- ds_type ty - kappas' <- mapM zonkTcKindToKind kappas - return (mkAppTys tau kappas') - -dsHsTypes :: [LHsType Name] -> TcM [Type] -dsHsTypes arg_tys = mapM dsHsType arg_tys -\end{code} - Note [Kind of a type splice] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider these terms, each with TH type splice inside: @@ -783,41 +745,13 @@ Help functions for type applications ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -ds_app :: HsType Name -> [LHsType Name] -> TcM Type -ds_app (HsAppTy ty1 ty2) tys - = ds_app (unLoc ty1) (ty2:tys) - -ds_app ty tys = do - arg_tys <- dsHsTypes tys - case ty of - HsTyVar fun -> ds_var_app fun arg_tys - _ -> do fun_ty <- ds_type ty - return (mkAppTys fun_ty arg_tys) - -ds_var_app :: Name -> [Type] -> TcM Type --- See Note [Type checking recursive type and class declarations] --- in TcTyClsDecls -ds_var_app name arg_tys - | isTvNameSpace (rdrNameSpace (nameRdrName name)) - = do { thing <- tcLookup name - ; case thing of - ATyVar _ tv -> return (mkAppTys (mkTyVarTy tv) arg_tys) - _ -> wrongThingErr "type" thing name } - - | otherwise - = do { thing <- tcLookupGlobal name - ; case thing of - ATyCon tc -> return (mkTyConApp tc arg_tys) - ADataCon dc -> return (mkTyConApp (buildPromotedDataCon dc) arg_tys) - _ -> wrongThingErr "type" (AGlobal thing) name } - -addKcTypeCtxt :: LHsType Name -> TcM a -> TcM a +addTypeCtxt :: LHsType Name -> TcM a -> TcM a -- Wrap a context around only if we want to show that contexts. -- Omit invisble ones and ones user's won't grok -addKcTypeCtxt (L _ other_ty) thing = addErrCtxt (typeCtxt other_ty) thing - -typeCtxt :: HsType Name -> SDoc -typeCtxt ty = ptext (sLit "In the type") <+> quotes (ppr ty) +addTypeCtxt (L _ ty) thing + = addErrCtxt doc thing + where + doc = ptext (sLit "In the type") <+> quotes (ppr ty) \end{code} %************************************************************************ @@ -842,16 +776,30 @@ then we'd also need since we only have BOX for a super kind) \begin{code} -kcHsTyVars :: [LHsTyVarBndr Name] - -> ([LHsTyVarBndr Name] -> TcM r) -- These binders are kind-annotated - -- They scope over the thing inside - -> TcM r -kcHsTyVars tvs thing_inside - = do { kinded_tvs <- mapM (wrapLocM kcHsTyVar) tvs - ; tcExtendKindEnvTvs kinded_tvs thing_inside } - -kcHsTyVar :: HsTyVarBndr Name -> TcM (HsTyVarBndr Name) --- Return a *kind-annotated* binder, whose PostTcKind is +bindScopedKindVars :: [LHsTyVarBndr 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 ] + +tcHsTyVarBndrs :: [LHsTyVarBndr 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 $ + do { tvs <- mapM tcHsTyVarBndr hs_tvs + ; traceTc "tcHsTyVarBndrs" (ppr hs_tvs $$ ppr tvs) + ; tcExtendTyVarEnv tvs (thing_inside tvs) } + +tcHsTyVarBndr :: LHsTyVarBndr Name -> TcM TyVar +-- Return a type variable -- initialised with a kind variable. -- Typically the Kind inside the KindedTyVar will be a tyvar with a mutable kind -- in it. We aren't yet sure whether the binder is a *type* variable or a *kind* @@ -862,48 +810,99 @@ kcHsTyVar :: HsTyVarBndr Name -> TcM (HsTyVarBndr Name) -- instance C (a,b) where -- type F (a,b) c = ... -- Here a,b will be in scope when processing the associated type instance for F. -kcHsTyVar tyvar = do in_scope <- getInLocalScope - if in_scope (hsTyVarName tyvar) - then do inscope_tyvar <- tcLookupTyVar (hsTyVarName tyvar) - return (UserTyVar (tyVarName inscope_tyvar) - (tyVarKind inscope_tyvar)) - else kcHsTyVar' tyvar - where - kcHsTyVar' (UserTyVar name _) = UserTyVar name <$> newMetaKindVar - kcHsTyVar' (KindedTyVar name kind _) = do - kind' <- scDsLHsKind kind - return (KindedTyVar name kind kind') +tcHsTyVarBndr (L _ hs_tv) + = do { let name = hsTyVarName hs_tv + ; mb_tv <- tcLookupLcl_maybe name + ; case mb_tv of { + Just (ATyVar _ tv) -> return tv ; + _ -> do + { kind <- case hs_tv of + UserTyVar {} -> newMetaKindVar + KindedTyVar _ (HsBSig kind _) _ -> tcLHsKind kind + ; return (mkTyVar name kind) } } } ------------------ -tcTyVarBndrs :: [LHsTyVarBndr Name] -- Kind-annotated binders, which need kind-zonking - -> ([TyVar] -> TcM r) - -> TcM r --- Used when type-checking types/classes/type-decls --- Brings into scope immutable TyVars, not mutable ones that require later zonking --- Fix #5426: avoid abstraction over kinds containing # or (#) -tcTyVarBndrs bndrs thing_inside = do - tyvars <- mapM (zonk . hsTyVarNameKind . unLoc) bndrs - tcExtendTyVarEnv tyvars (thing_inside tyvars) - where - zonk (name, kind) - = do { kind' <- zonkTcKind kind - ; return (mkTyVar name kind') } - -tcTyVarBndrsKindGen :: [LHsTyVarBndr Name] -> ([TyVar] -> TcM r) -> TcM r --- tcTyVarBndrsKindGen [(f :: ?k -> *), (a :: ?k)] thing_inside --- calls thing_inside with [(k :: BOX), (f :: k -> *), (a :: k)] -tcTyVarBndrsKindGen bndrs thing_inside - = do { let kinds = map (hsTyVarKind . unLoc) bndrs - ; (kvs, zonked_kinds) <- kindGeneralizeKinds kinds - ; let tyvars = zipWith mkTyVar (map hsLTyVarName bndrs) zonked_kinds - ktvs = kvs ++ tyvars -- See Note [Kinds of quantified type variables] - ; traceTc "tcTyVarBndrsKindGen" (ppr (bndrs, kvs, tyvars)) - ; tcExtendTyVarEnv ktvs (thing_inside ktvs) } +tcHsTyVarBndrsGen :: [LHsTyVarBndr Name] + -> TcM r + -> TcM ([TyVar], r) +-- tcHsTyVarBndrsGen [(f :: ?k -> *), (a :: ?k)] thing_inside +-- Returns with tyvars [(k :: BOX), (f :: k -> *), (a :: k)] +tcHsTyVarBndrsGen hs_tvs thing_inside + = do { traceTc "tcHsTyVarBndrsGen" (ppr hs_tvs) + ; (tvs, res) <- tcHsTyVarBndrs hs_tvs $ \ tvs -> + do { res <- thing_inside + ; return (tvs, res) } + ; let kinds = map tyVarKind tvs + ; (kvs', zonked_kinds) <- kindGeneralizeKinds kinds + ; let tvs' = zipWith setTyVarKind tvs zonked_kinds + -- See Note [Kinds of quantified type variables] + ; traceTc "tcTyVarBndrsGen" (ppr (hs_tvs, kvs', tvs)) + ; return (kvs' ++ tvs', res) } + +------------------ +-- Used when generalizing binders and type family patterns +-- It takes a kind from the type checker (like `k0 -> *`), and returns the +-- final, kind-generalized kind (`forall k::BOX. k -> *`) +kindGeneralizeKinds :: [TcKind] -> TcM ([KindVar], [Kind]) +-- INVARIANT: the returned kinds are zonked, and +-- mention the returned kind variables +kindGeneralizeKinds kinds + = do { -- Quantify over kind variables free in + -- the kinds, and *not* in the environment + ; traceTc "kindGeneralizeKinds 1" (ppr kinds) + + ; kvs <- kindGeneralize (tyVarsOfTypes kinds) + + -- Zonk the kinds again, to pick up either the kind + -- variables we quantify over, or *, depending on whether + -- zonkQuantifiedTyVars decided to generalise (which in + -- turn depends on PolyKinds) + ; final_kinds <- mapM zonkTcKind kinds + + ; traceTc "kindGeneralizeKinds 2" (vcat [ ppr kinds, ppr kvs, ppr final_kinds ]) + ; return (kvs, final_kinds) } + + +kindGeneralizeKind :: TcKind -> TcM ([KindVar], Kind) +-- Unary version of kindGeneralizeKinds +kindGeneralizeKind kind + = do { kvs <- kindGeneralize (tyVarsOfType kind) + ; kind' <- zonkTcKind kind + ; return (kvs, kind') } + +kindGeneralize :: TyVarSet -> TcM [KindVar] +kindGeneralize tkvs + = do { gbl_tvs <- tcGetGlobalTyVars -- Already zonked + ; tidy_env <- tcInitTidyEnv + ; tkvs <- zonkTyVarsAndFV tkvs + ; let kvs_to_quantify = varSetElems (tkvs `minusVarSet` gbl_tvs) + + (_, tidy_kvs_to_quantify) = tidyTyVarBndrs tidy_env kvs_to_quantify + -- We do not get a later chance to tidy! + + ; ASSERT2 (all isKindVar kvs_to_quantify, ppr kvs_to_quantify $$ ppr tkvs) + zonkQuantifiedTyVars tidy_kvs_to_quantify } \end{code} +Note [Kind generalisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do kind generalisation only at the outer level of a type signature. +For example, consider + T :: forall k. k -> * + f :: (forall a. T a -> Int) -> Int +When kind-checking f's type signature we generalise the kind at +the outermost level, thus: + f1 :: forall k. (forall (a:k). T k a -> Int) -> Int -- YES! +and *not* at the inner forall: + f2 :: (forall k. forall (a:k). T k a -> Int) -> Int -- NO! +Reason: same as for HM inference on value level declarations, +we want to infer the most general type. The f2 type signature +would be *less applicable* than f1, becuase it requires a more +polymorphic argument. + Note [Kinds of quantified type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcTyVarBndrsKindGen quantifies over a specified list of type variables, +tcTyVarBndrsGen quantifies over a specified list of type variables, *and* over the kind variables mentioned in the kinds of those tyvars. Note that we must zonk those kinds (obviously) but less obviously, we @@ -918,24 +917,75 @@ Reason: we're going to turn this into a for-all type, which the type checker will then instantiate, and instantiate does not look through unification variables! -Hence using zonked_kinds when forming 'tyvars'. +Hence using zonked_kinds when forming tvs'. \begin{code} +-------------------- +-- getInitialKind has made a suitably-shaped kind for the type or class +-- Unpack it, and attribute those kinds to the type variables +-- Extend the env with bindings for the tyvars, taken from +-- the kind of the tycon/class. Give it to the thing inside, and +-- check the result kind matches +kcLookupKind :: Name -> TcM Kind +kcLookupKind nm + = do { tc_ty_thing <- tcLookup nm + ; case tc_ty_thing of + AThing k -> return k + AGlobal (ATyCon tc) -> return (tyConKind tc) + _ -> 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, +-- when doing the initial kind-check. +kcTyClTyVars name hs_tvs thing_inside + = bindScopedKindVars hs_tvs $ + do { tc_kind <- kcLookupKind name + ; let (arg_ks, res_k) = splitKindFunTysN (length hs_tvs) tc_kind + -- There should be enough arrows, because + -- getInitialKinds used the tcdTyVars + ; name_ks <- zipWithM kc_tv hs_tvs arg_ks + ; tcExtendKindEnv name_ks (thing_inside res_k) } + where + kc_tv :: LHsTyVarBndr Name -> Kind -> TcM (Name, Kind) + 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 + = do { k <- tcLHsKind hs_k + ; _ <- unifyKind k exp_k + ; check_in_scope n exp_k + ; return (n, k) } + + check_in_scope :: Name -> Kind -> TcM () + -- In an associated type decl, the type variable may already + -- be in scope; in that case we want to make sure it matches + -- any signature etc here + check_in_scope n exp_k + = do { mb_thing <- tcLookupLcl_maybe n + ; case mb_thing of + Nothing -> return () + Just (AThing k) -> discardResult (unifyKind k exp_k) + Just thing -> pprPanic "check_in_scope" (ppr thing) } + +----------------------- tcTyClTyVars :: Name -> [LHsTyVarBndr 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 -- (tcTyClTyVars T [a,b] thing_inside) -- where T : forall k1 k2 (a:k1 -> *) (b:k1). k2 -> * -- calls thing_inside with arguments --- [k1,k2,a,b] (k2 -> *) +-- [k1,k2,a,b] (k2 -> *) +-- having also extended the type environment with bindings +-- for k1,k2,a,b -- -- No need to freshen the k's because they are just skolem -- constants here, and we are at top level anyway. tcTyClTyVars tycon tyvars thing_inside = do { thing <- tcLookup tycon - ; let { kind = - case thing of - AThing kind -> kind - _ -> panic "tcTyClTyVars" + ; let { kind = case thing of + AThing kind -> kind + _ -> panic "tcTyClTyVars" -- We only call tcTyClTyVars during typechecking in -- TcTyClDecls, where the local env is extended with -- the generalized_env (mapping Names to AThings). @@ -946,43 +996,6 @@ tcTyClTyVars tycon tyvars thing_inside ; all_vs = kvs ++ tvs } ; tcExtendTyVarEnv all_vs (thing_inside all_vs res) } --- Used when generalizing binders and type family patterns --- It takes a kind from the type checker (like `k0 -> *`), and returns the --- final, kind-generalized kind (`forall k::BOX. k -> *`) -kindGeneralizeKinds :: [TcKind] -> TcM ([KindVar], [Kind]) --- INVARIANT: the returned kinds are zonked, and --- mention the returned kind variables -kindGeneralizeKinds kinds - = do { -- Quantify over kind variables free in - -- the kinds, and *not* in the environment - ; traceTc "kindGeneralizeKinds 1" (ppr kinds) - ; zonked_kinds <- mapM zonkTcKind kinds - ; gbl_tvs <- tcGetGlobalTyVars -- Already zonked - ; tidy_env <- tcInitTidyEnv - ; let kvs_to_quantify = varSetElems (tyVarsOfTypes zonked_kinds - `minusVarSet` gbl_tvs) - - (_, tidy_kvs_to_quantify) = tidyTyVarBndrs tidy_env kvs_to_quantify - -- We do not get a later chance to tidy! - - ; kvs <- ASSERT2 (all isKindVar kvs_to_quantify, ppr kvs_to_quantify) - zonkQuantifiedTyVars tidy_kvs_to_quantify - - -- Zonk the kinds again, to pick up either the kind - -- variables we quantify over, or *, depending on whether - -- zonkQuantifiedTyVars decided to generalise (which in - -- turn depends on PolyKinds) - ; final_kinds <- mapM zonkTcKind zonked_kinds - - ; traceTc "kindGeneralizeKinds 2" (vcat [ ppr gbl_tvs, ppr kinds, ppr kvs_to_quantify - , ppr kvs, ppr final_kinds ]) - ; return (kvs, final_kinds) } - -kindGeneralizeKind :: TcKind -> TcM ( [KindVar] -- these were flexi kind vars - , Kind ) -- this is the old kind where flexis got zonked -kindGeneralizeKind kind = do - (kvs, [kind']) <- kindGeneralizeKinds [kind] - return (kvs, kind') ----------------------------------- tcDataKindSig :: Kind -> TcM [TyVar] @@ -1076,32 +1089,27 @@ Historical note: \begin{code} tcHsPatSigType :: UserTypeCtxt - -> LHsType Name -- The type signature - -> TcM ([TyVar], -- Newly in-scope type variables - Type) -- The signature + -> HsBndrSig (LHsType Name) -- The type signature + -> TcM ([TyVar], -- Newly in-scope type variables + Type) -- The signature -- 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 hs_ty +tcHsPatSigType ctxt (HsBSig hs_ty sig_tvs) = addErrCtxt (pprHsSigCtxt ctxt hs_ty) $ - do { -- Find the type variables that are mentioned in the type - -- but not already in scope. These are the ones that - -- should be bound by the pattern signature - in_scope <- getInLocalScope - ; let span = getLoc hs_ty - sig_tvs = userHsTyVarBndrs $ map (L span) $ - filterOut in_scope $ - nameSetToList (extractHsTyVars hs_ty) - - ; (tyvars, sig_ty) <- tcHsQuantifiedType sig_tvs hs_ty + do { let new_tv name = do { kind <- newMetaKindVar + ; return (mkTyVar name kind) } + ; tvs <- mapM new_tv sig_tvs + ; sig_ty <- tcExtendTyVarEnv tvs $ + tcHsLiftedType hs_ty + ; sig_ty <- zonkTcType sig_ty ; checkValidType ctxt sig_ty - ; return (tyvars, sig_ty) - } + ; return (tvs, sig_ty) } tcPatSig :: UserTypeCtxt - -> LHsType Name + -> HsBndrSig (LHsType Name) -> TcSigmaType -> TcM (TcType, -- The type to use for "inside" the signature [(Name, TcTyVar)], -- The new bit of type environment, binding @@ -1118,17 +1126,16 @@ tcPatSig ctxt sig res_ty -- Just do the subsumption check and return wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty ; return (sig_ty, [], wrap) - } else do { + } else do -- Type signature binds at least one scoped type variable -- A pattern binding cannot bind scoped type variables - -- The renamer fails with a name-out-of-scope error - -- if a pattern binding tries to bind a type variable, - -- So we just have an ASSERT here - ; let in_pat_bind = case ctxt of + -- It is more convenient to make the test here + -- than in the renamer + { let in_pat_bind = case ctxt of BindPatSigCtxt -> True _ -> False - ; ASSERT( not in_pat_bind || null sig_tvs ) return () + ; when in_pat_bind (addErr (patBindSigErr sig_tvs)) -- Check that all newly-in-scope tyvars are in fact -- constrained by the pattern. This catches tiresome @@ -1141,8 +1148,8 @@ tcPatSig ctxt sig res_ty ; checkTc (null bad_tvs) (badPatSigTvs sig_ty bad_tvs) -- Now do a subsumption check of the pattern signature against res_ty - ; sig_tvs' <- tcInstSigTyVars sig_tvs - ; let sig_ty' = substTyWith sig_tvs (mkTyVarTys sig_tvs') sig_ty + ; (subst, sig_tvs') <- tcInstSigTyVars sig_tvs + ; let sig_ty' = substTy subst sig_ty ; wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty' -- Check that each is bound to a distinct type variable, @@ -1168,6 +1175,12 @@ tcPatSig ctxt sig res_ty -- as some other in-scope type variable where dups = [n' | (n',tv') <- in_scope, tv' == tv] + +patBindSigErr :: [TyVar] -> SDoc +patBindSigErr sig_tvs + = hang (ptext (sLit "You cannot bind scoped type variable") <> plural sig_tvs + <+> pprQuotedList sig_tvs) + 2 (ptext (sLit "in a pattern binding signature")) \end{code} @@ -1203,13 +1216,13 @@ expArgKind exp kind arg_no = EK kind (ptext (sLit "The") <+> speakNth arg_no <+> ptext (sLit "argument of") <+> exp <+> ptext (sLit "should have")) -unifyKinds :: SDoc -> [(LHsType Name, TcKind)] -> TcM TcKind -unifyKinds fun act_kinds = do - kind <- newMetaKindVar - let checkArgs (arg_no, (ty, act_kind)) = - checkExpectedKind ty act_kind (expArgKind (quotes fun) kind arg_no) - mapM_ checkArgs (zip [1..] act_kinds) - return kind +unifyKinds :: SDoc -> [(TcType, TcKind)] -> TcM TcKind +unifyKinds fun act_kinds + = do { kind <- newMetaKindVar + ; let check (arg_no, (ty, act_kind)) + = checkExpectedKind ty act_kind (expArgKind (quotes fun) kind arg_no) + ; mapM_ check (zip [1..] act_kinds) + ; return kind } checkExpectedKind :: Outputable a => a -> TcKind -> ExpKind -> TcM () -- A fancy wrapper for 'unifyKind', which tries @@ -1279,65 +1292,59 @@ checkExpectedKind ty act_kind ek@(EK exp_kind ek_ctxt) = do %* * %************************************************************************ -scDsLHsKind converts a user-written kind to an internal, sort-checked kind. +tcLHsKind converts a user-written kind to an internal, sort-checked kind. It does sort checking and desugaring at the same time, in one single pass. It fails when the kinds are not well-formed (eg. data A :: * Int), or if there are non-promotable or non-fully applied kinds. \begin{code} -scDsLHsKind :: LHsKind Name -> TcM Kind -scDsLHsKind k = addErrCtxt (ptext (sLit "In the kind") <+> quotes (ppr k)) $ - sc_ds_lhs_kind k +tcLHsKind :: LHsKind Name -> TcM Kind +tcLHsKind k = addErrCtxt (ptext (sLit "In the kind") <+> quotes (ppr k)) $ + tc_lhs_kind k -scDsLHsMaybeKind :: Maybe (LHsKind Name) -> TcM (Maybe Kind) -scDsLHsMaybeKind Nothing = return Nothing -scDsLHsMaybeKind (Just k) = do k' <- scDsLHsKind k - return (Just k') - -sc_ds_lhs_kind :: LHsKind Name -> TcM Kind -sc_ds_lhs_kind (L span ki) = setSrcSpan span (sc_ds_hs_kind ki) +tc_lhs_kind :: LHsKind Name -> TcM Kind +tc_lhs_kind (L span ki) = setSrcSpan span (tc_hs_kind ki) -- The main worker -sc_ds_hs_kind :: HsKind Name -> TcM Kind -sc_ds_hs_kind k@(HsTyVar _) = sc_ds_app k [] -sc_ds_hs_kind k@(HsAppTy _ _) = sc_ds_app k [] +tc_hs_kind :: HsKind Name -> TcM Kind +tc_hs_kind k@(HsTyVar _) = tc_app k [] +tc_hs_kind k@(HsAppTy _ _) = tc_app k [] -sc_ds_hs_kind (HsParTy ki) = sc_ds_lhs_kind ki +tc_hs_kind (HsParTy ki) = tc_lhs_kind ki -sc_ds_hs_kind (HsFunTy ki1 ki2) = - do kappa_ki1 <- sc_ds_lhs_kind ki1 - kappa_ki2 <- sc_ds_lhs_kind ki2 +tc_hs_kind (HsFunTy ki1 ki2) = + do kappa_ki1 <- tc_lhs_kind ki1 + kappa_ki2 <- tc_lhs_kind ki2 return (mkArrowKind kappa_ki1 kappa_ki2) -sc_ds_hs_kind (HsListTy ki) = - do kappa <- sc_ds_lhs_kind ki +tc_hs_kind (HsListTy ki) = + do kappa <- tc_lhs_kind ki checkWiredInTyCon listTyCon return $ mkPromotedListTy kappa -sc_ds_hs_kind (HsTupleTy _ kis) = - do kappas <- mapM sc_ds_lhs_kind kis +tc_hs_kind (HsTupleTy _ kis) = + do kappas <- mapM tc_lhs_kind kis checkWiredInTyCon tycon return $ mkTyConApp tycon kappas where tycon = promotedTupleTyCon BoxedTuple (length kis) -- Argument not kind-shaped -sc_ds_hs_kind k = panic ("sc_ds_hs_kind: " ++ showPpr k) +tc_hs_kind k = panic ("tc_hs_kind: " ++ showPpr k) -- Special case for kind application -sc_ds_app :: HsKind Name -> [LHsKind Name] -> TcM Kind -sc_ds_app (HsAppTy ki1 ki2) kis = sc_ds_app (unLoc ki1) (ki2:kis) -sc_ds_app (HsTyVar tc) kis = - do arg_kis <- mapM sc_ds_lhs_kind kis - sc_ds_var_app tc arg_kis -sc_ds_app ki _ = failWithTc (quotes (ppr ki) <+> +tc_app :: HsKind Name -> [LHsKind Name] -> TcM Kind +tc_app (HsAppTy ki1 ki2) kis = tc_app (unLoc ki1) (ki2:kis) +tc_app (HsTyVar tc) kis = + do arg_kis <- mapM tc_lhs_kind kis + tc_var_app tc arg_kis +tc_app ki _ = failWithTc (quotes (ppr ki) <+> ptext (sLit "is not a kind constructor")) --- IA0_TODO: With explicit kind polymorphism I might need to add ATyVar -sc_ds_var_app :: Name -> [Kind] -> TcM Kind +tc_var_app :: Name -> [Kind] -> TcM Kind -- Special case for * and Constraint kinds -- They are kinds already, so we don't need to promote them -sc_ds_var_app name arg_kis +tc_var_app name arg_kis | name == liftedTypeKindTyConName || name == constraintKindTyConName = do { unless (null arg_kis) @@ -1345,10 +1352,10 @@ sc_ds_var_app name arg_kis ; thing <- tcLookup name ; case thing of AGlobal (ATyCon tc) -> return (mkTyConApp tc []) - _ -> panic "sc_ds_var_app 1" } + _ -> panic "tc_var_app 1" } -- General case -sc_ds_var_app name arg_kis = do +tc_var_app name arg_kis = do (_errs, mb_thing) <- tryTc (tcLookup name) case mb_thing of Just (AGlobal (ATyCon tc)) @@ -1361,11 +1368,16 @@ sc_ds_var_app name arg_kis = do Just _ -> err tc "is not fully applied" Nothing -> err tc "is not promotable" + -- A lexically scoped kind variable + Just (ATyVar _ kind_var) -> return (mkAppTys (mkTyVarTy kind_var) arg_kis) + -- It is in scope, but not what we expected Just thing -> wrongThingErr "promoted type" thing name -- It is not in scope, but it passed the renamer: staging error - Nothing -> ASSERT2 ( isTyConName name, ppr name ) + Nothing -> -- ASSERT2 ( isTyConName name, ppr name ) + do env <- getLclEnv + traceTc "tc_var_app" (ppr name $$ ppr (tcl_env env)) failWithTc (ptext (sLit "Promoted kind") <+> quotes (ppr name) <+> ptext (sLit "used in a mutually recursive group")) diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 69d729525e..229fed36b6 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -392,6 +392,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- try the deriving stuff, because that may give -- more errors still + ; traceTc "tcDeriving" empty ; (gbl_env, deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls inst_decls deriv_decls @@ -426,7 +427,8 @@ addFamInsts :: [FamInst] -> TcM a -> TcM a addFamInsts fam_insts thing_inside = tcExtendLocalFamInstEnv fam_insts $ tcExtendGlobalEnvImplicit things $ - do { tcg_env <- tcAddImplicits things + do { traceTc "addFamInsts" (pprFamInsts fam_insts) + ; tcg_env <- tcAddImplicits things ; setGblEnv tcg_env thing_inside } where axioms = map famInstAxiom fam_insts @@ -567,8 +569,8 @@ tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCType = cType ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc) -- Kind check type patterns - ; tcFamTyPats fam_tc tvs pats (\_always_star -> kcDataDecl decl) $ - \tvs' pats' resultKind -> do + ; tcFamTyPats fam_tc tvs pats (kcDataDecl decl) $ + \tvs' pats' res_kind -> do -- Check that left-hand side contains no type family applications -- (vanilla synonyms are fine, though, and we checked for @@ -576,9 +578,9 @@ tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCType = cType { mapM_ checkTyFamFreeness pats' -- Result kind must be '*' (otherwise, we have too few patterns) - ; checkTc (isLiftedTypeKind resultKind) $ tooFewParmsErr (tyConArity fam_tc) + ; checkTc (isLiftedTypeKind res_kind) $ tooFewParmsErr (tyConArity fam_tc) - ; stupid_theta <- tcHsKindedContext =<< kcHsContext ctxt + ; stupid_theta <- tcHsContext ctxt ; dataDeclChecks (tcdName decl) new_or_data stupid_theta cons -- Construct representation tycon @@ -794,34 +796,59 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) loc = getSrcSpan dfun_id ------------------------------ -checkInstSig :: Class -> [TcType] -> LSig Name -> TcM () --- Check that any type signatures have exactly the right type -checkInstSig clas inst_tys (L loc (TypeSig names@(L _ name1:_) hs_ty)) - = setSrcSpan loc $ - do { inst_sigs <- xoptM Opt_InstanceSigs - ; if inst_sigs then - do { sigma_ty <- tcHsSigType (FunSigCtxt name1) hs_ty - ; mapM_ (check sigma_ty) names } - else - addErrTc (misplacedInstSig names hs_ty) } +---------------------- +mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar] + -> [TcType] -> Id -> TcM (TcId, TcSigInfo) +mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id + = do { uniq <- newUnique + ; loc <- getSrcSpanM + ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name + ; local_meth_name <- newLocalName sel_name + -- Base the local_meth_name on the selector name, becuase + -- type errors from tcInstanceMethodBody come from here + + ; local_meth_sig <- case lookupHsSig sig_fn sel_name of + Just hs_ty -- There is a signature in the instance declaration + -> do { sig_ty <- check_inst_sig hs_ty + ; instTcTySig hs_ty sig_ty local_meth_name } + + Nothing -- No type signature + -> instTcTySigFromId loc (mkLocalId local_meth_name local_meth_ty) + -- Absent a type sig, there are no new scoped type variables here + -- Only the ones from the instance decl itself, which are already + -- in scope. Example: + -- class C a where { op :: forall b. Eq b => ... } + -- instance C [c] where { op = <rhs> } + -- In <rhs>, 'c' is scope but 'b' is not! + + ; let meth_id = mkLocalId meth_name meth_ty + ; return (meth_id, local_meth_sig) } where - check sigma_ty (L _ n) - = do { sel_id <- tcLookupId n - ; let meth_ty = instantiateMethod clas sel_id inst_tys - ; checkTc (sigma_ty `eqType` meth_ty) - (badInstSigErr n meth_ty) } - -checkInstSig _ _ _ = return () + sel_name = idName sel_id + local_meth_ty = instantiateMethod clas sel_id inst_tys + meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty + + -- Check that any type signatures have exactly the right type + check_inst_sig hs_ty@(L loc _) + = setSrcSpan loc $ + do { sig_ty <- tcHsSigType (FunSigCtxt sel_name) hs_ty + ; inst_sigs <- xoptM Opt_InstanceSigs + ; if inst_sigs then + checkTc (sig_ty `eqType` local_meth_ty) + (badInstSigErr sel_name sig_ty) + else + addErrTc (misplacedInstSig sel_name hs_ty) + ; return sig_ty } badInstSigErr :: Name -> Type -> SDoc badInstSigErr meth ty = hang (ptext (sLit "Method signature does not match class; it should be")) 2 (pprPrefixName meth <+> dcolon <+> ppr ty) -misplacedInstSig :: [Located Name] -> LHsType Name -> SDoc -misplacedInstSig names hs_ty +misplacedInstSig :: Name -> LHsType Name -> SDoc +misplacedInstSig name hs_ty = vcat [ hang (ptext (sLit "Illegal type signature in instance declaration:")) - 2 (hang (hsep $ punctuate comma (map (pprPrefixName . unLoc) names)) + 2 (hang (pprPrefixName name) 2 (dcolon <+> ppr hs_ty)) , ptext (sLit "(Use -XInstanceSigs to allow this)") ] @@ -969,46 +996,47 @@ tcInstanceMethods :: DFunId -> Class -> [TcTyVar] tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys (spec_inst_prags, prag_fn) op_items (VanillaInst binds sigs standalone_deriv) - = do { mapM_ (checkInstSig clas inst_tys) sigs - ; mapAndUnzipM tc_item op_items } + = do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds) + ; let hs_sig_fn = mkHsSigFun sigs + ; mapAndUnzipM (tc_item hs_sig_fn) op_items } where ---------------------- - tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id) - tc_item (sel_id, dm_info) + tc_item :: HsSigFun -> (Id, DefMeth) -> TcM (Id, LHsBind Id) + tc_item sig_fn (sel_id, dm_info) = case findMethodBind (idName sel_id) binds of - Just user_bind -> tc_body sel_id standalone_deriv user_bind + Just user_bind -> tc_body sig_fn sel_id standalone_deriv user_bind Nothing -> traceTc "tc_def" (ppr sel_id) >> - tc_default sel_id dm_info + tc_default sig_fn sel_id dm_info ---------------------- - tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id) - tc_body sel_id generated_code rn_bind + tc_body :: HsSigFun -> Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id) + tc_body sig_fn sel_id generated_code rn_bind = add_meth_ctxt sel_id generated_code rn_bind $ - do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars - inst_tys sel_id - ; let sel_name = idName sel_id - prags = prag_fn (idName sel_id) + do { traceTc "tc_item" (ppr sel_id <+> ppr (idType sel_id)) + ; (meth_id, local_meth_sig) <- setSrcSpan (getLoc rn_bind) $ + mkMethIds sig_fn clas tyvars dfun_ev_vars + inst_tys sel_id + ; let prags = prag_fn (idName sel_id) ; meth_id1 <- addInlinePrags meth_id prags ; spec_prags <- tcSpecPrags meth_id1 prags ; bind <- tcInstanceMethodBody InstSkol tyvars dfun_ev_vars - meth_id1 local_meth_id - (mk_meth_sig_fn sel_name) + meth_id1 local_meth_sig (mk_meth_spec_prags meth_id1 spec_prags) rn_bind ; return (meth_id1, bind) } ---------------------- - tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id) + tc_default :: HsSigFun -> Id -> DefMeth -> TcM (TcId, LHsBind Id) - tc_default sel_id (GenDefMeth dm_name) + tc_default sig_fn sel_id (GenDefMeth dm_name) = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name - ; tc_body sel_id False {- Not generated code? -} meth_bind } + ; tc_body sig_fn sel_id False {- Not generated code? -} meth_bind } - tc_default sel_id NoDefMeth -- No default method at all + tc_default sig_fn sel_id NoDefMeth -- No default method at all = do { traceTc "tc_def: warn" (ppr sel_id) ; warnMissingMethodOrAT "method" (idName sel_id) - ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars + ; (meth_id, _) <- mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id ; return (meth_id, mkVarBind meth_id $ mkLHsWrap lam_wrapper error_rhs) } @@ -1020,7 +1048,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ]) lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars - tc_default sel_id (DefMeth dm_name) -- A polymorphic default method + tc_default sig_fn sel_id (DefMeth dm_name) -- A polymorphic default method = do { -- Build the typechecked version directly, -- without calling typecheck_method; -- see Note [Default methods in instances] @@ -1033,13 +1061,14 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ; let self_ev_bind = EvBind self_dict (EvDFunApp dfun_id (mkTyVarTys tyvars) dfun_ev_vars) - ; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars + ; (meth_id, local_meth_sig) <- mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id ; dm_id <- tcLookupId dm_name ; let dm_inline_prag = idInlinePragma dm_id rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $ HsVar dm_id + local_meth_id = sig_id local_meth_sig meth_bind = mkVarBind local_meth_id (L loc rhs) meth_id1 = meth_id `setInlinePragma` dm_inline_prag -- Copy the inline pragma (if any) from the default @@ -1081,19 +1110,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys = [ L loc (SpecPrag meth_id wrap inl) | L loc (SpecPrag _ wrap inl) <- spec_inst_prags] - loc = getSrcSpan dfun_id - sig_fn = mkSigFun sigs - mk_meth_sig_fn sel_name _meth_name - = case sig_fn sel_name of - Nothing -> Just ([],loc) - Just r -> Just r - -- The orElse 'Just' says "yes, in effect there's always a type sig" - -- But there are no scoped type variables from local_method_id - -- Only the ones from the instance decl itself, which are already - -- in scope. Example: - -- class C a where { op :: forall b. Eq b => ... } - -- instance C [c] where { op = <rhs> } - -- In <rhs>, 'c' is scope but 'b' is not! + loc = getSrcSpan dfun_id -- For instance decls that come from standalone deriving clauses -- we want to print out the full source code if there's an error @@ -1144,14 +1161,16 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys -- co : [p] ~ T p co = mkTcSymCo (mkTcInstCos coi (mkTyVarTys tyvars)) + sig_fn = emptyHsSigs ---------------- tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId) tc_item (rep_ev_binds, rep_d) (sel_id, _) - = do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars - inst_tys sel_id + = do { (meth_id, local_meth_sig) <- mkMethIds sig_fn clas tyvars dfun_ev_vars + inst_tys sel_id - ; let meth_rhs = wrapId (mk_op_wrapper sel_id rep_d) sel_id + ; let meth_rhs = wrapId (mk_op_wrapper sel_id rep_d) sel_id + local_meth_id = sig_id local_meth_sig meth_bind = mkVarBind local_meth_id (L loc meth_rhs) export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id , abe_mono = local_meth_id, abe_prags = noSpecPrags } @@ -1175,23 +1194,6 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys `orElse` pprPanic "tcInstanceMethods" (ppr sel_id) ---------------------- -mkMethIds :: Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcId) -mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id - = do { uniq <- newUnique - ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name - ; local_meth_name <- newLocalName sel_name - -- Base the local_meth_name on the selector name, becuase - -- type errors from tcInstanceMethodBody come from here - - ; let meth_id = mkLocalId meth_name meth_ty - local_meth_id = mkLocalId local_meth_name local_meth_ty - ; return (meth_id, local_meth_id) } - where - local_meth_ty = instantiateMethod clas sel_id inst_tys - meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty - sel_name = idName sel_id - ----------------------- wrapId :: HsWrapper -> id -> HsExpr id wrapId wrapper id = mkHsWrap wrapper (HsVar id) diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 3e580133c2..5932934bb3 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -633,17 +633,22 @@ solveWithIdentity d eqv wd tv xi text "Right Kind is : " <+> ppr (typeKind xi) ] - ; setWantedTyBind tv xi - ; let refl_xi = mkTcReflCo xi + ; let xi' = defaultKind xi + -- We only instantiate kind unification variables + -- with simple kinds like *, not OpenKind or ArgKind + -- cf TcUnify.uUnboundKVar + + ; setWantedTyBind tv xi' + ; let refl_xi = mkTcReflCo xi' ; let solved_fl = mkSolvedFlavor wd UnkSkol (EvCoercion refl_xi) - ; (_,eqv_given) <- newGivenEqVar solved_fl (mkTyVarTy tv) xi refl_xi + ; (_,eqv_given) <- newGivenEqVar solved_fl (mkTyVarTy tv) xi' refl_xi ; when (isWanted wd) $ do { _ <- setEqBind eqv refl_xi wd; return () } -- We don't want to do this for Derived, that's why we use 'when (isWanted wd)' ; return $ SPSolved (CTyEqCan { cc_id = eqv_given , cc_flavor = solved_fl - , cc_tyvar = tv, cc_rhs = xi, cc_depth = d }) } + , cc_tyvar = tv, cc_rhs = xi', cc_depth = d }) } \end{code} @@ -1551,7 +1556,7 @@ doTopReact _inerts workItem@(CFunEqCan { cc_id = eqv, cc_flavor = fl ; return $ SomeTopInt { tir_rule = "Fun/Top (given)" , tir_new_item = ContinueWith workItem } } - Derived {} -> do { evc <- newEvVar fl (mkEqPred (xi, rhs_ty)) + Derived {} -> do { evc <- newEvVar fl (mkTcEqPred xi rhs_ty) ; let eqv' = evc_the_evvar evc ; when (isNewEvVar evc) $ (let ct = CNonCanonical { cc_id = eqv' diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 518a40363c..f045287692 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -24,7 +24,7 @@ module TcMType ( newFlexiTyVar, newFlexiTyVarTy, -- Kind -> TcM TcType newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] - newMetaKindVar, newMetaKindVars, + newMetaKindVar, newMetaKindVars, mkKindSigVar, mkTcTyVarName, newMetaTyVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, @@ -60,8 +60,8 @@ module TcMType ( -------------------------------- -- Zonking zonkType, zonkKind, zonkTcPredType, - skolemiseUnboundMetaTyVar, - zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkSigTyVar, + skolemiseSigTv, skolemiseUnboundMetaTyVar, + zonkTcTyVar, zonkTcTyVars, zonkTyVarsAndFV, zonkSigTyVar, zonkQuantifiedTyVar, zonkQuantifiedTyVars, zonkTcType, zonkTcTypes, zonkTcThetaType, @@ -116,12 +116,16 @@ import Data.List ( (\\), partition, mapAccumL ) \begin{code} newMetaKindVar :: TcM TcKind -newMetaKindVar = do { uniq <- newUnique - ; ref <- newMutVar Flexi - ; return (mkTyVarTy (mkMetaKindVar uniq ref)) } +newMetaKindVar = do { uniq <- newUnique + ; ref <- newMutVar Flexi + ; return (mkTyVarTy (mkMetaKindVar uniq ref)) } newMetaKindVars :: Int -> TcM [TcKind] newMetaKindVars n = mapM (\ _ -> newMetaKindVar) (nOfThem n ()) + +mkKindSigVar :: Name -> KindVar +-- Use the specified name; don't clone it +mkKindSigVar n = mkTcTyVar n superKind (SkolemTv False) \end{code} @@ -151,7 +155,7 @@ newEvVar ty = do { name <- newName (predTypeOccName ty) newEq :: TcType -> TcType -> TcM EvVar newEq ty1 ty2 = do { name <- newName (mkVarOccFS (fsLit "cobox")) - ; return (mkLocalId name (mkEqPred (ty1, ty2))) } + ; return (mkLocalId name (mkTcEqPred ty1 ty2)) } newIP :: IPName Name -> TcType -> TcM IpId newIP ip ty @@ -180,7 +184,7 @@ predTypeOccName ty = case classifyPredType ty of %************************************************************************ \begin{code} -tcInstType :: ([TyVar] -> TcM [TcTyVar]) -- How to instantiate the type variables +tcInstType :: ([TyVar] -> TcM (TvSubst, [TcTyVar])) -- How to instantiate the type variables -> TcType -- Type to instantiate -> TcM ([TcTyVar], TcThetaType, TcType) -- Result -- (type vars (excl coercion vars), preds (incl equalities), rho) @@ -192,14 +196,8 @@ tcInstType inst_tyvars ty in return ([], theta, tau) - (tyvars, rho) -> do { tyvars' <- inst_tyvars tyvars - - ; let tenv = zipTopTvSubst tyvars (mkTyVarTys tyvars') - -- Either the tyvars are freshly made, by inst_tyvars, - -- or any nested foralls have different binders. - -- Either way, zipTopTvSubst is ok - - ; let (theta, tau) = tcSplitPhiTy (substTy tenv rho) + (tyvars, rho) -> do { (subst, tyvars') <- inst_tyvars tyvars + ; let (theta, tau) = tcSplitPhiTy (substTy subst rho) ; return (tyvars', theta, tau) } tcSkolDFunType :: Type -> TcM ([TcTyVar], TcThetaType, TcType) @@ -208,12 +206,12 @@ tcSkolDFunType :: Type -> TcM ([TcTyVar], TcThetaType, TcType) -- be in the type environment: it is lexically scoped. tcSkolDFunType ty = tcInstType (\tvs -> return (tcSuperSkolTyVars tvs)) ty -tcSuperSkolTyVars :: [TyVar] -> [TcTyVar] +tcSuperSkolTyVars :: [TyVar] -> (TvSubst, [TcTyVar]) -- Make skolem constants, but do *not* give them new names, as above -- Moreover, make them "super skolems"; see comments with superSkolemTv -- see Note [Kind substitution when instantiating] -- Precondition: tyvars should be ordered (kind vars first) -tcSuperSkolTyVars = snd . mapAccumL tcSuperSkolTyVar (mkTopTvSubst []) +tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar (mkTopTvSubst []) tcSuperSkolTyVar :: TvSubst -> TyVar -> (TvSubst, TcTyVar) tcSuperSkolTyVar subst tv @@ -239,14 +237,11 @@ tcInstSkolTyVar overlappable subst tyvar occ = nameOccName old_name kind = substTy subst (tyVarKind tyvar) -tcInstSkolTyVars' :: Bool -> TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar]) --- Precondition: tyvars should be ordered (kind vars first) --- see Note [Kind substitution when instantiating] -tcInstSkolTyVars' isSuperSkol = mapAccumLM (tcInstSkolTyVar isSuperSkol) - -- Wrappers -tcInstSkolTyVars, tcInstSuperSkolTyVars :: [TyVar] -> TcM [TcTyVar] -tcInstSkolTyVars = fmap snd . tcInstSkolTyVars' False (mkTopTvSubst []) +tcInstSkolTyVars :: [TyVar] -> TcM (TvSubst, [TcTyVar]) +tcInstSkolTyVars = tcInstSkolTyVarsX (mkTopTvSubst []) + +tcInstSuperSkolTyVars :: [TyVar] -> TcM [TcTyVar] tcInstSuperSkolTyVars = fmap snd . tcInstSkolTyVars' True (mkTopTvSubst []) tcInstSkolTyVarsX, tcInstSuperSkolTyVarsX @@ -254,17 +249,24 @@ tcInstSkolTyVarsX, tcInstSuperSkolTyVarsX tcInstSkolTyVarsX subst = tcInstSkolTyVars' False subst tcInstSuperSkolTyVarsX subst = tcInstSkolTyVars' True subst +tcInstSkolTyVars' :: Bool -> TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar]) +-- Precondition: tyvars should be ordered (kind vars first) +-- see Note [Kind substitution when instantiating] +tcInstSkolTyVars' isSuperSkol = mapAccumLM (tcInstSkolTyVar isSuperSkol) + tcInstSkolType :: TcType -> TcM ([TcTyVar], TcThetaType, TcType) -- Instantiate a type with fresh skolem constants -- Binding location comes from the monad tcInstSkolType ty = tcInstType tcInstSkolTyVars ty -tcInstSigTyVars :: [TyVar] -> TcM [TcTyVar] +tcInstSigTyVars :: [TyVar] -> TcM (TvSubst, [TcTyVar]) -- Make meta SigTv type variables for patten-bound scoped type varaibles -- We use SigTvs for them, so that they can't unify with arbitrary types -- Precondition: tyvars should be ordered (kind vars first) -- see Note [Kind substitution when instantiating] -tcInstSigTyVars = fmap snd . mapAccumLM tcInstSigTyVar (mkTopTvSubst []) +tcInstSigTyVars = mapAccumLM tcInstSigTyVar (mkTopTvSubst []) + -- The tyvars are freshly made, by tcInstSigTyVar + -- So mkTopTvSubst [] is ok tcInstSigTyVar :: TvSubst -> TyVar -> TcM (TvSubst, TcTyVar) tcInstSigTyVar subst tv @@ -481,28 +483,31 @@ the environment. tcGetGlobalTyVars :: TcM TcTyVarSet tcGetGlobalTyVars = do { (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv - ; gbl_tvs <- readMutVar gtv_var - ; tys <- mapM zonk_tv (varSetElems gbl_tvs) - ; let gbl_tvs' = tyVarsOfTypes tys + ; gbl_tvs <- readMutVar gtv_var + ; gbl_tvs' <- zonkTyVarsAndFV gbl_tvs ; writeMutVar gtv_var gbl_tvs' ; return gbl_tvs' } where - zonk_tv tv | isTcTyVar tv = zonkTcTyVar tv - | otherwise = return (mkTyVarTy tv) - -- Hackily, the global tyvars can contain non-TcTyVars - -- These are added (only) in TcHsType.tcTyClTyVars, but it seems - -- painful to make them into TcTyVars there \end{code} ----------------- Type variables \begin{code} +zonkTyVar :: TyVar -> TcM TcType +-- Works on TyVars and TcTyVars +zonkTyVar tv | isTcTyVar tv = zonkTcTyVar tv + | otherwise = return (mkTyVarTy tv) + -- Hackily, when typechecking type and class decls + -- we have TyVars in scopeadded (only) in + -- TcHsType.tcTyClTyVars, but it seems + -- painful to make them into TcTyVars there + +zonkTyVarsAndFV :: TyVarSet -> TcM TyVarSet +zonkTyVarsAndFV tyvars = tyVarsOfTypes <$> mapM zonkTyVar (varSetElems tyvars) + zonkTcTyVars :: [TcTyVar] -> TcM [TcType] zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars -zonkTcTyVarsAndFV :: TcTyVarSet -> TcM TcTyVarSet -zonkTcTyVarsAndFV tyvars = tyVarsOfTypes <$> mapM zonkTcTyVar (varSetElems tyvars) - ----------------- Types zonkTcType :: TcType -> TcM TcType -- Simply look through all Flexis @@ -640,6 +645,17 @@ skolemiseUnboundMetaTyVar tv details ; writeMetaTyVar tv (mkTyVarTy final_tv) ; return final_tv } + +skolemiseSigTv :: TcTyVar -> TcM TcTyVar +-- In TcBinds we create SigTvs for type signatures +-- but for singleton groups we want them to really be skolems +-- which do not unify with each other +skolemiseSigTv tv + = ASSERT2( isSigTyVar tv, ppr tv ) + do { writeMetaTyVarRef tv (metaTvRef tv) (mkTyVarTy skol_tv) + ; return skol_tv } + where + skol_tv = setTcTyVarDetails tv (SkolemTv False) \end{code} \begin{code} @@ -803,12 +819,12 @@ zonkType zonk_tc_tyvar ty -- The two interesting cases! go (TyVarTy tyvar) | isTcTyVar tyvar = zonk_tc_tyvar tyvar - | otherwise = TyVarTy <$> updateTyVarKindM zonkTcKind tyvar + | otherwise = TyVarTy <$> updateTyVarKindM go tyvar -- Ordinary (non Tc) tyvars occur inside quantified types go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar ) do ty' <- go ty - tyvar' <- updateTyVarKindM zonkTcKind tyvar + tyvar' <- updateTyVarKindM go tyvar return (ForAllTy tyvar' ty') \end{code} @@ -869,71 +885,74 @@ expectedKindInCtxt GhciCtxt = Nothing expectedKindInCtxt ResSigCtxt = Just openTypeKind expectedKindInCtxt ExprSigCtxt = Just openTypeKind expectedKindInCtxt (ForSigCtxt _) = Just liftedTypeKind +expectedKindInCtxt InstDeclCtxt = Just constraintKind +expectedKindInCtxt SpecInstCtxt = Just constraintKind expectedKindInCtxt _ = Just argTypeKind checkValidType :: UserTypeCtxt -> Type -> TcM () -- Checks that the type is valid for the given context -checkValidType ctxt ty = do - traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty)) - unboxed <- xoptM Opt_UnboxedTuples - rank2 <- xoptM Opt_Rank2Types - rankn <- xoptM Opt_RankNTypes - polycomp <- xoptM Opt_PolymorphicComponents - constraintKinds <- xoptM Opt_ConstraintKinds - let - gen_rank n | rankn = ArbitraryRank - | rank2 = Rank 2 - | otherwise = Rank n - rank - = case ctxt of - DefaultDeclCtxt-> MustBeMonoType - ResSigCtxt -> MustBeMonoType - LamPatSigCtxt -> gen_rank 0 - BindPatSigCtxt -> gen_rank 0 - TySynCtxt _ -> gen_rank 0 - - ExprSigCtxt -> gen_rank 1 - FunSigCtxt _ -> gen_rank 1 - InfSigCtxt _ -> ArbitraryRank -- Inferred type - ConArgCtxt _ | polycomp -> gen_rank 2 - -- We are given the type of the entire - -- constructor, hence rank 1 - | otherwise -> gen_rank 1 - - ForSigCtxt _ -> gen_rank 1 - SpecInstCtxt -> gen_rank 1 +-- Not used for instance decls; checkValidInstance instead +checkValidType ctxt ty + = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty)) + ; unboxed <- xoptM Opt_UnboxedTuples + ; rank2 <- xoptM Opt_Rank2Types + ; rankn <- xoptM Opt_RankNTypes + ; polycomp <- xoptM Opt_PolymorphicComponents + ; constraintKinds <- xoptM Opt_ConstraintKinds + ; let gen_rank n | rankn = ArbitraryRank + | rank2 = Rank 2 + | otherwise = Rank n + rank + = case ctxt of + DefaultDeclCtxt-> MustBeMonoType + ResSigCtxt -> MustBeMonoType + LamPatSigCtxt -> gen_rank 0 + BindPatSigCtxt -> gen_rank 0 + TySynCtxt _ -> gen_rank 0 + + ExprSigCtxt -> gen_rank 1 + FunSigCtxt _ -> gen_rank 1 + InfSigCtxt _ -> ArbitraryRank -- Inferred type + ConArgCtxt _ | polycomp -> gen_rank 2 + -- We are given the type of the entire + -- constructor, hence rank 1 + | otherwise -> gen_rank 1 + + ForSigCtxt _ -> gen_rank 1 + SpecInstCtxt -> gen_rank 1 ThBrackCtxt -> gen_rank 1 - GhciCtxt -> ArbitraryRank + GhciCtxt -> ArbitraryRank _ -> panic "checkValidType" - -- Can't happen; not used for *user* sigs + -- Can't happen; not used for *user* sigs - actual_kind = typeKind ty + actual_kind = typeKind ty - kind_ok = case expectedKindInCtxt ctxt of - Nothing -> True - Just k -> tcIsSubKind actual_kind k + kind_ok = case expectedKindInCtxt ctxt of + Nothing -> True + Just k -> tcIsSubKind actual_kind k - ubx_tup - | not unboxed = UT_NotOk - | otherwise = case ctxt of - TySynCtxt _ -> UT_Ok - ExprSigCtxt -> UT_Ok - ThBrackCtxt -> UT_Ok - GhciCtxt -> UT_Ok - _ -> UT_NotOk + ubx_tup + | not unboxed = UT_NotOk + | otherwise = case ctxt of + TySynCtxt _ -> UT_Ok + ExprSigCtxt -> UT_Ok + ThBrackCtxt -> UT_Ok + GhciCtxt -> UT_Ok + _ -> UT_NotOk -- Check the internal validity of the type itself - check_type rank ubx_tup ty + ; check_type rank ubx_tup ty -- Check that the thing has kind Type, and is lifted if necessary -- Do this second, because we can't usefully take the kind of an -- ill-formed type such as (a~Int) - checkTc kind_ok (kindErr actual_kind) + ; checkTc kind_ok (kindErr actual_kind) -- Check that the thing does not have kind Constraint, -- if -XConstraintKinds isn't enabled - unless constraintKinds - $ checkTc (not (isConstraintKind actual_kind)) (predTupleErr ty) + ; unless constraintKinds $ + checkTc (not (isConstraintKind actual_kind)) (predTupleErr ty) + } checkValidMonoType :: Type -> TcM () checkValidMonoType ty = check_mono_type MustBeMonoType ty @@ -1184,7 +1203,7 @@ check_pred_ty' dflags _ctxt (EqPred ty1 ty2) = do { -- Equational constraints are valid in all contexts if type -- families are permitted ; checkTc (xopt Opt_TypeFamilies dflags || xopt Opt_GADTs dflags) - (eqPredTyErr (mkEqPred (ty1, ty2))) + (eqPredTyErr (mkEqPred ty1 ty2)) -- Check the form of the argument types ; checkValidMonoType ty1 @@ -1458,26 +1477,27 @@ We can also have instances for functions: @instance Foo (a -> b) ...@. \begin{code} checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM () -checkValidInstHead ctxt clas tys +checkValidInstHead ctxt clas cls_args = do { dflags <- getDynFlags -- Check language restrictions; -- but not for SPECIALISE isntance pragmas + ; let ty_args = dropWhile isKind cls_args ; unless spec_inst_prag $ do { checkTc (xopt Opt_TypeSynonymInstances dflags || - all tcInstHeadTyNotSynonym tys) + all tcInstHeadTyNotSynonym ty_args) (instTypeErr pp_pred head_type_synonym_msg) ; checkTc (xopt Opt_FlexibleInstances dflags || - all tcInstHeadTyAppAllTyVars tys) + all tcInstHeadTyAppAllTyVars ty_args) (instTypeErr pp_pred head_type_args_tyvars_msg) ; checkTc (xopt Opt_MultiParamTypeClasses dflags || - isSingleton (dropWhile isKind tys)) -- IA0_NOTE: only count type arguments + isSingleton ty_args) -- Only count type arguments (instTypeErr pp_pred head_one_type_msg) } -- May not contain type family applications - ; mapM_ checkTyFamFreeness tys + ; mapM_ checkTyFamFreeness ty_args - ; mapM_ checkValidMonoType tys + ; mapM_ checkValidMonoType ty_args -- For now, I only allow tau-types (not polytypes) in -- the head of an instance decl. -- E.g. instance C (forall a. a->a) is rejected @@ -1488,7 +1508,7 @@ checkValidInstHead ctxt clas tys where spec_inst_prag = case ctxt of { SpecInstCtxt -> True; _ -> False } - pp_pred = pprClassPred clas tys + pp_pred = pprClassPred clas cls_args head_type_synonym_msg = parens ( text "All instance types must be of the form (T t1 ... tn)" $$ text "where T is not a synonym." $$ @@ -1540,13 +1560,16 @@ validDerivPred tv_set ty = case getClassPredTys_maybe ty of %************************************************************************ \begin{code} -checkValidInstance :: UserTypeCtxt -> LHsType Name -> [TyVar] -> ThetaType - -> Class -> [TcType] -> TcM () -checkValidInstance ctxt hs_type tyvars theta clas inst_tys - = setSrcSpan (getLoc hs_type) $ +checkValidInstance :: UserTypeCtxt -> LHsType Name -> Type + -> TcM ([TyVar], ThetaType, Class, [Type]) +checkValidInstance ctxt hs_type ty + = do { let (tvs, theta, tau) = tcSplitSigmaTy ty + ; case getClassPredTys_maybe tau of { + Nothing -> failWithTc (ptext (sLit "Malformed instance type")) ; + Just (clas,inst_tys) -> do { setSrcSpan head_loc (checkValidInstHead ctxt clas inst_tys) ; checkValidTheta ctxt theta - ; checkAmbiguity tyvars theta (tyVarsOfTypes inst_tys) + ; checkAmbiguity tvs theta (tyVarsOfTypes inst_tys) -- Check that instance inference will terminate (if we care) -- For Haskell 98 this will already have been done by checkValidTheta, @@ -1558,7 +1581,7 @@ checkValidInstance ctxt hs_type tyvars theta clas inst_tys -- The Coverage Condition ; checkTc (undecidable_ok || checkInstCoverage clas inst_tys) (instTypeErr (pprClassPred clas inst_tys) msg) - } + ; return (tvs, theta, clas, inst_tys) } } } where msg = parens (vcat [ptext (sLit "the Coverage Condition fails for one of the functional dependencies;"), undecidableMsg]) diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 41647e7fd9..f237b67301 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -138,12 +138,11 @@ data TcSigInfo = TcSigInfo { sig_id :: TcId, -- *Polymorphic* binder for this value... - sig_scoped :: [Name], -- Scoped type variables - -- 1-1 correspondence with a prefix of sig_tvs - -- However, may be fewer than sig_tvs; - -- see Note [More instantiated than scoped] - sig_tvs :: [TcTyVar], -- Instantiated type variables - -- See Note [Instantiate sig] + sig_tvs :: [(Maybe Name, TcTyVar)], + -- Instantiated type and kind variables + -- Just n <=> this skolem is lexically in scope with name n + -- See Note [Kind vars in sig_tvs] + -- See Note [More instantiated than scoped] in TcBinds sig_theta :: TcThetaType, -- Instantiated theta @@ -158,6 +157,16 @@ instance Outputable TcSigInfo where = ppr id <+> ptext (sLit "::") <+> ppr tyvars <+> pprThetaArrowTy theta <+> ppr tau \end{code} +Note [Kind vars in sig_tvs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With kind polymorphism a signature like + f :: forall f a. f a -> f a +may actuallly give rise to + f :: forall k. forall (f::k -> *) (a:k). f a -> f a +So the sig_tvs will be [k,f,a], but only f,a are scoped. +So the scoped ones are not necessarily the *inital* ones! + + Note [sig_tau may be polymorphic] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note that "sig_tau" might actually be a polymorphic type, diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 8a5aab5437..f22c988b9f 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1458,7 +1458,7 @@ tcRnType hsc_env ictxt normalise rdr_type = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { - rn_type <- rnLHsType GHCiCtx rdr_type ; + (rn_type, _fvs) <- rnLHsType GHCiCtx rdr_type ; failIfErrsM ; -- Now kind-check the type diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 77a12301ff..1d8bdd763f 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -221,6 +221,9 @@ initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside %************************************************************************ \begin{code} +discardResult :: TcM a -> TcM () +discardResult a = a >> return () + getTopEnv :: TcRnIf gbl lcl HscEnv getTopEnv = do { env <- getEnv; return (env_top env) } diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index b353943488..e19ca3574d 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -569,8 +569,8 @@ data TcTyThing tct_closed :: TopLevelFlag, -- See Note [Bindings with closed types] tct_level :: ThLevel } - | ATyVar Name TcTyVar -- The type to which the lexically scoped type vaiable - -- is currently refined. We only need the Name + | ATyVar Name TcTyVar -- The type variable to which the lexically scoped type + -- variable is bound. We only need the Name -- for error-message purposes; it is the corresponding -- Name in the domain of the envt @@ -919,9 +919,9 @@ ctPred (CNonCanonical { cc_id = v }) = evVarPred v ctPred (CDictCan { cc_class = cls, cc_tyargs = xis }) = mkClassPred cls xis ctPred (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) - = mkEqPred (mkTyVarTy tv, xi) + = mkTcEqPred (mkTyVarTy tv) xi ctPred (CFunEqCan { cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 }) - = mkEqPred(mkTyConApp fn xis1, xi2) + = mkTcEqPred (mkTyConApp fn xis1) xi2 ctPred (CIPCan { cc_ip_nm = nm, cc_ip_ty = xi }) = mkIPPred nm xi ctPred (CIrredEvCan { cc_ty = xi }) = xi diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs index f4dafcbeee..bd58c3a537 100644 --- a/compiler/typecheck/TcRules.lhs +++ b/compiler/typecheck/TcRules.lhs @@ -95,7 +95,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) -- Now figure out what to quantify over -- c.f. TcSimplify.simplifyInfer - ; zonked_forall_tvs <- zonkTcTyVarsAndFV forall_tvs + ; zonked_forall_tvs <- zonkTyVarsAndFV forall_tvs ; gbl_tvs <- tcGetGlobalTyVars -- Already zonked ; let extra_bound_tvs = zonked_forall_tvs `minusVarSet` gbl_tvs @@ -124,8 +124,8 @@ tcRuleBndrs (RuleBndrSig var rn_ty : rule_bndrs) -- a::*, x :: a->a = do { let ctxt = FunSigCtxt (unLoc var) ; (tyvars, ty) <- tcHsPatSigType ctxt rn_ty - ; let skol_tvs = tcSuperSkolTyVars tyvars - id_ty = substTyWith tyvars (mkTyVarTys skol_tvs) ty + ; let (subst, skol_tvs) = tcSuperSkolTyVars tyvars + id_ty = substTy subst ty id = mkLocalId (unLoc var) id_ty -- The type variables scope over subsequent bindings; yuk diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 964a3d375e..5f87205dfb 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -1112,7 +1112,7 @@ checkWellStagedDFun pred dfun_id loc bind_lvl = TcM.topIdLvl dfun_id pprEq :: TcType -> TcType -> SDoc -pprEq ty1 ty2 = pprType $ mkEqPred (ty1,ty2) +pprEq ty1 ty2 = pprType $ mkEqPred ty1 ty2 isTouchableMetaTyVar :: TcTyVar -> TcS Bool isTouchableMetaTyVar tv @@ -1351,7 +1351,7 @@ newGivenEqVar fl ty1 ty2 co newEqVar :: CtFlavor -> TcType -> TcType -> TcS EvVarCreated newEqVar fl ty1 ty2 - = do { let pred = mkEqPred (ty1,ty2) + = do { let pred = mkTcEqPred ty1 ty2 ; v <- newEvVar fl pred ; traceTcS "newEqVar" (ppr v <+> dcolon <+> ppr pred) ; return v } diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index ae948b5f95..eff1890d76 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -97,20 +97,19 @@ simplifyDeriv :: CtOrigin -- Simplify 'wanted' as much as possibles -- Fail if not possible simplifyDeriv orig pred tvs theta - = do { tvs_skols <- tcInstSkolTyVars tvs -- Skolemize + = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize -- The constraint solving machinery -- expects *TcTyVars* not TyVars. -- We use *non-overlappable* (vanilla) skolems -- See Note [Overlap and deriving] - ; let skol_subst = zipTopTvSubst tvs $ map mkTyVarTy tvs_skols - subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs + ; let subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs skol_set = mkVarSet tvs_skols doc = parens $ ptext (sLit "deriving") <+> parens (ppr pred) ; wanted <- newFlatWanteds orig (substTheta skol_subst theta) - ; traceTc "simplifyDeriv" (ppr tvs $$ ppr theta $$ ppr wanted) + ; traceTc "simplifyDeriv" (pprTvBndrs tvs $$ ppr theta $$ ppr wanted) ; (residual_wanted, _ev_binds1) <- runTcS (SimplInfer doc) NoUntouchables emptyInert emptyWorkList $ solveWanteds $ mkFlatWC wanted @@ -248,13 +247,14 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds | otherwise = do { zonked_wanteds <- zonkWC wanteds - ; zonked_taus <- zonkTcTypes (map snd name_taus) ; gbl_tvs <- tcGetGlobalTyVars + ; zonked_tau_tvs <- zonkTyVarsAndFV (tyVarsOfTypes (map snd name_taus)) ; runtimeCoercionErrors <- doptM Opt_DeferTypeErrors ; traceTc "simplifyInfer {" $ vcat [ ptext (sLit "names =") <+> ppr (map fst name_taus) - , ptext (sLit "taus (zonked) =") <+> ppr zonked_taus + , ptext (sLit "taus =") <+> ppr (map snd name_taus) + , ptext (sLit "tau_tvs (zonked) =") <+> ppr zonked_tau_tvs , ptext (sLit "gbl_tvs =") <+> ppr gbl_tvs , ptext (sLit "closed =") <+> ppr _top_lvl , ptext (sLit "apply_mr =") <+> ppr apply_mr @@ -266,8 +266,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds -- Then split the constraints on the baisis of those tyvars -- to avoid unnecessarily simplifying a class constraint -- See Note [Avoid unecessary constraint simplification] - ; let zonked_tau_tvs = tyVarsOfTypes zonked_taus - proto_qtvs = growWanteds gbl_tvs zonked_wanteds $ + ; let proto_qtvs = growWanteds gbl_tvs zonked_wanteds $ zonked_tau_tvs `minusVarSet` gbl_tvs (perhaps_bound, surely_free) = partitionBag (quantifyMe proto_qtvs) (wc_flat zonked_wanteds) @@ -301,7 +300,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds -- Split again simplified_perhaps_bound, because some unifications -- may have happened, and emit the free constraints. ; gbl_tvs <- tcGetGlobalTyVars - ; zonked_tau_tvs <- zonkTcTyVarsAndFV zonked_tau_tvs + ; zonked_tau_tvs <- zonkTyVarsAndFV zonked_tau_tvs ; zonked_flats <- zonkCts (wc_flat simpl_results) ; let init_tvs = zonked_tau_tvs `minusVarSet` gbl_tvs poly_qtvs = growWantedEVs gbl_tvs zonked_flats init_tvs @@ -786,6 +785,11 @@ solve_wanteds wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols -- See Note [Solving Family Equations] -- NB: remaining_flats has already had subst applied + ; traceTcS "solveWanteds finished with" $ + vcat [ text "remaining_unsolved_flats =" <+> ppr remaining_unsolved_flats + , text "subst =" <+> ppr subst + ] + ; return $ WC { wc_flat = mapBag (substCt subst) remaining_unsolved_flats , wc_impl = mapBag (substImplication subst) unsolved_implics diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index e7ddd5bbeb..63501e9c07 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -7,7 +7,7 @@ TcSplice: Template Haskell splices \begin{code} -module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket, +module TcSplice( tcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket, lookupThName_maybe, runQuasiQuoteExpr, runQuasiQuotePat, runQuasiQuoteDecl, runQuasiQuoteType, @@ -286,7 +286,7 @@ The predicate we use is TcEnv.thTopLevelId. tcBracket :: HsBracket Name -> TcRhoType -> TcM (LHsExpr TcId) tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId) -kcSpliceType :: HsSplice Name -> FreeVars -> TcM (HsType Name, TcKind) +tcSpliceType :: HsSplice Name -> FreeVars -> TcM (TcType, TcKind) -- None of these functions add constraints to the LIE lookupThName_maybe :: TH.Name -> TcM (Maybe Name) @@ -302,7 +302,7 @@ runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation tcBracket x _ = pprPanic "Cant do tcBracket without GHCi" (ppr x) tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e) tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x) -kcSpliceType x fvs = pprPanic "Cant do kcSpliceType without GHCi" (ppr x) +tcSpliceType x fvs = pprPanic "Cant do kcSpliceType without GHCi" (ppr x) lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n) @@ -517,12 +517,12 @@ tcTopSpliceExpr tc_action Very like splicing an expression, but we don't yet share code. \begin{code} -kcSpliceType splice@(HsSplice name hs_expr) fvs +tcSpliceType (HsSplice name hs_expr) _ = setSrcSpan (getLoc hs_expr) $ do { stage <- getStage ; case stage of { - Splice -> kcTopSpliceType hs_expr ; - Comp -> kcTopSpliceType hs_expr ; + Splice -> tcTopSpliceType hs_expr ; + Comp -> tcTopSpliceType hs_expr ; Brack pop_level ps_var lie_var -> do -- See Note [How brackets and nested splices are handled] @@ -541,12 +541,13 @@ kcSpliceType splice@(HsSplice name hs_expr) fvs -- but $(h 4) :: a i.e. any type, of any kind ; kind <- newMetaKindVar - ; return (HsSpliceTy splice fvs kind, kind) + ; ty <- newFlexiTyVarTy kind + ; return (ty, kind) }}} -kcTopSpliceType :: LHsExpr Name -> TcM (HsType Name, TcKind) +tcTopSpliceType :: LHsExpr Name -> TcM (TcType, TcKind) -- Note [How top-level splices are handled] -kcTopSpliceType expr +tcTopSpliceType expr = do { meta_ty <- tcMetaTy typeQTyConName -- Typecheck the expression @@ -560,9 +561,8 @@ kcTopSpliceType expr -- otherwise the type checker just gives more spurious errors ; addErrCtxt (spliceResultDoc expr) $ do { let doc = SpliceTypeCtx hs_ty2 - ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2) - ; (ty4, kind) <- kcLHsType hs_ty3 - ; return (unLoc ty4, kind) }} + ; (hs_ty3, _fvs) <- checkNoErrs (rnLHsType doc hs_ty2) + ; tcLHsType hs_ty3 }} \end{code} %************************************************************************ @@ -1005,9 +1005,9 @@ reifyInstances th_nm th_tys <+> int tc_arity <> rparen)) ; loc <- getSrcSpanM ; rdr_tys <- mapM (cvt loc) th_tys -- Convert to HsType RdrName - ; rn_tys <- rnLHsTypes doc rdr_tys -- Rename to HsType Name - ; (tys, _res_k) <- kcApps tc (tyConKind tc) rn_tys - ; mapM dsHsType tys } + ; (rn_tys, _fvs) <- rnLHsTypes doc rdr_tys -- Rename to HsType Name + ; (tys, _res_k) <- tcInferApps tc (tyConKind tc) rn_tys + ; return tys } cvt :: SrcSpan -> TH.Type -> TcM (LHsType RdrName) cvt loc th_ty = case convertToHsType loc th_ty of diff --git a/compiler/typecheck/TcSplice.lhs-boot b/compiler/typecheck/TcSplice.lhs-boot index 18a31b0b93..de14aa3b95 100644 --- a/compiler/typecheck/TcSplice.lhs-boot +++ b/compiler/typecheck/TcSplice.lhs-boot @@ -1,12 +1,12 @@ \begin{code} module TcSplice where import HsSyn ( HsSplice, HsBracket, HsQuasiQuote, - HsExpr, HsType, LHsType, LHsExpr, LPat, LHsDecl ) + HsExpr, LHsType, LHsExpr, LPat, LHsDecl ) import Name ( Name ) import NameSet ( FreeVars ) import RdrName ( RdrName ) import TcRnTypes( TcM, TcId ) -import TcType ( TcRhoType, TcKind ) +import TcType ( TcRhoType, TcType, TcKind ) import Annotations ( Annotation, CoreAnnTarget ) import qualified Language.Haskell.TH as TH @@ -14,8 +14,7 @@ tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId) -kcSpliceType :: HsSplice Name -> FreeVars - -> TcM (HsType Name, TcKind) +tcSpliceType :: HsSplice Name -> FreeVars -> TcM (TcType, TcKind) tcBracket :: HsBracket Name -> TcRhoType diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index d02f0a8b94..b04f4156aa 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -31,6 +31,7 @@ import BuildTyCl import TcUnify import TcRnMonad import TcEnv +import TcHsSyn import TcBinds( tcRecSelBinds ) import TcTyDecls import TcClassDcl @@ -77,7 +78,6 @@ import Data.List Note [Grouping of type and class declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly connected component of mutually dependent types and classes. We kind check and type check each group separately to enhance kind polymorphism. Take the @@ -219,11 +219,11 @@ So we infer their kinds in dependency order We need to kind check all types in the mutually recursive group before we know the kind of the type variables. For example: -class C a where - op :: D b => a -> b -> b + class C a where + op :: D b => a -> b -> b -class D c where - bop :: (Monad c) => ... + class D c where + bop :: (Monad c) => ... Here, the kind of the locally-polymorphic type variable "b" depends on *all the uses of class D*. For example, the use of @@ -276,7 +276,7 @@ kcTyClGroup decls ; setLclEnv tcl_env $ do -- Step 3: kind-check the synonyms - { mapM_ (wrapLocM kcTyClDecl) non_syn_decls + { mapM_ kcLTyClDecl non_syn_decls -- Step 4: generalisation -- Kind checking done for this group @@ -304,28 +304,18 @@ getInitialKinds :: LTyClDecl Name -> TcM [(Name, TcTyThing)] -- of the definition (and probably including -- kind unification variables) -- Example: data T a b = ... --- return (T, kv1 -> kv2 -> *) +-- return (T, kv1 -> kv2 -> kv3) -- -- ALSO for each datacon, return (dc, ANothing) -- See Note [ANothing] in TcRnTypes getInitialKinds (L _ decl) - = do { arg_kinds <- mapM (mk_arg_kind . unLoc) (tyClDeclTyVars decl) - ; res_kind <- mk_res_kind decl + = do { arg_kinds <- mapM (\_ -> newMetaKindVar) (tyClDeclTyVars decl) + ; res_kind <- get_res_kind decl ; let main_pair = (tcdName decl, AThing (mkArrowKinds arg_kinds res_kind)) ; inner_pairs <- get_inner_kinds decl ; return (main_pair : inner_pairs) } where - mk_arg_kind (UserTyVar _ _) = newMetaKindVar - mk_arg_kind (KindedTyVar _ kind _) = scDsLHsKind kind - - mk_res_kind (TyFamily { tcdKind = Just kind }) = scDsLHsKind kind - mk_res_kind (TyData { tcdKindSig = Just kind }) = scDsLHsKind kind - -- On GADT-style declarations we allow a kind signature - -- data T :: *->* where { ... } - mk_res_kind (ClassDecl {}) = return constraintKind - mk_res_kind _ = return liftedTypeKind - get_inner_kinds :: TyClDecl Name -> TcM [(Name,TcTyThing)] get_inner_kinds (TyData { tcdCons = cons }) = return [ (unLoc (con_name con), ANothing) | L _ con <- cons ] @@ -334,14 +324,13 @@ getInitialKinds (L _ decl) get_inner_kinds _ = return [] -kcLookupKind :: Located Name -> TcM Kind -kcLookupKind nm = do - tc_ty_thing <- tcLookupLocated nm - case tc_ty_thing of - AThing k -> return k - AGlobal (ATyCon tc) -> return (tyConKind tc) - _ -> pprPanic "kcLookupKind" (ppr tc_ty_thing) - + get_res_kind (ClassDecl {}) = return constraintKind + get_res_kind (TyData { tcdKindSig = Nothing }) = return liftedTypeKind + get_res_kind _ = newMetaKindVar + -- Warning: you might be tempted to return * for all data decls + -- but on GADT-style declarations we allow a kind signature + -- data T :: *->* where { ... } + -- with *no tyClDeclTyVars* ---------------- kcSynDecls :: [SCC (LTyClDecl Name)] -> TcM (TcLclEnv) -- Kind bindings @@ -359,140 +348,94 @@ kcSynDecl1 (CyclicSCC decls) = do { recSynErr decls; failM } -- of out-of-scope tycons kcSynDecl :: TyClDecl Name -> TcM (Name, TcKind) -kcSynDecl decl -- Vanilla type synonyoms only, not family instances +kcSynDecl decl@(TySynonym { tcdTyVars = hs_tvs, tcdLName = L _ name + , tcdSynRhs = rhs }) + -- Vanilla type synonyoms only, not family instances + -- Returns a possibly-unzonked kind = tcAddDeclCtxt decl $ - kcHsTyVars (tcdTyVars decl) $ \ k_tvs -> - do { traceTc "kcd1" (ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl)) - <+> brackets (ppr k_tvs)) - ; (_, rhs_kind) <- kcLHsType (tcdSynRhs decl) - ; traceTc "kcd2" (ppr (tcdName decl)) - ; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs - ; return (tcdName decl, tc_kind) } + tcHsTyVarBndrs (tcdTyVars decl) $ \ k_tvs -> + do { traceTc "kcd1" (ppr name <+> brackets (ppr hs_tvs) + <+> brackets (ppr k_tvs)) + ; (_, rhs_kind) <- tcLHsType rhs + ; traceTc "kcd2" (ppr name) + ; let tc_kind = foldr (mkArrowKind . tyVarKind) rhs_kind k_tvs + ; return (name, tc_kind) } +kcSynDecl decl = pprPanic "kcSynDecl" (ppr decl) ------------------------------------------------------------------------ +kcLTyClDecl :: LTyClDecl Name -> TcM () +kcLTyClDecl (L loc decl) + = setSrcSpan loc $ tcAddDeclCtxt decl $ kcTyClDecl decl + kcTyClDecl :: TyClDecl Name -> TcM () -- This function is used solely for its side effect on kind variables -kcTyClDecl (ForeignType {}) - = return () -kcTyClDecl decl@(TyFamily {}) - = kcFamilyDecl [] decl -- the empty list signals a toplevel decl - -kcTyClDecl decl@(TyData {}) +kcTyClDecl decl@(TyData { tcdLName = L _ name, tcdTyVars = hs_tvs }) = ASSERT2( not . isFamInstDecl $ decl, ppr decl ) -- must not be a family instance - kcTyClDeclBody decl $ \_ -> kcDataDecl decl - -kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) - = kcTyClDeclBody decl $ \ tvs' -> - do { discardResult (kcHsContext ctxt) - ; mapM_ (wrapLocM (kcFamilyDecl tvs')) ats - ; mapM_ (wrapLocM kc_sig) sigs } + kcTyClTyVars name hs_tvs $ \ res_k -> kcDataDecl decl res_k + +kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs + , tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) + = kcTyClTyVars name hs_tvs $ \ res_k -> + do { _ <- tcHsContext ctxt + ; _ <- unifyKind res_k constraintKind + ; mapM_ (wrapLocM kcFamilyDecl) ats + ; mapM_ (wrapLocM kc_sig) sigs } where - kc_sig (TypeSig _ op_ty) = discardResult (kcHsLiftedSigType op_ty) - kc_sig (GenericSig _ op_ty) = discardResult (kcHsLiftedSigType op_ty) + kc_sig (TypeSig _ op_ty) = discardResult (tcHsLiftedType op_ty) + kc_sig (GenericSig _ op_ty) = discardResult (tcHsLiftedType op_ty) kc_sig _ = return () -kcTyClDecl (TySynonym {}) -- Type synonyms are never passed to kcTyClDecl - = panic "kcTyClDecl TySynonym" - --------------------- -kcTyClDeclBody :: TyClDecl Name - -> ([LHsTyVarBndr Name] -> TcM a) - -> TcM a --- getInitialKind has made a suitably-shaped kind for the type or class --- Unpack it, and attribute those kinds to the type variables --- Extend the env with bindings for the tyvars, taken from --- the kind of the tycon/class. Give it to the thing inside, and --- check the result kind matches -kcTyClDeclBody decl thing_inside - = tcAddDeclCtxt decl $ - do { tc_kind <- kcLookupKind (tcdLName decl) - ; let (kinds, _) = splitKindFunTys tc_kind - hs_tvs = tcdTyVars decl - kinded_tvs = ASSERT( length kinds >= length hs_tvs ) - zipWith add_kind hs_tvs kinds - ; tcExtendKindEnvTvs kinded_tvs thing_inside } - where - add_kind (L loc (UserTyVar n _)) k = L loc (UserTyVar n k) - add_kind (L loc (KindedTyVar n hsk _)) k = L loc (KindedTyVar n hsk k) +kcTyClDecl (ForeignType {}) = return () +kcTyClDecl decl@(TyFamily {}) = kcFamilyDecl decl + +kcTyClDecl (TySynonym {}) -- Type synonyms are never passed to kcTyClDecl + = panic "kcTyClDecl TySynonym" -- See Note [Kind checking for type and class decls] ------------------- -- Kind check a data declaration, assuming that we already extended the -- kind environment with the type variables of the left-hand side (these -- kinded type variables are also passed as the second parameter). -- -kcDataDecl :: TyClDecl Name -> TcM () -kcDataDecl (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) - = do { _ <- kcHsContext ctxt - ; _ <- mapM (wrapLocM (kcConDecl new_or_data)) cons - ; return () } -kcDataDecl d = pprPanic "kcDataDecl" (ppr d) +kcDataDecl :: TyClDecl Name -> Kind -> TcM () +kcDataDecl (TyData { tcdND = new_or_data, tcdCtxt = ctxt + , tcdCons = cons, tcdKindSig = mb_kind }) res_k + = do { _ <- tcHsContext ctxt + ; mapM_ (wrapLocM (kcConDecl new_or_data)) cons + ; kcResultKind mb_kind res_k } +kcDataDecl d _ = pprPanic "kcDataDecl" (ppr d) ------------------- -kcConDecl :: NewOrData -> ConDecl Name -> TcM (ConDecl Name) - -- doc comments are typechecked to Nothing here -kcConDecl new_or_data con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs - , con_cxt = ex_ctxt, con_details = details, con_res = res }) +kcConDecl :: NewOrData -> ConDecl Name -> TcM () +kcConDecl new_or_data (ConDecl { con_name = name, con_qvars = ex_tvs + , con_cxt = ex_ctxt, con_details = details, con_res = res }) = addErrCtxt (dataConCtxt name) $ - kcHsTyVars ex_tvs $ \ex_tvs' -> - do { ex_ctxt' <- kcHsContext ex_ctxt - ; details' <- kc_con_details details - ; res' <- case res of - ResTyH98 -> return ResTyH98 - ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') } - ; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt' - , con_details = details', con_res = res' }) } - where - kc_con_details (PrefixCon btys) - = do { btys' <- mapM kc_larg_ty btys - ; return (PrefixCon btys') } - kc_con_details (InfixCon bty1 bty2) - = do { bty1' <- kc_larg_ty bty1 - ; bty2' <- kc_larg_ty bty2 - ; return (InfixCon bty1' bty2') } - kc_con_details (RecCon fields) - = do { fields' <- mapM kc_field fields - ; return (RecCon fields') } - - kc_field (ConDeclField fld bty d) = do { bty' <- kc_larg_ty bty - ; return (ConDeclField fld bty' d) } - - kc_larg_ty bty = case new_or_data of - DataType -> kcHsSigType bty - NewType -> kcHsLiftedSigType bty - -- Can't allow an unlifted type for newtypes, because we're effectively - -- going to remove the constructor while coercing it to a lifted type. - -- And newtypes can't be bang'd + tcHsTyVarBndrs ex_tvs $ \ _ -> + do { _ <- tcHsContext ex_ctxt + ; mapM_ (tcHsConArgType new_or_data) (hsConDeclArgTys details) + ; _ <- tcConRes res + ; return () } ------------------- -- Kind check a family declaration or type family default declaration. -- -kcFamilyDecl :: [LHsTyVarBndr Name] -- tyvars of enclosing class decl if any - -> TyClDecl Name -> TcM () -kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind}) - = kcTyClDeclBody decl $ \tvs' -> - do { mapM_ unifyClassParmKinds tvs' - ; discardResult (scDsLHsMaybeKind kind) } - where - unifyClassParmKinds (L _ tv) - | (n,k) <- hsTyVarNameKind tv - , Just classParmKind <- lookup n classTyKinds - = traceTc "kcFam" (ppr k $$ ppr classParmKind $$ ppr classTyKinds) - >> - let ctxt = ptext ( sLit "When kind checking family declaration") - <+> ppr (tcdLName decl) - in addErrCtxt ctxt $ unifyKind k classParmKind >> return () - | otherwise = return () - classTyKinds = [hsTyVarNameKind tv | L _ tv <- classTvs] - -kcFamilyDecl _ (TySynonym {}) = return () +kcFamilyDecl :: TyClDecl Name -> TcM () +kcFamilyDecl (TyFamily { tcdLName = L _ name, tcdTyVars = hs_tvs + , tcdKindSig = mb_kind}) + = kcTyClTyVars name hs_tvs $ \res_k -> kcResultKind mb_kind res_k + +kcFamilyDecl (TySynonym {}) = return () -- We don't have to do anything here for type family defaults: -- tcClassATs will use tcAssocDecl to check them -kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d) - -------------------- -discardResult :: TcM a -> TcM () -discardResult a = a >> return () +kcFamilyDecl d = pprPanic "kcFamilyDecl" (ppr d) + +------------------ +kcResultKind :: Maybe (LHsKind Name) -> Kind -> TcM () +kcResultKind Nothing res_k + = discardResult (unifyKind res_k liftedTypeKind) +kcResultKind (Just k) res_k + = do { k' <- tcLHsKind k + ; discardResult (unifyKind k' res_k) } \end{code} @@ -577,27 +520,30 @@ tcTyClDecl1 parent _calc_isrec -- "type" synonym declaration tcTyClDecl1 _parent _calc_isrec - (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) + (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = hs_ty}) = ASSERT( isNoParent _parent ) tcTyClTyVars tc_name tvs $ \ tvs' kind -> do - { rhs_ty' <- tcCheckHsType rhs_ty kind - ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') - kind NoParentTyCon + { env <- getLclEnv + ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env)) + ; rhs_ty <- tcCheckLHsType hs_ty kind + ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty + ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty) + kind NoParentTyCon ; return [ATyCon tycon] } -- "newtype" and "data" -- NB: not used for newtype/data instances (whether associated or not) tcTyClDecl1 _parent calc_isrec (TyData { tcdND = new_or_data, tcdCType = cType - , tcdCtxt = ctxt, tcdTyVars = tvs + , tcdCtxt = ctxt, tcdTyVars = tvs , tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons }) = ASSERT( isNoParent _parent ) - let is_rec = calc_isrec tc_name - h98_syntax = consUseH98Syntax cons in tcTyClTyVars tc_name tvs $ \ tvs' kind -> do { extra_tvs <- tcDataKindSig kind - ; let final_tvs = tvs' ++ extra_tvs - ; stupid_theta <- tcHsKindedContext =<< kcHsContext ctxt + ; let is_rec = calc_isrec tc_name + h98_syntax = consUseH98Syntax cons + final_tvs = tvs' ++ extra_tvs + ; stupid_theta <- tcHsContext ctxt ; kind_signatures <- xoptM Opt_KindSignatures ; existential_ok <- xoptM Opt_ExistentialQuantification ; gadt_ok <- xoptM Opt_GADTs @@ -632,11 +578,16 @@ tcTyClDecl1 _parent calc_isrec { (tvs', ctxt', fds', sig_stuff, gen_dm_env) <- tcTyClTyVars class_name tvs $ \ tvs' kind -> do { MASSERT( isConstraintKind kind ) - ; ctxt' <- tcHsKindedContext =<< kcHsContext ctxt - ; fds' <- mapM (addLocM tc_fundep) fundeps + + ; ctxt' <- tcHsContext ctxt + ; ctxt' <- zonkTcTypeToTypes emptyZonkEnv ctxt' + -- Squeeze out any kind unification variables + + ; fds' <- mapM (addLocM tc_fundep) fundeps ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths ; return (tvs', ctxt', fds', sig_stuff, gen_dm_env) } - ; clas <- fixM $ \ clas -> do + + ; clas <- fixM $ \ clas -> do { let -- This little knot is just so we can get -- hold of the name of the class TyCon, which we -- need to look up its recursiveness @@ -644,8 +595,6 @@ tcTyClDecl1 _parent calc_isrec tc_isrec = calc_isrec tycon_name ; at_stuff <- tcClassATs class_name (AssocFamilyTyCon clas) ats at_defs - -- NB: 'ats' only contains "type family" and "data family" declarations - -- and 'at_defs' only contains associated-type defaults ; buildClass False {- Must include unfoldings for selectors -} class_name tvs' ctxt' fds' at_stuff @@ -738,27 +687,28 @@ tcDefaultAssocDecl fam_tc (L loc decl) ; (at_tvs, at_tys, at_rhs) <- tcSynFamInstDecl fam_tc decl ; return (ATD at_tvs at_tys at_rhs loc) } -- We check for well-formedness and validity later, in checkValidClass -------------------------- +------------------------- tcSynFamInstDecl :: TyCon -> TyClDecl Name -> TcM ([TyVar], [Type], Type) +-- Placed here because type family instances appear as +-- default decls in class declarations tcSynFamInstDecl fam_tc (TySynonym { tcdTyVars = tvs, tcdTyPats = Just pats - , tcdSynRhs = rhs }) + , tcdSynRhs = hs_ty }) = do { checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc) - ; let kc_rhs rhs kind = kcCheckLHsType rhs (EK kind (ptext (sLit "Expected"))) - - ; tcFamTyPats fam_tc tvs pats (kc_rhs rhs) + ; tcFamTyPats fam_tc tvs pats + (discardResult . tcCheckLHsType hs_ty) $ \tvs' pats' res_kind -> do - - { rhs' <- kc_rhs rhs res_kind - ; rhs'' <- tcHsKindedType rhs' - - ; return (tvs', pats', rhs'') } } + { rhs_ty <- tcCheckLHsType hs_ty res_kind + ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty + ; traceTc "tcSynFamInstDecl" (ppr fam_tc <+> (ppr tvs' $$ ppr pats' $$ ppr rhs_ty)) + ; return (tvs', pats', rhs_ty) } } tcSynFamInstDecl _ decl = pprPanic "tcSynFamInstDecl" (ppr decl) ------------------------- -- Kind check type patterns and kind annotate the embedded type variables. +-- type instance F [a] = rhs -- -- * Here we check that a type instance matches its kind signature, but we do -- not check whether there is a pattern for each type index; the latter @@ -767,9 +717,9 @@ tcSynFamInstDecl _ decl = pprPanic "tcSynFamInstDecl" (ppr decl) ----------------- tcFamTyPats :: TyCon -> [LHsTyVarBndr Name] -> [LHsType Name] - -> (TcKind -> TcM any) -- Kind checker for RHS + -> (TcKind -> TcM ()) -- Kind checker for RHS -- result is ignored - -> ([KindVar] -> [TcKind] -> Kind -> TcM a) + -> ([TKVar] -> [TcType] -> Kind -> TcM a) -> TcM a -- Check the type patterns of a type or data family instance -- type instance F <pat1> <pat2> = <type> @@ -782,42 +732,41 @@ 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 tyvars pats kind_checker thing_inside - = kcHsTyVars tyvars $ \tvs -> - do { let (fam_kvs, body) = splitForAllTys (tyConKind fam_tc) - - -- A family instance must have exactly the same number of type +tcFamTyPats fam_tc tyvars arg_pats 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 :: * -> * -- type instance F Int y = y -- because then the type (F Int) would be like (\y.y) - ; let fam_arity = tyConArity fam_tc - length fam_kvs - ; checkTc (length pats == fam_arity) $ + ; let (fam_kvs, fam_body) = splitForAllTys (tyConKind fam_tc) + fam_arity = tyConArity fam_tc - length fam_kvs + ; checkTc (length arg_pats == fam_arity) $ wrongNumberOfParmsErr fam_arity -- Instantiate with meta kind vars ; fam_arg_kinds <- mapM (const newMetaKindVar) fam_kvs - ; let body' = substKiWith fam_kvs fam_arg_kinds body - (kinds, resKind) = splitKindFunTysN fam_arity body' - ; typats <- zipWithM kcCheckLHsType pats - [ expArgKind (quotes (ppr fam_tc)) kind n - | (kind,n) <- kinds `zip` [1..]] - - -- Kind check the "thing inside"; this just works by - -- side-effecting any kind unification variables - ; _ <- kind_checker resKind - - -- Type check indexed data type declaration - -- We kind generalize the kind patterns since they contain - -- all the meta kind variables - -- See Note [Quantifying over family patterns] - ; tcTyVarBndrsKindGen tvs $ \tvs' -> do { + ; let (arg_kinds, res_kind) + = splitKindFunTysN fam_arity $ + substKiWith fam_kvs fam_arg_kinds fam_body - ; (t_kvs, fam_arg_kinds') <- kindGeneralizeKinds fam_arg_kinds - ; k_typats <- mapM tcHsKindedType typats + -- Kind-check + ; (tvs, typats) <- tcHsTyVarBndrs tyvars $ \tvs -> do + { typats <- tcHsArgTys (quotes (ppr fam_tc)) arg_pats arg_kinds + ; kind_checker res_kind + ; return (tvs, typats) } - ; thing_inside (t_kvs ++ tvs') (fam_arg_kinds' ++ k_typats) resKind } - } + -- Quantify + -- See Note [Quantifying over family patterns] + ; let tv_kinds = map tyVarKind tvs + ; (kvs, kinds') <- kindGeneralizeKinds (tv_kinds ++ fam_arg_kinds) + ; typats' <- zonkTcTypeToTypes emptyZonkEnv typats + ; res_kind' <- zonkTcTypeToType emptyZonkEnv res_kind + ; let (tv_kinds', fam_arg_kinds') = splitAtList tv_kinds kinds' + tvs' = zipWith setTyVarKind tvs tv_kinds' + tkvs = kvs ++ tvs' -- Kind and type variables + ; traceTc "tcFamPats" (ppr tvs' $$ ppr kvs $$ ppr kinds') + ; tcExtendTyVarEnv tkvs $ + thing_inside tkvs (fam_arg_kinds' ++ typats') res_kind' } \end{code} Note [Quantifying over family patterns] @@ -922,37 +871,75 @@ tcConDecl :: NewOrData -> TcM DataCon tcConDecl new_or_data existential_ok rep_tycon res_tmpl -- Data types - con@(ConDecl {con_name = name}) - = do - { ConDecl { con_qvars = tvs, con_cxt = ctxt - , con_details = details, con_res = res_ty } - <- kcConDecl new_or_data con - ; addErrCtxt (dataConCtxt name) $ - tcTyVarBndrsKindGen tvs $ \ tvs' -> do - { ctxt' <- tcHsKindedContext ctxt - ; checkTc (existential_ok || conRepresentibleWithH98Syntax con) - (badExistential name) - ; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty - ; let - tc_datacon is_infix field_lbls btys - = do { (arg_tys, stricts) <- mapAndUnzipM tcConArg btys - ; buildDataCon (unLoc name) is_infix - stricts field_lbls - univ_tvs ex_tvs eq_preds ctxt' arg_tys - res_ty' rep_tycon } + con@(ConDecl { con_name = name + , con_qvars = tvs, con_cxt = ctxt + , con_details = details, con_res = res_ty }) + = addErrCtxt (dataConCtxt name) $ + do { traceTc "tcConDecl 1" (ppr name) + ; (tvs', stuff) <- tcHsTyVarBndrsGen tvs $ + do { ctxt' <- tcHsContext ctxt + ; details' <- tcConArgs new_or_data details + ; res_ty' <- tcConRes res_ty + ; return (ctxt', details', res_ty') } + + ; let (ctxt', details', res_ty') = stuff + (is_infix, field_lbls, btys') = details' + (arg_tys', stricts) = unzip btys' + + -- Substitute, to account for the kind + -- unifications done by tcHsTyVarBndrsGen + ze = mkTyVarZonkEnv tvs' + + ; traceTc "tcConDecl 2" (ppr name) + ; arg_tys' <- zonkTcTypeToTypes ze arg_tys' + ; ctxt' <- zonkTcTypeToTypes ze ctxt' + ; res_ty' <- case res_ty' of + ResTyH98 -> return ResTyH98 + ResTyGADT ty -> ResTyGADT <$> zonkTcTypeToType ze ty + + ; checkTc (existential_ok || conRepresentibleWithH98Syntax con) + (badExistential name) + + ; let (univ_tvs, ex_tvs, eq_preds, res_ty'') + = rejigConRes res_tmpl tvs' res_ty' + + ; traceTc "tcConDecl 3" (ppr name) + ; buildDataCon (unLoc name) is_infix + stricts field_lbls + univ_tvs ex_tvs eq_preds ctxt' arg_tys' + res_ty'' rep_tycon -- NB: we put data_tc, the type constructor gotten from the -- constructor type signature into the data constructor; -- that way checkValidDataCon can complain if it's wrong. + } - ; traceTc "tcConDecl 2" (ppr name) - ; case details of - PrefixCon btys -> tc_datacon False [] btys - InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2] - RecCon fields -> tc_datacon False field_names btys - where - field_names = map (unLoc . cd_fld_name) fields - btys = map cd_fld_type fields - } } +tcConArgs :: NewOrData -> HsConDeclDetails Name -> TcM (Bool, [Name], [(TcType, HsBang)]) +tcConArgs new_or_data (PrefixCon btys) + = do { btys' <- mapM (tcConArg new_or_data) btys + ; return (False, [], btys') } +tcConArgs new_or_data (InfixCon bty1 bty2) + = do { bty1' <- tcConArg new_or_data bty1 + ; bty2' <- tcConArg new_or_data bty2 + ; return (True, [], [bty1', bty2']) } +tcConArgs new_or_data (RecCon fields) + = do { btys' <- mapM (tcConArg new_or_data) btys + ; return (False, field_names, btys') } + where + field_names = map (unLoc . cd_fld_name) fields + btys = map cd_fld_type fields + +tcConArg :: NewOrData -> LHsType Name -> TcM (TcType, HsBang) +tcConArg new_or_data bty + = do { traceTc "tcConArg 1" (ppr bty) + ; arg_ty <- tcHsConArgType new_or_data bty + ; traceTc "tcConArg 2" (ppr bty) + ; strict_mark <- chooseBoxingStrategy arg_ty (getBangStrictness bty) + ; return (arg_ty, strict_mark) } + +tcConRes :: ResType (LHsType Name) -> TcM (ResType Type) +tcConRes ResTyH98 = return ResTyH98 +tcConRes (ResTyGADT res_ty) = do { res_ty' <- tcHsLiftedType res_ty + ; return (ResTyGADT res_ty') } -- Example -- data instance T (b,c) where @@ -963,26 +950,26 @@ tcConDecl new_or_data existential_ok rep_tycon res_tmpl -- Data types -- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1 -- In this case orig_res_ty = T (e,e) -tcResultType :: ([TyVar], Type) -- Template for result type; e.g. +rejigConRes :: ([TyVar], Type) -- Template for result type; e.g. -- data instance T [a] b c = ... -- gives template ([a,b,c], T [a] b c) -> [TyVar] -- where MkT :: forall x y z. ... - -> ResType Name - -> TcM ([TyVar], -- Universal - [TyVar], -- Existential (distinct OccNames from univs) - [(TyVar,Type)], -- Equality predicates - Type) -- Typechecked return type + -> ResType Type + -> ([TyVar], -- Universal + [TyVar], -- Existential (distinct OccNames from univs) + [(TyVar,Type)], -- Equality predicates + Type) -- Typechecked return type -- We don't check that the TyCon given in the ResTy is -- the same as the parent tycon, because we are in the middle -- of a recursive knot; so it's postponed until checkValidDataCon -tcResultType (tmpl_tvs, res_ty) dc_tvs ResTyH98 - = return (tmpl_tvs, dc_tvs, [], res_ty) +rejigConRes (tmpl_tvs, res_ty) dc_tvs ResTyH98 + = (tmpl_tvs, dc_tvs, [], res_ty) -- In H98 syntax the dc_tvs are the existential ones -- data T a b c = forall d e. MkT ... -- The {a,b,c} are tc_tvs, and {d,e} are dc_tvs -tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty) +rejigConRes (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty) -- E.g. data T [a] b c where -- MkT :: forall x y z. T [(x,y)] z z -- Then we generate @@ -992,8 +979,9 @@ tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty) -- z -- Existentials are the leftover type vars: [x,y] -- So we return ([a,b,z], [x,y], [a~(x,y),b~z], T [(x,y)] z z) - = do { res_ty' <- tcHsKindedType res_ty - ; let Just subst = tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty' + = (univ_tvs, ex_tvs, eq_spec, res_ty) + where + Just subst = tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty -- This 'Just' pattern is sure to match, because if not -- checkValidDataCon will complain first. The 'subst' -- should not be looked at until after checkValidDataCon @@ -1002,20 +990,18 @@ tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty) -- /Lazily/ figure out the univ_tvs etc -- Each univ_tv is either a dc_tv or a tmpl_tv - (univ_tvs, eq_spec) = foldr choose ([], []) tidy_tmpl_tvs - choose tmpl (univs, eqs) - | Just ty <- lookupTyVar subst tmpl - = case tcGetTyVar_maybe ty of - Just tv | not (tv `elem` univs) - -> (tv:univs, eqs) - _other -> (new_tmpl:univs, (new_tmpl,ty):eqs) - where -- see Note [Substitution in template variables kinds] - new_tmpl = updateTyVarKind (substTy subst) tmpl - | otherwise = pprPanic "tcResultType" (ppr res_ty) - ex_tvs = dc_tvs `minusList` univ_tvs - - ; return (univ_tvs, ex_tvs, eq_spec, res_ty') } - where + (univ_tvs, eq_spec) = foldr choose ([], []) tidy_tmpl_tvs + choose tmpl (univs, eqs) + | Just ty <- lookupTyVar subst tmpl + = case tcGetTyVar_maybe ty of + Just tv | not (tv `elem` univs) + -> (tv:univs, eqs) + _other -> (new_tmpl:univs, (new_tmpl,ty):eqs) + where -- see Note [Substitution in template variables kinds] + new_tmpl = updateTyVarKind (substTy subst) tmpl + | otherwise = pprPanic "tcResultType" (ppr res_ty) + ex_tvs = dc_tvs `minusList` univ_tvs + -- NB: tmpl_tvs and dc_tvs are distinct, but -- we want them to be *visibly* distinct, both for -- interface files and general confusion. So rename @@ -1087,13 +1073,6 @@ conRepresentibleWithH98Syntax f _ _ = False ------------------- -tcConArg :: LHsType Name -> TcM (TcType, HsBang) -tcConArg bty - = do { traceTc "tcConArg 1" (ppr bty) - ; arg_ty <- tcHsBangType bty - ; traceTc "tcConArg 2" (ppr bty) - ; strict_mark <- chooseBoxingStrategy arg_ty (getBangStrictness bty) - ; return (arg_ty, strict_mark) } -- We attempt to unbox/unpack a strict field when either: -- (i) The field is marked '!!', or diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index f5d880d8fa..86dee6c400 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -25,7 +25,6 @@ module TcTyDecls( import TypeRep import HsSyn -import RnHsSyn import Class import Type import HscTypes @@ -62,7 +61,7 @@ We check for type synonym and class cycles on the *source* code. Main reasons: a) Otherwise we'd need a special function to extract type-synonym tycons - from a type, whereas we have extractHsTyNames already + from a type, whereas we already have the free vars pinned on the decl b) If we checked for type synonym loops after building the TyCon, we can't do a hoistForAllTys on the type synonym rhs, (else we fall into @@ -111,11 +110,8 @@ synTyConsOfType ty \begin{code} mkSynEdges :: [LTyClDecl Name] -> [(LTyClDecl Name, Name, [Name])] mkSynEdges syn_decls = [ (ldecl, unLoc (tcdLName decl), - mk_syn_edges (tcdSynRhs decl)) + nameSetToList (tcdFVs decl)) | ldecl@(L _ decl) <- syn_decls ] - where - mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs), - not (isTyVarName tc) ] calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)] calcSynCycles = stronglyConnCompFromEdgedVertices . mkSynEdges diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index c94752111c..669545a665 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -41,7 +41,7 @@ module TcType ( -------------------------------- -- Builders - mkPhiTy, mkSigmaTy, + mkPhiTy, mkSigmaTy, mkTcEqPred, -------------------------------- -- Splitters @@ -134,7 +134,7 @@ module TcType ( mkClassPred, mkIPPred, isDictLikeTy, tcSplitDFunTy, tcSplitDFunHead, - mkEqPred, + mkEqPred, -- Type substitutions TvSubst(..), -- Representation visible to a few friends @@ -389,11 +389,7 @@ mkKindName unique = mkSystemName unique kind_var_occ mkMetaKindVar :: Unique -> IORef MetaDetails -> MetaKindVar mkMetaKindVar u r - = mkTcTyVar (mkKindName u) - superKind -- not sure this is right, - -- do we need kind vars for - -- coercions? - (MetaTv TauTv r) + = mkTcTyVar (mkKindName u) superKind (MetaTv TauTv r) kind_var_occ :: OccName -- Just one for all MetaKindVars -- They may be jiggled by tidying @@ -776,6 +772,17 @@ mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau) mkPhiTy :: [PredType] -> Type -> Type mkPhiTy theta ty = foldr mkFunTy ty theta + +mkTcEqPred :: TcType -> TcType -> Type +-- During type checking we build equalities between +-- type variables with OpenKind or ArgKind. Ultimately +-- they will all settle, but we want the equality predicate +-- itself to have kind '*'. I think. +-- +-- But this is horribly delicate: what about type variables +-- that turn out to be bound to Int#? +mkTcEqPred ty1 ty2 + = mkNakedEqPred (defaultKind (typeKind ty1)) ty1 ty2 \end{code} @isTauTy@ tests for nested for-alls. It should not be called on a boxy type. diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 8c1fa17043..b1767b860d 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -650,12 +650,11 @@ unifySigmaTy origin ty1 ty2 (tvs2, body2) = tcSplitForAllTys ty2 ; defer_or_continue (not (equalLength tvs1 tvs2)) $ do { - skol_tvs <- tcInstSkolTyVars tvs1 + (subst1, skol_tvs) <- tcInstSkolTyVars tvs1 -- Get location from monad, not from tvs1 ; let tys = mkTyVarTys skol_tvs - in_scope = mkInScopeSet (mkVarSet skol_tvs) - phi1 = Type.substTy (mkTvSubst in_scope (zipTyEnv tvs1 tys)) body1 - phi2 = Type.substTy (mkTvSubst in_scope (zipTyEnv tvs2 tys)) body2 + phi1 = Type.substTy subst1 body1 + phi2 = Type.substTy (zipTopTvSubst tvs2 tys) body2 skol_info = UnifyForAllSkol skol_tvs phi1 ; (ev_binds, co) <- checkConstraints skol_info skol_tvs [] $ @@ -1161,7 +1160,7 @@ uUnboundKVar kv1 k2@(TyVarTy kv2) uUnboundKVar kv1 non_var_k2 = do { k2' <- zonkTcKind non_var_k2 ; kindOccurCheck kv1 k2' - ; let k2'' = kindSimpleKind k2' + ; let k2'' = defaultKind k2' -- MetaKindVars must be bound only to simple kinds ; writeMetaTyVar kv1 k2'' } @@ -1172,13 +1171,6 @@ kindOccurCheck kv1 k2 -- k2 is zonked then failWithTc (kindOccurCheckErr kv1 k2) else return () -kindSimpleKind :: Kind -> SimpleKind --- (kindSimpleKind k) returns a simple kind k' such that k' <= k -kindSimpleKind k - | isOpenTypeKind k = liftedTypeKind - | isArgTypeKind k = liftedTypeKind - | otherwise = k - mkKindErrorCtxt :: Type -> Type -> Kind -> Kind -> TidyEnv -> TcM (TidyEnv, SDoc) mkKindErrorCtxt ty1 ty2 k1 k2 env0 = let (env1, ty1') = tidyOpenType env0 ty1 diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index 735b3e3e3b..2f22c35b46 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -404,7 +404,7 @@ ppr_co p (AppCo co1 co2) = maybeParen p TyConPrec $ pprCo co1 <+> ppr_co TyConPrec co2 ppr_co p co@(ForAllCo {}) = ppr_forall_co p co ppr_co _ (CoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv) -ppr_co p (AxiomInstCo con cos) = pprTypeNameApp p ppr_co (getName con) cos +ppr_co p (AxiomInstCo con cos) = angleBrackets (pprTypeNameApp p ppr_co (getName con) cos) ppr_co p (TransCo co1 co2) = maybeParen p FunPrec $ ppr_co FunPrec co1 @@ -504,7 +504,7 @@ coVarKind cv -- | Makes a coercion type from two types: the types whose equality -- is proven by the relevant 'Coercion' mkCoercionType :: Type -> Type -> Type -mkCoercionType = curry mkPrimEqType +mkCoercionType = mkPrimEqPred isReflCo :: Coercion -> Bool isReflCo (Refl {}) = True diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 2952912b39..3c85395cbb 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -13,7 +13,7 @@ FamInstEnv: Type checked family instance declarations -- for details module FamInstEnv ( - FamInst(..), FamFlavor(..), famInstAxiom, famInstTyVars, + FamInst(..), FamFlavor(..), famInstAxiom, famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon, famInstLHS, pprFamInst, pprFamInstHdr, pprFamInsts, @@ -124,9 +124,6 @@ dataFamInstRepTyCon fi = case fi_flavor fi of DataFamilyInst tycon -> tycon SynFamilyInst -> pprPanic "dataFamInstRepTyCon" (ppr fi) - -famInstTyVars :: FamInst -> TyVarSet -famInstTyVars = fi_tvs \end{code} \begin{code} @@ -158,7 +155,9 @@ pprFamInstHdr (FamInst {fi_axiom = axiom, fi_flavor = flavor}) | isTyConAssoc fam_tc = empty | otherwise = ptext (sLit "instance") - pprHead = pprTypeApp fam_tc tys + pprHead = sep [ ifPprDebug (ptext (sLit "forall") + <+> pprTvBndrs (coAxiomTyVars axiom)) + , pprTypeApp fam_tc tys ] pprTyConSort = case flavor of SynFamilyInst -> ptext (sLit "type") DataFamilyInst tycon @@ -415,6 +414,7 @@ lookupFamInstEnvConflicts envs fam_inst skol_tvs (ppr tpl_tvs <+> ppr tpl_tys) ) -- Unification will break badly if the variables overlap -- They shouldn't because we allocate separate uniques for them + pprTrace "tcUnifyTys" (ppr tpl_tys $$ ppr match_tys $$ ppr fam_inst) $ case tcUnifyTys instanceBindFun tpl_tys match_tys of Just subst | conflicting old_fam_inst subst -> Just subst _other -> Nothing @@ -490,7 +490,7 @@ lookup_fam_inst_env' match_fun one_sided ie fam tys n_tys = length tys extra_tys = drop arity tys (match_tys, add_extra_tys) - | arity > n_tys = (take arity tys, \res_tys -> res_tys ++ extra_tys) + | arity < n_tys = (take arity tys, \res_tys -> res_tys ++ extra_tys) | otherwise = (tys, \res_tys -> res_tys) -- The second case is the common one, hence functional representation diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 1e99775906..225574d53a 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -122,7 +122,8 @@ instanceDFunId = is_dfun setInstanceDFunId :: ClsInst -> DFunId -> ClsInst setInstanceDFunId ispec dfun - = ASSERT( idType dfun `eqType` idType (is_dfun ispec) ) + = ASSERT2( idType dfun `eqType` idType (is_dfun ispec) + , ppr dfun $$ ppr (idType dfun) $$ ppr (is_dfun ispec) $$ ppr (idType (is_dfun ispec)) ) -- We need to create the cached fields afresh from -- the new dfun id. In particular, the is_tvs in -- the ClsInst must match those in the dfun! diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index 21b029eafd..31c0011db1 100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@ -276,9 +276,12 @@ defaultKind :: Kind -> Kind -- because that would allow a call like (f 3#) as well as (f True), -- and the calling conventions differ. -- This defaulting is done in TcMType.zonkTcTyVarBndr. -defaultKind k - | isSubOpenTypeKind k = liftedTypeKind - | otherwise = k +-- +-- The test is really whether the kind is strictly above '*' +defaultKind (TyConApp kc _args) + | isOpenTypeKindCon kc = ASSERT( null _args ) liftedTypeKind + | isArgTypeKindCon kc = ASSERT( null _args ) liftedTypeKind +defaultKind k = k -- Returns the free kind variables in a kind kiVarsOfKind :: Kind -> VarSet diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 114e3e9cfc..1946f1801c 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -27,7 +27,7 @@ module Type ( -- ** Constructing and deconstructing types mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, - mkAppTy, mkAppTys, splitAppTy, splitAppTys, + mkAppTy, mkAppTys, mkNakedAppTys, splitAppTy, splitAppTys, splitAppTy_maybe, repSplitAppTy_maybe, mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, @@ -48,11 +48,11 @@ module Type ( -- Pred types mkFamilyTyConApp, isDictLikeTy, - mkEqPred, mkClassPred, + mkNakedEqPred, mkEqPred, mkPrimEqPred, + mkClassPred, mkIPPred, noParenPred, isClassPred, isEqPred, isIPPred, - mkPrimEqType, - + -- Deconstructing predicate types PredTree(..), predTreePredType, classifyPredType, getClassPredTys, getClassPredTys_maybe, @@ -131,7 +131,8 @@ module Type ( substKiWith, substKisWith, -- * Pretty-printing - pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll, + pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, + pprTvBndr, pprTvBndrs, pprForAll, pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, pprSourceTyCon, ) where @@ -326,11 +327,8 @@ invariant: use it. \begin{code} -- | Applies a type to another, as in e.g. @k a@ mkAppTy :: Type -> Type -> Type -mkAppTy orig_ty1 orig_ty2 - = mk_app orig_ty1 - where - mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2]) - mk_app _ = AppTy orig_ty1 orig_ty2 +mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2]) +mkAppTy ty1 ty2 = AppTy ty1 ty2 -- Note that the TyConApp could be an -- under-saturated type synonym. GHC allows that; e.g. -- type Foo k = k a -> k a @@ -341,18 +339,14 @@ mkAppTy orig_ty1 orig_ty2 -- but once the type synonyms are expanded all is well mkAppTys :: Type -> [Type] -> Type -mkAppTys orig_ty1 [] = orig_ty1 - -- This check for an empty list of type arguments - -- avoids the needless loss of a type synonym constructor. - -- For example: mkAppTys Rational [] - -- returns to (Ratio Integer), which has needlessly lost - -- the Rational part. -mkAppTys orig_ty1 orig_tys2 - = mk_app orig_ty1 - where - mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2) - -- mkTyConApp: see notes with mkAppTy - mk_app _ = foldl AppTy orig_ty1 orig_tys2 +mkAppTys ty1 [] = ty1 +mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2) +mkAppTys ty1 tys2 = foldl AppTy ty1 tys2 + +mkNakedAppTys :: Type -> [Type] -> Type +mkNakedAppTys ty1 [] = ty1 +mkNakedAppTys (TyConApp tc tys1) tys2 = mkNakedTyConApp tc (tys1 ++ tys2) +mkNakedAppTys ty1 tys2 = foldl AppTy ty1 tys2 ------------- splitAppTy_maybe :: Type -> Maybe (Type, Type) @@ -480,6 +474,16 @@ funArgTy ty = pprPanic "funArgTy" (ppr ty) ~~~~~~~~ \begin{code} +-- | A key function: builds a 'TyConApp' or 'FunTy' as apppropriate to +-- its arguments. Applies its arguments to the constructor from left to right. +mkTyConApp :: TyCon -> [Type] -> Type +mkTyConApp tycon tys + | isFunTyCon tycon, [ty1,ty2] <- tys + = FunTy ty1 ty2 + + | otherwise + = TyConApp tycon tys + -- splitTyConApp "looks through" synonyms, because they don't -- mean a distinct type, but all other type-constructor applications -- including functions are returned as Just .. @@ -832,21 +836,26 @@ Make PredTypes --------------------- Equality types --------------------------------- \begin{code} -- | Creates a type equality predicate -mkEqPred :: (Type, Type) -> PredType -mkEqPred (ty1, ty2) - -- IA0_TODO: The caller should give the kind. - = WARN ( not (k `eqKind` defaultKind k), ppr (k, ty1, ty2) ) +mkNakedEqPred :: Kind -> Type -> Type -> PredType +mkNakedEqPred k ty1 ty2 + = WARN( not (typeKind ty1 `isSubKind` k) || not (typeKind ty2 `isSubKind` k), + ppr k $$ (ppr ty1 <+> dcolon <+> ppr (typeKind ty1)) + $$ (ppr ty2 <+> dcolon <+> ppr (typeKind ty2)) ) + TyConApp eqTyCon [k, ty1, ty2] + +mkEqPred :: Type -> Type -> PredType +mkEqPred ty1 ty2 + = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 ) TyConApp eqTyCon [k, ty1, ty2] - where k = defaultKind (typeKind ty1) --- where k = typeKind ty1 + where + k = typeKind ty1 -mkPrimEqType :: (Type, Type) -> Type -mkPrimEqType (ty1, ty2) - -- IA0_TODO: The caller should give the kind. - = WARN ( not (k `eqKind` defaultKind k), ppr (k, ty1, ty2) ) +mkPrimEqPred :: Type -> Type -> Type +mkPrimEqPred ty1 ty2 + = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 ) TyConApp eqPrimTyCon [k, ty1, ty2] - where k = defaultKind (typeKind ty1) --- where k = typeKind ty1 + where + k = typeKind ty1 \end{code} --------------------- Implicit parameters --------------------------------- @@ -914,7 +923,7 @@ data PredTree = ClassPred Class [Type] predTreePredType :: PredTree -> PredType predTreePredType (ClassPred clas tys) = mkClassPred clas tys -predTreePredType (EqPred ty1 ty2) = mkEqPred (ty1, ty2) +predTreePredType (EqPred ty1 ty2) = mkEqPred ty1 ty2 predTreePredType (IPPred ip ty) = mkIPPred ip ty predTreePredType (TuplePred tys) = mkBoxedTupleTy tys predTreePredType (IrredPred ty) = ty @@ -1540,14 +1549,14 @@ typeKind (TyConApp tc tys) typeKind (AppTy fun arg) = kindAppResult (typeKind fun) [arg] typeKind (ForAllTy _ ty) = typeKind ty typeKind (TyVarTy tyvar) = tyVarKind tyvar -typeKind (FunTy _arg res) +typeKind _ty@(FunTy _arg res) -- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*), -- not unliftedTypKind (#) -- The only things that can be after a function arrow are -- (a) types (of kind openTypeKind or its sub-kinds) -- (b) kinds (of super-kind TY) (e.g. * -> (* -> *)) | isSuperKind k = k - | otherwise = ASSERT( isSubOpenTypeKind k ) liftedTypeKind + | otherwise = ASSERT2( isSubOpenTypeKind k, ppr _ty $$ ppr k ) liftedTypeKind where k = typeKind res diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 9c1a1d71ee..0d1fb27164 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -4,6 +4,16 @@ % \section[TypeRep]{Type - friends' interface} +Note [The Type-related module hierarchy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Class + TyCon imports Class + TypeRep + TysPrim imports TypeRep ( including mkTyConTy ) + Kind imports TysPrim ( mainly for primitive kinds ) + Type imports Kind + Coercion imports Type + \begin{code} {-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. @@ -22,11 +32,11 @@ module TypeRep ( PredType, ThetaType, -- Synonyms -- Functions over types - mkTyConApp, mkTyConTy, mkTyVarTy, mkTyVarTys, + mkNakedTyConApp, mkTyConTy, mkTyVarTy, mkTyVarTys, isLiftedTypeKind, isSuperKind, isTypeVar, isKindVar, -- Pretty-printing - pprType, pprParendType, pprTypeApp, + pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs, pprTyThing, pprTyThingCategory, pprEqPred, pprTheta, pprForAll, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, @@ -59,6 +69,7 @@ import PrelNames import Outputable import FastString import Pair +import StaticFlags( opt_PprStyle_Debug ) -- libraries import qualified Data.Data as Data hiding ( TyCon ) @@ -244,19 +255,17 @@ mkTyVarTy = TyVarTy mkTyVarTys :: [TyVar] -> [Type] mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy --- | A key function: builds a 'TyConApp' or 'FunTy' as apppropriate to its arguments. --- Applies its arguments to the constructor from left to right -mkTyConApp :: TyCon -> [Type] -> Type -mkTyConApp tycon tys - | isFunTyCon tycon, [ty1,ty2] <- tys - = FunTy ty1 ty2 - - | otherwise - = TyConApp tycon tys +mkNakedTyConApp :: TyCon -> [Type] -> Type +-- Builds a TyConApp +-- * without being strict in TyCon, +-- * the TyCon should never be a saturated FunTyCon +-- Type.mkTyConApp is the usual one +mkNakedTyConApp tc tys + = TyConApp (ASSERT( not (isFunTyCon tc && length tys == 2) ) tc) tys -- | Create the plain type constructor type which has been applied to no type arguments at all. mkTyConTy :: TyCon -> Type -mkTyConTy tycon = mkTyConApp tycon [] +mkTyConTy tycon = TyConApp tycon [] \end{code} Some basic functions, put here to break loops eg with the pretty printer @@ -296,6 +305,7 @@ tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg tyVarsOfType (ForAllTy tyvar ty) = delVarSet (tyVarsOfType ty) tyvar + `unionVarSet` tyVarsOfType (tyVarKind tyvar) tyVarsOfTypes :: [Type] -> TyVarSet tyVarsOfTypes tys = foldr (unionVarSet . tyVarsOfType) emptyVarSet tys @@ -572,7 +582,10 @@ ppr_tvar tv -- Note [Infix type variables] ------------------- pprForAll :: [TyVar] -> SDoc pprForAll [] = empty -pprForAll tvs = ptext (sLit "forall") <+> sep (map pprTvBndr tvs) <> dot +pprForAll tvs = ptext (sLit "forall") <+> pprTvBndrs tvs <> dot + +pprTvBndrs :: [TyVar] -> SDoc +pprTvBndrs tvs = sep (map pprTvBndr tvs) pprTvBndr :: TyVar -> SDoc pprTvBndr tv @@ -620,8 +633,10 @@ pprTcApp p pp tc tys = pprPromotionQuote tc <> tupleParens (tupleTyConSort tc) (sep (punctuate comma (map (pp TopPrec) tys))) - | tc `hasKey` eqTyConKey -- We need to special case the type equality TyCon because + | not opt_PprStyle_Debug + , tc `hasKey` eqTyConKey -- We need to special case the type equality TyCon because , [_, ty1,ty2] <- tys -- with kind polymorphism it has 3 args, so won't get printed infix + -- With -dppr-debug switch this off so we can see the kind = pprInfixApp p pp (ppr tc) ty1 ty2 | otherwise |