-zonkCoreBinds :: [(Id, Type, CoreExpr)] -> NF_TcM [(Id, CoreExpr)]
-zonkCoreBinds ls = mapNF_Tc zonkOne ls
- where
- zonkOne (i, t, e) =
- zonkIdOcc i `thenNF_Tc` \ i' ->
- zonkCoreExpr e `thenNF_Tc` \ e' ->
- returnNF_Tc (i',e')
-
--- needed?
-zonkCoreExpr :: CoreExpr -> NF_TcM CoreExpr
-zonkCoreExpr e =
- case e of
- Var i ->
- zonkIdOcc i `thenNF_Tc` \ i' ->
- returnNF_Tc (Var i')
- Lit l -> returnNF_Tc (Lit l)
- App f arg ->
- zonkCoreExpr f `thenNF_Tc` \ f' ->
- zonkCoreExpr arg `thenNF_Tc` \ arg' ->
- returnNF_Tc (App f' arg')
- Lam b e ->
- zonkIdOcc b `thenNF_Tc` \ b' ->
- zonkCoreExpr e `thenNF_Tc` \ e' ->
- returnNF_Tc (Lam b' e')
- Case scrut n alts ->
- zonkCoreExpr scrut `thenNF_Tc` \ scrut' ->
- zonkIdOcc n `thenNF_Tc` \ n' ->
- mapNF_Tc zonkCoreAlt alts `thenNF_Tc` \ alts' ->
- returnNF_Tc (Case scrut' n' alts')
- Let b rhs ->
- zonkCoreBind b `thenNF_Tc` \ b' ->
- zonkCoreExpr rhs `thenNF_Tc` \ rhs' ->
- returnNF_Tc (Let b' rhs')
- Note note e ->
- zonkNote note `thenNF_Tc` \ note' ->
- zonkCoreExpr e `thenNF_Tc` \ e' ->
- returnNF_Tc (Note note' e')
- Type t ->
- zonkTcTypeToType t `thenNF_Tc` \ t' ->
- returnNF_Tc (Type t')
-
-zonkCoreBind :: CoreBind -> NF_TcM CoreBind
-zonkCoreBind (NonRec b e) =
- zonkIdOcc b `thenNF_Tc` \ b' ->
- zonkCoreExpr e `thenNF_Tc` \ e' ->
- returnNF_Tc (NonRec b' e')
-zonkCoreBind (Rec bs) =
- mapNF_Tc zonkIt bs `thenNF_Tc` \ bs' ->
- returnNF_Tc (Rec bs')
- where
- zonkIt (b,e) =
- zonkIdOcc b `thenNF_Tc` \ b' ->
- zonkCoreExpr e `thenNF_Tc` \ e' ->
- returnNF_Tc (b',e')
-
-
-zonkCoreAlt :: CoreAlt -> NF_TcM CoreAlt
-zonkCoreAlt (ac, bs, rhs) =
- mapNF_Tc zonkIdOcc bs `thenNF_Tc` \ bs' ->
- zonkCoreExpr rhs `thenNF_Tc` \ rhs' ->
- returnNF_Tc (ac, bs', rhs')
-
-zonkNote :: Note -> NF_TcM Note
-zonkNote n =
- case n of
- Coerce t f ->
- zonkTcTypeToType t `thenNF_Tc` \ t' ->
- zonkTcTypeToType f `thenNF_Tc` \ f' ->
- returnNF_Tc (Coerce t' f')
- _ -> returnNF_Tc n
+zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
+zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
+
+zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
+-- This variant collects unbound type variables in a mutable variable
+zonkTypeCollecting unbound_tv_set
+ = zonkType zonk_unbound_tyvar
+ where
+ zonk_unbound_tyvar tv
+ = zonkTcTyVarToTyVar tv `thenM` \ tv' ->
+ readMutVar unbound_tv_set `thenM` \ tv_set ->
+ writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_`
+ return (mkTyVarTy tv')
+
+zonkTypeZapping :: TcType -> TcM Type
+-- This variant is used for everything except the LHS of rules
+-- It zaps unbound type variables to (), or some other arbitrary type
+zonkTypeZapping 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 = mkTyConApp 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.