[commit: ghc] ghc-kinds: Partially fix kind abstraction for RULES. (fe25312)
José Pedro Magalhães
jpm at cs.uu.nl
Thu Oct 20 15:30:01 CEST 2011
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : ghc-kinds
http://hackage.haskell.org/trac/ghc/changeset/fe2531222b24ddcf21f95b57a2a20278880fdac2
>---------------------------------------------------------------
commit fe2531222b24ddcf21f95b57a2a20278880fdac2
Author: Jose Pedro Magalhaes <jpm at cs.uu.nl>
Date: Thu Oct 20 14:28:51 2011 +0100
Partially fix kind abstraction for RULES.
Also, improve debug warnings for ill-kinded metavariable updates.
>---------------------------------------------------------------
compiler/typecheck/TcHsSyn.lhs | 21 ++++++++++++---------
compiler/typecheck/TcHsType.lhs | 6 +++---
compiler/typecheck/TcMType.lhs | 29 ++++++++++++++++-------------
3 files changed, 31 insertions(+), 25 deletions(-)
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index b44414f..6735e16 100755
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -997,23 +997,25 @@ zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
= do { (env_rhs, new_bndrs) <- mapAccumLM zonk_bndr env vars
- ; unbound_tv_set <- newMutVar emptyVarSet
- ; let env_lhs = setZonkType env_rhs (\_ -> zonkTypeCollecting unbound_tv_set)
+ ; unbound_tkv_set <- newMutVar emptyVarSet
+ ; let env_lhs = setZonkType env_rhs (\_ -> zonkTypeCollecting unbound_tkv_set)
-- See Note [Zonking the LHS of a RULE]
; new_lhs <- zonkLExpr env_lhs lhs
; new_rhs <- zonkLExpr env_rhs rhs
- ; unbound_tvs <- readMutVar unbound_tv_set
+ ; unbound_tkvs <- readMutVar unbound_tkv_set
+
-- We want to make sure that all kind variables are zonked
- ; zonked_unbound_tvs <- zonkTcTyVarsAndFV unbound_tvs
+ ; let zonkTcKiTyVars vars = map (getTyVar "zonkRule zonkTcKiTyVars")
+ <$> zonkTcTyVars (varSetElemsKvsFirst vars)
+ ; zonked_unbound_tkvs <- zonkTcKiTyVars unbound_tkvs
; let final_bndrs :: [RuleBndr Var]
- final_bndrs = map (RuleBndr . noLoc)
- (varSetElemsKvsFirst zonked_unbound_tvs)
+ final_bndrs = map (RuleBndr . noLoc) zonked_unbound_tkvs
++ new_bndrs
- ; pprTrace "zonkRule" (ppr (unbound_tvs, zonked_unbound_tvs))
- $ return (HsRule name act final_bndrs new_lhs fv_lhs new_rhs fv_rhs) }
+ ; {- pprTrace "zonkRule" (ppr (unbound_tkvs, zonked_unbound_tkvs))
+ $ -} return (HsRule name act final_bndrs new_lhs fv_lhs new_rhs fv_rhs) }
where
zonk_bndr env (RuleBndr (L loc v))
= do { (env', v') <- zonk_it env v; return (env', RuleBndr (L loc v')) }
@@ -1163,7 +1165,8 @@ zonkTypeCollecting unbound_tv_set
where
zonk_unbound_tyvar tv
= do { tv' <- zonkQuantifiedTyVar tv
- ; tv_set <- pprTrace "zonkTypeCollecting" (ppr (tv,tv')) $ readMutVar unbound_tv_set
+ ; tv_set <- {- pprTrace "zonkTypeCollecting" (ppr (tv,tv'))
+ $ -} readMutVar unbound_tv_set
; writeMutVar unbound_tv_set (extendVarSet tv_set tv')
; return (mkTyVarTy tv') }
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 49ada59..a2b0e8b 100755
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -823,9 +823,9 @@ tcTyVarBndrs bndrs thing_inside = do
tcExtendTyVarEnv tyvars (thing_inside tyvars)
where
zonk (name, kind)
- = do { -- kind' <- zonkTcKindToKind anyKind kind -- JPM
- checkTc (noHashInKind kind) (ptext (sLit "Kind signature contains # or (#)"))
- ; return (mkTyVar name kind) }
+ = do { kind' <- zonkTcKind kind -- JPM
+ ; checkTc (noHashInKind kind') (ptext (sLit "Kind signature contains # or (#)"))
+ ; return (mkTyVar name kind') }
tcTyVarBndrsKindGen :: [LHsTyVarBndr Name] -> ([TyVar] -> TcM r) -> TcM r
-- tcTyVarBndrsKindGen [(f :: ?k -> *), (a :: ?k)] thing_inside
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 06d98e2..61d2780 100755
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -367,22 +367,27 @@ writeMetaTyVarRef tyvar ref ty
; writeMutVar ref (Indirect ty) }
-- Everything from here on only happens if DEBUG is on
- | not (isPredTy tv_kind) -- Don't check kinds for updates to coercion variables
- , not (ty_kind `isSubKind` tv_kind)
- -- IA0_TODO: the kind are not zonked sometimes
- = WARN( True, hang (text "Ill-kinded update to meta tyvar")
- 2 (ppr tyvar $$ ppr tv_kind $$ ppr ty $$ ppr ty_kind) )
- do { traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty)
- ; writeMutVar ref (Indirect ty) }
-
| otherwise
= do { meta_details <- readMutVar ref;
+ -- Zonk kinds before updating
+ ; zonked_tv_kind <- zonkTcKind tv_kind -- JPM: move up
+ ; zonked_ty_kind <- zonkTcKind ty_kind
+
+ -- Check for double updates
; ASSERT2( isFlexi meta_details,
hang (text "Double update of meta tyvar")
2 (ppr tyvar $$ ppr meta_details) )
traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty)
- ; writeMutVar ref (Indirect ty) }
+ ; writeMutVar ref (Indirect ty)
+ ; when ( not (isPredTy tv_kind)
+ -- Don't check kinds for updates to coercion variables
+ && not (zonked_ty_kind `isSubKind` zonked_tv_kind))
+ $ WARN( True, hang (text "Ill-kinded update to meta tyvar")
+ 2 ( ppr tyvar <+> text "::" <+> ppr tv_kind
+ <+> text ":="
+ <+> ppr ty <+> text "::" <+> ppr ty_kind) )
+ (return ()) }
where
tv_kind = tyVarKind tyvar
ty_kind = typeKind ty
@@ -577,8 +582,7 @@ zonkQuantifiedTyVar :: TcTyVar -> TcM TcTyVar
--
-- We leave skolem TyVars alone; they are immutable.
zonkQuantifiedTyVar tv
- = pprTrace "zonkQuantifiedTyVar" (ppr tv) $
- ASSERT2( isTcTyVar tv, ppr tv )
+ = ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
SkolemTv {} -> WARN( True, ppr tv ) -- Dec10: Can this really happen?
do { kind <- zonkTcKind (tyVarKind tv)
@@ -616,8 +620,7 @@ skolemiseUnboundMetaTyVar tv details
; (if isSuperKind final_kind
then writeMetaKindVar
else writeMetaTyVar) tv (mkTyVarTy final_tv)
- ; pprTrace "skolemiseUnboundMetaTyVar" (ppr (tyVarKind tv, final_kind))
- $ return final_tv }
+ ; return final_tv }
\end{code}
\begin{code}
More information about the Cvs-ghc
mailing list