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, mkTyVarTy, tcGetTyVar, mkTyConApp )
41 import Kind ( isLiftedTypeKind, liftedTypeKind, isSubKind )
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 Kind ( splitKindFunTys )
53 import PrimRep ( PrimRep(VoidRep) )
54 import Name ( getOccName, mkInternalName, mkDerivedTyConOcc )
55 import Var ( Var, isId, isLocalVar, tyVarKind )
58 import BasicTypes ( Boxity(..), IPName(..), ipNameName, mapIPName )
59 import Maybes ( orElse )
60 import Maybe ( isNothing )
61 import Unique ( Uniquable(..) )
62 import SrcLoc ( noSrcLoc, noLoc, Located(..), unLoc )
69 type TcDictBinds = LHsBinds TcId -- Bag of dictionary bindings
73 %************************************************************************
75 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
77 %************************************************************************
79 Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@,
80 then something is wrong.
82 hsPatType :: OutPat Id -> Type
83 hsPatType pat = pat_type (unLoc pat)
85 pat_type (ParPat pat) = hsPatType pat
86 pat_type (WildPat ty) = ty
87 pat_type (VarPat var) = idType var
88 pat_type (LazyPat pat) = hsPatType pat
89 pat_type (LitPat lit) = hsLitType lit
90 pat_type (AsPat var pat) = idType (unLoc var)
91 pat_type (ListPat _ ty) = mkListTy ty
92 pat_type (PArrPat _ ty) = mkPArrTy ty
93 pat_type (TuplePat pats box) = mkTupleTy box (length pats) (map hsPatType pats)
94 pat_type (ConPatOut _ _ ty _ _) = ty
95 pat_type (SigPatOut _ ty _) = ty
96 pat_type (NPatOut lit ty _) = ty
97 pat_type (NPlusKPatOut id _ _ _) = idType (unLoc id)
98 pat_type (DictPat ds ms) = case (ds ++ ms) of
101 ds -> mkTupleTy Boxed (length ds) (map idType ds)
104 hsLitType :: HsLit -> TcType
105 hsLitType (HsChar c) = charTy
106 hsLitType (HsCharPrim c) = charPrimTy
107 hsLitType (HsString str) = stringTy
108 hsLitType (HsStringPrim s) = addrPrimTy
109 hsLitType (HsInt i) = intTy
110 hsLitType (HsIntPrim i) = intPrimTy
111 hsLitType (HsInteger i ty) = ty
112 hsLitType (HsRat _ ty) = ty
113 hsLitType (HsFloatPrim f) = floatPrimTy
114 hsLitType (HsDoublePrim d) = doublePrimTy
117 %************************************************************************
119 \subsection{Coercion functions}
121 %************************************************************************
124 type Coercion a = Maybe (a -> a)
125 -- Nothing => identity fn
127 type ExprCoFn = Coercion (HsExpr TcId)
128 type PatCoFn = Coercion (Pat TcId)
130 (<.>) :: Coercion a -> Coercion a -> Coercion a -- Composition
131 Nothing <.> Nothing = Nothing
132 Nothing <.> Just f = Just f
133 Just f <.> Nothing = Just f
134 Just f1 <.> Just f2 = Just (f1 . f2)
136 (<$>) :: Coercion a -> a -> a
140 mkCoercion :: (a -> a) -> Coercion a
141 mkCoercion f = Just f
143 idCoercion :: Coercion a
146 isIdCoercion :: Coercion a -> Bool
147 isIdCoercion = isNothing
151 %************************************************************************
153 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
155 %************************************************************************
158 -- zonkId is used *during* typechecking just to zonk the Id's type
159 zonkId :: TcId -> TcM TcId
161 = zonkTcType (idType id) `thenM` \ ty' ->
162 returnM (setIdType id ty')
165 The rest of the zonking is done *after* typechecking.
166 The main zonking pass runs over the bindings
168 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
169 b) convert unbound TcTyVar to Void
170 c) convert each TcId to an Id by zonking its type
172 The type variables are converted by binding mutable tyvars to immutable ones
173 and then zonking as normal.
175 The Ids are converted by binding them in the normal Tc envt; that
176 way we maintain sharing; eg an Id is zonked at its binding site and they
177 all occurrences of that Id point to the common zonked copy
179 It's all pretty boring stuff, because HsSyn is such a large type, and
180 the environment manipulation is tiresome.
183 data ZonkEnv = ZonkEnv (TcType -> TcM Type) -- How to zonk a type
184 (IdEnv Id) -- What variables are in scope
185 -- Maps an Id to its zonked version; both have the same Name
186 -- Is only consulted lazily; hence knot-tying
188 emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
190 extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
191 extendZonkEnv (ZonkEnv zonk_ty env) ids
192 = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
194 setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
195 setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
197 mkZonkEnv :: [Id] -> ZonkEnv
198 mkZonkEnv ids = extendZonkEnv emptyZonkEnv ids
200 zonkIdOcc :: ZonkEnv -> TcId -> Id
201 -- Ids defined in this module should be in the envt;
202 -- ignore others. (Actually, data constructors are also
203 -- not LocalVars, even when locally defined, but that is fine.)
205 -- Actually, Template Haskell works in 'chunks' of declarations, and
206 -- an earlier chunk won't be in the 'env' that the zonking phase
207 -- carries around. Instead it'll be in the tcg_gbl_env, already fully
208 -- zonked. There's no point in looking it up there (except for error
209 -- checking), and it's not conveniently to hand; hence the simple
210 -- 'orElse' case in the LocalVar branch.
212 -- Even without template splices, in module Main, the checking of
213 -- 'main' is done as a separte chunk.
214 zonkIdOcc (ZonkEnv zonk_ty env) id
215 | isLocalVar id = lookupVarEnv env id `orElse` id
218 zonkIdOccs env ids = map (zonkIdOcc env) ids
220 -- zonkIdBndr is used *after* typechecking to get the Id's type
221 -- to its final form. The TyVarEnv give
222 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
224 = zonkTcTypeToType env (idType id) `thenM` \ ty' ->
225 returnM (setIdType id ty')
227 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
228 zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
230 zonkTopBndrs :: [TcId] -> TcM [Id]
231 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
236 zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
237 zonkTopExpr e = zonkExpr emptyZonkEnv e
239 zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
240 zonkTopLExpr e = zonkLExpr emptyZonkEnv e
242 zonkTopDecls :: Bag (LHsBind TcId) -> [LRuleDecl TcId] -> [LForeignDecl TcId]
247 zonkTopDecls binds rules fords -- Top level is implicitly recursive
248 = fixM (\ ~(new_ids, _, _, _) ->
250 zonk_env = mkZonkEnv new_ids
252 zonkMonoBinds zonk_env binds `thenM` \ binds' ->
253 zonkRules zonk_env rules `thenM` \ rules' ->
254 zonkForeignExports zonk_env fords `thenM` \ fords' ->
256 returnM (collectHsBindBinders binds', binds', fords', rules')
259 ---------------------------------------------
260 zonkGroup :: ZonkEnv -> HsBindGroup TcId -> TcM (ZonkEnv, HsBindGroup Id)
261 zonkGroup env (HsBindGroup bs sigs is_rec)
262 = ASSERT( null sigs )
263 do { (env1, bs') <- fixM (\ ~(_, new_binds) -> do
264 { let env1 = extendZonkEnv env (collectHsBindBinders new_binds)
265 ; bs' <- zonkMonoBinds env1 bs
266 ; return (env1, bs') })
267 ; return (env1, HsBindGroup bs' [] is_rec) }
270 zonkGroup env (HsIPBinds binds)
271 = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds ->
273 env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
275 returnM (env1, HsIPBinds new_binds)
277 zonk_ip_bind (IPBind n e)
278 = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' ->
279 zonkLExpr env e `thenM` \ e' ->
280 returnM (IPBind n' e')
282 ---------------------------------------------
283 zonkNestedBinds :: ZonkEnv -> [HsBindGroup TcId] -> TcM (ZonkEnv, [HsBindGroup Id])
284 zonkNestedBinds env [] = return (env, [])
285 zonkNestedBinds env (b:bs) = do { (env1, b') <- zonkGroup env b
286 ; (env2, bs') <- zonkNestedBinds env1 bs
287 ; return (env2, b':bs') }
289 ---------------------------------------------
290 zonkMonoBinds :: ZonkEnv -> Bag (LHsBind TcId) -> TcM (Bag (LHsBind Id))
291 zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds
293 zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
294 zonk_bind env (PatBind pat grhss)
295 = zonkPat env pat `thenM` \ (new_pat, _) ->
296 zonkGRHSs env grhss `thenM` \ new_grhss ->
297 returnM (PatBind new_pat new_grhss)
299 zonk_bind env (VarBind var expr)
300 = zonkIdBndr env var `thenM` \ new_var ->
301 zonkLExpr env expr `thenM` \ new_expr ->
302 returnM (VarBind new_var new_expr)
304 zonk_bind env (FunBind var inf ms)
305 = wrapLocM (zonkIdBndr env) var `thenM` \ new_var ->
306 mappM (zonkMatch env) ms `thenM` \ new_ms ->
307 returnM (FunBind new_var inf new_ms)
309 zonk_bind env (AbsBinds tyvars dicts exports inlines val_binds)
310 = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars ->
311 -- No need to extend tyvar env: the effects are
312 -- propagated through binding the tyvars themselves
314 zonkIdBndrs env dicts `thenM` \ new_dicts ->
315 fixM (\ ~(new_val_binds, _) ->
317 env1 = extendZonkEnv (extendZonkEnv env new_dicts)
318 (collectHsBindBinders new_val_binds)
320 zonkMonoBinds env1 val_binds `thenM` \ new_val_binds ->
321 mappM (zonkExport env1) exports `thenM` \ new_exports ->
322 returnM (new_val_binds, new_exports)
323 ) `thenM` \ (new_val_bind, new_exports) ->
324 returnM (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind)
326 zonkExport env (tyvars, global, local)
327 = zonkTcTyVars tyvars `thenM` \ tys ->
329 new_tyvars = map (tcGetTyVar "zonkExport") tys
330 -- This isn't the binding occurrence of these tyvars
331 -- but they should *be* tyvars. Hence tcGetTyVar.
333 zonkIdBndr env global `thenM` \ new_global ->
334 returnM (new_tyvars, new_global, zonkIdOcc env local)
337 %************************************************************************
339 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
341 %************************************************************************
344 zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id)
346 zonkMatch env (L loc (Match pats _ grhss))
347 = zonkPats env pats `thenM` \ (new_pats, new_ids) ->
348 zonkGRHSs (extendZonkEnv env (bagToList new_ids)) grhss `thenM` \ new_grhss ->
349 returnM (L loc (Match new_pats Nothing new_grhss))
351 -------------------------------------------------------------------------
352 zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id)
354 zonkGRHSs env (GRHSs grhss binds ty)
355 = zonkNestedBinds env binds `thenM` \ (new_env, new_binds) ->
357 zonk_grhs (GRHS guarded)
358 = zonkStmts new_env guarded `thenM` \ new_guarded ->
359 returnM (GRHS new_guarded)
361 mappM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss ->
362 zonkTcTypeToType env ty `thenM` \ new_ty ->
363 returnM (GRHSs new_grhss new_binds new_ty)
366 %************************************************************************
368 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
370 %************************************************************************
373 zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
374 zonkLExpr :: ZonkEnv -> LHsExpr TcId -> TcM (LHsExpr Id)
375 zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id)
377 zonkLExprs env exprs = mappM (zonkLExpr env) exprs
378 zonkLExpr env expr = wrapLocM (zonkExpr env) expr
380 zonkExpr env (HsVar id)
381 = returnM (HsVar (zonkIdOcc env id))
383 zonkExpr env (HsIPVar id)
384 = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
386 zonkExpr env (HsLit (HsRat f ty))
387 = zonkTcTypeToType env ty `thenM` \ new_ty ->
388 returnM (HsLit (HsRat f new_ty))
390 zonkExpr env (HsLit lit)
391 = returnM (HsLit lit)
393 -- HsOverLit doesn't appear in typechecker output
395 zonkExpr env (HsLam match)
396 = zonkMatch env match `thenM` \ new_match ->
397 returnM (HsLam new_match)
399 zonkExpr env (HsApp e1 e2)
400 = zonkLExpr env e1 `thenM` \ new_e1 ->
401 zonkLExpr env e2 `thenM` \ new_e2 ->
402 returnM (HsApp new_e1 new_e2)
404 zonkExpr env (HsBracketOut body bs)
405 = mappM zonk_b bs `thenM` \ bs' ->
406 returnM (HsBracketOut body bs')
408 zonk_b (n,e) = zonkLExpr env e `thenM` \ e' ->
411 zonkExpr env (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
412 returnM (HsSpliceE s)
414 zonkExpr env (OpApp e1 op fixity e2)
415 = zonkLExpr env e1 `thenM` \ new_e1 ->
416 zonkLExpr env op `thenM` \ new_op ->
417 zonkLExpr env e2 `thenM` \ new_e2 ->
418 returnM (OpApp new_e1 new_op fixity new_e2)
420 zonkExpr env (NegApp _ _) = panic "zonkExpr env: NegApp"
422 zonkExpr env (HsPar e)
423 = zonkLExpr env e `thenM` \new_e ->
424 returnM (HsPar new_e)
426 zonkExpr env (SectionL expr op)
427 = zonkLExpr env expr `thenM` \ new_expr ->
428 zonkLExpr env op `thenM` \ new_op ->
429 returnM (SectionL new_expr new_op)
431 zonkExpr env (SectionR op expr)
432 = zonkLExpr env op `thenM` \ new_op ->
433 zonkLExpr env expr `thenM` \ new_expr ->
434 returnM (SectionR new_op new_expr)
436 zonkExpr env (HsCase expr ms)
437 = zonkLExpr env expr `thenM` \ new_expr ->
438 mappM (zonkMatch env) ms `thenM` \ new_ms ->
439 returnM (HsCase new_expr new_ms)
441 zonkExpr env (HsIf e1 e2 e3)
442 = zonkLExpr env e1 `thenM` \ new_e1 ->
443 zonkLExpr env e2 `thenM` \ new_e2 ->
444 zonkLExpr env e3 `thenM` \ new_e3 ->
445 returnM (HsIf new_e1 new_e2 new_e3)
447 zonkExpr env (HsLet binds expr)
448 = zonkNestedBinds env binds `thenM` \ (new_env, new_binds) ->
449 zonkLExpr new_env expr `thenM` \ new_expr ->
450 returnM (HsLet new_binds new_expr)
452 zonkExpr env (HsDo do_or_lc stmts ids ty)
453 = zonkStmts env stmts `thenM` \ new_stmts ->
454 zonkTcTypeToType env ty `thenM` \ new_ty ->
455 zonkReboundNames env ids `thenM` \ new_ids ->
456 returnM (HsDo do_or_lc new_stmts new_ids new_ty)
458 zonkExpr env (ExplicitList ty exprs)
459 = zonkTcTypeToType env ty `thenM` \ new_ty ->
460 zonkLExprs env exprs `thenM` \ new_exprs ->
461 returnM (ExplicitList new_ty new_exprs)
463 zonkExpr env (ExplicitPArr ty exprs)
464 = zonkTcTypeToType env ty `thenM` \ new_ty ->
465 zonkLExprs env exprs `thenM` \ new_exprs ->
466 returnM (ExplicitPArr new_ty new_exprs)
468 zonkExpr env (ExplicitTuple exprs boxed)
469 = zonkLExprs env exprs `thenM` \ new_exprs ->
470 returnM (ExplicitTuple new_exprs boxed)
472 zonkExpr env (RecordConOut data_con con_expr rbinds)
473 = zonkLExpr env con_expr `thenM` \ new_con_expr ->
474 zonkRbinds env rbinds `thenM` \ new_rbinds ->
475 returnM (RecordConOut data_con new_con_expr new_rbinds)
477 zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd"
479 zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds)
480 = zonkLExpr env expr `thenM` \ new_expr ->
481 zonkTcTypeToType env in_ty `thenM` \ new_in_ty ->
482 zonkTcTypeToType env out_ty `thenM` \ new_out_ty ->
483 zonkRbinds env rbinds `thenM` \ new_rbinds ->
484 returnM (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
486 zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
487 zonkExpr env (ArithSeqIn _) = panic "zonkExpr env:ArithSeqIn"
488 zonkExpr env (PArrSeqIn _) = panic "zonkExpr env:PArrSeqIn"
490 zonkExpr env (ArithSeqOut expr info)
491 = zonkLExpr env expr `thenM` \ new_expr ->
492 zonkArithSeq env info `thenM` \ new_info ->
493 returnM (ArithSeqOut new_expr new_info)
495 zonkExpr env (PArrSeqOut expr info)
496 = zonkLExpr env expr `thenM` \ new_expr ->
497 zonkArithSeq env info `thenM` \ new_info ->
498 returnM (PArrSeqOut new_expr new_info)
500 zonkExpr env (HsSCC lbl expr)
501 = zonkLExpr env expr `thenM` \ new_expr ->
502 returnM (HsSCC lbl new_expr)
504 -- hdaume: core annotations
505 zonkExpr env (HsCoreAnn lbl expr)
506 = zonkLExpr env expr `thenM` \ new_expr ->
507 returnM (HsCoreAnn lbl new_expr)
509 zonkExpr env (TyLam tyvars expr)
510 = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars ->
511 -- No need to extend tyvar env; see AbsBinds
513 zonkLExpr env expr `thenM` \ new_expr ->
514 returnM (TyLam new_tyvars new_expr)
516 zonkExpr env (TyApp expr tys)
517 = zonkLExpr env expr `thenM` \ new_expr ->
518 mappM (zonkTcTypeToType env) tys `thenM` \ new_tys ->
519 returnM (TyApp new_expr new_tys)
521 zonkExpr env (DictLam dicts expr)
522 = zonkIdBndrs env dicts `thenM` \ new_dicts ->
524 env1 = extendZonkEnv env new_dicts
526 zonkLExpr env1 expr `thenM` \ new_expr ->
527 returnM (DictLam new_dicts new_expr)
529 zonkExpr env (DictApp expr dicts)
530 = zonkLExpr env expr `thenM` \ new_expr ->
531 returnM (DictApp new_expr (zonkIdOccs env dicts))
533 -- arrow notation extensions
534 zonkExpr env (HsProc pat body)
535 = zonkPat env pat `thenM` \ (new_pat, new_ids) ->
537 env1 = extendZonkEnv env (bagToList new_ids)
539 zonkCmdTop env1 body `thenM` \ new_body ->
540 returnM (HsProc new_pat new_body)
542 zonkExpr env (HsArrApp e1 e2 ty ho rl)
543 = zonkLExpr env e1 `thenM` \ new_e1 ->
544 zonkLExpr env e2 `thenM` \ new_e2 ->
545 zonkTcTypeToType env ty `thenM` \ new_ty ->
546 returnM (HsArrApp new_e1 new_e2 new_ty ho rl)
548 zonkExpr env (HsArrForm op fixity args)
549 = zonkLExpr env op `thenM` \ new_op ->
550 mappM (zonkCmdTop env) args `thenM` \ new_args ->
551 returnM (HsArrForm new_op fixity new_args)
553 zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
554 zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
556 zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
557 = zonkLExpr env cmd `thenM` \ new_cmd ->
558 mappM (zonkTcTypeToType env) stack_tys
559 `thenM` \ new_stack_tys ->
560 zonkTcTypeToType env ty `thenM` \ new_ty ->
561 zonkReboundNames env ids `thenM` \ new_ids ->
562 returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
564 -------------------------------------------------------------------------
565 zonkReboundNames :: ZonkEnv -> ReboundNames Id -> TcM (ReboundNames Id)
566 zonkReboundNames env prs
569 zonk (n, e) = zonkLExpr env e `thenM` \ new_e ->
573 -------------------------------------------------------------------------
574 zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
576 zonkArithSeq env (From e)
577 = zonkLExpr env e `thenM` \ new_e ->
580 zonkArithSeq env (FromThen e1 e2)
581 = zonkLExpr env e1 `thenM` \ new_e1 ->
582 zonkLExpr env e2 `thenM` \ new_e2 ->
583 returnM (FromThen new_e1 new_e2)
585 zonkArithSeq env (FromTo e1 e2)
586 = zonkLExpr env e1 `thenM` \ new_e1 ->
587 zonkLExpr env e2 `thenM` \ new_e2 ->
588 returnM (FromTo new_e1 new_e2)
590 zonkArithSeq env (FromThenTo e1 e2 e3)
591 = zonkLExpr env e1 `thenM` \ new_e1 ->
592 zonkLExpr env e2 `thenM` \ new_e2 ->
593 zonkLExpr env e3 `thenM` \ new_e3 ->
594 returnM (FromThenTo new_e1 new_e2 new_e3)
597 -------------------------------------------------------------------------
598 zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM [LStmt Id]
600 zonkStmts env stmts = zonk_stmts env stmts `thenM` \ (_, stmts) ->
603 zonk_stmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id])
604 zonk_stmts env [] = return (env, [])
605 zonk_stmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s
606 ; (env2, ss') <- zonk_stmts env1 ss
607 ; return (env2, s' : ss') }
609 zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
610 zonkStmt env (ParStmt stmts_w_bndrs)
611 = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs ->
613 new_binders = concat (map snd new_stmts_w_bndrs)
614 env1 = extendZonkEnv env new_binders
616 return (env1, ParStmt new_stmts_w_bndrs)
618 zonk_branch (stmts, bndrs) = zonk_stmts env stmts `thenM` \ (env1, new_stmts) ->
619 returnM (new_stmts, zonkIdOccs env1 bndrs)
621 zonkStmt env (RecStmt segStmts lvs rvs rets)
622 = zonkIdBndrs env rvs `thenM` \ new_rvs ->
624 env1 = extendZonkEnv env new_rvs
626 zonk_stmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
627 -- Zonk the ret-expressions in an envt that
628 -- has the polymorphic bindings in the envt
629 zonkLExprs env2 rets `thenM` \ new_rets ->
631 new_lvs = zonkIdOccs env2 lvs
632 env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
634 returnM (env3, RecStmt new_segStmts new_lvs new_rvs new_rets)
636 zonkStmt env (ResultStmt expr)
637 = zonkLExpr env expr `thenM` \ new_expr ->
638 returnM (env, ResultStmt new_expr)
640 zonkStmt env (ExprStmt expr ty)
641 = zonkLExpr env expr `thenM` \ new_expr ->
642 zonkTcTypeToType env ty `thenM` \ new_ty ->
643 returnM (env, ExprStmt new_expr new_ty)
645 zonkStmt env (LetStmt binds)
646 = zonkNestedBinds env binds `thenM` \ (env1, new_binds) ->
647 returnM (env1, LetStmt new_binds)
649 zonkStmt env (BindStmt pat expr)
650 = zonkLExpr env expr `thenM` \ new_expr ->
651 zonkPat env pat `thenM` \ (new_pat, new_ids) ->
653 env1 = extendZonkEnv env (bagToList new_ids)
655 returnM (env1, BindStmt new_pat new_expr)
659 -------------------------------------------------------------------------
660 zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id)
662 zonkRbinds env rbinds
663 = mappM zonk_rbind rbinds
665 zonk_rbind (field, expr)
666 = zonkLExpr env expr `thenM` \ new_expr ->
667 returnM (fmap (zonkIdOcc env) field, new_expr)
669 -------------------------------------------------------------------------
670 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
671 mapIPNameTc f (Dupable n) = f n `thenM` \ r -> returnM (Dupable r)
672 mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r)
676 %************************************************************************
678 \subsection[BackSubst-Pats]{Patterns}
680 %************************************************************************
683 zonkPat :: ZonkEnv -> OutPat TcId -> TcM (OutPat Id, Bag Id)
684 zonkPat env pat = wrapLocFstM (zonk_pat env) pat
686 zonk_pat env (ParPat p)
687 = zonkPat env p `thenM` \ (new_p, ids) ->
688 returnM (ParPat new_p, ids)
690 zonk_pat env (WildPat ty)
691 = zonkTcTypeToType env ty `thenM` \ new_ty ->
692 returnM (WildPat new_ty, emptyBag)
694 zonk_pat env (VarPat v)
695 = zonkIdBndr env v `thenM` \ new_v ->
696 returnM (VarPat new_v, unitBag new_v)
698 zonk_pat env (LazyPat pat)
699 = zonkPat env pat `thenM` \ (new_pat, ids) ->
700 returnM (LazyPat new_pat, ids)
702 zonk_pat env (AsPat n pat)
703 = wrapLocM (zonkIdBndr env) n `thenM` \ new_n ->
704 zonkPat env pat `thenM` \ (new_pat, ids) ->
705 returnM (AsPat new_n new_pat, unLoc new_n `consBag` ids)
707 zonk_pat env (ListPat pats ty)
708 = zonkTcTypeToType env ty `thenM` \ new_ty ->
709 zonkPats env pats `thenM` \ (new_pats, ids) ->
710 returnM (ListPat new_pats new_ty, ids)
712 zonk_pat env (PArrPat pats ty)
713 = zonkTcTypeToType env ty `thenM` \ new_ty ->
714 zonkPats env pats `thenM` \ (new_pats, ids) ->
715 returnM (PArrPat new_pats new_ty, ids)
717 zonk_pat env (TuplePat pats boxed)
718 = zonkPats env pats `thenM` \ (new_pats, ids) ->
719 returnM (TuplePat new_pats boxed, ids)
721 zonk_pat env (ConPatOut n stuff ty tvs dicts)
722 = zonkTcTypeToType env ty `thenM` \ new_ty ->
723 mappM zonkTcTyVarToTyVar tvs `thenM` \ new_tvs ->
724 zonkIdBndrs env dicts `thenM` \ new_dicts ->
726 env1 = extendZonkEnv env new_dicts
728 zonkConStuff env1 stuff `thenM` \ (new_stuff, ids) ->
729 returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts,
730 listToBag new_dicts `unionBags` ids)
732 zonk_pat env (LitPat lit) = returnM (LitPat lit, emptyBag)
734 zonk_pat env (SigPatOut pat ty expr)
735 = zonkPat env pat `thenM` \ (new_pat, ids) ->
736 zonkTcTypeToType env ty `thenM` \ new_ty ->
737 zonkExpr env expr `thenM` \ new_expr ->
738 returnM (SigPatOut new_pat new_ty new_expr, ids)
740 zonk_pat env (NPatOut lit ty expr)
741 = zonkTcTypeToType env ty `thenM` \ new_ty ->
742 zonkExpr env expr `thenM` \ new_expr ->
743 returnM (NPatOut lit new_ty new_expr, emptyBag)
745 zonk_pat env (NPlusKPatOut n k e1 e2)
746 = wrapLocM (zonkIdBndr env) n `thenM` \ new_n ->
747 zonkExpr env e1 `thenM` \ new_e1 ->
748 zonkExpr env e2 `thenM` \ new_e2 ->
749 returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag (unLoc new_n))
751 zonk_pat env (DictPat ds ms)
752 = zonkIdBndrs env ds `thenM` \ new_ds ->
753 zonkIdBndrs env ms `thenM` \ new_ms ->
754 returnM (DictPat new_ds new_ms,
755 listToBag new_ds `unionBags` listToBag new_ms)
757 ---------------------------
758 zonkConStuff env (PrefixCon pats)
759 = zonkPats env pats `thenM` \ (new_pats, ids) ->
760 returnM (PrefixCon new_pats, ids)
762 zonkConStuff env (InfixCon p1 p2)
763 = zonkPat env p1 `thenM` \ (new_p1, ids1) ->
764 zonkPat env p2 `thenM` \ (new_p2, ids2) ->
765 returnM (InfixCon new_p1 new_p2, ids1 `unionBags` ids2)
767 zonkConStuff env (RecCon rpats)
768 = mapAndUnzipM zonk_rpat rpats `thenM` \ (new_rpats, ids_s) ->
769 returnM (RecCon new_rpats, unionManyBags ids_s)
772 = zonkPat env pat `thenM` \ (new_pat, ids) ->
773 returnM ((f, new_pat), ids)
775 ---------------------------
777 = returnM ([], emptyBag)
779 zonkPats env (pat:pats)
780 = zonkPat env pat `thenM` \ (pat', ids1) ->
781 zonkPats env pats `thenM` \ (pats', ids2) ->
782 returnM (pat':pats', ids1 `unionBags` ids2)
785 %************************************************************************
787 \subsection[BackSubst-Foreign]{Foreign exports}
789 %************************************************************************
793 zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
794 zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
796 zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
797 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec) =
798 returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec isDeprec)
799 zonkForeignExport env for_imp
800 = returnM for_imp -- Foreign imports don't need zonking
804 zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
805 zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
807 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
808 zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs rhs)
809 = mappM zonk_bndr vars `thenM` \ new_bndrs ->
810 newMutVar emptyVarSet `thenM` \ unbound_tv_set ->
812 env_rhs = extendZonkEnv env [id | b <- new_bndrs, let id = unLoc b, isId id]
813 -- Type variables don't need an envt
814 -- They are bound through the mutable mechanism
816 env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
817 -- We need to gather the type variables mentioned on the LHS so we can
818 -- quantify over them. Example:
824 -- {-# RULES "myrule" foo C = 1 #-}
826 -- After type checking the LHS becomes (foo a (C a))
827 -- and we do not want to zap the unbound tyvar 'a' to (), because
828 -- that limits the applicability of the rule. Instead, we
829 -- want to quantify over it!
831 -- It's easiest to find the free tyvars here. Attempts to do so earlier
832 -- are tiresome, because (a) the data type is big and (b) finding the
833 -- free type vars of an expression is necessarily monadic operation.
834 -- (consider /\a -> f @ b, where b is side-effected to a)
836 zonkLExpr env_lhs lhs `thenM` \ new_lhs ->
837 zonkLExpr env_rhs rhs `thenM` \ new_rhs ->
839 readMutVar unbound_tv_set `thenM` \ unbound_tvs ->
841 final_bndrs :: [Located Var]
842 final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs
844 returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs new_rhs)
845 -- I hate this map RuleBndr stuff
847 zonk_bndr (RuleBndr v)
848 | isId (unLoc v) = wrapLocM (zonkIdBndr env) v
849 | otherwise = wrapLocM zonkTcTyVarToTyVar v
853 %************************************************************************
855 \subsection[BackSubst-Foreign]{Foreign exports}
857 %************************************************************************
860 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
861 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
863 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
864 -- This variant collects unbound type variables in a mutable variable
865 zonkTypeCollecting unbound_tv_set
866 = zonkType zonk_unbound_tyvar
868 zonk_unbound_tyvar tv
869 = zonkTcTyVarToTyVar tv `thenM` \ tv' ->
870 readMutVar unbound_tv_set `thenM` \ tv_set ->
871 writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_`
872 return (mkTyVarTy tv')
874 zonkTypeZapping :: TcType -> TcM Type
875 -- This variant is used for everything except the LHS of rules
876 -- It zaps unbound type variables to (), or some other arbitrary type
878 = zonkType zonk_unbound_tyvar ty
880 -- Zonk a mutable but unbound type variable to an arbitrary type
881 -- We know it's unbound even though we don't carry an environment,
882 -- because at the binding site for a type variable we bind the
883 -- mutable tyvar to a fresh immutable one. So the mutable store
884 -- plays the role of an environment. If we come across a mutable
885 -- type variable that isn't so bound, it must be completely free.
886 zonk_unbound_tyvar tv = putTcTyVar tv (mkArbitraryType tv)
889 -- When the type checker finds a type variable with no binding,
890 -- which means it can be instantiated with an arbitrary type, it
891 -- usually instantiates it to Void. Eg.
895 -- length Void (Nil Void)
897 -- But in really obscure programs, the type variable might have
898 -- a kind other than *, so we need to invent a suitably-kinded type.
902 -- List for kind *->*
903 -- Tuple for kind *->...*->*
905 -- which deals with most cases. (Previously, it only dealt with
908 -- In the other cases, it just makes up a TyCon with a suitable
909 -- kind. If this gets into an interface file, anyone reading that
910 -- file won't understand it. This is fixable (by making the client
911 -- of the interface file make up a TyCon too) but it is tiresome and
912 -- never happens, so I am leaving it
914 mkArbitraryType :: TcTyVar -> Type
915 -- Make up an arbitrary type whose kind is the same as the tyvar.
916 -- We'll use this to instantiate the (unbound) tyvar.
918 | liftedTypeKind `isSubKind` kind = voidTy -- The vastly common case
919 | otherwise = mkTyConApp tycon []
922 (args,res) = splitKindFunTys kind
924 tycon | kind == tyConKind listTyCon -- *->*
925 = listTyCon -- No tuples this size
927 | all isLiftedTypeKind args && isLiftedTypeKind res
928 = tupleTyCon Boxed (length args) -- *-> ... ->*->*
931 = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
932 mkPrimTyCon tc_name kind 0 [] VoidRep
933 -- Same name as the tyvar, apart from making it start with a colon (sigh)
934 -- I dread to think what will happen if this gets out into an
935 -- interface file. Catastrophe likely. Major sigh.
937 tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc