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 )
40 import Kind ( isLiftedTypeKind, liftedTypeKind, isSubKind )
42 import TcMType ( zonkQuantifiedTyVar, zonkType, zonkTcType,
44 import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
45 doublePrimTy, addrPrimTy
47 import TysWiredIn ( charTy, stringTy, intTy,
48 mkListTy, mkPArrTy, mkTupleTy, unitTy,
49 voidTy, listTyCon, tupleTyCon )
50 import TyCon ( mkPrimTyCon, tyConKind, PrimRep(..) )
51 import Kind ( splitKindFunTys )
52 import Name ( getOccName, mkInternalName, mkDerivedTyConOcc )
53 import Var ( Var, isId, isLocalVar, tyVarKind )
56 import BasicTypes ( Boxity(..), IPName(..), ipNameName, mapIPName )
57 import Maybes ( orElse )
58 import Maybe ( isNothing )
59 import Unique ( Uniquable(..) )
60 import SrcLoc ( noSrcLoc, noLoc, Located(..), unLoc )
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 (NPatOut lit ty _) = ty
91 pat_type (NPlusKPatOut 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.)
203 -- Actually, Template Haskell works in 'chunks' of declarations, and
204 -- an earlier chunk won't be in the 'env' that the zonking phase
205 -- carries around. Instead it'll be in the tcg_gbl_env, already fully
206 -- zonked. There's no point in looking it up there (except for error
207 -- checking), and it's not conveniently to hand; hence the simple
208 -- 'orElse' case in the LocalVar branch.
210 -- Even without template splices, in module Main, the checking of
211 -- 'main' is done as a separte chunk.
212 zonkIdOcc (ZonkEnv zonk_ty env) id
213 | isLocalVar id = lookupVarEnv env id `orElse` id
216 zonkIdOccs env ids = map (zonkIdOcc env) ids
218 -- zonkIdBndr is used *after* typechecking to get the Id's type
219 -- to its final form. The TyVarEnv give
220 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
222 = zonkTcTypeToType env (idType id) `thenM` \ ty' ->
223 returnM (setIdType id ty')
225 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
226 zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
228 zonkTopBndrs :: [TcId] -> TcM [Id]
229 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
234 zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
235 zonkTopExpr e = zonkExpr emptyZonkEnv e
237 zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
238 zonkTopLExpr e = zonkLExpr emptyZonkEnv e
240 zonkTopDecls :: LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId]
245 zonkTopDecls binds rules fords
246 = do { (env, binds') <- zonkRecMonoBinds emptyZonkEnv binds
247 -- Top level is implicitly recursive
248 ; rules' <- zonkRules env rules
249 ; fords' <- zonkForeignExports env fords
250 ; return (zonkEnvIds env, binds', fords', rules') }
252 ---------------------------------------------
253 zonkGroup :: ZonkEnv -> HsBindGroup TcId -> TcM (ZonkEnv, HsBindGroup Id)
254 zonkGroup env (HsBindGroup bs sigs is_rec)
255 = ASSERT( null sigs )
256 do { (env1, bs') <- zonkRecMonoBinds env bs
257 ; return (env1, HsBindGroup bs' [] is_rec) }
259 zonkGroup env (HsIPBinds binds)
260 = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds ->
262 env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
264 returnM (env1, HsIPBinds new_binds)
266 zonk_ip_bind (IPBind n e)
267 = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' ->
268 zonkLExpr env e `thenM` \ e' ->
269 returnM (IPBind n' e')
271 ---------------------------------------------
272 zonkNestedBinds :: ZonkEnv -> [HsBindGroup TcId] -> TcM (ZonkEnv, [HsBindGroup Id])
273 zonkNestedBinds env [] = return (env, [])
274 zonkNestedBinds env (b:bs) = do { (env1, b') <- zonkGroup env b
275 ; (env2, bs') <- zonkNestedBinds env1 bs
276 ; return (env2, b':bs') }
278 ---------------------------------------------
279 zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
280 zonkRecMonoBinds env binds
281 = fixM (\ ~(_, new_binds) -> do
282 { let env1 = extendZonkEnv env (collectHsBindBinders new_binds)
283 ; binds' <- zonkMonoBinds env1 binds
284 ; return (env1, binds') })
286 zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
287 zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds
289 zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
290 zonk_bind env (PatBind pat grhss ty)
291 = do { (_env, new_pat) <- zonkPat env pat -- Env already extended
292 ; new_grhss <- zonkGRHSs env grhss
293 ; new_ty <- zonkTcTypeToType env ty
294 ; return (PatBind new_pat new_grhss new_ty) }
296 zonk_bind env (VarBind var expr)
297 = zonkIdBndr env var `thenM` \ new_var ->
298 zonkLExpr env expr `thenM` \ new_expr ->
299 returnM (VarBind new_var new_expr)
301 zonk_bind env (FunBind var inf ms)
302 = wrapLocM (zonkIdBndr env) var `thenM` \ new_var ->
303 zonkMatchGroup env ms `thenM` \ new_ms ->
304 returnM (FunBind new_var inf new_ms)
306 zonk_bind env (AbsBinds tyvars dicts exports inlines val_binds)
307 = ASSERT( all isImmutableTyVar tyvars )
308 zonkIdBndrs env dicts `thenM` \ new_dicts ->
309 fixM (\ ~(new_val_binds, _) ->
311 env1 = extendZonkEnv (extendZonkEnv env new_dicts)
312 (collectHsBindBinders new_val_binds)
314 zonkMonoBinds env1 val_binds `thenM` \ new_val_binds ->
315 mappM (zonkExport env1) exports `thenM` \ new_exports ->
316 returnM (new_val_binds, new_exports)
317 ) `thenM` \ (new_val_bind, new_exports) ->
318 returnM (AbsBinds tyvars new_dicts new_exports inlines new_val_bind)
320 zonkExport env (tyvars, global, local)
321 = ASSERT( all isImmutableTyVar tyvars )
322 zonkIdBndr env global `thenM` \ new_global ->
323 returnM (tyvars, new_global, zonkIdOcc env local)
326 %************************************************************************
328 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
330 %************************************************************************
333 zonkMatchGroup :: ZonkEnv -> MatchGroup TcId-> TcM (MatchGroup Id)
334 zonkMatchGroup env (MatchGroup ms ty)
335 = do { ms' <- mapM (zonkMatch env) ms
336 ; ty' <- zonkTcTypeToType env ty
337 ; return (MatchGroup ms' ty') }
339 zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id)
340 zonkMatch env (L loc (Match pats _ grhss))
341 = do { (env1, new_pats) <- zonkPats env pats
342 ; new_grhss <- zonkGRHSs env1 grhss
343 ; return (L loc (Match new_pats Nothing new_grhss)) }
345 -------------------------------------------------------------------------
346 zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id)
348 zonkGRHSs env (GRHSs grhss binds)
349 = zonkNestedBinds env binds `thenM` \ (new_env, new_binds) ->
351 zonk_grhs (GRHS guarded)
352 = zonkStmts new_env guarded `thenM` \ new_guarded ->
353 returnM (GRHS new_guarded)
355 mappM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss ->
356 returnM (GRHSs new_grhss new_binds)
359 %************************************************************************
361 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
363 %************************************************************************
366 zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
367 zonkLExpr :: ZonkEnv -> LHsExpr TcId -> TcM (LHsExpr Id)
368 zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id)
370 zonkLExprs env exprs = mappM (zonkLExpr env) exprs
371 zonkLExpr env expr = wrapLocM (zonkExpr env) expr
373 zonkExpr env (HsVar id)
374 = returnM (HsVar (zonkIdOcc env id))
376 zonkExpr env (HsIPVar id)
377 = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
379 zonkExpr env (HsLit (HsRat f ty))
380 = zonkTcTypeToType env ty `thenM` \ new_ty ->
381 returnM (HsLit (HsRat f new_ty))
383 zonkExpr env (HsLit lit)
384 = returnM (HsLit lit)
385 -- HsOverLit doesn't appear in typechecker output
387 zonkExpr env (HsLam matches)
388 = zonkMatchGroup env matches `thenM` \ new_matches ->
389 returnM (HsLam new_matches)
391 zonkExpr env (HsApp e1 e2)
392 = zonkLExpr env e1 `thenM` \ new_e1 ->
393 zonkLExpr env e2 `thenM` \ new_e2 ->
394 returnM (HsApp new_e1 new_e2)
396 zonkExpr env (HsBracketOut body bs)
397 = mappM zonk_b bs `thenM` \ bs' ->
398 returnM (HsBracketOut body bs')
400 zonk_b (n,e) = zonkLExpr env e `thenM` \ e' ->
403 zonkExpr env (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
404 returnM (HsSpliceE s)
406 zonkExpr env (OpApp e1 op fixity e2)
407 = zonkLExpr env e1 `thenM` \ new_e1 ->
408 zonkLExpr env op `thenM` \ new_op ->
409 zonkLExpr env e2 `thenM` \ new_e2 ->
410 returnM (OpApp new_e1 new_op fixity new_e2)
412 zonkExpr env (NegApp _ _) = panic "zonkExpr env: NegApp"
414 zonkExpr env (HsPar e)
415 = zonkLExpr env e `thenM` \new_e ->
416 returnM (HsPar new_e)
418 zonkExpr env (SectionL expr op)
419 = zonkLExpr env expr `thenM` \ new_expr ->
420 zonkLExpr env op `thenM` \ new_op ->
421 returnM (SectionL new_expr new_op)
423 zonkExpr env (SectionR op expr)
424 = zonkLExpr env op `thenM` \ new_op ->
425 zonkLExpr env expr `thenM` \ new_expr ->
426 returnM (SectionR new_op new_expr)
429 zonkExpr env (HsCase expr ms)
430 = zonkLExpr env expr `thenM` \ new_expr ->
431 zonkMatchGroup env ms `thenM` \ new_ms ->
432 returnM (HsCase new_expr new_ms)
434 zonkExpr env (HsIf e1 e2 e3)
435 = zonkLExpr env e1 `thenM` \ new_e1 ->
436 zonkLExpr env e2 `thenM` \ new_e2 ->
437 zonkLExpr env e3 `thenM` \ new_e3 ->
438 returnM (HsIf new_e1 new_e2 new_e3)
440 zonkExpr env (HsLet binds expr)
441 = zonkNestedBinds env binds `thenM` \ (new_env, new_binds) ->
442 zonkLExpr new_env expr `thenM` \ new_expr ->
443 returnM (HsLet new_binds new_expr)
445 zonkExpr env (HsDo do_or_lc stmts ids ty)
446 = zonkStmts env stmts `thenM` \ new_stmts ->
447 zonkTcTypeToType env ty `thenM` \ new_ty ->
448 zonkReboundNames env ids `thenM` \ new_ids ->
449 returnM (HsDo do_or_lc new_stmts new_ids new_ty)
451 zonkExpr env (ExplicitList ty exprs)
452 = zonkTcTypeToType env ty `thenM` \ new_ty ->
453 zonkLExprs env exprs `thenM` \ new_exprs ->
454 returnM (ExplicitList new_ty new_exprs)
456 zonkExpr env (ExplicitPArr ty exprs)
457 = zonkTcTypeToType env ty `thenM` \ new_ty ->
458 zonkLExprs env exprs `thenM` \ new_exprs ->
459 returnM (ExplicitPArr new_ty new_exprs)
461 zonkExpr env (ExplicitTuple exprs boxed)
462 = zonkLExprs env exprs `thenM` \ new_exprs ->
463 returnM (ExplicitTuple new_exprs boxed)
465 zonkExpr env (RecordConOut data_con con_expr rbinds)
466 = zonkLExpr env con_expr `thenM` \ new_con_expr ->
467 zonkRbinds env rbinds `thenM` \ new_rbinds ->
468 returnM (RecordConOut data_con new_con_expr new_rbinds)
470 zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd"
472 zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds)
473 = zonkLExpr env expr `thenM` \ new_expr ->
474 zonkTcTypeToType env in_ty `thenM` \ new_in_ty ->
475 zonkTcTypeToType env out_ty `thenM` \ new_out_ty ->
476 zonkRbinds env rbinds `thenM` \ new_rbinds ->
477 returnM (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
479 zonkExpr env (ExprWithTySigOut e ty)
480 = do { e' <- zonkLExpr env e
481 ; return (ExprWithTySigOut e' ty) }
483 zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
484 zonkExpr env (ArithSeqIn _) = panic "zonkExpr env:ArithSeqIn"
485 zonkExpr env (PArrSeqIn _) = panic "zonkExpr env:PArrSeqIn"
487 zonkExpr env (ArithSeqOut expr info)
488 = zonkLExpr env expr `thenM` \ new_expr ->
489 zonkArithSeq env info `thenM` \ new_info ->
490 returnM (ArithSeqOut new_expr new_info)
492 zonkExpr env (PArrSeqOut expr info)
493 = zonkLExpr env expr `thenM` \ new_expr ->
494 zonkArithSeq env info `thenM` \ new_info ->
495 returnM (PArrSeqOut new_expr new_info)
497 zonkExpr env (HsSCC lbl expr)
498 = zonkLExpr env expr `thenM` \ new_expr ->
499 returnM (HsSCC lbl new_expr)
501 -- hdaume: core annotations
502 zonkExpr env (HsCoreAnn lbl expr)
503 = zonkLExpr env expr `thenM` \ new_expr ->
504 returnM (HsCoreAnn lbl new_expr)
506 zonkExpr env (TyLam tyvars expr)
507 = ASSERT( all isImmutableTyVar tyvars )
508 zonkLExpr env expr `thenM` \ new_expr ->
509 returnM (TyLam tyvars new_expr)
511 zonkExpr env (TyApp expr tys)
512 = zonkLExpr env expr `thenM` \ new_expr ->
513 mappM (zonkTcTypeToType env) tys `thenM` \ new_tys ->
514 returnM (TyApp new_expr new_tys)
516 zonkExpr env (DictLam dicts expr)
517 = zonkIdBndrs env dicts `thenM` \ new_dicts ->
519 env1 = extendZonkEnv env new_dicts
521 zonkLExpr env1 expr `thenM` \ new_expr ->
522 returnM (DictLam new_dicts new_expr)
524 zonkExpr env (DictApp expr dicts)
525 = zonkLExpr env expr `thenM` \ new_expr ->
526 returnM (DictApp new_expr (zonkIdOccs env dicts))
528 -- arrow notation extensions
529 zonkExpr env (HsProc pat body)
530 = do { (env1, new_pat) <- zonkPat env pat
531 ; new_body <- zonkCmdTop env1 body
532 ; return (HsProc new_pat new_body) }
534 zonkExpr env (HsArrApp e1 e2 ty ho rl)
535 = zonkLExpr env e1 `thenM` \ new_e1 ->
536 zonkLExpr env e2 `thenM` \ new_e2 ->
537 zonkTcTypeToType env ty `thenM` \ new_ty ->
538 returnM (HsArrApp new_e1 new_e2 new_ty ho rl)
540 zonkExpr env (HsArrForm op fixity args)
541 = zonkLExpr env op `thenM` \ new_op ->
542 mappM (zonkCmdTop env) args `thenM` \ new_args ->
543 returnM (HsArrForm new_op fixity new_args)
545 zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
546 zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
548 zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
549 = zonkLExpr env cmd `thenM` \ new_cmd ->
550 mappM (zonkTcTypeToType env) stack_tys
551 `thenM` \ new_stack_tys ->
552 zonkTcTypeToType env ty `thenM` \ new_ty ->
553 zonkReboundNames env ids `thenM` \ new_ids ->
554 returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
556 -------------------------------------------------------------------------
557 zonkReboundNames :: ZonkEnv -> ReboundNames Id -> TcM (ReboundNames Id)
558 zonkReboundNames env prs
561 zonk (n, e) = zonkExpr env e `thenM` \ new_e ->
565 -------------------------------------------------------------------------
566 zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
568 zonkArithSeq env (From e)
569 = zonkLExpr env e `thenM` \ new_e ->
572 zonkArithSeq env (FromThen e1 e2)
573 = zonkLExpr env e1 `thenM` \ new_e1 ->
574 zonkLExpr env e2 `thenM` \ new_e2 ->
575 returnM (FromThen new_e1 new_e2)
577 zonkArithSeq env (FromTo e1 e2)
578 = zonkLExpr env e1 `thenM` \ new_e1 ->
579 zonkLExpr env e2 `thenM` \ new_e2 ->
580 returnM (FromTo new_e1 new_e2)
582 zonkArithSeq env (FromThenTo e1 e2 e3)
583 = zonkLExpr env e1 `thenM` \ new_e1 ->
584 zonkLExpr env e2 `thenM` \ new_e2 ->
585 zonkLExpr env e3 `thenM` \ new_e3 ->
586 returnM (FromThenTo new_e1 new_e2 new_e3)
589 -------------------------------------------------------------------------
590 zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM [LStmt Id]
592 zonkStmts env stmts = zonk_stmts env stmts `thenM` \ (_, stmts) ->
595 zonk_stmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id])
596 zonk_stmts env [] = return (env, [])
597 zonk_stmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s
598 ; (env2, ss') <- zonk_stmts env1 ss
599 ; return (env2, s' : ss') }
601 zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
602 zonkStmt env (ParStmt stmts_w_bndrs)
603 = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs ->
605 new_binders = concat (map snd new_stmts_w_bndrs)
606 env1 = extendZonkEnv env new_binders
608 return (env1, ParStmt new_stmts_w_bndrs)
610 zonk_branch (stmts, bndrs) = zonk_stmts env stmts `thenM` \ (env1, new_stmts) ->
611 returnM (new_stmts, zonkIdOccs env1 bndrs)
613 zonkStmt env (RecStmt segStmts lvs rvs rets)
614 = zonkIdBndrs env rvs `thenM` \ new_rvs ->
616 env1 = extendZonkEnv env new_rvs
618 zonk_stmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
619 -- Zonk the ret-expressions in an envt that
620 -- has the polymorphic bindings in the envt
621 zonkLExprs env2 rets `thenM` \ new_rets ->
623 new_lvs = zonkIdOccs env2 lvs
624 env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
626 returnM (env3, RecStmt new_segStmts new_lvs new_rvs new_rets)
628 zonkStmt env (ResultStmt expr)
629 = zonkLExpr env expr `thenM` \ new_expr ->
630 returnM (env, ResultStmt new_expr)
632 zonkStmt env (ExprStmt expr ty)
633 = zonkLExpr env expr `thenM` \ new_expr ->
634 zonkTcTypeToType env ty `thenM` \ new_ty ->
635 returnM (env, ExprStmt new_expr new_ty)
637 zonkStmt env (LetStmt binds)
638 = zonkNestedBinds env binds `thenM` \ (env1, new_binds) ->
639 returnM (env1, LetStmt new_binds)
641 zonkStmt env (BindStmt pat expr)
642 = do { new_expr <- zonkLExpr env expr
643 ; (env1, new_pat) <- zonkPat env pat
644 ; return (env1, BindStmt new_pat new_expr) }
647 -------------------------------------------------------------------------
648 zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id)
650 zonkRbinds env rbinds
651 = mappM zonk_rbind rbinds
653 zonk_rbind (field, expr)
654 = zonkLExpr env expr `thenM` \ new_expr ->
655 returnM (fmap (zonkIdOcc env) field, new_expr)
657 -------------------------------------------------------------------------
658 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
659 mapIPNameTc f (Dupable n) = f n `thenM` \ r -> returnM (Dupable r)
660 mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r)
664 %************************************************************************
666 \subsection[BackSubst-Pats]{Patterns}
668 %************************************************************************
671 zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
672 -- Extend the environment as we go, because it's possible for one
673 -- pattern to bind something that is used in another (inside or
675 zonkPat env pat = wrapLocSndM (zonk_pat env) pat
677 zonk_pat env (ParPat p)
678 = do { (env', p') <- zonkPat env p
679 ; return (env', ParPat p') }
681 zonk_pat env (WildPat ty)
682 = do { ty' <- zonkTcTypeToType env ty
683 ; return (env, WildPat ty') }
685 zonk_pat env (VarPat v)
686 = do { v' <- zonkIdBndr env v
687 ; return (extendZonkEnv1 env v', VarPat v') }
689 zonk_pat env (VarPatOut v binds)
690 = do { v' <- zonkIdBndr env v
691 ; (env', binds') <- zonkRecMonoBinds (extendZonkEnv1 env v') binds
692 ; returnM (env', VarPatOut v' binds') }
694 zonk_pat env (LazyPat pat)
695 = do { (env', pat') <- zonkPat env pat
696 ; return (env', LazyPat pat') }
698 zonk_pat env (AsPat (L loc v) pat)
699 = do { v' <- zonkIdBndr env v
700 ; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
701 ; return (env', AsPat (L loc v') pat') }
703 zonk_pat env (ListPat pats ty)
704 = do { ty' <- zonkTcTypeToType env ty
705 ; (env', pats') <- zonkPats env pats
706 ; return (env', ListPat pats' ty') }
708 zonk_pat env (PArrPat pats ty)
709 = do { ty' <- zonkTcTypeToType env ty
710 ; (env', pats') <- zonkPats env pats
711 ; return (env', PArrPat pats' ty') }
713 zonk_pat env (TuplePat pats boxed)
714 = do { (env', pats') <- zonkPats env pats
715 ; return (env', TuplePat pats' boxed) }
717 zonk_pat env (ConPatOut n tvs dicts binds stuff ty)
718 = ASSERT( all isImmutableTyVar tvs )
719 do { new_ty <- zonkTcTypeToType env ty
720 ; new_dicts <- zonkIdBndrs env dicts
721 ; let env1 = extendZonkEnv env new_dicts
722 ; (env2, new_binds) <- zonkRecMonoBinds env1 binds
723 ; (env', new_stuff) <- zonkConStuff env2 stuff
724 ; returnM (env', ConPatOut n tvs new_dicts new_binds new_stuff new_ty) }
726 zonk_pat env (LitPat lit) = return (env, LitPat lit)
728 zonk_pat env (SigPatOut pat ty)
729 = do { ty' <- zonkTcTypeToType env ty
730 ; (env', pat') <- zonkPat env pat
731 ; return (env', SigPatOut pat' ty') }
733 zonk_pat env (NPatOut lit ty expr)
734 = do { ty' <- zonkTcTypeToType env ty
735 ; expr' <- zonkExpr env expr
736 ; return (env, NPatOut lit ty' expr') }
738 zonk_pat env (NPlusKPatOut (L loc n) k e1 e2)
739 = do { n' <- zonkIdBndr env n
740 ; e1' <- zonkExpr env e1
741 ; e2' <- zonkExpr env e2
742 ; return (extendZonkEnv1 env n', NPlusKPatOut (L loc n') k e1' e2') }
744 zonk_pat env (DictPat ds ms)
745 = do { ds' <- zonkIdBndrs env ds
746 ; ms' <- zonkIdBndrs env ms
747 ; return (extendZonkEnv env (ds' ++ ms'), DictPat ds' ms') }
749 ---------------------------
750 zonkConStuff env (PrefixCon pats)
751 = do { (env', pats') <- zonkPats env pats
752 ; return (env', PrefixCon pats') }
754 zonkConStuff env (InfixCon p1 p2)
755 = do { (env1, p1') <- zonkPat env p1
756 ; (env', p2') <- zonkPat env1 p2
757 ; return (env', InfixCon p1' p2') }
759 zonkConStuff env (RecCon rpats)
760 = do { (env', pats') <- zonkPats env pats
761 ; returnM (env', RecCon (fields `zip` pats')) }
763 (fields, pats) = unzip rpats
765 ---------------------------
766 zonkPats env [] = return (env, [])
767 zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
768 ; (env', pats') <- zonkPats env1 pats
769 ; return (env', pat':pats') }
772 %************************************************************************
774 \subsection[BackSubst-Foreign]{Foreign exports}
776 %************************************************************************
780 zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
781 zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
783 zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
784 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec) =
785 returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec isDeprec)
786 zonkForeignExport env for_imp
787 = returnM for_imp -- Foreign imports don't need zonking
791 zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
792 zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
794 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
795 zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs rhs)
796 = mappM zonk_bndr vars `thenM` \ new_bndrs ->
797 newMutVar emptyVarSet `thenM` \ unbound_tv_set ->
799 env_rhs = extendZonkEnv env [id | b <- new_bndrs, let id = unLoc b, isId id]
800 -- Type variables don't need an envt
801 -- They are bound through the mutable mechanism
803 env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
804 -- We need to gather the type variables mentioned on the LHS so we can
805 -- quantify over them. Example:
811 -- {-# RULES "myrule" foo C = 1 #-}
813 -- After type checking the LHS becomes (foo a (C a))
814 -- and we do not want to zap the unbound tyvar 'a' to (), because
815 -- that limits the applicability of the rule. Instead, we
816 -- want to quantify over it!
818 -- It's easiest to find the free tyvars here. Attempts to do so earlier
819 -- are tiresome, because (a) the data type is big and (b) finding the
820 -- free type vars of an expression is necessarily monadic operation.
821 -- (consider /\a -> f @ b, where b is side-effected to a)
823 zonkLExpr env_lhs lhs `thenM` \ new_lhs ->
824 zonkLExpr env_rhs rhs `thenM` \ new_rhs ->
826 readMutVar unbound_tv_set `thenM` \ unbound_tvs ->
828 final_bndrs :: [Located Var]
829 final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs
831 returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs new_rhs)
832 -- I hate this map RuleBndr stuff
834 zonk_bndr (RuleBndr v)
835 | isId (unLoc v) = wrapLocM (zonkIdBndr env) v
836 | otherwise = ASSERT( isImmutableTyVar (unLoc v) )
841 %************************************************************************
843 \subsection[BackSubst-Foreign]{Foreign exports}
845 %************************************************************************
848 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
849 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
851 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
852 -- This variant collects unbound type variables in a mutable variable
853 zonkTypeCollecting unbound_tv_set
854 = zonkType zonk_unbound_tyvar True
856 zonk_unbound_tyvar tv
857 = zonkQuantifiedTyVar tv `thenM` \ tv' ->
858 readMutVar unbound_tv_set `thenM` \ tv_set ->
859 writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_`
860 return (mkTyVarTy tv')
862 zonkTypeZapping :: TcType -> TcM Type
863 -- This variant is used for everything except the LHS of rules
864 -- It zaps unbound type variables to (), or some other arbitrary type
866 = zonkType zonk_unbound_tyvar True ty
868 -- Zonk a mutable but unbound type variable to an arbitrary type
869 -- We know it's unbound even though we don't carry an environment,
870 -- because at the binding site for a type variable we bind the
871 -- mutable tyvar to a fresh immutable one. So the mutable store
872 -- plays the role of an environment. If we come across a mutable
873 -- type variable that isn't so bound, it must be completely free.
874 zonk_unbound_tyvar tv = do { putMetaTyVar tv ty; return ty }
876 ty = mkArbitraryType tv
879 -- When the type checker finds a type variable with no binding,
880 -- which means it can be instantiated with an arbitrary type, it
881 -- usually instantiates it to Void. Eg.
885 -- length Void (Nil Void)
887 -- But in really obscure programs, the type variable might have
888 -- a kind other than *, so we need to invent a suitably-kinded type.
892 -- List for kind *->*
893 -- Tuple for kind *->...*->*
895 -- which deals with most cases. (Previously, it only dealt with
898 -- In the other cases, it just makes up a TyCon with a suitable
899 -- kind. If this gets into an interface file, anyone reading that
900 -- file won't understand it. This is fixable (by making the client
901 -- of the interface file make up a TyCon too) but it is tiresome and
902 -- never happens, so I am leaving it
904 mkArbitraryType :: TcTyVar -> Type
905 -- Make up an arbitrary type whose kind is the same as the tyvar.
906 -- We'll use this to instantiate the (unbound) tyvar.
908 | liftedTypeKind `isSubKind` kind = voidTy -- The vastly common case
909 | otherwise = mkTyConApp tycon []
912 (args,res) = splitKindFunTys kind
914 tycon | kind == tyConKind listTyCon -- *->*
915 = listTyCon -- No tuples this size
917 | all isLiftedTypeKind args && isLiftedTypeKind res
918 = tupleTyCon Boxed (length args) -- *-> ... ->*->*
921 = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
922 mkPrimTyCon tc_name kind 0 [] VoidRep
923 -- Same name as the tyvar, apart from making it start with a colon (sigh)
924 -- I dread to think what will happen if this gets out into an
925 -- interface file. Catastrophe likely. Major sigh.
927 tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc