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