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 ( 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 )
60 import Util ( mapSnd )
66 %************************************************************************
68 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
70 %************************************************************************
72 Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@,
73 then something is wrong.
75 hsPatType :: OutPat Id -> Type
76 hsPatType pat = pat_type (unLoc pat)
78 pat_type (ParPat pat) = hsPatType pat
79 pat_type (WildPat ty) = ty
80 pat_type (VarPat var) = idType var
81 pat_type (VarPatOut var _) = idType var
82 pat_type (LazyPat pat) = hsPatType pat
83 pat_type (LitPat lit) = hsLitType lit
84 pat_type (AsPat var pat) = idType (unLoc var)
85 pat_type (ListPat _ ty) = mkListTy ty
86 pat_type (PArrPat _ ty) = mkPArrTy ty
87 pat_type (TuplePat pats box) = mkTupleTy box (length pats) (map hsPatType pats)
88 pat_type (ConPatOut _ _ _ _ _ ty) = ty
89 pat_type (SigPatOut pat ty) = ty
90 pat_type (NPat lit _ _ ty) = ty
91 pat_type (NPlusKPat id _ _ _) = idType (unLoc id)
92 pat_type (DictPat ds ms) = case (ds ++ ms) of
95 ds -> mkTupleTy Boxed (length ds) (map idType ds)
98 hsLitType :: HsLit -> TcType
99 hsLitType (HsChar c) = charTy
100 hsLitType (HsCharPrim c) = charPrimTy
101 hsLitType (HsString str) = stringTy
102 hsLitType (HsStringPrim s) = addrPrimTy
103 hsLitType (HsInt i) = intTy
104 hsLitType (HsIntPrim i) = intPrimTy
105 hsLitType (HsInteger i ty) = ty
106 hsLitType (HsRat _ ty) = ty
107 hsLitType (HsFloatPrim f) = floatPrimTy
108 hsLitType (HsDoublePrim d) = doublePrimTy
111 %************************************************************************
113 \subsection{Coercion functions}
115 %************************************************************************
118 type Coercion a = Maybe (a -> a)
119 -- Nothing => identity fn
121 type ExprCoFn = Coercion (HsExpr TcId)
122 type PatCoFn = Coercion (Pat TcId)
124 (<.>) :: Coercion a -> Coercion a -> Coercion a -- Composition
125 Nothing <.> Nothing = Nothing
126 Nothing <.> Just f = Just f
127 Just f <.> Nothing = Just f
128 Just f1 <.> Just f2 = Just (f1 . f2)
130 (<$>) :: Coercion a -> a -> a
134 mkCoercion :: (a -> a) -> Coercion a
135 mkCoercion f = Just f
137 idCoercion :: Coercion a
140 isIdCoercion :: Coercion a -> Bool
141 isIdCoercion = isNothing
145 %************************************************************************
147 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
149 %************************************************************************
152 -- zonkId is used *during* typechecking just to zonk the Id's type
153 zonkId :: TcId -> TcM TcId
155 = zonkTcType (idType id) `thenM` \ ty' ->
156 returnM (setIdType id ty')
159 The rest of the zonking is done *after* typechecking.
160 The main zonking pass runs over the bindings
162 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
163 b) convert unbound TcTyVar to Void
164 c) convert each TcId to an Id by zonking its type
166 The type variables are converted by binding mutable tyvars to immutable ones
167 and then zonking as normal.
169 The Ids are converted by binding them in the normal Tc envt; that
170 way we maintain sharing; eg an Id is zonked at its binding site and they
171 all occurrences of that Id point to the common zonked copy
173 It's all pretty boring stuff, because HsSyn is such a large type, and
174 the environment manipulation is tiresome.
177 data ZonkEnv = ZonkEnv (TcType -> TcM Type) -- How to zonk a type
178 (IdEnv Id) -- What variables are in scope
179 -- Maps an Id to its zonked version; both have the same Name
180 -- Is only consulted lazily; hence knot-tying
182 emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
184 extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
185 extendZonkEnv (ZonkEnv zonk_ty env) ids
186 = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
188 extendZonkEnv1 :: ZonkEnv -> Id -> ZonkEnv
189 extendZonkEnv1 (ZonkEnv zonk_ty env) id
190 = ZonkEnv zonk_ty (extendVarEnv env id id)
192 setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
193 setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
195 zonkEnvIds :: ZonkEnv -> [Id]
196 zonkEnvIds (ZonkEnv _ env) = varEnvElts env
198 zonkIdOcc :: ZonkEnv -> TcId -> Id
199 -- Ids defined in this module should be in the envt;
200 -- ignore others. (Actually, data constructors are also
201 -- not LocalVars, even when locally defined, but that is fine.)
202 -- (Also foreign-imported things aren't currently in the ZonkEnv;
203 -- that's ok because they don't need zonking.)
205 -- Actually, Template Haskell works in 'chunks' of declarations, and
206 -- an earlier chunk won't be in the 'env' that the zonking phase
207 -- carries around. Instead it'll be in the tcg_gbl_env, already fully
208 -- zonked. There's no point in looking it up there (except for error
209 -- checking), and it's not conveniently to hand; hence the simple
210 -- 'orElse' case in the LocalVar branch.
212 -- Even without template splices, in module Main, the checking of
213 -- 'main' is done as a separate chunk.
214 zonkIdOcc (ZonkEnv zonk_ty env) id
215 | isLocalVar id = lookupVarEnv env id `orElse` id
218 zonkIdOccs env ids = map (zonkIdOcc env) ids
220 -- zonkIdBndr is used *after* typechecking to get the Id's type
221 -- to its final form. The TyVarEnv give
222 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
224 = zonkTcTypeToType env (idType id) `thenM` \ ty' ->
225 returnM (setIdType id ty')
227 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
228 zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
230 zonkTopBndrs :: [TcId] -> TcM [Id]
231 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
236 zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
237 zonkTopExpr e = zonkExpr emptyZonkEnv e
239 zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
240 zonkTopLExpr e = zonkLExpr emptyZonkEnv e
242 zonkTopDecls :: LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId]
247 zonkTopDecls binds rules fords
248 = do { (env, binds') <- zonkRecMonoBinds emptyZonkEnv binds
249 -- Top level is implicitly recursive
250 ; rules' <- zonkRules env rules
251 ; fords' <- zonkForeignExports env fords
252 ; return (zonkEnvIds env, binds', fords', rules') }
254 ---------------------------------------------
255 zonkGroup :: ZonkEnv -> HsBindGroup TcId -> TcM (ZonkEnv, HsBindGroup Id)
256 zonkGroup env (HsBindGroup bs sigs is_rec)
257 = ASSERT( null sigs )
258 do { (env1, bs') <- zonkRecMonoBinds env bs
259 ; return (env1, HsBindGroup bs' [] is_rec) }
261 zonkGroup env (HsIPBinds binds)
262 = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds ->
264 env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
266 returnM (env1, HsIPBinds new_binds)
268 zonk_ip_bind (IPBind n e)
269 = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' ->
270 zonkLExpr env e `thenM` \ e' ->
271 returnM (IPBind n' e')
273 ---------------------------------------------
274 zonkNestedBinds :: ZonkEnv -> [HsBindGroup TcId] -> TcM (ZonkEnv, [HsBindGroup Id])
275 zonkNestedBinds env [] = return (env, [])
276 zonkNestedBinds env (b:bs) = do { (env1, b') <- zonkGroup env b
277 ; (env2, bs') <- zonkNestedBinds env1 bs
278 ; return (env2, b':bs') }
280 ---------------------------------------------
281 zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
282 zonkRecMonoBinds env binds
283 = fixM (\ ~(_, new_binds) -> do
284 { let env1 = extendZonkEnv env (collectHsBindBinders new_binds)
285 ; binds' <- zonkMonoBinds env1 binds
286 ; return (env1, binds') })
288 zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
289 zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds
291 zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
292 zonk_bind env (PatBind pat grhss ty)
293 = do { (_env, new_pat) <- zonkPat env pat -- Env already extended
294 ; new_grhss <- zonkGRHSs env grhss
295 ; new_ty <- zonkTcTypeToType env ty
296 ; return (PatBind new_pat new_grhss new_ty) }
298 zonk_bind env (VarBind var expr)
299 = zonkIdBndr env var `thenM` \ new_var ->
300 zonkLExpr env expr `thenM` \ new_expr ->
301 returnM (VarBind new_var new_expr)
303 zonk_bind env (FunBind var inf ms)
304 = wrapLocM (zonkIdBndr env) var `thenM` \ new_var ->
305 zonkMatchGroup env ms `thenM` \ new_ms ->
306 returnM (FunBind new_var inf new_ms)
308 zonk_bind env (AbsBinds tyvars dicts exports inlines val_binds)
309 = ASSERT( all isImmutableTyVar tyvars )
310 zonkIdBndrs env dicts `thenM` \ new_dicts ->
311 fixM (\ ~(new_val_binds, _) ->
313 env1 = extendZonkEnv (extendZonkEnv env new_dicts)
314 (collectHsBindBinders new_val_binds)
316 zonkMonoBinds env1 val_binds `thenM` \ new_val_binds ->
317 mappM (zonkExport env1) exports `thenM` \ new_exports ->
318 returnM (new_val_binds, new_exports)
319 ) `thenM` \ (new_val_bind, new_exports) ->
320 returnM (AbsBinds tyvars new_dicts new_exports inlines new_val_bind)
322 zonkExport env (tyvars, global, local)
323 = zonkTcTyVars tyvars `thenM` \ tys ->
325 new_tyvars = map (tcGetTyVar "zonkExport") tys
326 -- This isn't the binding occurrence of these tyvars
327 -- but they should *be* tyvars. Hence tcGetTyVar.
329 zonkIdBndr env global `thenM` \ new_global ->
330 returnM (new_tyvars, new_global, zonkIdOcc env local)
333 %************************************************************************
335 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
337 %************************************************************************
340 zonkMatchGroup :: ZonkEnv -> MatchGroup TcId-> TcM (MatchGroup Id)
341 zonkMatchGroup env (MatchGroup ms ty)
342 = do { ms' <- mapM (zonkMatch env) ms
343 ; ty' <- zonkTcTypeToType env ty
344 ; return (MatchGroup ms' ty') }
346 zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id)
347 zonkMatch env (L loc (Match pats _ grhss))
348 = do { (env1, new_pats) <- zonkPats env pats
349 ; new_grhss <- zonkGRHSs env1 grhss
350 ; return (L loc (Match new_pats Nothing new_grhss)) }
352 -------------------------------------------------------------------------
353 zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id)
355 zonkGRHSs env (GRHSs grhss binds)
356 = zonkNestedBinds env binds `thenM` \ (new_env, new_binds) ->
358 zonk_grhs (GRHS guarded rhs)
359 = zonkStmts new_env guarded `thenM` \ (env2, new_guarded) ->
360 zonkLExpr env2 rhs `thenM` \ new_rhs ->
361 returnM (GRHS new_guarded new_rhs)
363 mappM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss ->
364 returnM (GRHSs new_grhss new_binds)
367 %************************************************************************
369 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
371 %************************************************************************
374 zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
375 zonkLExpr :: ZonkEnv -> LHsExpr TcId -> TcM (LHsExpr Id)
376 zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id)
378 zonkLExprs env exprs = mappM (zonkLExpr env) exprs
379 zonkLExpr env expr = wrapLocM (zonkExpr env) expr
381 zonkExpr env (HsVar id)
382 = returnM (HsVar (zonkIdOcc env id))
384 zonkExpr env (HsIPVar id)
385 = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
387 zonkExpr env (HsLit (HsRat f ty))
388 = zonkTcTypeToType env ty `thenM` \ new_ty ->
389 returnM (HsLit (HsRat f new_ty))
391 zonkExpr env (HsLit lit)
392 = returnM (HsLit lit)
394 zonkExpr env (HsOverLit lit)
395 = do { lit' <- zonkOverLit env lit
396 ; return (HsOverLit lit') }
398 zonkExpr env (HsLam matches)
399 = zonkMatchGroup env matches `thenM` \ new_matches ->
400 returnM (HsLam new_matches)
402 zonkExpr env (HsApp e1 e2)
403 = zonkLExpr env e1 `thenM` \ new_e1 ->
404 zonkLExpr env e2 `thenM` \ new_e2 ->
405 returnM (HsApp new_e1 new_e2)
407 zonkExpr env (HsBracketOut body bs)
408 = mappM zonk_b bs `thenM` \ bs' ->
409 returnM (HsBracketOut body bs')
411 zonk_b (n,e) = zonkLExpr env e `thenM` \ e' ->
414 zonkExpr env (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
415 returnM (HsSpliceE s)
417 zonkExpr env (OpApp e1 op fixity e2)
418 = zonkLExpr env e1 `thenM` \ new_e1 ->
419 zonkLExpr env op `thenM` \ new_op ->
420 zonkLExpr env e2 `thenM` \ new_e2 ->
421 returnM (OpApp new_e1 new_op fixity new_e2)
423 zonkExpr env (NegApp expr op)
424 = zonkLExpr env expr `thenM` \ new_expr ->
425 zonkExpr env op `thenM` \ new_op ->
426 returnM (NegApp new_expr new_op)
428 zonkExpr env (HsPar e)
429 = zonkLExpr env e `thenM` \new_e ->
430 returnM (HsPar new_e)
432 zonkExpr env (SectionL expr op)
433 = zonkLExpr env expr `thenM` \ new_expr ->
434 zonkLExpr env op `thenM` \ new_op ->
435 returnM (SectionL new_expr new_op)
437 zonkExpr env (SectionR op expr)
438 = zonkLExpr env op `thenM` \ new_op ->
439 zonkLExpr env expr `thenM` \ new_expr ->
440 returnM (SectionR new_op new_expr)
442 zonkExpr env (HsCase expr ms)
443 = zonkLExpr env expr `thenM` \ new_expr ->
444 zonkMatchGroup env ms `thenM` \ new_ms ->
445 returnM (HsCase new_expr new_ms)
447 zonkExpr env (HsIf e1 e2 e3)
448 = zonkLExpr env e1 `thenM` \ new_e1 ->
449 zonkLExpr env e2 `thenM` \ new_e2 ->
450 zonkLExpr env e3 `thenM` \ new_e3 ->
451 returnM (HsIf new_e1 new_e2 new_e3)
453 zonkExpr env (HsLet binds expr)
454 = zonkNestedBinds env binds `thenM` \ (new_env, new_binds) ->
455 zonkLExpr new_env expr `thenM` \ new_expr ->
456 returnM (HsLet new_binds new_expr)
458 zonkExpr env (HsDo do_or_lc stmts body ty)
459 = zonkStmts env stmts `thenM` \ (new_env, new_stmts) ->
460 zonkLExpr new_env body `thenM` \ new_body ->
461 zonkTcTypeToType env ty `thenM` \ new_ty ->
462 returnM (HsDo (zonkDo env do_or_lc)
463 new_stmts new_body new_ty)
465 zonkExpr env (ExplicitList ty exprs)
466 = zonkTcTypeToType env ty `thenM` \ new_ty ->
467 zonkLExprs env exprs `thenM` \ new_exprs ->
468 returnM (ExplicitList new_ty new_exprs)
470 zonkExpr env (ExplicitPArr ty exprs)
471 = zonkTcTypeToType env ty `thenM` \ new_ty ->
472 zonkLExprs env exprs `thenM` \ new_exprs ->
473 returnM (ExplicitPArr new_ty new_exprs)
475 zonkExpr env (ExplicitTuple exprs boxed)
476 = zonkLExprs env exprs `thenM` \ new_exprs ->
477 returnM (ExplicitTuple new_exprs boxed)
479 zonkExpr env (RecordCon data_con con_expr rbinds)
480 = zonkExpr env con_expr `thenM` \ new_con_expr ->
481 zonkRbinds env rbinds `thenM` \ new_rbinds ->
482 returnM (RecordCon data_con new_con_expr new_rbinds)
484 zonkExpr env (RecordUpd expr rbinds in_ty out_ty)
485 = zonkLExpr env expr `thenM` \ new_expr ->
486 zonkTcTypeToType env in_ty `thenM` \ new_in_ty ->
487 zonkTcTypeToType env out_ty `thenM` \ new_out_ty ->
488 zonkRbinds env rbinds `thenM` \ new_rbinds ->
489 returnM (RecordUpd new_expr new_rbinds new_in_ty new_out_ty)
491 zonkExpr env (ExprWithTySigOut e ty)
492 = do { e' <- zonkLExpr env e
493 ; return (ExprWithTySigOut e' ty) }
495 zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
497 zonkExpr env (ArithSeq expr info)
498 = zonkExpr env expr `thenM` \ new_expr ->
499 zonkArithSeq env info `thenM` \ new_info ->
500 returnM (ArithSeq new_expr new_info)
502 zonkExpr env (PArrSeq expr info)
503 = zonkExpr env expr `thenM` \ new_expr ->
504 zonkArithSeq env info `thenM` \ new_info ->
505 returnM (PArrSeq new_expr new_info)
507 zonkExpr env (HsSCC lbl expr)
508 = zonkLExpr env expr `thenM` \ new_expr ->
509 returnM (HsSCC lbl new_expr)
511 -- hdaume: core annotations
512 zonkExpr env (HsCoreAnn lbl expr)
513 = zonkLExpr env expr `thenM` \ new_expr ->
514 returnM (HsCoreAnn lbl new_expr)
516 zonkExpr env (TyLam tyvars expr)
517 = ASSERT( all isImmutableTyVar tyvars )
518 zonkLExpr env expr `thenM` \ new_expr ->
519 returnM (TyLam tyvars new_expr)
521 zonkExpr env (TyApp expr tys)
522 = zonkLExpr env expr `thenM` \ new_expr ->
523 zonkTcTypeToTypes env tys `thenM` \ new_tys ->
524 returnM (TyApp new_expr new_tys)
526 zonkExpr env (DictLam dicts expr)
527 = zonkIdBndrs env dicts `thenM` \ new_dicts ->
529 env1 = extendZonkEnv env new_dicts
531 zonkLExpr env1 expr `thenM` \ new_expr ->
532 returnM (DictLam new_dicts new_expr)
534 zonkExpr env (DictApp expr dicts)
535 = zonkLExpr env expr `thenM` \ new_expr ->
536 returnM (DictApp new_expr (zonkIdOccs env dicts))
538 -- arrow notation extensions
539 zonkExpr env (HsProc pat body)
540 = do { (env1, new_pat) <- zonkPat env pat
541 ; new_body <- zonkCmdTop env1 body
542 ; return (HsProc new_pat new_body) }
544 zonkExpr env (HsArrApp e1 e2 ty ho rl)
545 = zonkLExpr env e1 `thenM` \ new_e1 ->
546 zonkLExpr env e2 `thenM` \ new_e2 ->
547 zonkTcTypeToType env ty `thenM` \ new_ty ->
548 returnM (HsArrApp new_e1 new_e2 new_ty ho rl)
550 zonkExpr env (HsArrForm op fixity args)
551 = zonkLExpr env op `thenM` \ new_op ->
552 mappM (zonkCmdTop env) args `thenM` \ new_args ->
553 returnM (HsArrForm new_op fixity new_args)
555 zonkExpr env other = pprPanic "zonkExpr" (ppr other)
557 zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
558 zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
560 zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
561 = zonkLExpr env cmd `thenM` \ new_cmd ->
562 zonkTcTypeToTypes env stack_tys `thenM` \ new_stack_tys ->
563 zonkTcTypeToType env ty `thenM` \ new_ty ->
564 mapSndM (zonkExpr env) ids `thenM` \ new_ids ->
565 returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
567 -------------------------------------------------------------------------
568 zonkDo :: ZonkEnv -> HsStmtContext Name -> HsStmtContext Name
569 -- Only used for 'do', so the only Ids are in a MDoExpr table
570 zonkDo env (MDoExpr tbl) = MDoExpr (mapSnd (zonkIdOcc env) tbl)
571 zonkDo env do_or_lc = do_or_lc
573 -------------------------------------------------------------------------
574 zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
575 zonkOverLit env (HsIntegral i e)
576 = do { e' <- zonkExpr env e; return (HsIntegral i e') }
577 zonkOverLit env (HsFractional r e)
578 = do { e' <- zonkExpr env e; return (HsFractional r e') }
580 -------------------------------------------------------------------------
581 zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
583 zonkArithSeq env (From e)
584 = zonkLExpr env e `thenM` \ new_e ->
587 zonkArithSeq env (FromThen e1 e2)
588 = zonkLExpr env e1 `thenM` \ new_e1 ->
589 zonkLExpr env e2 `thenM` \ new_e2 ->
590 returnM (FromThen new_e1 new_e2)
592 zonkArithSeq env (FromTo e1 e2)
593 = zonkLExpr env e1 `thenM` \ new_e1 ->
594 zonkLExpr env e2 `thenM` \ new_e2 ->
595 returnM (FromTo new_e1 new_e2)
597 zonkArithSeq env (FromThenTo e1 e2 e3)
598 = zonkLExpr env e1 `thenM` \ new_e1 ->
599 zonkLExpr env e2 `thenM` \ new_e2 ->
600 zonkLExpr env e3 `thenM` \ new_e3 ->
601 returnM (FromThenTo new_e1 new_e2 new_e3)
604 -------------------------------------------------------------------------
605 zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id])
606 zonkStmts env [] = return (env, [])
607 zonkStmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s
608 ; (env2, ss') <- zonkStmts env1 ss
609 ; return (env2, s' : ss') }
611 zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
612 zonkStmt env (ParStmt stmts_w_bndrs)
613 = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs ->
615 new_binders = concat (map snd new_stmts_w_bndrs)
616 env1 = extendZonkEnv env new_binders
618 return (env1, ParStmt new_stmts_w_bndrs)
620 zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) ->
621 returnM (new_stmts, zonkIdOccs env1 bndrs)
623 zonkStmt env (RecStmt segStmts lvs rvs rets binds)
624 = zonkIdBndrs env rvs `thenM` \ new_rvs ->
626 env1 = extendZonkEnv env new_rvs
628 zonkStmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
629 -- Zonk the ret-expressions in an envt that
630 -- has the polymorphic bindings in the envt
631 mapM (zonkExpr env2) rets `thenM` \ new_rets ->
633 new_lvs = zonkIdOccs env2 lvs
634 env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
636 zonkRecMonoBinds env3 binds `thenM` \ (env4, new_binds) ->
637 returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets new_binds)
639 zonkStmt env (ExprStmt expr then_op ty)
640 = zonkLExpr env expr `thenM` \ new_expr ->
641 zonkExpr env then_op `thenM` \ new_then ->
642 zonkTcTypeToType env ty `thenM` \ new_ty ->
643 returnM (env, ExprStmt new_expr new_then new_ty)
645 zonkStmt env (LetStmt binds)
646 = zonkNestedBinds env binds `thenM` \ (env1, new_binds) ->
647 returnM (env1, LetStmt new_binds)
649 zonkStmt env (BindStmt pat expr bind_op fail_op)
650 = do { new_expr <- zonkLExpr env expr
651 ; (env1, new_pat) <- zonkPat env pat
652 ; new_bind <- zonkExpr env bind_op
653 ; new_fail <- zonkExpr env fail_op
654 ; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
657 -------------------------------------------------------------------------
658 zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id)
660 zonkRbinds env rbinds
661 = mappM zonk_rbind rbinds
663 zonk_rbind (field, expr)
664 = zonkLExpr env expr `thenM` \ new_expr ->
665 returnM (fmap (zonkIdOcc env) field, new_expr)
667 -------------------------------------------------------------------------
668 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
669 mapIPNameTc f (Dupable n) = f n `thenM` \ r -> returnM (Dupable r)
670 mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r)
674 %************************************************************************
676 \subsection[BackSubst-Pats]{Patterns}
678 %************************************************************************
681 zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
682 -- Extend the environment as we go, because it's possible for one
683 -- pattern to bind something that is used in another (inside or
685 zonkPat env pat = wrapLocSndM (zonk_pat env) pat
687 zonk_pat env (ParPat p)
688 = do { (env', p') <- zonkPat env p
689 ; return (env', ParPat p') }
691 zonk_pat env (WildPat ty)
692 = do { ty' <- zonkTcTypeToType env ty
693 ; return (env, WildPat ty') }
695 zonk_pat env (VarPat v)
696 = do { v' <- zonkIdBndr env v
697 ; return (extendZonkEnv1 env v', VarPat v') }
699 zonk_pat env (VarPatOut v binds)
700 = do { v' <- zonkIdBndr env v
701 ; (env', binds') <- zonkRecMonoBinds (extendZonkEnv1 env v') binds
702 ; returnM (env', VarPatOut v' binds') }
704 zonk_pat env (LazyPat pat)
705 = do { (env', pat') <- zonkPat env pat
706 ; return (env', LazyPat pat') }
708 zonk_pat env (AsPat (L loc v) pat)
709 = do { v' <- zonkIdBndr env v
710 ; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
711 ; return (env', AsPat (L loc v') pat') }
713 zonk_pat env (ListPat pats ty)
714 = do { ty' <- zonkTcTypeToType env ty
715 ; (env', pats') <- zonkPats env pats
716 ; return (env', ListPat pats' ty') }
718 zonk_pat env (PArrPat pats ty)
719 = do { ty' <- zonkTcTypeToType env ty
720 ; (env', pats') <- zonkPats env pats
721 ; return (env', PArrPat pats' ty') }
723 zonk_pat env (TuplePat pats boxed)
724 = do { (env', pats') <- zonkPats env pats
725 ; return (env', TuplePat pats' boxed) }
727 zonk_pat env (ConPatOut n tvs dicts binds stuff ty)
728 = ASSERT( all isImmutableTyVar tvs )
729 do { new_ty <- zonkTcTypeToType env ty
730 ; new_dicts <- zonkIdBndrs env dicts
731 ; let env1 = extendZonkEnv env new_dicts
732 ; (env2, new_binds) <- zonkRecMonoBinds env1 binds
733 ; (env', new_stuff) <- zonkConStuff env2 stuff
734 ; returnM (env', ConPatOut n tvs new_dicts new_binds new_stuff new_ty) }
736 zonk_pat env (LitPat lit) = return (env, LitPat lit)
738 zonk_pat env (SigPatOut pat ty)
739 = do { ty' <- zonkTcTypeToType env ty
740 ; (env', pat') <- zonkPat env pat
741 ; return (env', SigPatOut pat' ty') }
743 zonk_pat env (NPat lit mb_neg eq_expr ty)
744 = do { lit' <- zonkOverLit env lit
745 ; mb_neg' <- case mb_neg of
746 Nothing -> return Nothing
747 Just neg -> do { neg' <- zonkExpr env neg
748 ; return (Just neg') }
749 ; eq_expr' <- zonkExpr env eq_expr
750 ; ty' <- zonkTcTypeToType env ty
751 ; return (env, NPat lit' mb_neg' eq_expr' ty') }
753 zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
754 = do { n' <- zonkIdBndr env n
755 ; lit' <- zonkOverLit env lit
756 ; e1' <- zonkExpr env e1
757 ; e2' <- zonkExpr env e2
758 ; return (extendZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
760 zonk_pat env (DictPat ds ms)
761 = do { ds' <- zonkIdBndrs env ds
762 ; ms' <- zonkIdBndrs env ms
763 ; return (extendZonkEnv env (ds' ++ ms'), DictPat ds' ms') }
765 ---------------------------
766 zonkConStuff env (PrefixCon pats)
767 = do { (env', pats') <- zonkPats env pats
768 ; return (env', PrefixCon pats') }
770 zonkConStuff env (InfixCon p1 p2)
771 = do { (env1, p1') <- zonkPat env p1
772 ; (env', p2') <- zonkPat env1 p2
773 ; return (env', InfixCon p1' p2') }
775 zonkConStuff env (RecCon rpats)
776 = do { (env', pats') <- zonkPats env pats
777 ; returnM (env', RecCon (fields `zip` pats')) }
779 (fields, pats) = unzip rpats
781 ---------------------------
782 zonkPats env [] = return (env, [])
783 zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
784 ; (env', pats') <- zonkPats env1 pats
785 ; return (env', pat':pats') }
788 %************************************************************************
790 \subsection[BackSubst-Foreign]{Foreign exports}
792 %************************************************************************
796 zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
797 zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
799 zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
800 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec) =
801 returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec isDeprec)
802 zonkForeignExport env for_imp
803 = returnM for_imp -- Foreign imports don't need zonking
807 zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
808 zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
810 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
811 zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs rhs)
812 = mappM zonk_bndr vars `thenM` \ new_bndrs ->
813 newMutVar emptyVarSet `thenM` \ unbound_tv_set ->
815 env_rhs = extendZonkEnv env [id | b <- new_bndrs, let id = unLoc b, isId id]
816 -- Type variables don't need an envt
817 -- They are bound through the mutable mechanism
819 env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
820 -- We need to gather the type variables mentioned on the LHS so we can
821 -- quantify over them. Example:
827 -- {-# RULES "myrule" foo C = 1 #-}
829 -- After type checking the LHS becomes (foo a (C a))
830 -- and we do not want to zap the unbound tyvar 'a' to (), because
831 -- that limits the applicability of the rule. Instead, we
832 -- want to quantify over it!
834 -- It's easiest to find the free tyvars here. Attempts to do so earlier
835 -- are tiresome, because (a) the data type is big and (b) finding the
836 -- free type vars of an expression is necessarily monadic operation.
837 -- (consider /\a -> f @ b, where b is side-effected to a)
839 zonkLExpr env_lhs lhs `thenM` \ new_lhs ->
840 zonkLExpr env_rhs rhs `thenM` \ new_rhs ->
842 readMutVar unbound_tv_set `thenM` \ unbound_tvs ->
844 final_bndrs :: [Located Var]
845 final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs
847 returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs new_rhs)
848 -- I hate this map RuleBndr stuff
850 zonk_bndr (RuleBndr v)
851 | isId (unLoc v) = wrapLocM (zonkIdBndr env) v
852 | otherwise = ASSERT( isImmutableTyVar (unLoc v) )
857 %************************************************************************
859 \subsection[BackSubst-Foreign]{Foreign exports}
861 %************************************************************************
864 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
865 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
867 zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
868 zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
870 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
871 -- This variant collects unbound type variables in a mutable variable
872 zonkTypeCollecting unbound_tv_set
873 = zonkType zonk_unbound_tyvar True
875 zonk_unbound_tyvar tv
876 = zonkQuantifiedTyVar tv `thenM` \ tv' ->
877 readMutVar unbound_tv_set `thenM` \ tv_set ->
878 writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_`
879 return (mkTyVarTy tv')
881 zonkTypeZapping :: TcType -> TcM Type
882 -- This variant is used for everything except the LHS of rules
883 -- It zaps unbound type variables to (), or some other arbitrary type
885 = zonkType zonk_unbound_tyvar True ty
887 -- Zonk a mutable but unbound type variable to an arbitrary type
888 -- We know it's unbound even though we don't carry an environment,
889 -- because at the binding site for a type variable we bind the
890 -- mutable tyvar to a fresh immutable one. So the mutable store
891 -- plays the role of an environment. If we come across a mutable
892 -- type variable that isn't so bound, it must be completely free.
893 zonk_unbound_tyvar tv = do { putMetaTyVar tv ty; return ty }
895 ty = mkArbitraryType tv
898 -- When the type checker finds a type variable with no binding,
899 -- which means it can be instantiated with an arbitrary type, it
900 -- usually instantiates it to Void. Eg.
904 -- length Void (Nil Void)
906 -- But in really obscure programs, the type variable might have
907 -- a kind other than *, so we need to invent a suitably-kinded type.
911 -- List for kind *->*
912 -- Tuple for kind *->...*->*
914 -- which deals with most cases. (Previously, it only dealt with
917 -- In the other cases, it just makes up a TyCon with a suitable
918 -- kind. If this gets into an interface file, anyone reading that
919 -- file won't understand it. This is fixable (by making the client
920 -- of the interface file make up a TyCon too) but it is tiresome and
921 -- never happens, so I am leaving it
923 mkArbitraryType :: TcTyVar -> Type
924 -- Make up an arbitrary type whose kind is the same as the tyvar.
925 -- We'll use this to instantiate the (unbound) tyvar.
927 | liftedTypeKind `isSubKind` kind = voidTy -- The vastly common case
928 | otherwise = mkTyConApp tycon []
931 (args,res) = splitKindFunTys kind
933 tycon | kind == tyConKind listTyCon -- *->*
934 = listTyCon -- No tuples this size
936 | all isLiftedTypeKind args && isLiftedTypeKind res
937 = tupleTyCon Boxed (length args) -- *-> ... ->*->*
940 = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
941 mkPrimTyCon tc_name kind 0 [] VoidRep
942 -- Same name as the tyvar, apart from making it start with a colon (sigh)
943 -- I dread to think what will happen if this gets out into an
944 -- interface file. Catastrophe likely. Major sigh.
946 tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc