Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/e9449158567f44d909c184d0e666ec130978757f >--------------------------------------------------------------- commit e9449158567f44d909c184d0e666ec130978757f Author: Jose Pedro Magalhaes <[email protected]> Date: Mon Nov 14 10:38:55 2011 +0000 Use mapAccumL when performing kind and type instantiation >--------------------------------------------------------------- compiler/typecheck/TcMType.lhs | 89 +++++++++++++++++++--------------------- compiler/typecheck/TcPat.lhs | 7 +-- 2 files changed, 44 insertions(+), 52 deletions(-) diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 3f88cbb..29ec51c 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -42,7 +42,9 @@ module TcMType ( -- Instantiation tcInstTyVars, tcInstSigTyVars, tcInstType, - tcInstSkolTyVars, tcInstSuperSkolTyVars, tcInstSkolTyVar, tcInstSkolType, + tcInstSkolTyVars, tcInstSuperSkolTyVars, + tcInstSkolTyVarsX, tcInstSuperSkolTyVarsX, + tcInstSkolTyVar, tcInstSkolType, tcSkolDFunType, tcSuperSkolTyVars, -------------------------------- @@ -102,7 +104,7 @@ import Unique( Unique ) import Bag import Control.Monad -import Data.List ( (\\), partition ) +import Data.List ( (\\), partition, mapAccumL ) \end{code} @@ -210,51 +212,47 @@ tcSuperSkolTyVars :: [TyVar] -> [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] -tcSuperSkolTyVars tyvars -- IA0_NOTE: should be ordered (kind vars first) - = kvs' ++ tvs' +-- Precondition: tyvars should be ordered (kind vars first) +tcSuperSkolTyVars = snd . mapAccumL tcSuperSkolTyVar (mkTopTvSubst []) + +tcSuperSkolTyVar :: TvSubst -> TyVar -> (TvSubst, TcTyVar) +tcSuperSkolTyVar subst tv + = (extendTvSubst subst tv (mkTyVarTy new_tv), new_tv) where - (kvs, tvs) = splitKiTyVars tyvars - kvs' = [ mkTcTyVar (tyVarName kv) (tyVarKind kv) superSkolemTv - | kv <- kvs ] - tvs' = [ mkTcTyVar (tyVarName tv) (substTy subst (tyVarKind tv)) superSkolemTv - | tv <- tvs ] - subst = zipTopTvSubst kvs (map mkTyVarTy kvs') - -tcInstSkolTyVar :: Bool -> TvSubst -> TyVar -> TcM TcTyVar + kind = substTy subst (tyVarKind tv) + new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv + +tcInstSkolTyVar :: Bool -> TvSubst -> TyVar -> TcM (TvSubst, TcTyVar) -- Instantiate the tyvar, using --- * the occ-name and kind of the supplied tyvar, --- * the unique from the monad, --- * the location either from the tyvar (skol_info = SigSkol) +-- * the occ-name and kind of the supplied tyvar, +-- * the unique from the monad, +-- * the location either from the tyvar (skol_info = SigSkol) -- or from the monad (otherwise) tcInstSkolTyVar overlappable subst tyvar - = do { uniq <- newUnique - ; loc <- getSrcSpanM - ; let new_name = mkInternalName uniq occ loc - ; return (mkTcTyVar new_name kind (SkolemTv overlappable)) } + = do { uniq <- newUnique + ; loc <- getSrcSpanM + ; let new_name = mkInternalName uniq occ loc + new_tv = mkTcTyVar new_name kind (SkolemTv overlappable) + ; return (extendTvSubst subst tyvar (mkTyVarTy new_tv), new_tv) } where old_name = tyVarName tyvar occ = nameOccName old_name kind = substTy subst (tyVarKind tyvar) -tcInstSkolTyVars :: [TyVar] -> TcM [TcTyVar] +tcInstSkolTyVars' :: Bool -> TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar]) -- Precondition: tyvars should be ordered (kind vars first) -- see Note [Kind substitution when instantiating] -tcInstSkolTyVars tyvars - = do { kvs' <- mapM (tcInstSkolTyVar False (mkTopTvSubst [])) kvs - ; tvs' <- mapM (tcInstSkolTyVar False (zipTopTvSubst kvs (map mkTyVarTy kvs'))) tvs - ; return (kvs' ++ tvs') } - where (kvs, tvs) = splitKiTyVars tyvars +tcInstSkolTyVars' isSuperSkol = mapAccumLM (tcInstSkolTyVar isSuperSkol) -tcInstSuperSkolTyVars :: [TyVar] -> TcM [TcTyVar] --- Precondition: tyvars should be ordered (kind vars first) --- see Note [Kind substitution when instantiating] +-- Wrappers +tcInstSkolTyVars, tcInstSuperSkolTyVars :: [TyVar] -> TcM [TcTyVar] +tcInstSkolTyVars = fmap snd . tcInstSkolTyVars' False (mkTopTvSubst []) +tcInstSuperSkolTyVars = fmap snd . tcInstSkolTyVars' True (mkTopTvSubst []) --- JPM: do this with mapAccumLM -tcInstSuperSkolTyVars tyvars - = do { kvs' <- mapM (tcInstSkolTyVar True (mkTopTvSubst [])) kvs - ; tvs' <- mapM (tcInstSkolTyVar True (zipTopTvSubst kvs (map mkTyVarTy kvs'))) tvs - ; return (kvs' ++ tvs') } - where (kvs, tvs) = splitKiTyVars tyvars +tcInstSkolTyVarsX, tcInstSuperSkolTyVarsX + :: TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar]) +tcInstSkolTyVarsX subst = tcInstSkolTyVars' False subst +tcInstSuperSkolTyVarsX subst = tcInstSkolTyVars' True subst tcInstSkolType :: TcType -> TcM ([TcTyVar], TcThetaType, TcType) -- Instantiate a type with fresh skolem constants @@ -266,21 +264,18 @@ tcInstSigTyVars :: [TyVar] -> TcM [TcTyVar] -- 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 tyvars - = do { kvs' <- mapM (tcInstSigTyVar (mkTopTvSubst [])) kvs - ; tvs' <- mapM (tcInstSigTyVar (zipTopTvSubst kvs (map mkTyVarTy kvs'))) tvs - ; return (kvs' ++ tvs') } - where (kvs, tvs) = splitKiTyVars tyvars - -tcInstSigTyVar :: TvSubst -> TyVar -> TcM TcTyVar -tcInstSigTyVar subst tyvar +tcInstSigTyVars = fmap snd . mapAccumLM tcInstSigTyVar (mkTopTvSubst []) + +tcInstSigTyVar :: TvSubst -> TyVar -> TcM (TvSubst, TcTyVar) +tcInstSigTyVar subst tv = 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 = substTy subst (tyVarKind tyvar) - ; return (mkTcTyVar name kind (MetaTv SigTv ref)) } + ; let name = setNameUnique (tyVarName tv) uniq + -- Use the same OccName so that the tidy-er + -- doesn't rename 'a' to 'a0' etc + kind = substTy subst (tyVarKind tv) + new_tv = mkTcTyVar name kind (MetaTv SigTv ref) + ; return (extendTvSubst subst tv (mkTyVarTy new_tv), new_tv) } \end{code} Note [Kind substitution when instantiating] diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 4204564..c9a67aa 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -672,17 +672,14 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys ; checkExistentials ex_tvs penv - ; ex_tvs' <- tcInstSuperSkolTyVars ex_tvs --- JPM: call the X version, with initial subt (univ_tvs -> ctxt_res_tys) --- return tenv + ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX + (zipTopTvSubst univ_tvs ctxt_res_tys) ex_tvs -- Get location from monad, not from ex_tvs ; let pat_ty' = mkTyConApp tycon ctxt_res_tys -- pat_ty' is type of the actual constructor application -- pat_ty' /= pat_ty iff coi /= IdCo - tenv = zipTopTvSubst (univ_tvs ++ ex_tvs) - (ctxt_res_tys ++ mkTyVarTys ex_tvs') arg_tys' = substTys tenv arg_tys ; if null ex_tvs && null eq_spec && null theta _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
