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
12 mkHsTyApp, mkHsDictApp, mkHsConApp,
13 mkHsTyLam, mkHsDictLam, mkHsLet, mkHsApp,
14 hsLitType, hsPatType, mkHsAppTy, mkSimpleHsAlt,
15 nlHsIntLit, glueBindsOnGRHSs,
19 Coercion, ExprCoFn, PatCoFn,
20 (<$>), (<.>), mkCoercion,
21 idCoercion, isIdCoercion,
23 -- re-exported from TcMonad
26 zonkTopDecls, zonkTopExpr, zonkTopLExpr,
30 #include "HsVersions.h"
33 import HsSyn -- oodles of it
36 import Id ( idType, setIdType, Id )
40 import TcType ( TcType, TcTyVar, eqKind, isTypeKind, mkTyVarTy,
41 tcGetTyVar, isAnyTypeKind, mkTyConApp )
43 import TcMType ( zonkTcTyVarToTyVar, zonkType, zonkTcType, zonkTcTyVars,
45 import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
46 doublePrimTy, addrPrimTy
48 import TysWiredIn ( charTy, stringTy, intTy,
49 mkListTy, mkPArrTy, mkTupleTy, unitTy,
50 voidTy, listTyCon, tupleTyCon )
51 import TyCon ( mkPrimTyCon, tyConKind )
52 import PrimRep ( PrimRep(VoidRep) )
53 import Name ( getOccName, mkInternalName, mkDerivedTyConOcc )
54 import Var ( Var, isId, isLocalVar, tyVarKind )
57 import BasicTypes ( Boxity(..), IPName(..), ipNameName, mapIPName )
58 import Maybes ( orElse )
59 import Maybe ( isNothing )
60 import Unique ( Uniquable(..) )
61 import SrcLoc ( noSrcLoc, noLoc, Located(..), unLoc )
68 type TcDictBinds = LHsBinds TcId -- Bag of dictionary bindings
72 %************************************************************************
74 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
76 %************************************************************************
78 Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@,
79 then something is wrong.
81 hsPatType :: OutPat Id -> Type
82 hsPatType pat = pat_type (unLoc pat)
84 pat_type (ParPat pat) = hsPatType pat
85 pat_type (WildPat ty) = ty
86 pat_type (VarPat var) = idType var
87 pat_type (LazyPat pat) = hsPatType pat
88 pat_type (LitPat lit) = hsLitType lit
89 pat_type (AsPat var pat) = idType (unLoc var)
90 pat_type (ListPat _ ty) = mkListTy ty
91 pat_type (PArrPat _ ty) = mkPArrTy ty
92 pat_type (TuplePat pats box) = mkTupleTy box (length pats) (map hsPatType pats)
93 pat_type (ConPatOut _ _ ty _ _) = ty
94 pat_type (SigPatOut _ ty _) = ty
95 pat_type (NPatOut lit ty _) = ty
96 pat_type (NPlusKPatOut id _ _ _) = idType (unLoc id)
97 pat_type (DictPat ds ms) = case (ds ++ ms) of
100 ds -> mkTupleTy Boxed (length ds) (map idType ds)
103 hsLitType :: HsLit -> TcType
104 hsLitType (HsChar c) = charTy
105 hsLitType (HsCharPrim c) = charPrimTy
106 hsLitType (HsString str) = stringTy
107 hsLitType (HsStringPrim s) = addrPrimTy
108 hsLitType (HsInt i) = intTy
109 hsLitType (HsIntPrim i) = intPrimTy
110 hsLitType (HsInteger i ty) = ty
111 hsLitType (HsRat _ ty) = ty
112 hsLitType (HsFloatPrim f) = floatPrimTy
113 hsLitType (HsDoublePrim d) = doublePrimTy
116 %************************************************************************
118 \subsection{Coercion functions}
120 %************************************************************************
123 type Coercion a = Maybe (a -> a)
124 -- Nothing => identity fn
126 type ExprCoFn = Coercion (HsExpr TcId)
127 type PatCoFn = Coercion (Pat TcId)
129 (<.>) :: Coercion a -> Coercion a -> Coercion a -- Composition
130 Nothing <.> Nothing = Nothing
131 Nothing <.> Just f = Just f
132 Just f <.> Nothing = Just f
133 Just f1 <.> Just f2 = Just (f1 . f2)
135 (<$>) :: Coercion a -> a -> a
139 mkCoercion :: (a -> a) -> Coercion a
140 mkCoercion f = Just f
142 idCoercion :: Coercion a
145 isIdCoercion :: Coercion a -> Bool
146 isIdCoercion = isNothing
150 %************************************************************************
152 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
154 %************************************************************************
157 -- zonkId is used *during* typechecking just to zonk the Id's type
158 zonkId :: TcId -> TcM TcId
160 = zonkTcType (idType id) `thenM` \ ty' ->
161 returnM (setIdType id ty')
164 The rest of the zonking is done *after* typechecking.
165 The main zonking pass runs over the bindings
167 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
168 b) convert unbound TcTyVar to Void
169 c) convert each TcId to an Id by zonking its type
171 The type variables are converted by binding mutable tyvars to immutable ones
172 and then zonking as normal.
174 The Ids are converted by binding them in the normal Tc envt; that
175 way we maintain sharing; eg an Id is zonked at its binding site and they
176 all occurrences of that Id point to the common zonked copy
178 It's all pretty boring stuff, because HsSyn is such a large type, and
179 the environment manipulation is tiresome.
182 data ZonkEnv = ZonkEnv (TcType -> TcM Type) -- How to zonk a type
183 (IdEnv Id) -- What variables are in scope
184 -- Maps an Id to its zonked version; both have the same Name
185 -- Is only consulted lazily; hence knot-tying
187 emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
189 extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
190 extendZonkEnv (ZonkEnv zonk_ty env) ids
191 = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
193 setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
194 setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
196 mkZonkEnv :: [Id] -> ZonkEnv
197 mkZonkEnv ids = extendZonkEnv emptyZonkEnv ids
199 zonkIdOcc :: ZonkEnv -> TcId -> Id
200 -- Ids defined in this module should be in the envt;
201 -- ignore others. (Actually, data constructors are also
202 -- not LocalVars, even when locally defined, but that is fine.)
204 -- Actually, Template Haskell works in 'chunks' of declarations, and
205 -- an earlier chunk won't be in the 'env' that the zonking phase
206 -- carries around. Instead it'll be in the tcg_gbl_env, already fully
207 -- zonked. There's no point in looking it up there (except for error
208 -- checking), and it's not conveniently to hand; hence the simple
209 -- 'orElse' case in the LocalVar branch.
211 -- Even without template splices, in module Main, the checking of
212 -- 'main' is done as a separte chunk.
213 zonkIdOcc (ZonkEnv zonk_ty env) id
214 | isLocalVar id = lookupVarEnv env id `orElse` id
217 zonkIdOccs env ids = map (zonkIdOcc env) ids
219 -- zonkIdBndr is used *after* typechecking to get the Id's type
220 -- to its final form. The TyVarEnv give
221 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
223 = zonkTcTypeToType env (idType id) `thenM` \ ty' ->
224 returnM (setIdType id ty')
226 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
227 zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
229 zonkTopBndrs :: [TcId] -> TcM [Id]
230 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
235 zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
236 zonkTopExpr e = zonkExpr emptyZonkEnv e
238 zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
239 zonkTopLExpr e = zonkLExpr emptyZonkEnv e
241 zonkTopDecls :: Bag (LHsBind TcId) -> [LRuleDecl TcId] -> [LForeignDecl TcId]
246 zonkTopDecls binds rules fords -- Top level is implicitly recursive
247 = fixM (\ ~(new_ids, _, _, _) ->
249 zonk_env = mkZonkEnv new_ids
251 zonkMonoBinds zonk_env binds `thenM` \ binds' ->
252 zonkRules zonk_env rules `thenM` \ rules' ->
253 zonkForeignExports zonk_env fords `thenM` \ fords' ->
255 returnM (collectHsBindBinders binds', binds', fords', rules')
258 ---------------------------------------------
259 zonkGroup :: ZonkEnv -> HsBindGroup TcId -> TcM (ZonkEnv, HsBindGroup Id)
260 zonkGroup env (HsBindGroup bs sigs is_rec)
261 = ASSERT( null sigs )
262 do { (env1, bs') <- fixM (\ ~(_, new_binds) -> do
263 { let env1 = extendZonkEnv env (collectHsBindBinders new_binds)
264 ; bs' <- zonkMonoBinds env1 bs
265 ; return (env1, bs') })
266 ; return (env1, HsBindGroup bs' [] is_rec) }
269 zonkGroup env (HsIPBinds binds)
270 = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds ->
272 env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
274 returnM (env1, HsIPBinds new_binds)
276 zonk_ip_bind (IPBind n e)
277 = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' ->
278 zonkLExpr env e `thenM` \ e' ->
279 returnM (IPBind n' e')
281 ---------------------------------------------
282 zonkNestedBinds :: ZonkEnv -> [HsBindGroup TcId] -> TcM (ZonkEnv, [HsBindGroup Id])
283 zonkNestedBinds env [] = return (env, [])
284 zonkNestedBinds env (b:bs) = do { (env1, b') <- zonkGroup env b
285 ; (env2, bs') <- zonkNestedBinds env1 bs
286 ; return (env2, b':bs') }
288 ---------------------------------------------
289 zonkMonoBinds :: ZonkEnv -> Bag (LHsBind TcId) -> TcM (Bag (LHsBind Id))
290 zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds
292 zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
293 zonk_bind env (PatBind pat grhss)
294 = zonkPat env pat `thenM` \ (new_pat, _) ->
295 zonkGRHSs env grhss `thenM` \ new_grhss ->
296 returnM (PatBind new_pat new_grhss)
298 zonk_bind env (VarBind var expr)
299 = zonkIdBndr env var `thenM` \ new_var ->
300 zonkLExpr env expr `thenM` \ new_expr ->
301 returnM (VarBind new_var new_expr)
303 zonk_bind env (FunBind var inf ms)
304 = wrapLocM (zonkIdBndr env) var `thenM` \ new_var ->
305 mappM (zonkMatch env) ms `thenM` \ new_ms ->
306 returnM (FunBind new_var inf new_ms)
308 zonk_bind env (AbsBinds tyvars dicts exports inlines val_binds)
309 = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars ->
310 -- No need to extend tyvar env: the effects are
311 -- propagated through binding the tyvars themselves
313 zonkIdBndrs env dicts `thenM` \ new_dicts ->
314 fixM (\ ~(new_val_binds, _) ->
316 env1 = extendZonkEnv (extendZonkEnv env new_dicts)
317 (collectHsBindBinders new_val_binds)
319 zonkMonoBinds env1 val_binds `thenM` \ new_val_binds ->
320 mappM (zonkExport env1) exports `thenM` \ new_exports ->
321 returnM (new_val_binds, new_exports)
322 ) `thenM` \ (new_val_bind, new_exports) ->
323 returnM (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind)
325 zonkExport env (tyvars, global, local)
326 = zonkTcTyVars tyvars `thenM` \ tys ->
328 new_tyvars = map (tcGetTyVar "zonkExport") tys
329 -- This isn't the binding occurrence of these tyvars
330 -- but they should *be* tyvars. Hence tcGetTyVar.
332 zonkIdBndr env global `thenM` \ new_global ->
333 returnM (new_tyvars, new_global, zonkIdOcc env local)
336 %************************************************************************
338 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
340 %************************************************************************
343 zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id)
345 zonkMatch env (L loc (Match pats _ grhss))
346 = zonkPats env pats `thenM` \ (new_pats, new_ids) ->
347 zonkGRHSs (extendZonkEnv env (bagToList new_ids)) grhss `thenM` \ new_grhss ->
348 returnM (L loc (Match new_pats Nothing new_grhss))
350 -------------------------------------------------------------------------
351 zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id)
353 zonkGRHSs env (GRHSs grhss binds ty)
354 = zonkNestedBinds env binds `thenM` \ (new_env, new_binds) ->
356 zonk_grhs (GRHS guarded)
357 = zonkStmts new_env guarded `thenM` \ new_guarded ->
358 returnM (GRHS new_guarded)
360 mappM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss ->
361 zonkTcTypeToType env ty `thenM` \ new_ty ->
362 returnM (GRHSs new_grhss new_binds new_ty)
365 %************************************************************************
367 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
369 %************************************************************************
372 zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
373 zonkLExpr :: ZonkEnv -> LHsExpr TcId -> TcM (LHsExpr Id)
374 zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id)
376 zonkLExprs env exprs = mappM (zonkLExpr env) exprs
377 zonkLExpr env expr = wrapLocM (zonkExpr env) expr
379 zonkExpr env (HsVar id)
380 = returnM (HsVar (zonkIdOcc env id))
382 zonkExpr env (HsIPVar id)
383 = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
385 zonkExpr env (HsLit (HsRat f ty))
386 = zonkTcTypeToType env ty `thenM` \ new_ty ->
387 returnM (HsLit (HsRat f new_ty))
389 zonkExpr env (HsLit lit)
390 = returnM (HsLit lit)
392 -- HsOverLit doesn't appear in typechecker output
394 zonkExpr env (HsLam match)
395 = zonkMatch env match `thenM` \ new_match ->
396 returnM (HsLam new_match)
398 zonkExpr env (HsApp e1 e2)
399 = zonkLExpr env e1 `thenM` \ new_e1 ->
400 zonkLExpr env e2 `thenM` \ new_e2 ->
401 returnM (HsApp new_e1 new_e2)
403 zonkExpr env (HsBracketOut body bs)
404 = mappM zonk_b bs `thenM` \ bs' ->
405 returnM (HsBracketOut body bs')
407 zonk_b (n,e) = zonkLExpr env e `thenM` \ e' ->
410 zonkExpr env (HsSplice n e) = WARN( True, ppr e ) -- Should not happen
411 returnM (HsSplice n e)
413 zonkExpr env (OpApp e1 op fixity e2)
414 = zonkLExpr env e1 `thenM` \ new_e1 ->
415 zonkLExpr env op `thenM` \ new_op ->
416 zonkLExpr env e2 `thenM` \ new_e2 ->
417 returnM (OpApp new_e1 new_op fixity new_e2)
419 zonkExpr env (NegApp _ _) = panic "zonkExpr env: NegApp"
421 zonkExpr env (HsPar e)
422 = zonkLExpr env e `thenM` \new_e ->
423 returnM (HsPar new_e)
425 zonkExpr env (SectionL expr op)
426 = zonkLExpr env expr `thenM` \ new_expr ->
427 zonkLExpr env op `thenM` \ new_op ->
428 returnM (SectionL new_expr new_op)
430 zonkExpr env (SectionR op expr)
431 = zonkLExpr env op `thenM` \ new_op ->
432 zonkLExpr env expr `thenM` \ new_expr ->
433 returnM (SectionR new_op new_expr)
435 zonkExpr env (HsCase expr ms)
436 = zonkLExpr env expr `thenM` \ new_expr ->
437 mappM (zonkMatch env) ms `thenM` \ new_ms ->
438 returnM (HsCase new_expr new_ms)
440 zonkExpr env (HsIf e1 e2 e3)
441 = zonkLExpr env e1 `thenM` \ new_e1 ->
442 zonkLExpr env e2 `thenM` \ new_e2 ->
443 zonkLExpr env e3 `thenM` \ new_e3 ->
444 returnM (HsIf new_e1 new_e2 new_e3)
446 zonkExpr env (HsLet binds expr)
447 = zonkNestedBinds env binds `thenM` \ (new_env, new_binds) ->
448 zonkLExpr new_env expr `thenM` \ new_expr ->
449 returnM (HsLet new_binds new_expr)
451 zonkExpr env (HsDo do_or_lc stmts ids ty)
452 = zonkStmts env stmts `thenM` \ new_stmts ->
453 zonkTcTypeToType env ty `thenM` \ new_ty ->
454 zonkReboundNames env ids `thenM` \ new_ids ->
455 returnM (HsDo do_or_lc new_stmts new_ids new_ty)
457 zonkExpr env (ExplicitList ty exprs)
458 = zonkTcTypeToType env ty `thenM` \ new_ty ->
459 zonkLExprs env exprs `thenM` \ new_exprs ->
460 returnM (ExplicitList new_ty new_exprs)
462 zonkExpr env (ExplicitPArr ty exprs)
463 = zonkTcTypeToType env ty `thenM` \ new_ty ->
464 zonkLExprs env exprs `thenM` \ new_exprs ->
465 returnM (ExplicitPArr new_ty new_exprs)
467 zonkExpr env (ExplicitTuple exprs boxed)
468 = zonkLExprs env exprs `thenM` \ new_exprs ->
469 returnM (ExplicitTuple new_exprs boxed)
471 zonkExpr env (RecordConOut data_con con_expr rbinds)
472 = zonkLExpr env con_expr `thenM` \ new_con_expr ->
473 zonkRbinds env rbinds `thenM` \ new_rbinds ->
474 returnM (RecordConOut data_con new_con_expr new_rbinds)
476 zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd"
478 zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds)
479 = zonkLExpr env expr `thenM` \ new_expr ->
480 zonkTcTypeToType env in_ty `thenM` \ new_in_ty ->
481 zonkTcTypeToType env out_ty `thenM` \ new_out_ty ->
482 zonkRbinds env rbinds `thenM` \ new_rbinds ->
483 returnM (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
485 zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
486 zonkExpr env (ArithSeqIn _) = panic "zonkExpr env:ArithSeqIn"
487 zonkExpr env (PArrSeqIn _) = panic "zonkExpr env:PArrSeqIn"
489 zonkExpr env (ArithSeqOut expr info)
490 = zonkLExpr env expr `thenM` \ new_expr ->
491 zonkArithSeq env info `thenM` \ new_info ->
492 returnM (ArithSeqOut new_expr new_info)
494 zonkExpr env (PArrSeqOut expr info)
495 = zonkLExpr env expr `thenM` \ new_expr ->
496 zonkArithSeq env info `thenM` \ new_info ->
497 returnM (PArrSeqOut new_expr new_info)
499 zonkExpr env (HsSCC lbl expr)
500 = zonkLExpr env expr `thenM` \ new_expr ->
501 returnM (HsSCC lbl new_expr)
503 -- hdaume: core annotations
504 zonkExpr env (HsCoreAnn lbl expr)
505 = zonkLExpr env expr `thenM` \ new_expr ->
506 returnM (HsCoreAnn lbl new_expr)
508 zonkExpr env (TyLam tyvars expr)
509 = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars ->
510 -- No need to extend tyvar env; see AbsBinds
512 zonkLExpr env expr `thenM` \ new_expr ->
513 returnM (TyLam new_tyvars new_expr)
515 zonkExpr env (TyApp expr tys)
516 = zonkLExpr env expr `thenM` \ new_expr ->
517 mappM (zonkTcTypeToType env) tys `thenM` \ new_tys ->
518 returnM (TyApp new_expr new_tys)
520 zonkExpr env (DictLam dicts expr)
521 = zonkIdBndrs env dicts `thenM` \ new_dicts ->
523 env1 = extendZonkEnv env new_dicts
525 zonkLExpr env1 expr `thenM` \ new_expr ->
526 returnM (DictLam new_dicts new_expr)
528 zonkExpr env (DictApp expr dicts)
529 = zonkLExpr env expr `thenM` \ new_expr ->
530 returnM (DictApp new_expr (zonkIdOccs env dicts))
532 -- arrow notation extensions
533 zonkExpr env (HsProc pat body)
534 = zonkPat env pat `thenM` \ (new_pat, new_ids) ->
536 env1 = extendZonkEnv env (bagToList new_ids)
538 zonkCmdTop env1 body `thenM` \ new_body ->
539 returnM (HsProc new_pat new_body)
541 zonkExpr env (HsArrApp e1 e2 ty ho rl)
542 = zonkLExpr env e1 `thenM` \ new_e1 ->
543 zonkLExpr env e2 `thenM` \ new_e2 ->
544 zonkTcTypeToType env ty `thenM` \ new_ty ->
545 returnM (HsArrApp new_e1 new_e2 new_ty ho rl)
547 zonkExpr env (HsArrForm op fixity args)
548 = zonkLExpr env op `thenM` \ new_op ->
549 mappM (zonkCmdTop env) args `thenM` \ new_args ->
550 returnM (HsArrForm new_op fixity new_args)
552 zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
553 zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
555 zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
556 = zonkLExpr env cmd `thenM` \ new_cmd ->
557 mappM (zonkTcTypeToType env) stack_tys
558 `thenM` \ new_stack_tys ->
559 zonkTcTypeToType env ty `thenM` \ new_ty ->
560 zonkReboundNames env ids `thenM` \ new_ids ->
561 returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
563 -------------------------------------------------------------------------
564 zonkReboundNames :: ZonkEnv -> ReboundNames Id -> TcM (ReboundNames Id)
565 zonkReboundNames env prs
568 zonk (n, e) = zonkLExpr env e `thenM` \ new_e ->
572 -------------------------------------------------------------------------
573 zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
575 zonkArithSeq env (From e)
576 = zonkLExpr env e `thenM` \ new_e ->
579 zonkArithSeq env (FromThen e1 e2)
580 = zonkLExpr env e1 `thenM` \ new_e1 ->
581 zonkLExpr env e2 `thenM` \ new_e2 ->
582 returnM (FromThen new_e1 new_e2)
584 zonkArithSeq env (FromTo e1 e2)
585 = zonkLExpr env e1 `thenM` \ new_e1 ->
586 zonkLExpr env e2 `thenM` \ new_e2 ->
587 returnM (FromTo new_e1 new_e2)
589 zonkArithSeq env (FromThenTo e1 e2 e3)
590 = zonkLExpr env e1 `thenM` \ new_e1 ->
591 zonkLExpr env e2 `thenM` \ new_e2 ->
592 zonkLExpr env e3 `thenM` \ new_e3 ->
593 returnM (FromThenTo new_e1 new_e2 new_e3)
596 -------------------------------------------------------------------------
597 zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM [LStmt Id]
599 zonkStmts env stmts = zonk_stmts env stmts `thenM` \ (_, stmts) ->
602 zonk_stmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id])
603 zonk_stmts env [] = return (env, [])
604 zonk_stmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s
605 ; (env2, ss') <- zonk_stmts env1 ss
606 ; return (env2, s' : ss') }
608 zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
609 zonkStmt env (ParStmt stmts_w_bndrs)
610 = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs ->
612 new_binders = concat (map snd new_stmts_w_bndrs)
613 env1 = extendZonkEnv env new_binders
615 return (env1, ParStmt new_stmts_w_bndrs)
617 zonk_branch (stmts, bndrs) = zonk_stmts env stmts `thenM` \ (env1, new_stmts) ->
618 returnM (new_stmts, zonkIdOccs env1 bndrs)
620 zonkStmt env (RecStmt segStmts lvs rvs rets)
621 = zonkIdBndrs env rvs `thenM` \ new_rvs ->
623 env1 = extendZonkEnv env new_rvs
625 zonk_stmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
626 -- Zonk the ret-expressions in an envt that
627 -- has the polymorphic bindings in the envt
628 zonkLExprs env2 rets `thenM` \ new_rets ->
630 new_lvs = zonkIdOccs env2 lvs
631 env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
633 returnM (env3, RecStmt new_segStmts new_lvs new_rvs new_rets)
635 zonkStmt env (ResultStmt expr)
636 = zonkLExpr env expr `thenM` \ new_expr ->
637 returnM (env, ResultStmt new_expr)
639 zonkStmt env (ExprStmt expr ty)
640 = zonkLExpr env expr `thenM` \ new_expr ->
641 zonkTcTypeToType env ty `thenM` \ new_ty ->
642 returnM (env, ExprStmt new_expr new_ty)
644 zonkStmt env (LetStmt binds)
645 = zonkNestedBinds env binds `thenM` \ (env1, new_binds) ->
646 returnM (env1, LetStmt new_binds)
648 zonkStmt env (BindStmt pat expr)
649 = zonkLExpr env expr `thenM` \ new_expr ->
650 zonkPat env pat `thenM` \ (new_pat, new_ids) ->
652 env1 = extendZonkEnv env (bagToList new_ids)
654 returnM (env1, BindStmt new_pat new_expr)
658 -------------------------------------------------------------------------
659 zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id)
661 zonkRbinds env rbinds
662 = mappM zonk_rbind rbinds
664 zonk_rbind (field, expr)
665 = zonkLExpr env expr `thenM` \ new_expr ->
666 returnM (fmap (zonkIdOcc env) field, new_expr)
668 -------------------------------------------------------------------------
669 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
670 mapIPNameTc f (Dupable n) = f n `thenM` \ r -> returnM (Dupable r)
671 mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r)
675 %************************************************************************
677 \subsection[BackSubst-Pats]{Patterns}
679 %************************************************************************
682 zonkPat :: ZonkEnv -> OutPat TcId -> TcM (OutPat Id, Bag Id)
683 zonkPat env pat = wrapLocFstM (zonk_pat env) pat
685 zonk_pat env (ParPat p)
686 = zonkPat env p `thenM` \ (new_p, ids) ->
687 returnM (ParPat new_p, ids)
689 zonk_pat env (WildPat ty)
690 = zonkTcTypeToType env ty `thenM` \ new_ty ->
691 returnM (WildPat new_ty, emptyBag)
693 zonk_pat env (VarPat v)
694 = zonkIdBndr env v `thenM` \ new_v ->
695 returnM (VarPat new_v, unitBag new_v)
697 zonk_pat env (LazyPat pat)
698 = zonkPat env pat `thenM` \ (new_pat, ids) ->
699 returnM (LazyPat new_pat, ids)
701 zonk_pat env (AsPat n pat)
702 = wrapLocM (zonkIdBndr env) n `thenM` \ new_n ->
703 zonkPat env pat `thenM` \ (new_pat, ids) ->
704 returnM (AsPat new_n new_pat, unLoc new_n `consBag` ids)
706 zonk_pat env (ListPat pats ty)
707 = zonkTcTypeToType env ty `thenM` \ new_ty ->
708 zonkPats env pats `thenM` \ (new_pats, ids) ->
709 returnM (ListPat new_pats new_ty, ids)
711 zonk_pat env (PArrPat pats ty)
712 = zonkTcTypeToType env ty `thenM` \ new_ty ->
713 zonkPats env pats `thenM` \ (new_pats, ids) ->
714 returnM (PArrPat new_pats new_ty, ids)
716 zonk_pat env (TuplePat pats boxed)
717 = zonkPats env pats `thenM` \ (new_pats, ids) ->
718 returnM (TuplePat new_pats boxed, ids)
720 zonk_pat env (ConPatOut n stuff ty tvs dicts)
721 = zonkTcTypeToType env ty `thenM` \ new_ty ->
722 mappM zonkTcTyVarToTyVar tvs `thenM` \ new_tvs ->
723 zonkIdBndrs env dicts `thenM` \ new_dicts ->
725 env1 = extendZonkEnv env new_dicts
727 zonkConStuff env1 stuff `thenM` \ (new_stuff, ids) ->
728 returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts,
729 listToBag new_dicts `unionBags` ids)
731 zonk_pat env (LitPat lit) = returnM (LitPat lit, emptyBag)
733 zonk_pat env (SigPatOut pat ty expr)
734 = zonkPat env pat `thenM` \ (new_pat, ids) ->
735 zonkTcTypeToType env ty `thenM` \ new_ty ->
736 zonkExpr env expr `thenM` \ new_expr ->
737 returnM (SigPatOut new_pat new_ty new_expr, ids)
739 zonk_pat env (NPatOut lit ty expr)
740 = zonkTcTypeToType env ty `thenM` \ new_ty ->
741 zonkExpr env expr `thenM` \ new_expr ->
742 returnM (NPatOut lit new_ty new_expr, emptyBag)
744 zonk_pat env (NPlusKPatOut n k e1 e2)
745 = wrapLocM (zonkIdBndr env) n `thenM` \ new_n ->
746 zonkExpr env e1 `thenM` \ new_e1 ->
747 zonkExpr env e2 `thenM` \ new_e2 ->
748 returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag (unLoc new_n))
750 zonk_pat env (DictPat ds ms)
751 = zonkIdBndrs env ds `thenM` \ new_ds ->
752 zonkIdBndrs env ms `thenM` \ new_ms ->
753 returnM (DictPat new_ds new_ms,
754 listToBag new_ds `unionBags` listToBag new_ms)
756 ---------------------------
757 zonkConStuff env (PrefixCon pats)
758 = zonkPats env pats `thenM` \ (new_pats, ids) ->
759 returnM (PrefixCon new_pats, ids)
761 zonkConStuff env (InfixCon p1 p2)
762 = zonkPat env p1 `thenM` \ (new_p1, ids1) ->
763 zonkPat env p2 `thenM` \ (new_p2, ids2) ->
764 returnM (InfixCon new_p1 new_p2, ids1 `unionBags` ids2)
766 zonkConStuff env (RecCon rpats)
767 = mapAndUnzipM zonk_rpat rpats `thenM` \ (new_rpats, ids_s) ->
768 returnM (RecCon new_rpats, unionManyBags ids_s)
771 = zonkPat env pat `thenM` \ (new_pat, ids) ->
772 returnM ((f, new_pat), ids)
774 ---------------------------
776 = returnM ([], emptyBag)
778 zonkPats env (pat:pats)
779 = zonkPat env pat `thenM` \ (pat', ids1) ->
780 zonkPats env pats `thenM` \ (pats', ids2) ->
781 returnM (pat':pats', ids1 `unionBags` ids2)
784 %************************************************************************
786 \subsection[BackSubst-Foreign]{Foreign exports}
788 %************************************************************************
792 zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
793 zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
795 zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
796 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec) =
797 returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec isDeprec)
798 zonkForeignExport env for_imp
799 = returnM for_imp -- Foreign imports don't need zonking
803 zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
804 zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
806 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
807 zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs rhs)
808 = mappM zonk_bndr vars `thenM` \ new_bndrs ->
809 newMutVar emptyVarSet `thenM` \ unbound_tv_set ->
811 env_rhs = extendZonkEnv env [id | b <- new_bndrs, let id = unLoc b, isId id]
812 -- Type variables don't need an envt
813 -- They are bound through the mutable mechanism
815 env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
816 -- We need to gather the type variables mentioned on the LHS so we can
817 -- quantify over them. Example:
823 -- {-# RULES "myrule" foo C = 1 #-}
825 -- After type checking the LHS becomes (foo a (C a))
826 -- and we do not want to zap the unbound tyvar 'a' to (), because
827 -- that limits the applicability of the rule. Instead, we
828 -- want to quantify over it!
830 -- It's easiest to find the free tyvars here. Attempts to do so earlier
831 -- are tiresome, because (a) the data type is big and (b) finding the
832 -- free type vars of an expression is necessarily monadic operation.
833 -- (consider /\a -> f @ b, where b is side-effected to a)
835 zonkLExpr env_lhs lhs `thenM` \ new_lhs ->
836 zonkLExpr env_rhs rhs `thenM` \ new_rhs ->
838 readMutVar unbound_tv_set `thenM` \ unbound_tvs ->
840 final_bndrs :: [Located Var]
841 final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs
843 returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs new_rhs)
844 -- I hate this map RuleBndr stuff
846 zonk_bndr (RuleBndr v)
847 | isId (unLoc v) = wrapLocM (zonkIdBndr env) v
848 | otherwise = wrapLocM zonkTcTyVarToTyVar v
852 %************************************************************************
854 \subsection[BackSubst-Foreign]{Foreign exports}
856 %************************************************************************
859 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
860 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
862 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
863 -- This variant collects unbound type variables in a mutable variable
864 zonkTypeCollecting unbound_tv_set
865 = zonkType zonk_unbound_tyvar
867 zonk_unbound_tyvar tv
868 = zonkTcTyVarToTyVar tv `thenM` \ tv' ->
869 readMutVar unbound_tv_set `thenM` \ tv_set ->
870 writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_`
871 return (mkTyVarTy tv')
873 zonkTypeZapping :: TcType -> TcM Type
874 -- This variant is used for everything except the LHS of rules
875 -- It zaps unbound type variables to (), or some other arbitrary type
877 = zonkType zonk_unbound_tyvar ty
879 -- Zonk a mutable but unbound type variable to an arbitrary type
880 -- We know it's unbound even though we don't carry an environment,
881 -- because at the binding site for a type variable we bind the
882 -- mutable tyvar to a fresh immutable one. So the mutable store
883 -- plays the role of an environment. If we come across a mutable
884 -- type variable that isn't so bound, it must be completely free.
885 zonk_unbound_tyvar tv = putTcTyVar tv (mkArbitraryType tv)
888 -- When the type checker finds a type variable with no binding,
889 -- which means it can be instantiated with an arbitrary type, it
890 -- usually instantiates it to Void. Eg.
894 -- length Void (Nil Void)
896 -- But in really obscure programs, the type variable might have
897 -- a kind other than *, so we need to invent a suitably-kinded type.
901 -- List for kind *->*
902 -- Tuple for kind *->...*->*
904 -- which deals with most cases. (Previously, it only dealt with
907 -- In the other cases, it just makes up a TyCon with a suitable
908 -- kind. If this gets into an interface file, anyone reading that
909 -- file won't understand it. This is fixable (by making the client
910 -- of the interface file make up a TyCon too) but it is tiresome and
911 -- never happens, so I am leaving it
913 mkArbitraryType :: TcTyVar -> Type
914 -- Make up an arbitrary type whose kind is the same as the tyvar.
915 -- We'll use this to instantiate the (unbound) tyvar.
917 | isAnyTypeKind kind = voidTy -- The vastly common case
918 | otherwise = mkTyConApp tycon []
921 (args,res) = Type.splitFunTys kind -- Kinds are simple; use Type.splitFunTys
923 tycon | kind `eqKind` tyConKind listTyCon -- *->*
924 = listTyCon -- No tuples this size
926 | all isTypeKind args && isTypeKind res
927 = tupleTyCon Boxed (length args) -- *-> ... ->*->*
930 = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
931 mkPrimTyCon tc_name kind 0 [] VoidRep
932 -- Same name as the tyvar, apart from making it start with a colon (sigh)
933 -- I dread to think what will happen if this gets out into an
934 -- interface file. Catastrophe likely. Major sigh.
936 tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc