2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 \section[TcHsSyn]{Specialisations of the @HsSyn@ syntax for the typechecker}
6 This module is an extension of @HsSyn@ syntax, for use in the type
11 mkHsTyApp, mkHsDictApp, mkHsConApp,
12 mkHsTyLam, mkHsDictLam, mkHsDictLet, mkHsApp,
13 hsLitType, hsPatType, mkHsAppTy, mkSimpleHsAlt,
14 nlHsIntLit, mkVanillaTuplePat,
17 -- re-exported from TcMonad
18 TcId, TcIdSet, TcDictBinds,
20 zonkTopDecls, zonkTopExpr, zonkTopLExpr,
24 #include "HsVersions.h"
27 import HsSyn -- oodles of it
30 import Id ( idType, setIdType, Id )
34 import TcType ( TcType, TcTyVar, mkTyVarTy, mkTyConApp, isImmutableTyVar )
35 import Kind ( isLiftedTypeKind, liftedTypeKind, isSubKind )
37 import TcMType ( zonkQuantifiedTyVar, zonkType, zonkTcType, writeMetaTyVar )
38 import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
39 doublePrimTy, addrPrimTy
41 import TysWiredIn ( charTy, stringTy, intTy,
42 mkListTy, mkPArrTy, mkTupleTy, unitTy,
43 voidTy, listTyCon, tupleTyCon )
44 import TyCon ( mkPrimTyCon, tyConKind, PrimRep(..) )
45 import Kind ( splitKindFunTys )
46 import Name ( Name, getOccName, mkInternalName, mkDerivedTyConOcc )
47 import Var ( Var, isId, isLocalVar, tyVarKind )
50 import BasicTypes ( Boxity(..), IPName(..), ipNameName, mapIPName )
51 import Maybes ( orElse )
52 import Unique ( Uniquable(..) )
53 import SrcLoc ( noSrcLoc, noLoc, Located(..), unLoc )
54 import Util ( mapSnd )
60 %************************************************************************
62 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
64 %************************************************************************
66 Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@,
67 then something is wrong.
69 mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
70 -- A vanilla tuple pattern simply gets its type from its sub-patterns
71 mkVanillaTuplePat pats box
72 = TuplePat pats box (mkTupleTy box (length pats) (map hsPatType pats))
74 hsPatType :: OutPat Id -> Type
75 hsPatType pat = pat_type (unLoc pat)
77 pat_type (ParPat pat) = hsPatType pat
78 pat_type (WildPat ty) = ty
79 pat_type (VarPat var) = idType var
80 pat_type (VarPatOut var _) = idType var
81 pat_type (LazyPat pat) = hsPatType pat
82 pat_type (LitPat lit) = hsLitType lit
83 pat_type (AsPat var pat) = idType (unLoc var)
84 pat_type (ListPat _ ty) = mkListTy ty
85 pat_type (PArrPat _ ty) = mkPArrTy ty
86 pat_type (TuplePat pats box ty) = ty
87 pat_type (ConPatOut _ _ _ _ _ ty) = ty
88 pat_type (SigPatOut pat ty) = ty
89 pat_type (NPat lit _ _ ty) = ty
90 pat_type (NPlusKPat id _ _ _) = idType (unLoc id)
91 pat_type (DictPat ds ms) = case (ds ++ ms) of
94 ds -> mkTupleTy Boxed (length ds) (map idType ds)
97 hsLitType :: HsLit -> TcType
98 hsLitType (HsChar c) = charTy
99 hsLitType (HsCharPrim c) = charPrimTy
100 hsLitType (HsString str) = stringTy
101 hsLitType (HsStringPrim s) = addrPrimTy
102 hsLitType (HsInt i) = intTy
103 hsLitType (HsIntPrim i) = intPrimTy
104 hsLitType (HsInteger i ty) = ty
105 hsLitType (HsRat _ ty) = ty
106 hsLitType (HsFloatPrim f) = floatPrimTy
107 hsLitType (HsDoublePrim d) = doublePrimTy
111 %************************************************************************
113 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
115 %************************************************************************
118 -- zonkId is used *during* typechecking just to zonk the Id's type
119 zonkId :: TcId -> TcM TcId
121 = zonkTcType (idType id) `thenM` \ ty' ->
122 returnM (setIdType id ty')
125 The rest of the zonking is done *after* typechecking.
126 The main zonking pass runs over the bindings
128 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
129 b) convert unbound TcTyVar to Void
130 c) convert each TcId to an Id by zonking its type
132 The type variables are converted by binding mutable tyvars to immutable ones
133 and then zonking as normal.
135 The Ids are converted by binding them in the normal Tc envt; that
136 way we maintain sharing; eg an Id is zonked at its binding site and they
137 all occurrences of that Id point to the common zonked copy
139 It's all pretty boring stuff, because HsSyn is such a large type, and
140 the environment manipulation is tiresome.
143 data ZonkEnv = ZonkEnv (TcType -> TcM Type) -- How to zonk a type
144 (IdEnv Id) -- What variables are in scope
145 -- Maps an Id to its zonked version; both have the same Name
146 -- Is only consulted lazily; hence knot-tying
148 emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
150 extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
151 extendZonkEnv (ZonkEnv zonk_ty env) ids
152 = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
154 extendZonkEnv1 :: ZonkEnv -> Id -> ZonkEnv
155 extendZonkEnv1 (ZonkEnv zonk_ty env) id
156 = ZonkEnv zonk_ty (extendVarEnv env id id)
158 setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
159 setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
161 zonkEnvIds :: ZonkEnv -> [Id]
162 zonkEnvIds (ZonkEnv _ env) = varEnvElts env
164 zonkIdOcc :: ZonkEnv -> TcId -> Id
165 -- Ids defined in this module should be in the envt;
166 -- ignore others. (Actually, data constructors are also
167 -- not LocalVars, even when locally defined, but that is fine.)
168 -- (Also foreign-imported things aren't currently in the ZonkEnv;
169 -- that's ok because they don't need zonking.)
171 -- Actually, Template Haskell works in 'chunks' of declarations, and
172 -- an earlier chunk won't be in the 'env' that the zonking phase
173 -- carries around. Instead it'll be in the tcg_gbl_env, already fully
174 -- zonked. There's no point in looking it up there (except for error
175 -- checking), and it's not conveniently to hand; hence the simple
176 -- 'orElse' case in the LocalVar branch.
178 -- Even without template splices, in module Main, the checking of
179 -- 'main' is done as a separate chunk.
180 zonkIdOcc (ZonkEnv zonk_ty env) id
181 | isLocalVar id = lookupVarEnv env id `orElse` id
184 zonkIdOccs env ids = map (zonkIdOcc env) ids
186 -- zonkIdBndr is used *after* typechecking to get the Id's type
187 -- to its final form. The TyVarEnv give
188 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
190 = zonkTcTypeToType env (idType id) `thenM` \ ty' ->
191 returnM (setIdType id ty')
193 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
194 zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
196 zonkTopBndrs :: [TcId] -> TcM [Id]
197 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
202 zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
203 zonkTopExpr e = zonkExpr emptyZonkEnv e
205 zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
206 zonkTopLExpr e = zonkLExpr emptyZonkEnv e
208 zonkTopDecls :: LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId]
213 zonkTopDecls binds rules fords
214 = do { (env, binds') <- zonkRecMonoBinds emptyZonkEnv binds
215 -- Top level is implicitly recursive
216 ; rules' <- zonkRules env rules
217 ; fords' <- zonkForeignExports env fords
218 ; return (zonkEnvIds env, binds', fords', rules') }
220 ---------------------------------------------
221 zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
222 zonkLocalBinds env EmptyLocalBinds
223 = return (env, EmptyLocalBinds)
225 zonkLocalBinds env (HsValBinds binds)
226 = do { (env1, new_binds) <- zonkValBinds env binds
227 ; return (env1, HsValBinds new_binds) }
229 zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds))
230 = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds ->
232 env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
234 zonkRecMonoBinds env1 dict_binds `thenM` \ (env2, new_dict_binds) ->
235 returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
237 zonk_ip_bind (IPBind n e)
238 = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' ->
239 zonkLExpr env e `thenM` \ e' ->
240 returnM (IPBind n' e')
243 ---------------------------------------------
244 zonkValBinds :: ZonkEnv -> HsValBinds TcId -> TcM (ZonkEnv, HsValBinds Id)
245 zonkValBinds env bs@(ValBindsIn _ _)
246 = panic "zonkValBinds" -- Not in typechecker output
247 zonkValBinds env (ValBindsOut binds sigs)
248 = do { (env1, new_binds) <- go env binds
249 ; return (env1, ValBindsOut new_binds sigs) }
251 go env [] = return (env, [])
252 go env ((r,b):bs) = do { (env1, b') <- zonkRecMonoBinds env b
253 ; (env2, bs') <- go env1 bs
254 ; return (env2, (r,b'):bs') }
256 ---------------------------------------------
257 zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
258 zonkRecMonoBinds env binds
259 = fixM (\ ~(_, new_binds) -> do
260 { let env1 = extendZonkEnv env (collectHsBindBinders new_binds)
261 ; binds' <- zonkMonoBinds env1 binds
262 ; return (env1, binds') })
264 ---------------------------------------------
265 zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
266 zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds
268 zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
269 zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
270 = do { (_env, new_pat) <- zonkPat env pat -- Env already extended
271 ; new_grhss <- zonkGRHSs env grhss
272 ; new_ty <- zonkTcTypeToType env ty
273 ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
275 zonk_bind env (VarBind { var_id = var, var_rhs = expr })
276 = zonkIdBndr env var `thenM` \ new_var ->
277 zonkLExpr env expr `thenM` \ new_expr ->
278 returnM (VarBind { var_id = new_var, var_rhs = new_expr })
280 zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn })
281 = wrapLocM (zonkIdBndr env) var `thenM` \ new_var ->
282 zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) ->
283 zonkMatchGroup env1 ms `thenM` \ new_ms ->
284 returnM (bind { fun_id = new_var, fun_matches = new_ms, fun_co_fn = new_co_fn })
286 zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts,
287 abs_exports = exports, abs_binds = val_binds })
288 = ASSERT( all isImmutableTyVar tyvars )
289 zonkIdBndrs env dicts `thenM` \ new_dicts ->
290 fixM (\ ~(new_val_binds, _) ->
292 env1 = extendZonkEnv env new_dicts
293 env2 = extendZonkEnv env1 (collectHsBindBinders new_val_binds)
295 zonkMonoBinds env2 val_binds `thenM` \ new_val_binds ->
296 mappM (zonkExport env2) exports `thenM` \ new_exports ->
297 returnM (new_val_binds, new_exports)
298 ) `thenM` \ (new_val_bind, new_exports) ->
299 returnM (AbsBinds { abs_tvs = tyvars, abs_dicts = new_dicts,
300 abs_exports = new_exports, abs_binds = new_val_bind })
302 zonkExport env (tyvars, global, local, prags)
303 = zonkIdBndr env global `thenM` \ new_global ->
304 mapM zonk_prag prags `thenM` \ new_prags ->
305 returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
306 zonk_prag prag@(InlinePrag {}) = return prag
307 zonk_prag (SpecPrag expr ty ds inl) = do { expr' <- zonkExpr env expr
308 ; ty' <- zonkTcTypeToType env ty
309 ; let ds' = zonkIdOccs env ds
310 ; return (SpecPrag expr' ty' ds' inl) }
313 %************************************************************************
315 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
317 %************************************************************************
320 zonkMatchGroup :: ZonkEnv -> MatchGroup TcId-> TcM (MatchGroup Id)
321 zonkMatchGroup env (MatchGroup ms ty)
322 = do { ms' <- mapM (zonkMatch env) ms
323 ; ty' <- zonkTcTypeToType env ty
324 ; return (MatchGroup ms' ty') }
326 zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id)
327 zonkMatch env (L loc (Match pats _ grhss))
328 = do { (env1, new_pats) <- zonkPats env pats
329 ; new_grhss <- zonkGRHSs env1 grhss
330 ; return (L loc (Match new_pats Nothing new_grhss)) }
332 -------------------------------------------------------------------------
333 zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id)
335 zonkGRHSs env (GRHSs grhss binds)
336 = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) ->
338 zonk_grhs (GRHS guarded rhs)
339 = zonkStmts new_env guarded `thenM` \ (env2, new_guarded) ->
340 zonkLExpr env2 rhs `thenM` \ new_rhs ->
341 returnM (GRHS new_guarded new_rhs)
343 mappM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss ->
344 returnM (GRHSs new_grhss new_binds)
347 %************************************************************************
349 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
351 %************************************************************************
354 zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
355 zonkLExpr :: ZonkEnv -> LHsExpr TcId -> TcM (LHsExpr Id)
356 zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id)
358 zonkLExprs env exprs = mappM (zonkLExpr env) exprs
359 zonkLExpr env expr = wrapLocM (zonkExpr env) expr
361 zonkExpr env (HsVar id)
362 = returnM (HsVar (zonkIdOcc env id))
364 zonkExpr env (HsIPVar id)
365 = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
367 zonkExpr env (HsLit (HsRat f ty))
368 = zonkTcTypeToType env ty `thenM` \ new_ty ->
369 returnM (HsLit (HsRat f new_ty))
371 zonkExpr env (HsLit lit)
372 = returnM (HsLit lit)
374 zonkExpr env (HsOverLit lit)
375 = do { lit' <- zonkOverLit env lit
376 ; return (HsOverLit lit') }
378 zonkExpr env (HsLam matches)
379 = zonkMatchGroup env matches `thenM` \ new_matches ->
380 returnM (HsLam new_matches)
382 zonkExpr env (HsApp e1 e2)
383 = zonkLExpr env e1 `thenM` \ new_e1 ->
384 zonkLExpr env e2 `thenM` \ new_e2 ->
385 returnM (HsApp new_e1 new_e2)
387 zonkExpr env (HsBracketOut body bs)
388 = mappM zonk_b bs `thenM` \ bs' ->
389 returnM (HsBracketOut body bs')
391 zonk_b (n,e) = zonkLExpr env e `thenM` \ e' ->
394 zonkExpr env (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
395 returnM (HsSpliceE s)
397 zonkExpr env (OpApp e1 op fixity e2)
398 = zonkLExpr env e1 `thenM` \ new_e1 ->
399 zonkLExpr env op `thenM` \ new_op ->
400 zonkLExpr env e2 `thenM` \ new_e2 ->
401 returnM (OpApp new_e1 new_op fixity new_e2)
403 zonkExpr env (NegApp expr op)
404 = zonkLExpr env expr `thenM` \ new_expr ->
405 zonkExpr env op `thenM` \ new_op ->
406 returnM (NegApp new_expr new_op)
408 zonkExpr env (HsPar e)
409 = zonkLExpr env e `thenM` \new_e ->
410 returnM (HsPar new_e)
412 zonkExpr env (SectionL expr op)
413 = zonkLExpr env expr `thenM` \ new_expr ->
414 zonkLExpr env op `thenM` \ new_op ->
415 returnM (SectionL new_expr new_op)
417 zonkExpr env (SectionR op expr)
418 = zonkLExpr env op `thenM` \ new_op ->
419 zonkLExpr env expr `thenM` \ new_expr ->
420 returnM (SectionR new_op new_expr)
422 zonkExpr env (HsCase expr ms)
423 = zonkLExpr env expr `thenM` \ new_expr ->
424 zonkMatchGroup env ms `thenM` \ new_ms ->
425 returnM (HsCase new_expr new_ms)
427 zonkExpr env (HsIf e1 e2 e3)
428 = zonkLExpr env e1 `thenM` \ new_e1 ->
429 zonkLExpr env e2 `thenM` \ new_e2 ->
430 zonkLExpr env e3 `thenM` \ new_e3 ->
431 returnM (HsIf new_e1 new_e2 new_e3)
433 zonkExpr env (HsLet binds expr)
434 = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) ->
435 zonkLExpr new_env expr `thenM` \ new_expr ->
436 returnM (HsLet new_binds new_expr)
438 zonkExpr env (HsDo do_or_lc stmts body ty)
439 = zonkStmts env stmts `thenM` \ (new_env, new_stmts) ->
440 zonkLExpr new_env body `thenM` \ new_body ->
441 zonkTcTypeToType env ty `thenM` \ new_ty ->
442 returnM (HsDo (zonkDo env do_or_lc)
443 new_stmts new_body new_ty)
445 zonkExpr env (ExplicitList ty exprs)
446 = zonkTcTypeToType env ty `thenM` \ new_ty ->
447 zonkLExprs env exprs `thenM` \ new_exprs ->
448 returnM (ExplicitList new_ty new_exprs)
450 zonkExpr env (ExplicitPArr ty exprs)
451 = zonkTcTypeToType env ty `thenM` \ new_ty ->
452 zonkLExprs env exprs `thenM` \ new_exprs ->
453 returnM (ExplicitPArr new_ty new_exprs)
455 zonkExpr env (ExplicitTuple exprs boxed)
456 = zonkLExprs env exprs `thenM` \ new_exprs ->
457 returnM (ExplicitTuple new_exprs boxed)
459 zonkExpr env (RecordCon data_con con_expr rbinds)
460 = zonkExpr env con_expr `thenM` \ new_con_expr ->
461 zonkRbinds env rbinds `thenM` \ new_rbinds ->
462 returnM (RecordCon data_con new_con_expr new_rbinds)
464 zonkExpr env (RecordUpd expr rbinds in_ty out_ty)
465 = zonkLExpr env expr `thenM` \ new_expr ->
466 zonkTcTypeToType env in_ty `thenM` \ new_in_ty ->
467 zonkTcTypeToType env out_ty `thenM` \ new_out_ty ->
468 zonkRbinds env rbinds `thenM` \ new_rbinds ->
469 returnM (RecordUpd new_expr new_rbinds new_in_ty new_out_ty)
471 zonkExpr env (ExprWithTySigOut e ty)
472 = do { e' <- zonkLExpr env e
473 ; return (ExprWithTySigOut e' ty) }
475 zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
477 zonkExpr env (ArithSeq expr info)
478 = zonkExpr env expr `thenM` \ new_expr ->
479 zonkArithSeq env info `thenM` \ new_info ->
480 returnM (ArithSeq new_expr new_info)
482 zonkExpr env (PArrSeq expr info)
483 = zonkExpr env expr `thenM` \ new_expr ->
484 zonkArithSeq env info `thenM` \ new_info ->
485 returnM (PArrSeq new_expr new_info)
487 zonkExpr env (HsSCC lbl expr)
488 = zonkLExpr env expr `thenM` \ new_expr ->
489 returnM (HsSCC lbl new_expr)
491 -- hdaume: core annotations
492 zonkExpr env (HsCoreAnn lbl expr)
493 = zonkLExpr env expr `thenM` \ new_expr ->
494 returnM (HsCoreAnn lbl new_expr)
496 zonkExpr env (TyLam tyvars expr)
497 = ASSERT( all isImmutableTyVar tyvars )
498 zonkLExpr env expr `thenM` \ new_expr ->
499 returnM (TyLam tyvars new_expr)
501 zonkExpr env (TyApp expr tys)
502 = zonkLExpr env expr `thenM` \ new_expr ->
503 zonkTcTypeToTypes env tys `thenM` \ new_tys ->
504 returnM (TyApp new_expr new_tys)
506 zonkExpr env (DictLam dicts expr)
507 = zonkIdBndrs env dicts `thenM` \ new_dicts ->
509 env1 = extendZonkEnv env new_dicts
511 zonkLExpr env1 expr `thenM` \ new_expr ->
512 returnM (DictLam new_dicts new_expr)
514 zonkExpr env (DictApp expr dicts)
515 = zonkLExpr env expr `thenM` \ new_expr ->
516 returnM (DictApp new_expr (zonkIdOccs env dicts))
518 -- arrow notation extensions
519 zonkExpr env (HsProc pat body)
520 = do { (env1, new_pat) <- zonkPat env pat
521 ; new_body <- zonkCmdTop env1 body
522 ; return (HsProc new_pat new_body) }
524 zonkExpr env (HsArrApp e1 e2 ty ho rl)
525 = zonkLExpr env e1 `thenM` \ new_e1 ->
526 zonkLExpr env e2 `thenM` \ new_e2 ->
527 zonkTcTypeToType env ty `thenM` \ new_ty ->
528 returnM (HsArrApp new_e1 new_e2 new_ty ho rl)
530 zonkExpr env (HsArrForm op fixity args)
531 = zonkLExpr env op `thenM` \ new_op ->
532 mappM (zonkCmdTop env) args `thenM` \ new_args ->
533 returnM (HsArrForm new_op fixity new_args)
535 zonkExpr env (HsCoerce co_fn expr)
536 = zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) ->
537 zonkExpr env1 expr `thenM` \ new_expr ->
538 return (HsCoerce new_co_fn new_expr)
540 zonkExpr env other = pprPanic "zonkExpr" (ppr other)
542 zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
543 zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
545 zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
546 = zonkLExpr env cmd `thenM` \ new_cmd ->
547 zonkTcTypeToTypes env stack_tys `thenM` \ new_stack_tys ->
548 zonkTcTypeToType env ty `thenM` \ new_ty ->
549 mapSndM (zonkExpr env) ids `thenM` \ new_ids ->
550 returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
552 -------------------------------------------------------------------------
553 zonkCoFn :: ZonkEnv -> ExprCoFn -> TcM (ZonkEnv, ExprCoFn)
554 zonkCoFn env CoHole = return (env, CoHole)
555 zonkCoFn env (CoCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
556 ; (env2, c2') <- zonkCoFn env1 c2
557 ; return (env2, CoCompose c1' c2') }
558 zonkCoFn env (CoLams ids c) = do { ids' <- zonkIdBndrs env ids
559 ; let env1 = extendZonkEnv env ids'
560 ; (env2, c') <- zonkCoFn env1 c
561 ; return (env2, CoLams ids' c') }
562 zonkCoFn env (CoTyLams tvs c) = ASSERT( all isImmutableTyVar tvs )
563 do { (env1, c') <- zonkCoFn env c
564 ; return (env1, CoTyLams tvs c') }
565 zonkCoFn env (CoApps c ids) = do { (env1, c') <- zonkCoFn env c
566 ; return (env1, CoApps c' (zonkIdOccs env ids)) }
567 zonkCoFn env (CoTyApps c tys) = do { tys' <- zonkTcTypeToTypes env tys
568 ; (env1, c') <- zonkCoFn env c
569 ; return (env1, CoTyApps c' tys') }
570 zonkCoFn env (CoLet bs c) = do { (env1, bs') <- zonkRecMonoBinds env bs
571 ; (env2, c') <- zonkCoFn env1 c
572 ; return (env2, CoLet bs' c') }
575 -------------------------------------------------------------------------
576 zonkDo :: ZonkEnv -> HsStmtContext Name -> HsStmtContext Name
577 -- Only used for 'do', so the only Ids are in a MDoExpr table
578 zonkDo env (MDoExpr tbl) = MDoExpr (mapSnd (zonkIdOcc env) tbl)
579 zonkDo env do_or_lc = do_or_lc
581 -------------------------------------------------------------------------
582 zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
583 zonkOverLit env (HsIntegral i e)
584 = do { e' <- zonkExpr env e; return (HsIntegral i e') }
585 zonkOverLit env (HsFractional r e)
586 = do { e' <- zonkExpr env e; return (HsFractional r e') }
588 -------------------------------------------------------------------------
589 zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
591 zonkArithSeq env (From e)
592 = zonkLExpr env e `thenM` \ new_e ->
595 zonkArithSeq env (FromThen e1 e2)
596 = zonkLExpr env e1 `thenM` \ new_e1 ->
597 zonkLExpr env e2 `thenM` \ new_e2 ->
598 returnM (FromThen new_e1 new_e2)
600 zonkArithSeq env (FromTo e1 e2)
601 = zonkLExpr env e1 `thenM` \ new_e1 ->
602 zonkLExpr env e2 `thenM` \ new_e2 ->
603 returnM (FromTo new_e1 new_e2)
605 zonkArithSeq env (FromThenTo e1 e2 e3)
606 = zonkLExpr env e1 `thenM` \ new_e1 ->
607 zonkLExpr env e2 `thenM` \ new_e2 ->
608 zonkLExpr env e3 `thenM` \ new_e3 ->
609 returnM (FromThenTo new_e1 new_e2 new_e3)
612 -------------------------------------------------------------------------
613 zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id])
614 zonkStmts env [] = return (env, [])
615 zonkStmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s
616 ; (env2, ss') <- zonkStmts env1 ss
617 ; return (env2, s' : ss') }
619 zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
620 zonkStmt env (ParStmt stmts_w_bndrs)
621 = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs ->
623 new_binders = concat (map snd new_stmts_w_bndrs)
624 env1 = extendZonkEnv env new_binders
626 return (env1, ParStmt new_stmts_w_bndrs)
628 zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) ->
629 returnM (new_stmts, zonkIdOccs env1 bndrs)
631 zonkStmt env (RecStmt segStmts lvs rvs rets binds)
632 = zonkIdBndrs env rvs `thenM` \ new_rvs ->
634 env1 = extendZonkEnv env new_rvs
636 zonkStmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
637 -- Zonk the ret-expressions in an envt that
638 -- has the polymorphic bindings in the envt
639 mapM (zonkExpr env2) rets `thenM` \ new_rets ->
641 new_lvs = zonkIdOccs env2 lvs
642 env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
644 zonkRecMonoBinds env3 binds `thenM` \ (env4, new_binds) ->
645 returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets new_binds)
647 zonkStmt env (ExprStmt expr then_op ty)
648 = zonkLExpr env expr `thenM` \ new_expr ->
649 zonkExpr env then_op `thenM` \ new_then ->
650 zonkTcTypeToType env ty `thenM` \ new_ty ->
651 returnM (env, ExprStmt new_expr new_then new_ty)
653 zonkStmt env (LetStmt binds)
654 = zonkLocalBinds env binds `thenM` \ (env1, new_binds) ->
655 returnM (env1, LetStmt new_binds)
657 zonkStmt env (BindStmt pat expr bind_op fail_op)
658 = do { new_expr <- zonkLExpr env expr
659 ; (env1, new_pat) <- zonkPat env pat
660 ; new_bind <- zonkExpr env bind_op
661 ; new_fail <- zonkExpr env fail_op
662 ; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
665 -------------------------------------------------------------------------
666 zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id)
668 zonkRbinds env rbinds
669 = mappM zonk_rbind rbinds
671 zonk_rbind (field, expr)
672 = zonkLExpr env expr `thenM` \ new_expr ->
673 returnM (fmap (zonkIdOcc env) field, new_expr)
675 -------------------------------------------------------------------------
676 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
677 mapIPNameTc f (Dupable n) = f n `thenM` \ r -> returnM (Dupable r)
678 mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r)
682 %************************************************************************
684 \subsection[BackSubst-Pats]{Patterns}
686 %************************************************************************
689 zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
690 -- Extend the environment as we go, because it's possible for one
691 -- pattern to bind something that is used in another (inside or
693 zonkPat env pat = wrapLocSndM (zonk_pat env) pat
695 zonk_pat env (ParPat p)
696 = do { (env', p') <- zonkPat env p
697 ; return (env', ParPat p') }
699 zonk_pat env (WildPat ty)
700 = do { ty' <- zonkTcTypeToType env ty
701 ; return (env, WildPat ty') }
703 zonk_pat env (VarPat v)
704 = do { v' <- zonkIdBndr env v
705 ; return (extendZonkEnv1 env v', VarPat v') }
707 zonk_pat env (VarPatOut v binds)
708 = do { v' <- zonkIdBndr env v
709 ; (env', binds') <- zonkRecMonoBinds (extendZonkEnv1 env v') binds
710 ; returnM (env', VarPatOut v' binds') }
712 zonk_pat env (LazyPat pat)
713 = do { (env', pat') <- zonkPat env pat
714 ; return (env', LazyPat pat') }
716 zonk_pat env (AsPat (L loc v) pat)
717 = do { v' <- zonkIdBndr env v
718 ; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
719 ; return (env', AsPat (L loc v') pat') }
721 zonk_pat env (ListPat pats ty)
722 = do { ty' <- zonkTcTypeToType env ty
723 ; (env', pats') <- zonkPats env pats
724 ; return (env', ListPat pats' ty') }
726 zonk_pat env (PArrPat pats ty)
727 = do { ty' <- zonkTcTypeToType env ty
728 ; (env', pats') <- zonkPats env pats
729 ; return (env', PArrPat pats' ty') }
731 zonk_pat env (TuplePat pats boxed ty)
732 = do { ty' <- zonkTcTypeToType env ty
733 ; (env', pats') <- zonkPats env pats
734 ; return (env', TuplePat pats' boxed ty') }
736 zonk_pat env (ConPatOut n tvs dicts binds stuff ty)
737 = ASSERT( all isImmutableTyVar tvs )
738 do { new_ty <- zonkTcTypeToType env ty
739 ; new_dicts <- zonkIdBndrs env dicts
740 ; let env1 = extendZonkEnv env new_dicts
741 ; (env2, new_binds) <- zonkRecMonoBinds env1 binds
742 ; (env', new_stuff) <- zonkConStuff env2 stuff
743 ; returnM (env', ConPatOut n tvs new_dicts new_binds new_stuff new_ty) }
745 zonk_pat env (LitPat lit) = return (env, LitPat lit)
747 zonk_pat env (SigPatOut pat ty)
748 = do { ty' <- zonkTcTypeToType env ty
749 ; (env', pat') <- zonkPat env pat
750 ; return (env', SigPatOut pat' ty') }
752 zonk_pat env (NPat lit mb_neg eq_expr ty)
753 = do { lit' <- zonkOverLit env lit
754 ; mb_neg' <- case mb_neg of
755 Nothing -> return Nothing
756 Just neg -> do { neg' <- zonkExpr env neg
757 ; return (Just neg') }
758 ; eq_expr' <- zonkExpr env eq_expr
759 ; ty' <- zonkTcTypeToType env ty
760 ; return (env, NPat lit' mb_neg' eq_expr' ty') }
762 zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
763 = do { n' <- zonkIdBndr env n
764 ; lit' <- zonkOverLit env lit
765 ; e1' <- zonkExpr env e1
766 ; e2' <- zonkExpr env e2
767 ; return (extendZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
769 zonk_pat env (DictPat ds ms)
770 = do { ds' <- zonkIdBndrs env ds
771 ; ms' <- zonkIdBndrs env ms
772 ; return (extendZonkEnv env (ds' ++ ms'), DictPat ds' ms') }
774 ---------------------------
775 zonkConStuff env (PrefixCon pats)
776 = do { (env', pats') <- zonkPats env pats
777 ; return (env', PrefixCon pats') }
779 zonkConStuff env (InfixCon p1 p2)
780 = do { (env1, p1') <- zonkPat env p1
781 ; (env', p2') <- zonkPat env1 p2
782 ; return (env', InfixCon p1' p2') }
784 zonkConStuff env (RecCon rpats)
785 = do { (env', pats') <- zonkPats env pats
786 ; returnM (env', RecCon (fields `zip` pats')) }
788 (fields, pats) = unzip rpats
790 ---------------------------
791 zonkPats env [] = return (env, [])
792 zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
793 ; (env', pats') <- zonkPats env1 pats
794 ; return (env', pat':pats') }
797 %************************************************************************
799 \subsection[BackSubst-Foreign]{Foreign exports}
801 %************************************************************************
805 zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
806 zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
808 zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
809 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec) =
810 returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec isDeprec)
811 zonkForeignExport env for_imp
812 = returnM for_imp -- Foreign imports don't need zonking
816 zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
817 zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
819 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
820 zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs rhs)
821 = mappM zonk_bndr vars `thenM` \ new_bndrs ->
822 newMutVar emptyVarSet `thenM` \ unbound_tv_set ->
824 env_rhs = extendZonkEnv env [id | b <- new_bndrs, let id = unLoc b, isId id]
825 -- Type variables don't need an envt
826 -- They are bound through the mutable mechanism
828 env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
829 -- We need to gather the type variables mentioned on the LHS so we can
830 -- quantify over them. Example:
836 -- {-# RULES "myrule" foo C = 1 #-}
838 -- After type checking the LHS becomes (foo a (C a))
839 -- and we do not want to zap the unbound tyvar 'a' to (), because
840 -- that limits the applicability of the rule. Instead, we
841 -- want to quantify over it!
843 -- It's easiest to find the free tyvars here. Attempts to do so earlier
844 -- are tiresome, because (a) the data type is big and (b) finding the
845 -- free type vars of an expression is necessarily monadic operation.
846 -- (consider /\a -> f @ b, where b is side-effected to a)
848 zonkLExpr env_lhs lhs `thenM` \ new_lhs ->
849 zonkLExpr env_rhs rhs `thenM` \ new_rhs ->
851 readMutVar unbound_tv_set `thenM` \ unbound_tvs ->
853 final_bndrs :: [Located Var]
854 final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs
856 returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs new_rhs)
857 -- I hate this map RuleBndr stuff
859 zonk_bndr (RuleBndr v)
860 | isId (unLoc v) = wrapLocM (zonkIdBndr env) v
861 | otherwise = ASSERT( isImmutableTyVar (unLoc v) )
866 %************************************************************************
868 \subsection[BackSubst-Foreign]{Foreign exports}
870 %************************************************************************
873 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
874 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
876 zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
877 zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
879 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
880 -- This variant collects unbound type variables in a mutable variable
881 zonkTypeCollecting unbound_tv_set
882 = zonkType zonk_unbound_tyvar
884 zonk_unbound_tyvar tv
885 = zonkQuantifiedTyVar tv `thenM` \ tv' ->
886 readMutVar unbound_tv_set `thenM` \ tv_set ->
887 writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_`
888 return (mkTyVarTy tv')
890 zonkTypeZapping :: TcType -> TcM Type
891 -- This variant is used for everything except the LHS of rules
892 -- It zaps unbound type variables to (), or some other arbitrary type
894 = zonkType zonk_unbound_tyvar ty
896 -- Zonk a mutable but unbound type variable to an arbitrary type
897 -- We know it's unbound even though we don't carry an environment,
898 -- because at the binding site for a type variable we bind the
899 -- mutable tyvar to a fresh immutable one. So the mutable store
900 -- plays the role of an environment. If we come across a mutable
901 -- type variable that isn't so bound, it must be completely free.
902 zonk_unbound_tyvar tv = do { writeMetaTyVar tv ty; return ty }
904 ty = mkArbitraryType tv
907 -- When the type checker finds a type variable with no binding,
908 -- which means it can be instantiated with an arbitrary type, it
909 -- usually instantiates it to Void. Eg.
913 -- length Void (Nil Void)
915 -- But in really obscure programs, the type variable might have
916 -- a kind other than *, so we need to invent a suitably-kinded type.
920 -- List for kind *->*
921 -- Tuple for kind *->...*->*
923 -- which deals with most cases. (Previously, it only dealt with
926 -- In the other cases, it just makes up a TyCon with a suitable
927 -- kind. If this gets into an interface file, anyone reading that
928 -- file won't understand it. This is fixable (by making the client
929 -- of the interface file make up a TyCon too) but it is tiresome and
930 -- never happens, so I am leaving it
932 mkArbitraryType :: TcTyVar -> Type
933 -- Make up an arbitrary type whose kind is the same as the tyvar.
934 -- We'll use this to instantiate the (unbound) tyvar.
936 | liftedTypeKind `isSubKind` kind = voidTy -- The vastly common case
937 | otherwise = mkTyConApp tycon []
940 (args,res) = splitKindFunTys kind
942 tycon | kind == tyConKind listTyCon -- *->*
943 = listTyCon -- No tuples this size
945 | all isLiftedTypeKind args && isLiftedTypeKind res
946 = tupleTyCon Boxed (length args) -- *-> ... ->*->*
949 = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
950 mkPrimTyCon tc_name kind 0 [] VoidRep
951 -- Same name as the tyvar, apart from making it start with a colon (sigh)
952 -- I dread to think what will happen if this gets out into an
953 -- interface file. Catastrophe likely. Major sigh.
955 tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc