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, mkHsLet, mkHsApp,
13 hsLitType, hsPatType, mkHsAppTy, mkSimpleHsAlt,
14 nlHsIntLit, glueBindsOnGRHSs,
18 Coercion, ExprCoFn, PatCoFn,
19 (<$>), (<.>), mkCoercion,
20 idCoercion, isIdCoercion,
22 -- re-exported from TcMonad
23 TcId, TcIdSet, TcDictBinds,
25 zonkTopDecls, zonkTopExpr, zonkTopLExpr,
29 #include "HsVersions.h"
32 import HsSyn -- oodles of it
35 import Id ( idType, setIdType, Id )
39 import TcType ( TcType, TcTyVar, mkTyVarTy, mkTyConApp, isImmutableTyVar, tcGetTyVar )
40 import Kind ( isLiftedTypeKind, liftedTypeKind, isSubKind )
42 import TcMType ( zonkQuantifiedTyVar, zonkType, zonkTcType, zonkTcTyVars, putMetaTyVar )
43 import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
44 doublePrimTy, addrPrimTy
46 import TysWiredIn ( charTy, stringTy, intTy,
47 mkListTy, mkPArrTy, mkTupleTy, unitTy,
48 voidTy, listTyCon, tupleTyCon )
49 import TyCon ( mkPrimTyCon, tyConKind, PrimRep(..) )
50 import Kind ( splitKindFunTys )
51 import Name ( getOccName, mkInternalName, mkDerivedTyConOcc )
52 import Var ( Var, isId, isLocalVar, tyVarKind )
55 import BasicTypes ( Boxity(..), IPName(..), ipNameName, mapIPName )
56 import Maybes ( orElse )
57 import Maybe ( isNothing )
58 import Unique ( Uniquable(..) )
59 import SrcLoc ( noSrcLoc, noLoc, Located(..), unLoc )
65 %************************************************************************
67 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
69 %************************************************************************
71 Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@,
72 then something is wrong.
74 hsPatType :: OutPat Id -> Type
75 hsPatType pat = pat_type (unLoc pat)
77 pat_type (ParPat pat) = hsPatType pat
78 pat_type (WildPat ty) = ty
79 pat_type (VarPat var) = idType var
80 pat_type (VarPatOut var _) = idType var
81 pat_type (LazyPat pat) = hsPatType pat
82 pat_type (LitPat lit) = hsLitType lit
83 pat_type (AsPat var pat) = idType (unLoc var)
84 pat_type (ListPat _ ty) = mkListTy ty
85 pat_type (PArrPat _ ty) = mkPArrTy ty
86 pat_type (TuplePat pats box) = mkTupleTy box (length pats) (map hsPatType pats)
87 pat_type (ConPatOut _ _ _ _ _ ty) = ty
88 pat_type (SigPatOut pat ty) = ty
89 pat_type (NPatOut lit ty _) = ty
90 pat_type (NPlusKPatOut id _ _ _) = idType (unLoc id)
91 pat_type (DictPat ds ms) = case (ds ++ ms) of
94 ds -> mkTupleTy Boxed (length ds) (map idType ds)
97 hsLitType :: HsLit -> TcType
98 hsLitType (HsChar c) = charTy
99 hsLitType (HsCharPrim c) = charPrimTy
100 hsLitType (HsString str) = stringTy
101 hsLitType (HsStringPrim s) = addrPrimTy
102 hsLitType (HsInt i) = intTy
103 hsLitType (HsIntPrim i) = intPrimTy
104 hsLitType (HsInteger i ty) = ty
105 hsLitType (HsRat _ ty) = ty
106 hsLitType (HsFloatPrim f) = floatPrimTy
107 hsLitType (HsDoublePrim d) = doublePrimTy
110 %************************************************************************
112 \subsection{Coercion functions}
114 %************************************************************************
117 type Coercion a = Maybe (a -> a)
118 -- Nothing => identity fn
120 type ExprCoFn = Coercion (HsExpr TcId)
121 type PatCoFn = Coercion (Pat TcId)
123 (<.>) :: Coercion a -> Coercion a -> Coercion a -- Composition
124 Nothing <.> Nothing = Nothing
125 Nothing <.> Just f = Just f
126 Just f <.> Nothing = Just f
127 Just f1 <.> Just f2 = Just (f1 . f2)
129 (<$>) :: Coercion a -> a -> a
133 mkCoercion :: (a -> a) -> Coercion a
134 mkCoercion f = Just f
136 idCoercion :: Coercion a
139 isIdCoercion :: Coercion a -> Bool
140 isIdCoercion = isNothing
144 %************************************************************************
146 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
148 %************************************************************************
151 -- zonkId is used *during* typechecking just to zonk the Id's type
152 zonkId :: TcId -> TcM TcId
154 = zonkTcType (idType id) `thenM` \ ty' ->
155 returnM (setIdType id ty')
158 The rest of the zonking is done *after* typechecking.
159 The main zonking pass runs over the bindings
161 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
162 b) convert unbound TcTyVar to Void
163 c) convert each TcId to an Id by zonking its type
165 The type variables are converted by binding mutable tyvars to immutable ones
166 and then zonking as normal.
168 The Ids are converted by binding them in the normal Tc envt; that
169 way we maintain sharing; eg an Id is zonked at its binding site and they
170 all occurrences of that Id point to the common zonked copy
172 It's all pretty boring stuff, because HsSyn is such a large type, and
173 the environment manipulation is tiresome.
176 data ZonkEnv = ZonkEnv (TcType -> TcM Type) -- How to zonk a type
177 (IdEnv Id) -- What variables are in scope
178 -- Maps an Id to its zonked version; both have the same Name
179 -- Is only consulted lazily; hence knot-tying
181 emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
183 extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
184 extendZonkEnv (ZonkEnv zonk_ty env) ids
185 = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
187 extendZonkEnv1 :: ZonkEnv -> Id -> ZonkEnv
188 extendZonkEnv1 (ZonkEnv zonk_ty env) id
189 = ZonkEnv zonk_ty (extendVarEnv env id id)
191 setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
192 setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
194 zonkEnvIds :: ZonkEnv -> [Id]
195 zonkEnvIds (ZonkEnv _ env) = varEnvElts env
197 zonkIdOcc :: ZonkEnv -> TcId -> Id
198 -- Ids defined in this module should be in the envt;
199 -- ignore others. (Actually, data constructors are also
200 -- not LocalVars, even when locally defined, but that is fine.)
202 -- Actually, Template Haskell works in 'chunks' of declarations, and
203 -- an earlier chunk won't be in the 'env' that the zonking phase
204 -- carries around. Instead it'll be in the tcg_gbl_env, already fully
205 -- zonked. There's no point in looking it up there (except for error
206 -- checking), and it's not conveniently to hand; hence the simple
207 -- 'orElse' case in the LocalVar branch.
209 -- Even without template splices, in module Main, the checking of
210 -- 'main' is done as a separte chunk.
211 zonkIdOcc (ZonkEnv zonk_ty env) id
212 | isLocalVar id = lookupVarEnv env id `orElse` id
215 zonkIdOccs env ids = map (zonkIdOcc env) ids
217 -- zonkIdBndr is used *after* typechecking to get the Id's type
218 -- to its final form. The TyVarEnv give
219 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
221 = zonkTcTypeToType env (idType id) `thenM` \ ty' ->
222 returnM (setIdType id ty')
224 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
225 zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
227 zonkTopBndrs :: [TcId] -> TcM [Id]
228 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
233 zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
234 zonkTopExpr e = zonkExpr emptyZonkEnv e
236 zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
237 zonkTopLExpr e = zonkLExpr emptyZonkEnv e
239 zonkTopDecls :: LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId]
244 zonkTopDecls binds rules fords
245 = do { (env, binds') <- zonkRecMonoBinds emptyZonkEnv binds
246 -- Top level is implicitly recursive
247 ; rules' <- zonkRules env rules
248 ; fords' <- zonkForeignExports env fords
249 ; return (zonkEnvIds env, binds', fords', rules') }
251 ---------------------------------------------
252 zonkGroup :: ZonkEnv -> HsBindGroup TcId -> TcM (ZonkEnv, HsBindGroup Id)
253 zonkGroup env (HsBindGroup bs sigs is_rec)
254 = ASSERT( null sigs )
255 do { (env1, bs') <- zonkRecMonoBinds env bs
256 ; return (env1, HsBindGroup bs' [] is_rec) }
258 zonkGroup env (HsIPBinds binds)
259 = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds ->
261 env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
263 returnM (env1, HsIPBinds new_binds)
265 zonk_ip_bind (IPBind n e)
266 = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' ->
267 zonkLExpr env e `thenM` \ e' ->
268 returnM (IPBind n' e')
270 ---------------------------------------------
271 zonkNestedBinds :: ZonkEnv -> [HsBindGroup TcId] -> TcM (ZonkEnv, [HsBindGroup Id])
272 zonkNestedBinds env [] = return (env, [])
273 zonkNestedBinds env (b:bs) = do { (env1, b') <- zonkGroup env b
274 ; (env2, bs') <- zonkNestedBinds env1 bs
275 ; return (env2, b':bs') }
277 ---------------------------------------------
278 zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
279 zonkRecMonoBinds env binds
280 = fixM (\ ~(_, new_binds) -> do
281 { let env1 = extendZonkEnv env (collectHsBindBinders new_binds)
282 ; binds' <- zonkMonoBinds env1 binds
283 ; return (env1, binds') })
285 zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
286 zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds
288 zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
289 zonk_bind env (PatBind pat grhss ty)
290 = do { (_env, new_pat) <- zonkPat env pat -- Env already extended
291 ; new_grhss <- zonkGRHSs env grhss
292 ; new_ty <- zonkTcTypeToType env ty
293 ; return (PatBind new_pat new_grhss new_ty) }
295 zonk_bind env (VarBind var expr)
296 = zonkIdBndr env var `thenM` \ new_var ->
297 zonkLExpr env expr `thenM` \ new_expr ->
298 returnM (VarBind new_var new_expr)
300 zonk_bind env (FunBind var inf ms)
301 = wrapLocM (zonkIdBndr env) var `thenM` \ new_var ->
302 zonkMatchGroup env ms `thenM` \ new_ms ->
303 returnM (FunBind new_var inf new_ms)
305 zonk_bind env (AbsBinds tyvars dicts exports inlines val_binds)
306 = ASSERT( all isImmutableTyVar tyvars )
307 zonkIdBndrs env dicts `thenM` \ new_dicts ->
308 fixM (\ ~(new_val_binds, _) ->
310 env1 = extendZonkEnv (extendZonkEnv env new_dicts)
311 (collectHsBindBinders new_val_binds)
313 zonkMonoBinds env1 val_binds `thenM` \ new_val_binds ->
314 mappM (zonkExport env1) exports `thenM` \ new_exports ->
315 returnM (new_val_binds, new_exports)
316 ) `thenM` \ (new_val_bind, new_exports) ->
317 returnM (AbsBinds tyvars new_dicts new_exports inlines new_val_bind)
319 zonkExport env (tyvars, global, local)
320 = zonkTcTyVars tyvars `thenM` \ tys ->
322 new_tyvars = map (tcGetTyVar "zonkExport") tys
323 -- This isn't the binding occurrence of these tyvars
324 -- but they should *be* tyvars. Hence tcGetTyVar.
326 zonkIdBndr env global `thenM` \ new_global ->
327 returnM (new_tyvars, new_global, zonkIdOcc env local)
330 %************************************************************************
332 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
334 %************************************************************************
337 zonkMatchGroup :: ZonkEnv -> MatchGroup TcId-> TcM (MatchGroup Id)
338 zonkMatchGroup env (MatchGroup ms ty)
339 = do { ms' <- mapM (zonkMatch env) ms
340 ; ty' <- zonkTcTypeToType env ty
341 ; return (MatchGroup ms' ty') }
343 zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id)
344 zonkMatch env (L loc (Match pats _ grhss))
345 = do { (env1, new_pats) <- zonkPats env pats
346 ; new_grhss <- zonkGRHSs env1 grhss
347 ; return (L loc (Match new_pats Nothing new_grhss)) }
349 -------------------------------------------------------------------------
350 zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id)
352 zonkGRHSs env (GRHSs grhss binds)
353 = zonkNestedBinds env binds `thenM` \ (new_env, new_binds) ->
355 zonk_grhs (GRHS guarded)
356 = zonkStmts new_env guarded `thenM` \ new_guarded ->
357 returnM (GRHS new_guarded)
359 mappM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss ->
360 returnM (GRHSs new_grhss new_binds)
363 %************************************************************************
365 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
367 %************************************************************************
370 zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
371 zonkLExpr :: ZonkEnv -> LHsExpr TcId -> TcM (LHsExpr Id)
372 zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id)
374 zonkLExprs env exprs = mappM (zonkLExpr env) exprs
375 zonkLExpr env expr = wrapLocM (zonkExpr env) expr
377 zonkExpr env (HsVar id)
378 = returnM (HsVar (zonkIdOcc env id))
380 zonkExpr env (HsIPVar id)
381 = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
383 zonkExpr env (HsLit (HsRat f ty))
384 = zonkTcTypeToType env ty `thenM` \ new_ty ->
385 returnM (HsLit (HsRat f new_ty))
387 zonkExpr env (HsLit lit)
388 = returnM (HsLit lit)
389 -- HsOverLit doesn't appear in typechecker output
391 zonkExpr env (HsLam matches)
392 = zonkMatchGroup env matches `thenM` \ new_matches ->
393 returnM (HsLam new_matches)
395 zonkExpr env (HsApp e1 e2)
396 = zonkLExpr env e1 `thenM` \ new_e1 ->
397 zonkLExpr env e2 `thenM` \ new_e2 ->
398 returnM (HsApp new_e1 new_e2)
400 zonkExpr env (HsBracketOut body bs)
401 = mappM zonk_b bs `thenM` \ bs' ->
402 returnM (HsBracketOut body bs')
404 zonk_b (n,e) = zonkLExpr env e `thenM` \ e' ->
407 zonkExpr env (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
408 returnM (HsSpliceE s)
410 zonkExpr env (OpApp e1 op fixity e2)
411 = zonkLExpr env e1 `thenM` \ new_e1 ->
412 zonkLExpr env op `thenM` \ new_op ->
413 zonkLExpr env e2 `thenM` \ new_e2 ->
414 returnM (OpApp new_e1 new_op fixity new_e2)
416 zonkExpr env (NegApp _ _) = panic "zonkExpr env: NegApp"
418 zonkExpr env (HsPar e)
419 = zonkLExpr env e `thenM` \new_e ->
420 returnM (HsPar new_e)
422 zonkExpr env (SectionL expr op)
423 = zonkLExpr env expr `thenM` \ new_expr ->
424 zonkLExpr env op `thenM` \ new_op ->
425 returnM (SectionL new_expr new_op)
427 zonkExpr env (SectionR op expr)
428 = zonkLExpr env op `thenM` \ new_op ->
429 zonkLExpr env expr `thenM` \ new_expr ->
430 returnM (SectionR new_op new_expr)
433 zonkExpr env (HsCase expr ms)
434 = zonkLExpr env expr `thenM` \ new_expr ->
435 zonkMatchGroup env ms `thenM` \ new_ms ->
436 returnM (HsCase new_expr new_ms)
438 zonkExpr env (HsIf e1 e2 e3)
439 = zonkLExpr env e1 `thenM` \ new_e1 ->
440 zonkLExpr env e2 `thenM` \ new_e2 ->
441 zonkLExpr env e3 `thenM` \ new_e3 ->
442 returnM (HsIf new_e1 new_e2 new_e3)
444 zonkExpr env (HsLet binds expr)
445 = zonkNestedBinds env binds `thenM` \ (new_env, new_binds) ->
446 zonkLExpr new_env expr `thenM` \ new_expr ->
447 returnM (HsLet new_binds new_expr)
449 zonkExpr env (HsDo do_or_lc stmts ids ty)
450 = zonkStmts env stmts `thenM` \ new_stmts ->
451 zonkTcTypeToType env ty `thenM` \ new_ty ->
452 zonkReboundNames env ids `thenM` \ new_ids ->
453 returnM (HsDo do_or_lc new_stmts new_ids new_ty)
455 zonkExpr env (ExplicitList ty exprs)
456 = zonkTcTypeToType env ty `thenM` \ new_ty ->
457 zonkLExprs env exprs `thenM` \ new_exprs ->
458 returnM (ExplicitList new_ty new_exprs)
460 zonkExpr env (ExplicitPArr ty exprs)
461 = zonkTcTypeToType env ty `thenM` \ new_ty ->
462 zonkLExprs env exprs `thenM` \ new_exprs ->
463 returnM (ExplicitPArr new_ty new_exprs)
465 zonkExpr env (ExplicitTuple exprs boxed)
466 = zonkLExprs env exprs `thenM` \ new_exprs ->
467 returnM (ExplicitTuple new_exprs boxed)
469 zonkExpr env (RecordConOut data_con con_expr rbinds)
470 = zonkLExpr env con_expr `thenM` \ new_con_expr ->
471 zonkRbinds env rbinds `thenM` \ new_rbinds ->
472 returnM (RecordConOut data_con new_con_expr new_rbinds)
474 zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd"
476 zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds)
477 = zonkLExpr env expr `thenM` \ new_expr ->
478 zonkTcTypeToType env in_ty `thenM` \ new_in_ty ->
479 zonkTcTypeToType env out_ty `thenM` \ new_out_ty ->
480 zonkRbinds env rbinds `thenM` \ new_rbinds ->
481 returnM (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
483 zonkExpr env (ExprWithTySigOut e ty)
484 = do { e' <- zonkLExpr env e
485 ; return (ExprWithTySigOut e' ty) }
487 zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
488 zonkExpr env (ArithSeqIn _) = panic "zonkExpr env:ArithSeqIn"
489 zonkExpr env (PArrSeqIn _) = panic "zonkExpr env:PArrSeqIn"
491 zonkExpr env (ArithSeqOut expr info)
492 = zonkLExpr env expr `thenM` \ new_expr ->
493 zonkArithSeq env info `thenM` \ new_info ->
494 returnM (ArithSeqOut new_expr new_info)
496 zonkExpr env (PArrSeqOut expr info)
497 = zonkLExpr env expr `thenM` \ new_expr ->
498 zonkArithSeq env info `thenM` \ new_info ->
499 returnM (PArrSeqOut new_expr new_info)
501 zonkExpr env (HsSCC lbl expr)
502 = zonkLExpr env expr `thenM` \ new_expr ->
503 returnM (HsSCC lbl new_expr)
505 -- hdaume: core annotations
506 zonkExpr env (HsCoreAnn lbl expr)
507 = zonkLExpr env expr `thenM` \ new_expr ->
508 returnM (HsCoreAnn lbl new_expr)
510 zonkExpr env (TyLam tyvars expr)
511 = ASSERT( all isImmutableTyVar tyvars )
512 zonkLExpr env expr `thenM` \ new_expr ->
513 returnM (TyLam tyvars new_expr)
515 zonkExpr env (TyApp expr tys)
516 = zonkLExpr env expr `thenM` \ new_expr ->
517 mappM (zonkTcTypeToType env) tys `thenM` \ new_tys ->
518 returnM (TyApp new_expr new_tys)
520 zonkExpr env (DictLam dicts expr)
521 = zonkIdBndrs env dicts `thenM` \ new_dicts ->
523 env1 = extendZonkEnv env new_dicts
525 zonkLExpr env1 expr `thenM` \ new_expr ->
526 returnM (DictLam new_dicts new_expr)
528 zonkExpr env (DictApp expr dicts)
529 = zonkLExpr env expr `thenM` \ new_expr ->
530 returnM (DictApp new_expr (zonkIdOccs env dicts))
532 -- arrow notation extensions
533 zonkExpr env (HsProc pat body)
534 = do { (env1, new_pat) <- zonkPat env pat
535 ; new_body <- zonkCmdTop env1 body
536 ; return (HsProc new_pat new_body) }
538 zonkExpr env (HsArrApp e1 e2 ty ho rl)
539 = zonkLExpr env e1 `thenM` \ new_e1 ->
540 zonkLExpr env e2 `thenM` \ new_e2 ->
541 zonkTcTypeToType env ty `thenM` \ new_ty ->
542 returnM (HsArrApp new_e1 new_e2 new_ty ho rl)
544 zonkExpr env (HsArrForm op fixity args)
545 = zonkLExpr env op `thenM` \ new_op ->
546 mappM (zonkCmdTop env) args `thenM` \ new_args ->
547 returnM (HsArrForm new_op fixity new_args)
549 zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
550 zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
552 zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
553 = zonkLExpr env cmd `thenM` \ new_cmd ->
554 mappM (zonkTcTypeToType env) stack_tys
555 `thenM` \ new_stack_tys ->
556 zonkTcTypeToType env ty `thenM` \ new_ty ->
557 zonkReboundNames env ids `thenM` \ new_ids ->
558 returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
560 -------------------------------------------------------------------------
561 zonkReboundNames :: ZonkEnv -> ReboundNames Id -> TcM (ReboundNames Id)
562 zonkReboundNames env prs
565 zonk (n, e) = zonkExpr env e `thenM` \ new_e ->
569 -------------------------------------------------------------------------
570 zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
572 zonkArithSeq env (From e)
573 = zonkLExpr env e `thenM` \ new_e ->
576 zonkArithSeq env (FromThen e1 e2)
577 = zonkLExpr env e1 `thenM` \ new_e1 ->
578 zonkLExpr env e2 `thenM` \ new_e2 ->
579 returnM (FromThen new_e1 new_e2)
581 zonkArithSeq env (FromTo e1 e2)
582 = zonkLExpr env e1 `thenM` \ new_e1 ->
583 zonkLExpr env e2 `thenM` \ new_e2 ->
584 returnM (FromTo new_e1 new_e2)
586 zonkArithSeq env (FromThenTo e1 e2 e3)
587 = zonkLExpr env e1 `thenM` \ new_e1 ->
588 zonkLExpr env e2 `thenM` \ new_e2 ->
589 zonkLExpr env e3 `thenM` \ new_e3 ->
590 returnM (FromThenTo new_e1 new_e2 new_e3)
593 -------------------------------------------------------------------------
594 zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM [LStmt Id]
596 zonkStmts env stmts = zonk_stmts env stmts `thenM` \ (_, stmts) ->
599 zonk_stmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id])
600 zonk_stmts env [] = return (env, [])
601 zonk_stmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s
602 ; (env2, ss') <- zonk_stmts env1 ss
603 ; return (env2, s' : ss') }
605 zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
606 zonkStmt env (ParStmt stmts_w_bndrs)
607 = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs ->
609 new_binders = concat (map snd new_stmts_w_bndrs)
610 env1 = extendZonkEnv env new_binders
612 return (env1, ParStmt new_stmts_w_bndrs)
614 zonk_branch (stmts, bndrs) = zonk_stmts env stmts `thenM` \ (env1, new_stmts) ->
615 returnM (new_stmts, zonkIdOccs env1 bndrs)
617 zonkStmt env (RecStmt segStmts lvs rvs rets)
618 = zonkIdBndrs env rvs `thenM` \ new_rvs ->
620 env1 = extendZonkEnv env new_rvs
622 zonk_stmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
623 -- Zonk the ret-expressions in an envt that
624 -- has the polymorphic bindings in the envt
625 zonkLExprs env2 rets `thenM` \ new_rets ->
627 new_lvs = zonkIdOccs env2 lvs
628 env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
630 returnM (env3, RecStmt new_segStmts new_lvs new_rvs new_rets)
632 zonkStmt env (ResultStmt expr)
633 = zonkLExpr env expr `thenM` \ new_expr ->
634 returnM (env, ResultStmt new_expr)
636 zonkStmt env (ExprStmt expr ty)
637 = zonkLExpr env expr `thenM` \ new_expr ->
638 zonkTcTypeToType env ty `thenM` \ new_ty ->
639 returnM (env, ExprStmt new_expr new_ty)
641 zonkStmt env (LetStmt binds)
642 = zonkNestedBinds env binds `thenM` \ (env1, new_binds) ->
643 returnM (env1, LetStmt new_binds)
645 zonkStmt env (BindStmt pat expr)
646 = do { new_expr <- zonkLExpr env expr
647 ; (env1, new_pat) <- zonkPat env pat
648 ; return (env1, BindStmt new_pat new_expr) }
651 -------------------------------------------------------------------------
652 zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id)
654 zonkRbinds env rbinds
655 = mappM zonk_rbind rbinds
657 zonk_rbind (field, expr)
658 = zonkLExpr env expr `thenM` \ new_expr ->
659 returnM (fmap (zonkIdOcc env) field, new_expr)
661 -------------------------------------------------------------------------
662 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
663 mapIPNameTc f (Dupable n) = f n `thenM` \ r -> returnM (Dupable r)
664 mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r)
668 %************************************************************************
670 \subsection[BackSubst-Pats]{Patterns}
672 %************************************************************************
675 zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
676 -- Extend the environment as we go, because it's possible for one
677 -- pattern to bind something that is used in another (inside or
679 zonkPat env pat = wrapLocSndM (zonk_pat env) pat
681 zonk_pat env (ParPat p)
682 = do { (env', p') <- zonkPat env p
683 ; return (env', ParPat p') }
685 zonk_pat env (WildPat ty)
686 = do { ty' <- zonkTcTypeToType env ty
687 ; return (env, WildPat ty') }
689 zonk_pat env (VarPat v)
690 = do { v' <- zonkIdBndr env v
691 ; return (extendZonkEnv1 env v', VarPat v') }
693 zonk_pat env (VarPatOut v binds)
694 = do { v' <- zonkIdBndr env v
695 ; (env', binds') <- zonkRecMonoBinds (extendZonkEnv1 env v') binds
696 ; returnM (env', VarPatOut v' binds') }
698 zonk_pat env (LazyPat pat)
699 = do { (env', pat') <- zonkPat env pat
700 ; return (env', LazyPat pat') }
702 zonk_pat env (AsPat (L loc v) pat)
703 = do { v' <- zonkIdBndr env v
704 ; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
705 ; return (env', AsPat (L loc v') pat') }
707 zonk_pat env (ListPat pats ty)
708 = do { ty' <- zonkTcTypeToType env ty
709 ; (env', pats') <- zonkPats env pats
710 ; return (env', ListPat pats' ty') }
712 zonk_pat env (PArrPat pats ty)
713 = do { ty' <- zonkTcTypeToType env ty
714 ; (env', pats') <- zonkPats env pats
715 ; return (env', PArrPat pats' ty') }
717 zonk_pat env (TuplePat pats boxed)
718 = do { (env', pats') <- zonkPats env pats
719 ; return (env', TuplePat pats' boxed) }
721 zonk_pat env (ConPatOut n tvs dicts binds stuff ty)
722 = ASSERT( all isImmutableTyVar tvs )
723 do { new_ty <- zonkTcTypeToType env ty
724 ; new_dicts <- zonkIdBndrs env dicts
725 ; let env1 = extendZonkEnv env new_dicts
726 ; (env2, new_binds) <- zonkRecMonoBinds env1 binds
727 ; (env', new_stuff) <- zonkConStuff env2 stuff
728 ; returnM (env', ConPatOut n tvs new_dicts new_binds new_stuff new_ty) }
730 zonk_pat env (LitPat lit) = return (env, LitPat lit)
732 zonk_pat env (SigPatOut pat ty)
733 = do { ty' <- zonkTcTypeToType env ty
734 ; (env', pat') <- zonkPat env pat
735 ; return (env', SigPatOut pat' ty') }
737 zonk_pat env (NPatOut lit ty expr)
738 = do { ty' <- zonkTcTypeToType env ty
739 ; expr' <- zonkExpr env expr
740 ; return (env, NPatOut lit ty' expr') }
742 zonk_pat env (NPlusKPatOut (L loc n) k e1 e2)
743 = do { n' <- zonkIdBndr env n
744 ; e1' <- zonkExpr env e1
745 ; e2' <- zonkExpr env e2
746 ; return (extendZonkEnv1 env n', NPlusKPatOut (L loc n') k 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 ---------------------------
754 zonkConStuff env (PrefixCon pats)
755 = do { (env', pats') <- zonkPats env pats
756 ; return (env', PrefixCon pats') }
758 zonkConStuff env (InfixCon p1 p2)
759 = do { (env1, p1') <- zonkPat env p1
760 ; (env', p2') <- zonkPat env1 p2
761 ; return (env', InfixCon p1' p2') }
763 zonkConStuff env (RecCon rpats)
764 = do { (env', pats') <- zonkPats env pats
765 ; returnM (env', RecCon (fields `zip` pats')) }
767 (fields, pats) = unzip rpats
769 ---------------------------
770 zonkPats env [] = return (env, [])
771 zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
772 ; (env', pats') <- zonkPats env1 pats
773 ; return (env', pat':pats') }
776 %************************************************************************
778 \subsection[BackSubst-Foreign]{Foreign exports}
780 %************************************************************************
784 zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
785 zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
787 zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
788 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec) =
789 returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec isDeprec)
790 zonkForeignExport env for_imp
791 = returnM for_imp -- Foreign imports don't need zonking
795 zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
796 zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
798 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
799 zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs rhs)
800 = mappM zonk_bndr vars `thenM` \ new_bndrs ->
801 newMutVar emptyVarSet `thenM` \ unbound_tv_set ->
803 env_rhs = extendZonkEnv env [id | b <- new_bndrs, let id = unLoc b, isId id]
804 -- Type variables don't need an envt
805 -- They are bound through the mutable mechanism
807 env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
808 -- We need to gather the type variables mentioned on the LHS so we can
809 -- quantify over them. Example:
815 -- {-# RULES "myrule" foo C = 1 #-}
817 -- After type checking the LHS becomes (foo a (C a))
818 -- and we do not want to zap the unbound tyvar 'a' to (), because
819 -- that limits the applicability of the rule. Instead, we
820 -- want to quantify over it!
822 -- It's easiest to find the free tyvars here. Attempts to do so earlier
823 -- are tiresome, because (a) the data type is big and (b) finding the
824 -- free type vars of an expression is necessarily monadic operation.
825 -- (consider /\a -> f @ b, where b is side-effected to a)
827 zonkLExpr env_lhs lhs `thenM` \ new_lhs ->
828 zonkLExpr env_rhs rhs `thenM` \ new_rhs ->
830 readMutVar unbound_tv_set `thenM` \ unbound_tvs ->
832 final_bndrs :: [Located Var]
833 final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs
835 returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs new_rhs)
836 -- I hate this map RuleBndr stuff
838 zonk_bndr (RuleBndr v)
839 | isId (unLoc v) = wrapLocM (zonkIdBndr env) v
840 | otherwise = ASSERT( isImmutableTyVar (unLoc v) )
845 %************************************************************************
847 \subsection[BackSubst-Foreign]{Foreign exports}
849 %************************************************************************
852 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
853 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
855 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
856 -- This variant collects unbound type variables in a mutable variable
857 zonkTypeCollecting unbound_tv_set
858 = zonkType zonk_unbound_tyvar True
860 zonk_unbound_tyvar tv
861 = zonkQuantifiedTyVar tv `thenM` \ tv' ->
862 readMutVar unbound_tv_set `thenM` \ tv_set ->
863 writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_`
864 return (mkTyVarTy tv')
866 zonkTypeZapping :: TcType -> TcM Type
867 -- This variant is used for everything except the LHS of rules
868 -- It zaps unbound type variables to (), or some other arbitrary type
870 = zonkType zonk_unbound_tyvar True ty
872 -- Zonk a mutable but unbound type variable to an arbitrary type
873 -- We know it's unbound even though we don't carry an environment,
874 -- because at the binding site for a type variable we bind the
875 -- mutable tyvar to a fresh immutable one. So the mutable store
876 -- plays the role of an environment. If we come across a mutable
877 -- type variable that isn't so bound, it must be completely free.
878 zonk_unbound_tyvar tv = do { putMetaTyVar tv ty; return ty }
880 ty = mkArbitraryType tv
883 -- When the type checker finds a type variable with no binding,
884 -- which means it can be instantiated with an arbitrary type, it
885 -- usually instantiates it to Void. Eg.
889 -- length Void (Nil Void)
891 -- But in really obscure programs, the type variable might have
892 -- a kind other than *, so we need to invent a suitably-kinded type.
896 -- List for kind *->*
897 -- Tuple for kind *->...*->*
899 -- which deals with most cases. (Previously, it only dealt with
902 -- In the other cases, it just makes up a TyCon with a suitable
903 -- kind. If this gets into an interface file, anyone reading that
904 -- file won't understand it. This is fixable (by making the client
905 -- of the interface file make up a TyCon too) but it is tiresome and
906 -- never happens, so I am leaving it
908 mkArbitraryType :: TcTyVar -> Type
909 -- Make up an arbitrary type whose kind is the same as the tyvar.
910 -- We'll use this to instantiate the (unbound) tyvar.
912 | liftedTypeKind `isSubKind` kind = voidTy -- The vastly common case
913 | otherwise = mkTyConApp tycon []
916 (args,res) = splitKindFunTys kind
918 tycon | kind == tyConKind listTyCon -- *->*
919 = listTyCon -- No tuples this size
921 | all isLiftedTypeKind args && isLiftedTypeKind res
922 = tupleTyCon Boxed (length args) -- *-> ... ->*->*
925 = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
926 mkPrimTyCon tc_name kind 0 [] VoidRep
927 -- Same name as the tyvar, apart from making it start with a colon (sigh)
928 -- I dread to think what will happen if this gets out into an
929 -- interface file. Catastrophe likely. Major sigh.
931 tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc