[commit: ghc] master: Use mapAccumL when performing kind and type instantiation (e944915)
José Pedro Magalhães
jpm at cs.uu.nl
Mon Nov 14 15:47:55 CET 2011
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 <jpm at cs.uu.nl>
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
More information about the Cvs-ghc
mailing list