X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMType.lhs;h=2c01d2300a4505c34164414c5f746b6d8f862d7c;hp=74533340f3b846a68cb5d82ae0606f8447675782;hb=febf1ced754a3996ac1a5877dcded87828560d1c;hpb=2c3412138019d6b42a9974f7d8c7853c86ec96d5 diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 7453334..2c01d23 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -26,7 +26,6 @@ module TcMType ( -------------------------------- -- Creating new evidence variables newEvVar, newCoVar, newEvVars, - writeWantedCoVar, readWantedCoVar, newIP, newDict, newSilentGiven, isSilentEvVar, newWantedEvVar, newWantedEvVars, @@ -34,8 +33,8 @@ module TcMType ( -------------------------------- -- Instantiation - tcInstTyVar, tcInstTyVars, tcInstSigTyVars, - tcInstType, instMetaTyVar, + tcInstTyVars, tcInstSigTyVars, + tcInstType, tcInstSkolTyVars, tcInstSuperSkolTyVars, tcInstSkolTyVar, tcInstSkolType, tcSkolDFunType, tcSuperSkolTyVars, @@ -43,16 +42,15 @@ module TcMType ( -- Checking type validity Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType, SourceTyCtxt(..), checkValidTheta, - checkValidInstance, - checkValidTypeInst, checkTyFamFreeness, + checkValidInstHead, checkValidInstance, + checkInstTermination, checkValidTypeInst, checkTyFamFreeness, arityErr, growPredTyVars, growThetaTyVars, validDerivPred, -------------------------------- -- Zonking zonkType, mkZonkTcTyVar, zonkTcPredType, - zonkTcTypeCarefully, - skolemiseUnboundMetaTyVar, + zonkTcTypeCarefully, skolemiseUnboundMetaTyVar, zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkSigTyVar, zonkQuantifiedTyVar, zonkQuantifiedTyVars, zonkTcType, zonkTcTypes, zonkTcThetaType, @@ -72,7 +70,6 @@ module TcMType ( import TypeRep import TcType import Type -import Coercion import Class import TyCon import Var @@ -145,7 +142,7 @@ newEvVar (IParam ip ty) = newIP ip ty newCoVar :: TcType -> TcType -> TcM CoVar newCoVar ty1 ty2 - = do { name <- newName (mkTyVarOccFS (fsLit "co")) + = do { name <- newName (mkVarOccFS (fsLit "co")) ; return (mkCoVar name (mkPredTy (EqPred ty1 ty2))) } newIP :: IPName Name -> TcType -> TcM IpId @@ -258,8 +255,17 @@ tcInstSkolType ty = tcInstType tcInstSkolTyVars ty tcInstSigTyVars :: [TyVar] -> TcM [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 -tcInstSigTyVars = mapM (\tv -> instMetaTyVar (SigTv (tyVarName tv)) tv) - -- ToDo: the "function binding site is bogus +tcInstSigTyVars = mapM tcInstSigTyVar + +tcInstSigTyVar :: TyVar -> TcM TcTyVar +tcInstSigTyVar tyvar + = do { uniq <- newMetaUnique + ; ref <- newMutVar Flexi + ; let name = setNameUnique (tyVarName tyvar) uniq + -- Use the same OccName so that the tidy-er + -- doesn't rename 'a' to 'a0' etc + kind = tyVarKind tyvar + ; return (mkTcTyVar name kind (MetaTv SigTv ref)) } \end{code} @@ -277,9 +283,9 @@ newMetaTyVar meta_info kind ; ref <- newMutVar Flexi ; let name = mkTcTyVarName uniq s s = case meta_info of - TauTv -> fsLit "t" - TcsTv -> fsLit "u" - SigTv _ -> fsLit "a" + TauTv -> fsLit "t" + TcsTv -> fsLit "u" + SigTv -> fsLit "a" ; return (mkTcTyVar name kind (MetaTv meta_info ref)) } mkTcTyVarName :: Unique -> FastString -> Name @@ -287,24 +293,10 @@ mkTcTyVarName :: Unique -> FastString -> Name -- leaving the un-cluttered names free for user names mkTcTyVarName uniq str = mkSysTvName uniq str -instMetaTyVar :: MetaInfo -> TyVar -> TcM TcTyVar --- Make a new meta tyvar whose Name and Kind --- come from an existing TyVar -instMetaTyVar meta_info tyvar - = do { uniq <- newMetaUnique - ; ref <- newMutVar Flexi - ; let name = mkSystemName uniq (getOccName tyvar) - kind = tyVarKind tyvar - ; return (mkTcTyVar name kind (MetaTv meta_info ref)) } - readMetaTyVar :: TyVar -> TcM MetaDetails readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar ) readMutVar (metaTvRef tyvar) -readWantedCoVar :: CoVar -> TcM MetaDetails -readWantedCoVar covar = ASSERT2( isMetaTyVar covar, ppr covar ) - readMutVar (metaTvRef covar) - isFilledMetaTyVar :: TyVar -> TcM Bool -- True of a filled-in (Indirect) meta type variable isFilledMetaTyVar tv @@ -343,9 +335,6 @@ writeMetaTyVar tyvar ty = WARN( True, text "Writing to non-meta tyvar" <+> ppr tyvar ) return () -writeWantedCoVar :: CoVar -> Coercion -> TcM () -writeWantedCoVar cv co = writeMetaTyVar cv co - -------------------- writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM () -- Here the tyvar is for error checking only; @@ -394,10 +383,6 @@ newFlexiTyVarTy kind = do newFlexiTyVarTys :: Int -> Kind -> TcM [TcType] newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind) -tcInstTyVar :: TyVar -> TcM TcTyVar --- Instantiate with a META type variable -tcInstTyVar tyvar = instMetaTyVar TauTv tyvar - tcInstTyVars :: [TyVar] -> TcM ([TcTyVar], [TcType], TvSubst) -- Instantiate with META type variables tcInstTyVars tyvars @@ -407,6 +392,16 @@ tcInstTyVars tyvars -- Since the tyvars are freshly made, -- they cannot possibly be captured by -- any existing for-alls. Hence zipTopTvSubst + +tcInstTyVar :: TyVar -> TcM TcTyVar +-- Make a new unification variable tyvar whose Name and Kind +-- come from an existing TyVar +tcInstTyVar tyvar + = do { uniq <- newMetaUnique + ; ref <- newMutVar Flexi + ; let name = mkSystemName uniq (getOccName tyvar) + kind = tyVarKind tyvar + ; return (mkTcTyVar name kind (MetaTv TauTv ref)) } \end{code} @@ -622,8 +617,8 @@ zonkWantedEvVar :: WantedEvVar -> TcM WantedEvVar zonkWantedEvVar (EvVarX v l) = do { v' <- zonkEvVar v; return (EvVarX v' l) } zonkFlavor :: CtFlavor -> TcM CtFlavor -zonkFlavor (Given loc) = do { loc' <- zonkGivenLoc loc; return (Given loc') } -zonkFlavor fl = return fl +zonkFlavor (Given loc gk) = do { loc' <- zonkGivenLoc loc; return (Given loc' gk) } +zonkFlavor fl = return fl zonkGivenLoc :: GivenLoc -> TcM GivenLoc -- GivenLocs may have unification variables inside them! @@ -745,13 +740,12 @@ zonkType zonk_tc_tyvar ty -- The two interesting cases! go (TyVarTy tyvar) | isTcTyVar tyvar = zonk_tc_tyvar tyvar - | otherwise = liftM TyVarTy $ - zonkTyVar zonk_tc_tyvar tyvar + | otherwise = return (TyVarTy tyvar) -- Ordinary (non Tc) tyvars occur inside quantified types go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar ) do ty' <- go ty - tyvar' <- zonkTyVar zonk_tc_tyvar tyvar + tyvar' <- return tyvar return (ForAllTy tyvar' ty') go_pred (ClassP c tys) = do tys' <- mapM go tys @@ -774,16 +768,6 @@ mkZonkTcTyVar unbound_var_fn tyvar ; case cts of Flexi -> unbound_var_fn tyvar Indirect ty -> zonkType (mkZonkTcTyVar unbound_var_fn) ty } - --- Zonk the kind of a non-TC tyvar in case it is a coercion variable --- (their kind contains types). -zonkTyVar :: (TcTyVar -> TcM Type) -- What to do for a TcTyVar - -> TyVar -> TcM TyVar -zonkTyVar zonk_tc_tyvar tv - | isCoVar tv - = do { kind <- zonkType zonk_tc_tyvar (tyVarKind tv) - ; return $ setTyVarKind tv kind } - | otherwise = return tv \end{code} @@ -1154,7 +1138,7 @@ check_valid_theta ctxt theta = do warnTc (notNull dups) (dupPredWarn dups) mapM_ (check_pred_ty dflags ctxt) theta where - (_,dups) = removeDups tcCmpPred theta + (_,dups) = removeDups cmpPred theta ------------------------- check_pred_ty :: DynFlags -> SourceTyCtxt -> PredType -> TcM () @@ -1276,7 +1260,7 @@ checkAmbiguity forall_tyvars theta tau_tyvars ambigErr :: PredType -> SDoc ambigErr pred - = sep [ptext (sLit "Ambiguous constraint") <+> quotes (pprPred pred), + = sep [ptext (sLit "Ambiguous constraint") <+> quotes (pprPredTy pred), nest 2 (ptext (sLit "At least one of the forall'd type variables mentioned by the constraint") $$ ptext (sLit "must be reachable from the type after the '=>'"))] \end{code} @@ -1343,14 +1327,14 @@ eqSuperClassErr pred 2 (ppr pred) badPredTyErr, eqPredTyErr, predTyVarErr :: PredType -> SDoc -badPredTyErr pred = ptext (sLit "Illegal constraint") <+> pprPred pred -eqPredTyErr pred = ptext (sLit "Illegal equational constraint") <+> pprPred pred +badPredTyErr pred = ptext (sLit "Illegal constraint") <+> pprPredTy pred +eqPredTyErr pred = ptext (sLit "Illegal equational constraint") <+> pprPredTy pred $$ parens (ptext (sLit "Use -XTypeFamilies to permit this")) predTyVarErr pred = sep [ptext (sLit "Non type-variable argument"), - nest 2 (ptext (sLit "in the constraint:") <+> pprPred pred)] + nest 2 (ptext (sLit "in the constraint:") <+> pprPredTy pred)] dupPredWarn :: [[PredType]] -> SDoc -dupPredWarn dups = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups) +dupPredWarn dups = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas pprPredTy (map head dups) arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc arityErr kind name n m @@ -1498,7 +1482,7 @@ checkInstTermination tys theta predUndecErr :: PredType -> SDoc -> SDoc predUndecErr pred msg = sep [msg, - nest 2 (ptext (sLit "in the constraint:") <+> pprPred pred)] + nest 2 (ptext (sLit "in the constraint:") <+> pprPredTy pred)] nomoreMsg, smallerMsg, undecidableMsg :: SDoc nomoreMsg = ptext (sLit "Variable occurs more often in a constraint than in the instance head")