2 % (c) The University of Glasgow 2006
3 % (c) The AQUA Project, Glasgow University, 1996-1998
6 TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker
8 This module is an extension of @HsSyn@ syntax, for use in the type
13 mkHsConApp, mkHsDictLet, mkHsApp,
14 hsLitType, hsLPatType, hsPatType,
15 mkHsAppTy, mkSimpleHsAlt,
16 nlHsIntLit, mkVanillaTuplePat,
19 -- re-exported from TcMonad
20 TcId, TcIdSet, TcDictBinds,
22 zonkTopDecls, zonkTopExpr, zonkTopLExpr,
26 #include "HsVersions.h"
29 import HsSyn -- oodles of it
42 import {- Kind parts of -} Type
57 %************************************************************************
59 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
61 %************************************************************************
63 Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
64 then something is wrong.
66 mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
67 -- A vanilla tuple pattern simply gets its type from its sub-patterns
68 mkVanillaTuplePat pats box
69 = TuplePat pats box (mkTupleTy box (length pats) (map hsLPatType pats))
71 hsLPatType :: OutPat Id -> Type
72 hsLPatType (L _ pat) = hsPatType pat
74 hsPatType (ParPat pat) = hsLPatType pat
75 hsPatType (WildPat ty) = ty
76 hsPatType (VarPat var) = idType var
77 hsPatType (VarPatOut var _) = idType var
78 hsPatType (BangPat pat) = hsLPatType pat
79 hsPatType (LazyPat pat) = hsLPatType pat
80 hsPatType (LitPat lit) = hsLitType lit
81 hsPatType (AsPat var pat) = idType (unLoc var)
82 hsPatType (ListPat _ ty) = mkListTy ty
83 hsPatType (PArrPat _ ty) = mkPArrTy ty
84 hsPatType (TuplePat pats box ty) = ty
85 hsPatType (ConPatOut{ pat_ty = ty })= ty
86 hsPatType (SigPatOut pat ty) = ty
87 hsPatType (NPat lit _ _ ty) = ty
88 hsPatType (NPlusKPat id _ _ _) = idType (unLoc id)
89 hsPatType (CoPat _ _ ty) = ty
90 hsPatType (DictPat ds ms) = case (ds ++ ms) of
93 ds -> mkTupleTy Boxed (length ds) (map idType ds)
96 hsLitType :: HsLit -> TcType
97 hsLitType (HsChar c) = charTy
98 hsLitType (HsCharPrim c) = charPrimTy
99 hsLitType (HsString str) = stringTy
100 hsLitType (HsStringPrim s) = addrPrimTy
101 hsLitType (HsInt i) = intTy
102 hsLitType (HsIntPrim i) = intPrimTy
103 hsLitType (HsInteger i ty) = ty
104 hsLitType (HsRat _ ty) = ty
105 hsLitType (HsFloatPrim f) = floatPrimTy
106 hsLitType (HsDoublePrim d) = doublePrimTy
110 %************************************************************************
112 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
114 %************************************************************************
117 -- zonkId is used *during* typechecking just to zonk the Id's type
118 zonkId :: TcId -> TcM TcId
120 = zonkTcType (idType id) `thenM` \ ty' ->
121 returnM (Id.setIdType id ty')
124 The rest of the zonking is done *after* typechecking.
125 The main zonking pass runs over the bindings
127 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
128 b) convert unbound TcTyVar to Void
129 c) convert each TcId to an Id by zonking its type
131 The type variables are converted by binding mutable tyvars to immutable ones
132 and then zonking as normal.
134 The Ids are converted by binding them in the normal Tc envt; that
135 way we maintain sharing; eg an Id is zonked at its binding site and they
136 all occurrences of that Id point to the common zonked copy
138 It's all pretty boring stuff, because HsSyn is such a large type, and
139 the environment manipulation is tiresome.
142 data ZonkEnv = ZonkEnv (TcType -> TcM Type) -- How to zonk a type
143 (IdEnv Id) -- What variables are in scope
144 -- Maps an Id to its zonked version; both have the same Name
145 -- Is only consulted lazily; hence knot-tying
147 emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
149 extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
150 extendZonkEnv (ZonkEnv zonk_ty env) ids
151 = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
153 extendZonkEnv1 :: ZonkEnv -> Id -> ZonkEnv
154 extendZonkEnv1 (ZonkEnv zonk_ty env) id
155 = ZonkEnv zonk_ty (extendVarEnv env id id)
157 setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
158 setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
160 zonkEnvIds :: ZonkEnv -> [Id]
161 zonkEnvIds (ZonkEnv _ env) = varEnvElts env
163 zonkIdOcc :: ZonkEnv -> TcId -> Id
164 -- Ids defined in this module should be in the envt;
165 -- ignore others. (Actually, data constructors are also
166 -- not LocalVars, even when locally defined, but that is fine.)
167 -- (Also foreign-imported things aren't currently in the ZonkEnv;
168 -- that's ok because they don't need zonking.)
170 -- Actually, Template Haskell works in 'chunks' of declarations, and
171 -- an earlier chunk won't be in the 'env' that the zonking phase
172 -- carries around. Instead it'll be in the tcg_gbl_env, already fully
173 -- zonked. There's no point in looking it up there (except for error
174 -- checking), and it's not conveniently to hand; hence the simple
175 -- 'orElse' case in the LocalVar branch.
177 -- Even without template splices, in module Main, the checking of
178 -- 'main' is done as a separate chunk.
179 zonkIdOcc (ZonkEnv zonk_ty env) id
180 | isLocalVar id = lookupVarEnv env id `orElse` id
183 zonkIdOccs env ids = map (zonkIdOcc env) ids
185 -- zonkIdBndr is used *after* typechecking to get the Id's type
186 -- to its final form. The TyVarEnv give
187 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
189 = zonkTcTypeToType env (idType id) `thenM` \ ty' ->
190 returnM (Id.setIdType id ty')
192 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
193 zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
195 zonkTopBndrs :: [TcId] -> TcM [Id]
196 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
201 zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
202 zonkTopExpr e = zonkExpr emptyZonkEnv e
204 zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
205 zonkTopLExpr e = zonkLExpr emptyZonkEnv e
207 zonkTopDecls :: LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId]
212 zonkTopDecls binds rules fords
213 = do { (env, binds') <- zonkRecMonoBinds emptyZonkEnv binds
214 -- Top level is implicitly recursive
215 ; rules' <- zonkRules env rules
216 ; fords' <- zonkForeignExports env fords
217 ; return (zonkEnvIds env, binds', fords', rules') }
219 ---------------------------------------------
220 zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
221 zonkLocalBinds env EmptyLocalBinds
222 = return (env, EmptyLocalBinds)
224 zonkLocalBinds env (HsValBinds binds)
225 = do { (env1, new_binds) <- zonkValBinds env binds
226 ; return (env1, HsValBinds new_binds) }
228 zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds))
229 = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds ->
231 env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
233 zonkRecMonoBinds env1 dict_binds `thenM` \ (env2, new_dict_binds) ->
234 returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
236 zonk_ip_bind (IPBind n e)
237 = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' ->
238 zonkLExpr env e `thenM` \ e' ->
239 returnM (IPBind n' e')
242 ---------------------------------------------
243 zonkValBinds :: ZonkEnv -> HsValBinds TcId -> TcM (ZonkEnv, HsValBinds Id)
244 zonkValBinds env bs@(ValBindsIn _ _)
245 = panic "zonkValBinds" -- Not in typechecker output
246 zonkValBinds env (ValBindsOut binds sigs)
247 = do { (env1, new_binds) <- go env binds
248 ; return (env1, ValBindsOut new_binds sigs) }
250 go env [] = return (env, [])
251 go env ((r,b):bs) = do { (env1, b') <- zonkRecMonoBinds env b
252 ; (env2, bs') <- go env1 bs
253 ; return (env2, (r,b'):bs') }
255 ---------------------------------------------
256 zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
257 zonkRecMonoBinds env binds
258 = fixM (\ ~(_, new_binds) -> do
259 { let env1 = extendZonkEnv env (collectHsBindBinders new_binds)
260 ; binds' <- zonkMonoBinds env1 binds
261 ; return (env1, binds') })
263 ---------------------------------------------
264 zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
265 zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds
267 zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
268 zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
269 = do { (_env, new_pat) <- zonkPat env pat -- Env already extended
270 ; new_grhss <- zonkGRHSs env grhss
271 ; new_ty <- zonkTcTypeToType env ty
272 ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
274 zonk_bind env (VarBind { var_id = var, var_rhs = expr })
275 = zonkIdBndr env var `thenM` \ new_var ->
276 zonkLExpr env expr `thenM` \ new_expr ->
277 returnM (VarBind { var_id = new_var, var_rhs = new_expr })
279 zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn })
280 = wrapLocM (zonkIdBndr env) var `thenM` \ new_var ->
281 zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) ->
282 zonkMatchGroup env1 ms `thenM` \ new_ms ->
283 returnM (bind { fun_id = new_var, fun_matches = new_ms, fun_co_fn = new_co_fn })
285 zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts,
286 abs_exports = exports, abs_binds = val_binds })
287 = ASSERT( all isImmutableTyVar tyvars )
288 zonkIdBndrs env dicts `thenM` \ new_dicts ->
289 fixM (\ ~(new_val_binds, _) ->
291 env1 = extendZonkEnv env new_dicts
292 env2 = extendZonkEnv env1 (collectHsBindBinders new_val_binds)
294 zonkMonoBinds env2 val_binds `thenM` \ new_val_binds ->
295 mappM (zonkExport env2) exports `thenM` \ new_exports ->
296 returnM (new_val_binds, new_exports)
297 ) `thenM` \ (new_val_bind, new_exports) ->
298 returnM (AbsBinds { abs_tvs = tyvars, abs_dicts = new_dicts,
299 abs_exports = new_exports, abs_binds = new_val_bind })
301 zonkExport env (tyvars, global, local, prags)
302 -- The tyvars are already zonked
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 -- arrow notation extensions
497 zonkExpr env (HsProc pat body)
498 = do { (env1, new_pat) <- zonkPat env pat
499 ; new_body <- zonkCmdTop env1 body
500 ; return (HsProc new_pat new_body) }
502 zonkExpr env (HsArrApp e1 e2 ty ho rl)
503 = zonkLExpr env e1 `thenM` \ new_e1 ->
504 zonkLExpr env e2 `thenM` \ new_e2 ->
505 zonkTcTypeToType env ty `thenM` \ new_ty ->
506 returnM (HsArrApp new_e1 new_e2 new_ty ho rl)
508 zonkExpr env (HsArrForm op fixity args)
509 = zonkLExpr env op `thenM` \ new_op ->
510 mappM (zonkCmdTop env) args `thenM` \ new_args ->
511 returnM (HsArrForm new_op fixity new_args)
513 zonkExpr env (HsWrap co_fn expr)
514 = zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) ->
515 zonkExpr env1 expr `thenM` \ new_expr ->
516 return (HsWrap new_co_fn new_expr)
518 zonkExpr env other = pprPanic "zonkExpr" (ppr other)
520 zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
521 zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
523 zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
524 = zonkLExpr env cmd `thenM` \ new_cmd ->
525 zonkTcTypeToTypes env stack_tys `thenM` \ new_stack_tys ->
526 zonkTcTypeToType env ty `thenM` \ new_ty ->
527 mapSndM (zonkExpr env) ids `thenM` \ new_ids ->
528 returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
530 -------------------------------------------------------------------------
531 zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
532 zonkCoFn env WpHole = return (env, WpHole)
533 zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
534 ; (env2, c2') <- zonkCoFn env1 c2
535 ; return (env2, WpCompose c1' c2') }
536 zonkCoFn env (WpCo co) = do { co' <- zonkTcTypeToType env co
537 ; return (env, WpCo co') }
538 zonkCoFn env (WpLam id) = do { id' <- zonkIdBndr env id
539 ; let env1 = extendZonkEnv1 env id'
540 ; return (env1, WpLam id') }
541 zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv )
542 do { return (env, WpTyLam tv) }
543 zonkCoFn env (WpApp id) = do { return (env, WpApp (zonkIdOcc env id)) }
544 zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty
545 ; return (env, WpTyApp ty') }
546 zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkRecMonoBinds env bs
547 ; return (env1, WpLet bs') }
550 -------------------------------------------------------------------------
551 zonkDo :: ZonkEnv -> HsStmtContext Name -> HsStmtContext Name
552 -- Only used for 'do', so the only Ids are in a MDoExpr table
553 zonkDo env (MDoExpr tbl) = MDoExpr (mapSnd (zonkIdOcc env) tbl)
554 zonkDo env do_or_lc = do_or_lc
556 -------------------------------------------------------------------------
557 zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
558 zonkOverLit env (HsIntegral i e)
559 = do { e' <- zonkExpr env e; return (HsIntegral i e') }
560 zonkOverLit env (HsFractional r e)
561 = do { e' <- zonkExpr env e; return (HsFractional r e') }
563 -------------------------------------------------------------------------
564 zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
566 zonkArithSeq env (From e)
567 = zonkLExpr env e `thenM` \ new_e ->
570 zonkArithSeq env (FromThen e1 e2)
571 = zonkLExpr env e1 `thenM` \ new_e1 ->
572 zonkLExpr env e2 `thenM` \ new_e2 ->
573 returnM (FromThen new_e1 new_e2)
575 zonkArithSeq env (FromTo e1 e2)
576 = zonkLExpr env e1 `thenM` \ new_e1 ->
577 zonkLExpr env e2 `thenM` \ new_e2 ->
578 returnM (FromTo new_e1 new_e2)
580 zonkArithSeq env (FromThenTo e1 e2 e3)
581 = zonkLExpr env e1 `thenM` \ new_e1 ->
582 zonkLExpr env e2 `thenM` \ new_e2 ->
583 zonkLExpr env e3 `thenM` \ new_e3 ->
584 returnM (FromThenTo new_e1 new_e2 new_e3)
587 -------------------------------------------------------------------------
588 zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id])
589 zonkStmts env [] = return (env, [])
590 zonkStmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s
591 ; (env2, ss') <- zonkStmts env1 ss
592 ; return (env2, s' : ss') }
594 zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
595 zonkStmt env (ParStmt stmts_w_bndrs)
596 = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs ->
598 new_binders = concat (map snd new_stmts_w_bndrs)
599 env1 = extendZonkEnv env new_binders
601 return (env1, ParStmt new_stmts_w_bndrs)
603 zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) ->
604 returnM (new_stmts, zonkIdOccs env1 bndrs)
606 zonkStmt env (RecStmt segStmts lvs rvs rets binds)
607 = zonkIdBndrs env rvs `thenM` \ new_rvs ->
609 env1 = extendZonkEnv env new_rvs
611 zonkStmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
612 -- Zonk the ret-expressions in an envt that
613 -- has the polymorphic bindings in the envt
614 mapM (zonkExpr env2) rets `thenM` \ new_rets ->
616 new_lvs = zonkIdOccs env2 lvs
617 env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
619 zonkRecMonoBinds env3 binds `thenM` \ (env4, new_binds) ->
620 returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets new_binds)
622 zonkStmt env (ExprStmt expr then_op ty)
623 = zonkLExpr env expr `thenM` \ new_expr ->
624 zonkExpr env then_op `thenM` \ new_then ->
625 zonkTcTypeToType env ty `thenM` \ new_ty ->
626 returnM (env, ExprStmt new_expr new_then new_ty)
628 zonkStmt env (LetStmt binds)
629 = zonkLocalBinds env binds `thenM` \ (env1, new_binds) ->
630 returnM (env1, LetStmt new_binds)
632 zonkStmt env (BindStmt pat expr bind_op fail_op)
633 = do { new_expr <- zonkLExpr env expr
634 ; (env1, new_pat) <- zonkPat env pat
635 ; new_bind <- zonkExpr env bind_op
636 ; new_fail <- zonkExpr env fail_op
637 ; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
640 -------------------------------------------------------------------------
641 zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id)
643 zonkRbinds env rbinds
644 = mappM zonk_rbind rbinds
646 zonk_rbind (field, expr)
647 = zonkLExpr env expr `thenM` \ new_expr ->
648 returnM (fmap (zonkIdOcc env) field, new_expr)
650 -------------------------------------------------------------------------
651 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
652 mapIPNameTc f (IPName n) = f n `thenM` \ r -> returnM (IPName r)
656 %************************************************************************
658 \subsection[BackSubst-Pats]{Patterns}
660 %************************************************************************
663 zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
664 -- Extend the environment as we go, because it's possible for one
665 -- pattern to bind something that is used in another (inside or
667 zonkPat env pat = wrapLocSndM (zonk_pat env) pat
669 zonk_pat env (ParPat p)
670 = do { (env', p') <- zonkPat env p
671 ; return (env', ParPat p') }
673 zonk_pat env (WildPat ty)
674 = do { ty' <- zonkTcTypeToType env ty
675 ; return (env, WildPat ty') }
677 zonk_pat env (VarPat v)
678 = do { v' <- zonkIdBndr env v
679 ; return (extendZonkEnv1 env v', VarPat v') }
681 zonk_pat env (VarPatOut v binds)
682 = do { v' <- zonkIdBndr env v
683 ; (env', binds') <- zonkRecMonoBinds (extendZonkEnv1 env v') binds
684 ; returnM (env', VarPatOut v' binds') }
686 zonk_pat env (LazyPat pat)
687 = do { (env', pat') <- zonkPat env pat
688 ; return (env', LazyPat pat') }
690 zonk_pat env (BangPat pat)
691 = do { (env', pat') <- zonkPat env pat
692 ; return (env', BangPat pat') }
694 zonk_pat env (AsPat (L loc v) pat)
695 = do { v' <- zonkIdBndr env v
696 ; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
697 ; return (env', AsPat (L loc v') pat') }
699 zonk_pat env (ListPat pats ty)
700 = do { ty' <- zonkTcTypeToType env ty
701 ; (env', pats') <- zonkPats env pats
702 ; return (env', ListPat pats' ty') }
704 zonk_pat env (PArrPat pats ty)
705 = do { ty' <- zonkTcTypeToType env ty
706 ; (env', pats') <- zonkPats env pats
707 ; return (env', PArrPat pats' ty') }
709 zonk_pat env (TuplePat pats boxed ty)
710 = do { ty' <- zonkTcTypeToType env ty
711 ; (env', pats') <- zonkPats env pats
712 ; return (env', TuplePat pats' boxed ty') }
714 zonk_pat env p@(ConPatOut { pat_ty = ty, pat_dicts = dicts, pat_binds = binds, pat_args = args })
715 = ASSERT( all isImmutableTyVar (pat_tvs p) )
716 do { new_ty <- zonkTcTypeToType env ty
717 ; new_dicts <- zonkIdBndrs env dicts
718 ; let env1 = extendZonkEnv env new_dicts
719 ; (env2, new_binds) <- zonkRecMonoBinds env1 binds
720 ; (env', new_args) <- zonkConStuff env2 args
721 ; returnM (env', p { pat_ty = new_ty, pat_dicts = new_dicts,
722 pat_binds = new_binds, pat_args = new_args }) }
724 zonk_pat env (LitPat lit) = return (env, LitPat lit)
726 zonk_pat env (SigPatOut pat ty)
727 = do { ty' <- zonkTcTypeToType env ty
728 ; (env', pat') <- zonkPat env pat
729 ; return (env', SigPatOut pat' ty') }
731 zonk_pat env (NPat lit mb_neg eq_expr ty)
732 = do { lit' <- zonkOverLit env lit
733 ; mb_neg' <- case mb_neg of
734 Nothing -> return Nothing
735 Just neg -> do { neg' <- zonkExpr env neg
736 ; return (Just neg') }
737 ; eq_expr' <- zonkExpr env eq_expr
738 ; ty' <- zonkTcTypeToType env ty
739 ; return (env, NPat lit' mb_neg' eq_expr' ty') }
741 zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
742 = do { n' <- zonkIdBndr env n
743 ; lit' <- zonkOverLit env lit
744 ; e1' <- zonkExpr env e1
745 ; e2' <- zonkExpr env e2
746 ; return (extendZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
748 zonk_pat env (DictPat ds ms)
749 = do { ds' <- zonkIdBndrs env ds
750 ; ms' <- zonkIdBndrs env ms
751 ; return (extendZonkEnv env (ds' ++ ms'), DictPat ds' ms') }
753 zonk_pat env (CoPat co_fn pat ty)
754 = do { (env', co_fn') <- zonkCoFn env co_fn
755 ; (env'', pat') <- zonkPat env' (noLoc pat)
756 ; ty' <- zonkTcTypeToType env'' ty
757 ; return (env'', CoPat co_fn' (unLoc pat') ty') }
759 zonk_pat env pat = pprPanic "zonk_pat" (ppr pat)
761 ---------------------------
762 zonkConStuff env (PrefixCon pats)
763 = do { (env', pats') <- zonkPats env pats
764 ; return (env', PrefixCon pats') }
766 zonkConStuff env (InfixCon p1 p2)
767 = do { (env1, p1') <- zonkPat env p1
768 ; (env', p2') <- zonkPat env1 p2
769 ; return (env', InfixCon p1' p2') }
771 zonkConStuff env (RecCon rpats)
772 = do { let (fields, pats) = unzip [ (f, p) | HsRecField f p _ <- rpats ]
773 ; (env', pats') <- zonkPats env pats
774 ; let recCon = RecCon [ mkRecField f p | (f, p) <- zip fields pats' ]
775 ; returnM (env', recCon) }
777 ---------------------------
778 zonkPats env [] = return (env, [])
779 zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
780 ; (env', pats') <- zonkPats env1 pats
781 ; return (env', pat':pats') }
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) =
797 returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec)
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 fv_lhs rhs fv_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 fv_lhs new_rhs fv_rhs)
844 -- I hate this map RuleBndr stuff
846 zonk_bndr (RuleBndr v)
847 | isId (unLoc v) = wrapLocM (zonkIdBndr env) v
848 | otherwise = ASSERT( isImmutableTyVar (unLoc 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 zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
864 zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
866 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
867 -- This variant collects unbound type variables in a mutable variable
868 zonkTypeCollecting unbound_tv_set
869 = zonkType zonk_unbound_tyvar
871 zonk_unbound_tyvar tv
872 = zonkQuantifiedTyVar tv `thenM` \ tv' ->
873 readMutVar unbound_tv_set `thenM` \ tv_set ->
874 writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_`
875 return (mkTyVarTy tv')
877 zonkTypeZapping :: TcType -> TcM Type
878 -- This variant is used for everything except the LHS of rules
879 -- It zaps unbound type variables to (), or some other arbitrary type
881 = zonkType zonk_unbound_tyvar ty
883 -- Zonk a mutable but unbound type variable to an arbitrary type
884 -- We know it's unbound even though we don't carry an environment,
885 -- because at the binding site for a type variable we bind the
886 -- mutable tyvar to a fresh immutable one. So the mutable store
887 -- plays the role of an environment. If we come across a mutable
888 -- type variable that isn't so bound, it must be completely free.
889 zonk_unbound_tyvar tv = do { writeMetaTyVar tv ty; return ty }
891 ty = mkArbitraryType tv
894 -- When the type checker finds a type variable with no binding,
895 -- which means it can be instantiated with an arbitrary type, it
896 -- usually instantiates it to Void. Eg.
900 -- length Void (Nil Void)
902 -- But in really obscure programs, the type variable might have
903 -- a kind other than *, so we need to invent a suitably-kinded type.
907 -- List for kind *->*
908 -- Tuple for kind *->...*->*
910 -- which deals with most cases. (Previously, it only dealt with
913 -- In the other cases, it just makes up a TyCon with a suitable
914 -- kind. If this gets into an interface file, anyone reading that
915 -- file won't understand it. This is fixable (by making the client
916 -- of the interface file make up a TyCon too) but it is tiresome and
917 -- never happens, so I am leaving it
919 mkArbitraryType :: TcTyVar -> Type
920 -- Make up an arbitrary type whose kind is the same as the tyvar.
921 -- We'll use this to instantiate the (unbound) tyvar.
923 | liftedTypeKind `isSubKind` kind = voidTy -- The vastly common case
924 | otherwise = mkTyConApp tycon []
927 (args,res) = splitKindFunTys kind
929 tycon | eqKind kind (tyConKind listTyCon) -- *->*
930 = listTyCon -- No tuples this size
932 | all isLiftedTypeKind args && isLiftedTypeKind res
933 = tupleTyCon Boxed (length args) -- *-> ... ->*->*
936 = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
937 mkPrimTyCon tc_name kind 0 VoidRep
938 -- Same name as the tyvar, apart from making it start with a colon (sigh)
939 -- I dread to think what will happen if this gets out into an
940 -- interface file. Catastrophe likely. Major sigh.
942 tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc