2 #include "HsVersions.h"
8 newTyVarTy, -- Kind -> NF_TcM s (TcType s)
9 newTyVarTys, -- Int -> Kind -> NF_TcM s [TcType s]
14 -----------------------------------------
15 TcType(..), TcMaybe(..),
16 TcTauType(..), TcThetaType(..), TcRhoType(..),
18 -- Find the type to which a type variable is bound
19 tcWriteTyVar, -- :: TcTyVar s -> TcType s -> NF_TcM (TcType s)
20 tcReadTyVar, -- :: TcTyVar s -> NF_TcM (TcMaybe s)
25 tcInstType, tcInstSigType, tcInstTcType, tcInstSigTcType,
26 tcInstTheta, tcInstId,
39 import Type ( SYN_IE(Type), SYN_IE(ThetaType), GenType(..),
40 tyVarsOfTypes, getTyVar_maybe,
41 splitForAllTy, splitRhoTy,
42 mkForAllTys, instantiateTy
44 import TyVar ( SYN_IE(TyVar), GenTyVar(..), SYN_IE(TyVarSet), SYN_IE(GenTyVarSet),
45 SYN_IE(TyVarEnv), lookupTyVarEnv, addOneToTyVarEnv,
46 nullTyVarEnv, mkTyVarEnv,
51 import Class ( GenClass )
54 import TcKind ( TcKind )
55 import TcMonad hiding ( rnMtoTcM )
56 import Usage ( SYN_IE(Usage), GenUsage, SYN_IE(UVar), duffUsage )
58 import TysPrim ( voidTy )
61 import Unique ( Unique )
62 import UniqFM ( UniqFM )
63 import Maybes ( assocMaybe )
64 import Util ( zipEqual, nOfThem, panic, pprPanic, pprTrace{-ToDo:rm-} )
66 import Outputable ( Outputable(..) ) -- Debugging messages
67 import PprType ( GenTyVar, GenType )
68 import Pretty -- ditto
69 import PprStyle ( PprStyle(..) ) -- ditto
78 type TcType s = GenType (TcTyVar s) UVar -- Used during typechecker
79 -- Invariant on ForAllTy in TcTypes:
81 -- a cannot occur inside a MutTyVar in T; that is,
82 -- T is "flattened" before quantifying over a
84 type TcThetaType s = [(Class, TcType s)]
85 type TcRhoType s = TcType s -- No ForAllTys
86 type TcTauType s = TcType s -- No DictTys or ForAllTys
88 type Box s = MutableVar s (TcMaybe s)
90 data TcMaybe s = UnBound
92 | DontBind -- This variant is used for tyvars
93 -- arising from type signatures, or
94 -- existentially quantified tyvars;
95 -- The idea is that we must not unify
96 -- such tyvars with anything except
99 -- Interestingly, you can't use (Maybe (TcType s)) instead of (TcMaybe s),
100 -- because you get a synonym loop if you do!
102 type TcTyVar s = GenTyVar (Box s)
103 type TcTyVarSet s = GenTyVarSet (Box s)
107 tcTyVarToTyVar :: TcTyVar s -> TyVar
108 tcTyVarToTyVar (TyVar uniq kind name _) = TyVar uniq kind name duffUsage
115 newTcTyVar :: Kind -> NF_TcM s (TcTyVar s)
117 = tcGetUnique `thenNF_Tc` \ uniq ->
118 tcNewMutVar UnBound `thenNF_Tc` \ box ->
119 returnNF_Tc (TyVar uniq kind Nothing box)
121 newTyVarTy :: Kind -> NF_TcM s (TcType s)
123 = newTcTyVar kind `thenNF_Tc` \ tc_tyvar ->
124 returnNF_Tc (TyVarTy tc_tyvar)
126 newTyVarTys :: Int -> Kind -> NF_TcM s [TcType s]
127 newTyVarTys n kind = mapNF_Tc newTyVarTy (nOfThem n kind)
130 -- For signature type variables, mark them as "DontBind"
131 tcInstTyVars, tcInstSigTyVars
133 -> NF_TcM s ([TcTyVar s], [TcType s], [(GenTyVar flexi, TcType s)])
135 tcInstTyVars tyvars = inst_tyvars UnBound tyvars
136 tcInstSigTyVars tyvars = inst_tyvars DontBind tyvars
138 inst_tyvars initial_cts tyvars
139 = mapNF_Tc (inst_tyvar initial_cts) tyvars `thenNF_Tc` \ tc_tyvars ->
141 tys = map TyVarTy tc_tyvars
143 returnNF_Tc (tc_tyvars, tys, zipEqual "inst_tyvars" tyvars tys)
145 inst_tyvar initial_cts (TyVar _ kind name _)
146 = tcGetUnique `thenNF_Tc` \ uniq ->
147 tcNewMutVar initial_cts `thenNF_Tc` \ box ->
148 returnNF_Tc (TyVar uniq kind name box)
151 @tcInstType@ and @tcInstSigType@ both create a fresh instance of a
152 type, returning a @TcType@. All inner for-alls are instantiated with
155 The difference is that tcInstType instantiates all forall'd type
156 variables (and their bindees) with UnBound type variables, whereas
157 tcInstSigType instantiates them with DontBind types variables.
158 @tcInstSigType@ also doesn't take an environment.
160 On the other hand, @tcInstTcType@ instantiates a TcType. It uses
161 instantiateTy which could take advantage of sharing some day.
164 tcInstTcType :: TcType s -> NF_TcM s ([TcTyVar s], TcType s)
167 [] -> returnNF_Tc ([], ty) -- Nothing to do
168 other -> tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) ->
169 returnNF_Tc (tyvars', instantiateTy tenv rho)
171 (tyvars, rho) = splitForAllTy ty
173 tcInstSigTcType :: TcType s -> NF_TcM s ([TcTyVar s], TcType s)
176 [] -> returnNF_Tc ([], ty) -- Nothing to do
177 other -> tcInstSigTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) ->
178 returnNF_Tc (tyvars', instantiateTy tenv rho)
180 (tyvars, rho) = splitForAllTy ty
182 tcInstType :: [(GenTyVar flexi,TcType s)]
183 -> GenType (GenTyVar flexi) UVar
184 -> NF_TcM s (TcType s)
185 tcInstType tenv ty_to_inst
186 = tcConvert bind_fn occ_fn (mkTyVarEnv tenv) ty_to_inst
188 bind_fn = inst_tyvar UnBound
189 occ_fn env tyvar = case lookupTyVarEnv env tyvar of
190 Just ty -> returnNF_Tc ty
191 Nothing -> pprPanic "tcInstType:" (ppAboves [ppr PprDebug ty_to_inst,
194 tcInstSigType :: GenType (GenTyVar flexi) UVar -> NF_TcM s (TcType s)
195 tcInstSigType ty_to_inst
196 = tcConvert bind_fn occ_fn nullTyVarEnv ty_to_inst
198 bind_fn = inst_tyvar DontBind
199 occ_fn env tyvar = case lookupTyVarEnv env tyvar of
200 Just ty -> returnNF_Tc ty
201 Nothing -> pprPanic "tcInstType:" (ppAboves [ppr PprDebug ty_to_inst,
204 zonkTcTyVarToTyVar :: TcTyVar s -> NF_TcM s TyVar
205 zonkTcTyVarToTyVar tv
206 = zonkTcTyVar tv `thenNF_Tc` \ tv_ty ->
207 case tv_ty of -- Should be a tyvar!
209 TyVarTy tv' -> returnNF_Tc (tcTyVarToTyVar tv')
211 _ -> pprTrace "zonkTcTyVarToTyVar:" (ppCat [ppr PprDebug tv, ppr PprDebug tv_ty]) $
212 returnNF_Tc (tcTyVarToTyVar tv)
215 zonkTcTypeToType :: TyVarEnv Type -> TcType s -> NF_TcM s Type
216 zonkTcTypeToType env ty
217 = tcConvert zonkTcTyVarToTyVar occ_fn env ty
220 = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
222 BoundTo (TyVarTy tyvar') -> lookup env tyvar'
223 BoundTo other_ty -> tcConvert zonkTcTyVarToTyVar occ_fn env other_ty
224 other -> lookup env tyvar
226 lookup env tyvar = case lookupTyVarEnv env tyvar of
227 Just ty -> returnNF_Tc ty
228 Nothing -> returnNF_Tc voidTy -- Unbound type variables go to Void
231 tcConvert bind_fn occ_fn env ty_to_convert
232 = do env ty_to_convert
234 do env (TyConTy tycon usage) = returnNF_Tc (TyConTy tycon usage)
236 do env (SynTy tycon tys ty) = mapNF_Tc (do env) tys `thenNF_Tc` \ tys' ->
237 do env ty `thenNF_Tc` \ ty' ->
238 returnNF_Tc (SynTy tycon tys' ty')
240 do env (FunTy arg res usage) = do env arg `thenNF_Tc` \ arg' ->
241 do env res `thenNF_Tc` \ res' ->
242 returnNF_Tc (FunTy arg' res' usage)
244 do env (AppTy fun arg) = do env fun `thenNF_Tc` \ fun' ->
245 do env arg `thenNF_Tc` \ arg' ->
246 returnNF_Tc (AppTy fun' arg')
248 do env (DictTy clas ty usage)= do env ty `thenNF_Tc` \ ty' ->
249 returnNF_Tc (DictTy clas ty' usage)
251 do env (ForAllUsageTy u us ty) = do env ty `thenNF_Tc` \ ty' ->
252 returnNF_Tc (ForAllUsageTy u us ty')
254 -- The two interesting cases!
255 do env (TyVarTy tv) = occ_fn env tv
257 do env (ForAllTy tyvar ty)
258 = bind_fn tyvar `thenNF_Tc` \ tyvar' ->
260 new_env = addOneToTyVarEnv env tyvar (TyVarTy tyvar')
262 do new_env ty `thenNF_Tc` \ ty' ->
263 returnNF_Tc (ForAllTy tyvar' ty')
266 tcInstTheta :: [(TyVar,TcType s)] -> ThetaType -> NF_TcM s (TcThetaType s)
267 tcInstTheta tenv theta
270 go (clas,ty) = tcInstType tenv ty `thenNF_Tc` \ tc_ty ->
271 returnNF_Tc (clas, tc_ty)
273 -- A useful function that takes an occurrence of a global thing
274 -- and instantiates its type with fresh type variables
276 -> NF_TcM s ([TcTyVar s], -- It's instantiated type
282 (tyvars, rho) = splitForAllTy (idType id)
284 tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
285 tcInstType tenv rho `thenNF_Tc` \ rho' ->
287 (theta', tau') = splitRhoTy rho'
289 returnNF_Tc (tyvars', theta', tau')
292 Reading and writing TcTyVars
293 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
295 tcWriteTyVar :: TcTyVar s -> TcType s -> NF_TcM s ()
296 tcReadTyVar :: TcTyVar s -> NF_TcM s (TcMaybe s)
302 tcWriteTyVar (TyVar uniq kind name box) ty = tcWriteMutVar box (BoundTo ty)
305 Reading is more interesting. The easy thing to do is just to read, thus:
307 tcReadTyVar (TyVar uniq kind name box) = tcReadMutVar box
310 But it's more fun to short out indirections on the way: If this
311 version returns a TyVar, then that TyVar is unbound. If it returns
312 any other type, then there might be bound TyVars embedded inside it.
314 We return Nothing iff the original box was unbound.
317 tcReadTyVar (TyVar uniq kind name box)
318 = tcReadMutVar box `thenNF_Tc` \ maybe_ty ->
320 BoundTo ty -> short_out ty `thenNF_Tc` \ ty' ->
321 tcWriteMutVar box (BoundTo ty') `thenNF_Tc_`
322 returnNF_Tc (BoundTo ty')
324 other -> returnNF_Tc other
326 short_out :: TcType s -> NF_TcM s (TcType s)
327 short_out ty@(TyVarTy (TyVar uniq kind name box))
328 = tcReadMutVar box `thenNF_Tc` \ maybe_ty ->
330 BoundTo ty' -> short_out ty' `thenNF_Tc` \ ty' ->
331 tcWriteMutVar box (BoundTo ty') `thenNF_Tc_`
334 other -> returnNF_Tc ty
336 short_out other_ty = returnNF_Tc other_ty
343 zonkTcTyVars :: TcTyVarSet s -> NF_TcM s (TcTyVarSet s)
345 = mapNF_Tc zonkTcTyVar (tyVarSetToList tyvars) `thenNF_Tc` \ tys ->
346 returnNF_Tc (tyVarsOfTypes tys)
348 zonkTcTyVar :: TcTyVar s -> NF_TcM s (TcType s)
350 = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
352 BoundTo ty@(TyVarTy tyvar') -> returnNF_Tc ty
353 BoundTo other -> zonkTcType other
354 other -> returnNF_Tc (TyVarTy tyvar)
356 zonkTcType :: TcType s -> NF_TcM s (TcType s)
358 zonkTcType (TyVarTy tyvar) = zonkTcTyVar tyvar
360 zonkTcType (AppTy ty1 ty2)
361 = zonkTcType ty1 `thenNF_Tc` \ ty1' ->
362 zonkTcType ty2 `thenNF_Tc` \ ty2' ->
363 returnNF_Tc (AppTy ty1' ty2')
365 zonkTcType (TyConTy tc u)
366 = returnNF_Tc (TyConTy tc u)
368 zonkTcType (SynTy tc tys ty)
369 = mapNF_Tc zonkTcType tys `thenNF_Tc` \ tys' ->
370 zonkTcType ty `thenNF_Tc` \ ty' ->
371 returnNF_Tc (SynTy tc tys' ty')
373 zonkTcType (ForAllTy tv ty)
374 = zonkTcTyVar tv `thenNF_Tc` \ tv_ty ->
375 zonkTcType ty `thenNF_Tc` \ ty' ->
376 case tv_ty of -- Should be a tyvar!
378 returnNF_Tc (ForAllTy tv' ty')
379 _ -> pprTrace "zonkTcType:ForAllTy:" (ppCat [ppr PprDebug tv, ppr PprDebug tv_ty]) $
381 returnNF_Tc (ForAllTy tv{-(tcTyVarToTyVar tv)-} ty')
383 zonkTcType (ForAllUsageTy uv uvs ty)
384 = panic "zonk:ForAllUsageTy"
386 zonkTcType (FunTy ty1 ty2 u)
387 = zonkTcType ty1 `thenNF_Tc` \ ty1' ->
388 zonkTcType ty2 `thenNF_Tc` \ ty2' ->
389 returnNF_Tc (FunTy ty1' ty2' u)
391 zonkTcType (DictTy c ty u)
392 = zonkTcType ty `thenNF_Tc` \ ty' ->
393 returnNF_Tc (DictTy c ty' u)