Commit 451a42dc authored by simonpj's avatar simonpj

[project @ 2002-09-17 13:00:14 by simonpj]

--------------------------------------
	Another attempt to make unbound type
	variables in RULES work right
	--------------------------------------

Sigh.  I'm trying to find the unbound type variables on the LHS of a
RULE.  I thought I could just gather free vars, but that does not work
well on an un-zonked LHS, because a big lambda might bind a type variable
that looks different (pre-zonking) but isn't really.

Oh well, back to plan B which is more work but more robust.

Now the zonking phase (in TcHsSyn) arranges to zonk types in a different
way (zonkTypeCollecting) on a rule LHS than in ordinary expressions
(zonkTypeZapping).  This is less dependent on the exact form of the LHS
(good) but involves another mutable variable (not unclean, but it's sad
to have to admit that mutable variables do sometimes allow you to make
non-invasive changes).
parent 4a486aef
This diff is collapsed.
......@@ -34,9 +34,10 @@ module TcMType (
--------------------------------
-- Zonking
zonkType,
zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV,
zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType,
zonkTcPredType, zonkTcTypeToType, zonkTcTyVarToTyVar, zonkKindEnv,
zonkTcPredType, zonkTcTyVarToTyVar, zonkKindEnv,
) where
......@@ -61,38 +62,33 @@ import TcType ( TcType, TcThetaType, TcTauType, TcPredType,
liftedTypeKind, openTypeKind, defaultKind, superKind,
superBoxity, liftedBoxity, typeKind,
tyVarsOfType, tyVarsOfTypes,
eqKind, isTypeKind, isAnyTypeKind,
eqKind, isTypeKind,
isFFIArgumentTy, isFFIImportResultTy
)
import qualified Type ( splitFunTys )
import Subst ( Subst, mkTopTyVarSubst, substTy )
import Class ( Class, DefMeth(..), classArity, className, classBigSig )
import TyCon ( TyCon, mkPrimTyCon, isSynTyCon, isUnboxedTupleTyCon,
import TyCon ( TyCon, isSynTyCon, isUnboxedTupleTyCon,
tyConArity, tyConName, tyConKind, tyConTheta,
getSynTyConDefn, tyConDataCons )
import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels )
import FieldLabel ( fieldLabelName, fieldLabelType )
import PrimRep ( PrimRep(VoidRep) )
import Var ( TyVar, idType, idName, tyVarKind, tyVarName, isTyVar,
mkTyVar, mkMutTyVar, isMutTyVar, mutTyVarRef )
-- others:
import Generics ( validGenericMethodType )
import TcRnMonad -- TcType, amongst others
import TysWiredIn ( voidTy, listTyCon, tupleTyCon )
import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
import ForeignCall ( Safety(..) )
import FunDeps ( grow )
import PprType ( pprPred, pprSourceType, pprTheta, pprClassPred )
import Name ( Name, NamedThing(..), setNameUnique,
mkInternalName, mkDerivedTyConOcc,
mkSystemTvNameEncoded,
)
import VarSet
import BasicTypes ( Boxity(Boxed) )
import CmdLineOpts ( dopt, DynFlag(..) )
import Unique ( Uniquable(..) )
import SrcLoc ( noSrcLoc )
import Util ( nOfThem, isSingleton, equalLength, notNull )
import ListSetOps ( equivClasses, removeDups )
......@@ -375,68 +371,6 @@ zonkKindEnv pairs
| tyVarKind kv `eqKind` superBoxity = putTcTyVar kv liftedBoxity
| otherwise = pprPanic "zonkKindEnv" (ppr kv)
zonkTcTypeToType :: TcType -> TcM Type
zonkTcTypeToType ty = zonkType zonk_unbound_tyvar ty
where
-- Zonk a mutable but unbound type variable to an arbitrary type
-- We know it's unbound even though we don't carry an environment,
-- because at the binding site for a type variable we bind the
-- mutable tyvar to a fresh immutable one. So the mutable store
-- plays the role of an environment. If we come across a mutable
-- type variable that isn't so bound, it must be completely free.
zonk_unbound_tyvar tv = putTcTyVar tv (mkArbitraryType tv)
-- When the type checker finds a type variable with no binding,
-- which means it can be instantiated with an arbitrary type, it
-- usually instantiates it to Void. Eg.
--
-- length []
-- ===>
-- length Void (Nil Void)
--
-- But in really obscure programs, the type variable might have
-- a kind other than *, so we need to invent a suitably-kinded type.
--
-- This commit uses
-- Void for kind *
-- List for kind *->*
-- Tuple for kind *->...*->*
--
-- which deals with most cases. (Previously, it only dealt with
-- kind *.)
--
-- In the other cases, it just makes up a TyCon with a suitable
-- kind. If this gets into an interface file, anyone reading that
-- file won't understand it. This is fixable (by making the client
-- of the interface file make up a TyCon too) but it is tiresome and
-- never happens, so I am leaving it
mkArbitraryType :: TcTyVar -> Type
-- Make up an arbitrary type whose kind is the same as the tyvar.
-- We'll use this to instantiate the (unbound) tyvar.
mkArbitraryType tv
| isAnyTypeKind kind = voidTy -- The vastly common case
| otherwise = TyConApp tycon []
where
kind = tyVarKind tv
(args,res) = Type.splitFunTys kind -- Kinds are simple; use Type.splitFunTys
tycon | kind `eqKind` tyConKind listTyCon -- *->*
= listTyCon -- No tuples this size
| all isTypeKind args && isTypeKind res
= tupleTyCon Boxed (length args) -- *-> ... ->*->*
| otherwise
= pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
mkPrimTyCon tc_name kind 0 [] VoidRep
-- Same name as the tyvar, apart from making it start with a colon (sigh)
-- I dread to think what will happen if this gets out into an
-- interface file. Catastrophe likely. Major sigh.
tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc
-- zonkTcTyVarToTyVar is applied to the *binding* occurrence
-- of a type variable, at the *end* of type checking. It changes
-- the *mutable* type variable into an *immutable* one.
......
......@@ -34,7 +34,7 @@ import RnHsSyn ( RenamedHsDecl, RenamedStmt, RenamedTyClDecl,
ruleDeclFVs, instDeclFVs, tyClDeclFVs )
import TcHsSyn ( TypecheckedHsExpr, TypecheckedRuleDecl,
zonkTopBinds, zonkTopDecls, mkHsLet,
zonkTopExpr, zonkIdBndr
zonkTopExpr, zonkTopBndrs
)
import TcExpr ( tcExpr_id )
......@@ -410,7 +410,7 @@ tc_stmts names stmts
HsDo DoExpr tc_stmts io_ids
(mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc } ;
zonked_expr <- zonkTopExpr expr ;
zonked_ids <- mappM zonkIdBndr ids ;
zonked_ids <- zonkTopBndrs ids ;
return (zonked_ids, zonked_expr)
}
......
......@@ -87,12 +87,10 @@ tcRule (HsRule name act vars lhs rhs src_loc)
-- RULE: forall v. fst (ss v) = fst v
-- The type of the rhs of the rule is just a, but v::(a,(b,c))
--
-- We also need to get the free tyvars of the LHS; see notes
-- below with ruleLhsTvs.
-- We also need to get the free tyvars of the LHS; but we do that
-- during zonking (see TcHsSyn.zonkRule)
--
forall_tvs = tyVarsOfTypes (rule_ty : map idType tpl_ids)
`unionVarSet`
ruleLhsTvs lhs'
in
-- RHS can be a bit more lenient. In particular,
-- we let constant dictionaries etc float outwards
......@@ -114,48 +112,6 @@ tcRule (HsRule name act vars lhs rhs src_loc)
new_id (RuleBndrSig var rn_ty) = tcHsSigType (RuleSigCtxt var) rn_ty `thenM` \ ty ->
returnM (mkLocalId var ty)
ruleLhsTvs :: TcExpr -> TcTyVarSet
-- We need to gather the type variables mentioned on the LHS so we can
-- quantify over them. Example:
-- data T a = C
--
-- foo :: T a -> Int
-- foo C = 1
--
-- {-# RULES "myrule" foo C = 1 #-}
--
-- After type checking the LHS becomes (foo a (C a))
-- and we do not want to zap the unbound tyvar 'a' to (), because
-- that limits the applicability of the rule. Instead, we
-- want to quantify over it!
--
-- Fortunately the form of the LHS is pretty limited (see RnSource.validRuleLhs)
-- so we don't need to deal with the whole of HsSyn.
--
-- Uh oh! validRuleLhs only checks the function part of rule LHSs!
ruleLhsTvs (HsPar e) = ruleLhsTvs e
ruleLhsTvs (HsLit e) = emptyVarSet
ruleLhsTvs (HsOverLit e) = emptyVarSet
ruleLhsTvs (HsVar v) = emptyVarSet -- I don't think we need the tyvars of the Id
ruleLhsTvs (OpApp e1 op _ e2) = ruleLhsTvs e1 `unionVarSet` ruleLhsTvs op
`unionVarSet` ruleLhsTvs e2
ruleLhsTvs (HsApp e1 e2) = ruleLhsTvs e1 `unionVarSet` ruleLhsTvs e2
ruleLhsTvs (TyApp e1 tys) = ruleLhsTvs e1 `unionVarSet` tyVarsOfTypes tys
ruleLhsTvs (DictApp e ds) = ruleLhsTvs e
ruleLhsTvs (NegApp e _) = ruleLhsTvs e
ruleLhsTvs (ExplicitList ty es) = tyVarsOfType ty `unionVarSet` ruleLhsTvs_s es
ruleLhsTvs (ExplicitTuple es _) = ruleLhsTvs_s es
-- Type abstractions can occur in rules like
-- "foldr k z (build g) = g k z"
ruleLhsTvs (TyLam tvs e) = ruleLhsTvs e `delVarSetList` tvs
ruleLhsTvs (DictLam ids e) = ruleLhsTvs e
ruleLhsTvs e = pprPanic "ruleLhsTvs" (ppr e)
ruleLhsTvs_s es = foldr (unionVarSet . ruleLhsTvs) emptyVarSet es
ruleCtxt name = ptext SLIT("When checking the transformation rule") <+>
doubleQuotes (ftext name)
\end{code}
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment