2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 \section[TcHsSyn]{Specialisations of the @HsSyn@ syntax for the typechecker}
6 This module is an extension of @HsSyn@ syntax, for use in the type
11 mkHsTyApp, mkHsDictApp, mkHsConApp,
12 mkHsTyLam, mkHsDictLam, mkHsDictLet, mkHsApp,
13 hsLitType, hsPatType, mkHsAppTy, mkSimpleHsAlt,
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 zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
256 zonkLocalBinds env EmptyLocalBinds
257 = return (env, EmptyLocalBinds)
259 zonkLocalBinds env (HsValBinds binds)
260 = do { (env1, new_binds) <- zonkValBinds env binds
261 ; return (env1, HsValBinds new_binds) }
263 zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds))
264 = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds ->
266 env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
268 zonkRecMonoBinds env1 dict_binds `thenM` \ (env2, new_dict_binds) ->
269 returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
271 zonk_ip_bind (IPBind n e)
272 = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' ->
273 zonkLExpr env e `thenM` \ e' ->
274 returnM (IPBind n' e')
277 ---------------------------------------------
278 zonkValBinds :: ZonkEnv -> HsValBinds TcId -> TcM (ZonkEnv, HsValBinds Id)
279 zonkValBinds env bs@(ValBindsIn _ _)
280 = panic "zonkValBinds" -- Not in typechecker output
281 zonkValBinds env (ValBindsOut binds)
282 = do { (env1, new_binds) <- go env binds
283 ; return (env1, ValBindsOut new_binds) }
285 go env [] = return (env, [])
286 go env ((r,b):bs) = do { (env1, b') <- zonkRecMonoBinds env b
287 ; (env2, bs') <- go env1 bs
288 ; return (env2, (r,b'):bs') }
290 ---------------------------------------------
291 zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
292 zonkRecMonoBinds env binds
293 = fixM (\ ~(_, new_binds) -> do
294 { let env1 = extendZonkEnv env (collectHsBindBinders new_binds)
295 ; binds' <- zonkMonoBinds env1 binds
296 ; return (env1, binds') })
298 ---------------------------------------------
299 zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
300 zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds
302 zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
303 zonk_bind env (PatBind pat grhss ty fvs)
304 = do { (_env, new_pat) <- zonkPat env pat -- Env already extended
305 ; new_grhss <- zonkGRHSs env grhss
306 ; new_ty <- zonkTcTypeToType env ty
307 ; return (PatBind new_pat new_grhss new_ty fvs) }
309 zonk_bind env (VarBind var expr)
310 = zonkIdBndr env var `thenM` \ new_var ->
311 zonkLExpr env expr `thenM` \ new_expr ->
312 returnM (VarBind new_var new_expr)
314 zonk_bind env (FunBind var inf ms fvs)
315 = wrapLocM (zonkIdBndr env) var `thenM` \ new_var ->
316 zonkMatchGroup env ms `thenM` \ new_ms ->
317 returnM (FunBind new_var inf new_ms fvs)
319 zonk_bind env (AbsBinds tyvars dicts exports val_binds)
320 = ASSERT( all isImmutableTyVar tyvars )
321 zonkIdBndrs env dicts `thenM` \ new_dicts ->
322 fixM (\ ~(new_val_binds, _) ->
324 env1 = extendZonkEnv env new_dicts
325 env2 = extendZonkEnv env1 (collectHsBindBinders new_val_binds)
327 zonkMonoBinds env2 val_binds `thenM` \ new_val_binds ->
328 mappM (zonkExport env2) exports `thenM` \ new_exports ->
329 returnM (new_val_binds, new_exports)
330 ) `thenM` \ (new_val_bind, new_exports) ->
331 returnM (AbsBinds tyvars new_dicts new_exports new_val_bind)
333 zonkExport env (tyvars, global, local, prags)
334 = zonkTcTyVars tyvars `thenM` \ tys ->
336 new_tyvars = map (tcGetTyVar "zonkExport") tys
337 -- This isn't the binding occurrence of these tyvars
338 -- but they should *be* tyvars. Hence tcGetTyVar.
340 zonkIdBndr env global `thenM` \ new_global ->
341 mapM zonk_prag prags `thenM` \ new_prags ->
342 returnM (new_tyvars, new_global, zonkIdOcc env local, new_prags)
343 zonk_prag prag@(InlinePrag _ _) = return prag
344 zonk_prag (SpecPrag expr ty ds) = do { expr' <- zonkExpr env expr
345 ; ty' <- zonkTcTypeToType env ty
346 ; let ds' = zonkIdOccs env ds
347 ; return (SpecPrag expr' ty' ds') }
350 %************************************************************************
352 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
354 %************************************************************************
357 zonkMatchGroup :: ZonkEnv -> MatchGroup TcId-> TcM (MatchGroup Id)
358 zonkMatchGroup env (MatchGroup ms ty)
359 = do { ms' <- mapM (zonkMatch env) ms
360 ; ty' <- zonkTcTypeToType env ty
361 ; return (MatchGroup ms' ty') }
363 zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id)
364 zonkMatch env (L loc (Match pats _ grhss))
365 = do { (env1, new_pats) <- zonkPats env pats
366 ; new_grhss <- zonkGRHSs env1 grhss
367 ; return (L loc (Match new_pats Nothing new_grhss)) }
369 -------------------------------------------------------------------------
370 zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id)
372 zonkGRHSs env (GRHSs grhss binds)
373 = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) ->
375 zonk_grhs (GRHS guarded rhs)
376 = zonkStmts new_env guarded `thenM` \ (env2, new_guarded) ->
377 zonkLExpr env2 rhs `thenM` \ new_rhs ->
378 returnM (GRHS new_guarded new_rhs)
380 mappM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss ->
381 returnM (GRHSs new_grhss new_binds)
384 %************************************************************************
386 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
388 %************************************************************************
391 zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
392 zonkLExpr :: ZonkEnv -> LHsExpr TcId -> TcM (LHsExpr Id)
393 zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id)
395 zonkLExprs env exprs = mappM (zonkLExpr env) exprs
396 zonkLExpr env expr = wrapLocM (zonkExpr env) expr
398 zonkExpr env (HsVar id)
399 = returnM (HsVar (zonkIdOcc env id))
401 zonkExpr env (HsIPVar id)
402 = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
404 zonkExpr env (HsLit (HsRat f ty))
405 = zonkTcTypeToType env ty `thenM` \ new_ty ->
406 returnM (HsLit (HsRat f new_ty))
408 zonkExpr env (HsLit lit)
409 = returnM (HsLit lit)
411 zonkExpr env (HsOverLit lit)
412 = do { lit' <- zonkOverLit env lit
413 ; return (HsOverLit lit') }
415 zonkExpr env (HsLam matches)
416 = zonkMatchGroup env matches `thenM` \ new_matches ->
417 returnM (HsLam new_matches)
419 zonkExpr env (HsApp e1 e2)
420 = zonkLExpr env e1 `thenM` \ new_e1 ->
421 zonkLExpr env e2 `thenM` \ new_e2 ->
422 returnM (HsApp new_e1 new_e2)
424 zonkExpr env (HsBracketOut body bs)
425 = mappM zonk_b bs `thenM` \ bs' ->
426 returnM (HsBracketOut body bs')
428 zonk_b (n,e) = zonkLExpr env e `thenM` \ e' ->
431 zonkExpr env (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
432 returnM (HsSpliceE s)
434 zonkExpr env (OpApp e1 op fixity e2)
435 = zonkLExpr env e1 `thenM` \ new_e1 ->
436 zonkLExpr env op `thenM` \ new_op ->
437 zonkLExpr env e2 `thenM` \ new_e2 ->
438 returnM (OpApp new_e1 new_op fixity new_e2)
440 zonkExpr env (NegApp expr op)
441 = zonkLExpr env expr `thenM` \ new_expr ->
442 zonkExpr env op `thenM` \ new_op ->
443 returnM (NegApp new_expr new_op)
445 zonkExpr env (HsPar e)
446 = zonkLExpr env e `thenM` \new_e ->
447 returnM (HsPar new_e)
449 zonkExpr env (SectionL expr op)
450 = zonkLExpr env expr `thenM` \ new_expr ->
451 zonkLExpr env op `thenM` \ new_op ->
452 returnM (SectionL new_expr new_op)
454 zonkExpr env (SectionR op expr)
455 = zonkLExpr env op `thenM` \ new_op ->
456 zonkLExpr env expr `thenM` \ new_expr ->
457 returnM (SectionR new_op new_expr)
459 zonkExpr env (HsCase expr ms)
460 = zonkLExpr env expr `thenM` \ new_expr ->
461 zonkMatchGroup env ms `thenM` \ new_ms ->
462 returnM (HsCase new_expr new_ms)
464 zonkExpr env (HsIf e1 e2 e3)
465 = zonkLExpr env e1 `thenM` \ new_e1 ->
466 zonkLExpr env e2 `thenM` \ new_e2 ->
467 zonkLExpr env e3 `thenM` \ new_e3 ->
468 returnM (HsIf new_e1 new_e2 new_e3)
470 zonkExpr env (HsLet binds expr)
471 = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) ->
472 zonkLExpr new_env expr `thenM` \ new_expr ->
473 returnM (HsLet new_binds new_expr)
475 zonkExpr env (HsDo do_or_lc stmts body ty)
476 = zonkStmts env stmts `thenM` \ (new_env, new_stmts) ->
477 zonkLExpr new_env body `thenM` \ new_body ->
478 zonkTcTypeToType env ty `thenM` \ new_ty ->
479 returnM (HsDo (zonkDo env do_or_lc)
480 new_stmts new_body new_ty)
482 zonkExpr env (ExplicitList ty exprs)
483 = zonkTcTypeToType env ty `thenM` \ new_ty ->
484 zonkLExprs env exprs `thenM` \ new_exprs ->
485 returnM (ExplicitList new_ty new_exprs)
487 zonkExpr env (ExplicitPArr ty exprs)
488 = zonkTcTypeToType env ty `thenM` \ new_ty ->
489 zonkLExprs env exprs `thenM` \ new_exprs ->
490 returnM (ExplicitPArr new_ty new_exprs)
492 zonkExpr env (ExplicitTuple exprs boxed)
493 = zonkLExprs env exprs `thenM` \ new_exprs ->
494 returnM (ExplicitTuple new_exprs boxed)
496 zonkExpr env (RecordCon data_con con_expr rbinds)
497 = zonkExpr env con_expr `thenM` \ new_con_expr ->
498 zonkRbinds env rbinds `thenM` \ new_rbinds ->
499 returnM (RecordCon data_con new_con_expr new_rbinds)
501 zonkExpr env (RecordUpd expr rbinds in_ty out_ty)
502 = zonkLExpr env expr `thenM` \ new_expr ->
503 zonkTcTypeToType env in_ty `thenM` \ new_in_ty ->
504 zonkTcTypeToType env out_ty `thenM` \ new_out_ty ->
505 zonkRbinds env rbinds `thenM` \ new_rbinds ->
506 returnM (RecordUpd new_expr new_rbinds new_in_ty new_out_ty)
508 zonkExpr env (ExprWithTySigOut e ty)
509 = do { e' <- zonkLExpr env e
510 ; return (ExprWithTySigOut e' ty) }
512 zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
514 zonkExpr env (ArithSeq expr info)
515 = zonkExpr env expr `thenM` \ new_expr ->
516 zonkArithSeq env info `thenM` \ new_info ->
517 returnM (ArithSeq new_expr new_info)
519 zonkExpr env (PArrSeq expr info)
520 = zonkExpr env expr `thenM` \ new_expr ->
521 zonkArithSeq env info `thenM` \ new_info ->
522 returnM (PArrSeq new_expr new_info)
524 zonkExpr env (HsSCC lbl expr)
525 = zonkLExpr env expr `thenM` \ new_expr ->
526 returnM (HsSCC lbl new_expr)
528 -- hdaume: core annotations
529 zonkExpr env (HsCoreAnn lbl expr)
530 = zonkLExpr env expr `thenM` \ new_expr ->
531 returnM (HsCoreAnn lbl new_expr)
533 zonkExpr env (TyLam tyvars expr)
534 = ASSERT( all isImmutableTyVar tyvars )
535 zonkLExpr env expr `thenM` \ new_expr ->
536 returnM (TyLam tyvars new_expr)
538 zonkExpr env (TyApp expr tys)
539 = zonkLExpr env expr `thenM` \ new_expr ->
540 zonkTcTypeToTypes env tys `thenM` \ new_tys ->
541 returnM (TyApp new_expr new_tys)
543 zonkExpr env (DictLam dicts expr)
544 = zonkIdBndrs env dicts `thenM` \ new_dicts ->
546 env1 = extendZonkEnv env new_dicts
548 zonkLExpr env1 expr `thenM` \ new_expr ->
549 returnM (DictLam new_dicts new_expr)
551 zonkExpr env (DictApp expr dicts)
552 = zonkLExpr env expr `thenM` \ new_expr ->
553 returnM (DictApp new_expr (zonkIdOccs env dicts))
555 -- arrow notation extensions
556 zonkExpr env (HsProc pat body)
557 = do { (env1, new_pat) <- zonkPat env pat
558 ; new_body <- zonkCmdTop env1 body
559 ; return (HsProc new_pat new_body) }
561 zonkExpr env (HsArrApp e1 e2 ty ho rl)
562 = zonkLExpr env e1 `thenM` \ new_e1 ->
563 zonkLExpr env e2 `thenM` \ new_e2 ->
564 zonkTcTypeToType env ty `thenM` \ new_ty ->
565 returnM (HsArrApp new_e1 new_e2 new_ty ho rl)
567 zonkExpr env (HsArrForm op fixity args)
568 = zonkLExpr env op `thenM` \ new_op ->
569 mappM (zonkCmdTop env) args `thenM` \ new_args ->
570 returnM (HsArrForm new_op fixity new_args)
572 zonkExpr env other = pprPanic "zonkExpr" (ppr other)
574 zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
575 zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
577 zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
578 = zonkLExpr env cmd `thenM` \ new_cmd ->
579 zonkTcTypeToTypes env stack_tys `thenM` \ new_stack_tys ->
580 zonkTcTypeToType env ty `thenM` \ new_ty ->
581 mapSndM (zonkExpr env) ids `thenM` \ new_ids ->
582 returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
584 -------------------------------------------------------------------------
585 zonkDo :: ZonkEnv -> HsStmtContext Name -> HsStmtContext Name
586 -- Only used for 'do', so the only Ids are in a MDoExpr table
587 zonkDo env (MDoExpr tbl) = MDoExpr (mapSnd (zonkIdOcc env) tbl)
588 zonkDo env do_or_lc = do_or_lc
590 -------------------------------------------------------------------------
591 zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
592 zonkOverLit env (HsIntegral i e)
593 = do { e' <- zonkExpr env e; return (HsIntegral i e') }
594 zonkOverLit env (HsFractional r e)
595 = do { e' <- zonkExpr env e; return (HsFractional r e') }
597 -------------------------------------------------------------------------
598 zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
600 zonkArithSeq env (From e)
601 = zonkLExpr env e `thenM` \ new_e ->
604 zonkArithSeq env (FromThen e1 e2)
605 = zonkLExpr env e1 `thenM` \ new_e1 ->
606 zonkLExpr env e2 `thenM` \ new_e2 ->
607 returnM (FromThen new_e1 new_e2)
609 zonkArithSeq env (FromTo e1 e2)
610 = zonkLExpr env e1 `thenM` \ new_e1 ->
611 zonkLExpr env e2 `thenM` \ new_e2 ->
612 returnM (FromTo new_e1 new_e2)
614 zonkArithSeq env (FromThenTo e1 e2 e3)
615 = zonkLExpr env e1 `thenM` \ new_e1 ->
616 zonkLExpr env e2 `thenM` \ new_e2 ->
617 zonkLExpr env e3 `thenM` \ new_e3 ->
618 returnM (FromThenTo new_e1 new_e2 new_e3)
621 -------------------------------------------------------------------------
622 zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id])
623 zonkStmts env [] = return (env, [])
624 zonkStmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s
625 ; (env2, ss') <- zonkStmts env1 ss
626 ; return (env2, s' : ss') }
628 zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
629 zonkStmt env (ParStmt stmts_w_bndrs)
630 = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs ->
632 new_binders = concat (map snd new_stmts_w_bndrs)
633 env1 = extendZonkEnv env new_binders
635 return (env1, ParStmt new_stmts_w_bndrs)
637 zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) ->
638 returnM (new_stmts, zonkIdOccs env1 bndrs)
640 zonkStmt env (RecStmt segStmts lvs rvs rets binds)
641 = zonkIdBndrs env rvs `thenM` \ new_rvs ->
643 env1 = extendZonkEnv env new_rvs
645 zonkStmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
646 -- Zonk the ret-expressions in an envt that
647 -- has the polymorphic bindings in the envt
648 mapM (zonkExpr env2) rets `thenM` \ new_rets ->
650 new_lvs = zonkIdOccs env2 lvs
651 env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
653 zonkRecMonoBinds env3 binds `thenM` \ (env4, new_binds) ->
654 returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets new_binds)
656 zonkStmt env (ExprStmt expr then_op ty)
657 = zonkLExpr env expr `thenM` \ new_expr ->
658 zonkExpr env then_op `thenM` \ new_then ->
659 zonkTcTypeToType env ty `thenM` \ new_ty ->
660 returnM (env, ExprStmt new_expr new_then new_ty)
662 zonkStmt env (LetStmt binds)
663 = zonkLocalBinds env binds `thenM` \ (env1, new_binds) ->
664 returnM (env1, LetStmt new_binds)
666 zonkStmt env (BindStmt pat expr bind_op fail_op)
667 = do { new_expr <- zonkLExpr env expr
668 ; (env1, new_pat) <- zonkPat env pat
669 ; new_bind <- zonkExpr env bind_op
670 ; new_fail <- zonkExpr env fail_op
671 ; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
674 -------------------------------------------------------------------------
675 zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id)
677 zonkRbinds env rbinds
678 = mappM zonk_rbind rbinds
680 zonk_rbind (field, expr)
681 = zonkLExpr env expr `thenM` \ new_expr ->
682 returnM (fmap (zonkIdOcc env) field, new_expr)
684 -------------------------------------------------------------------------
685 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
686 mapIPNameTc f (Dupable n) = f n `thenM` \ r -> returnM (Dupable r)
687 mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r)
691 %************************************************************************
693 \subsection[BackSubst-Pats]{Patterns}
695 %************************************************************************
698 zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
699 -- Extend the environment as we go, because it's possible for one
700 -- pattern to bind something that is used in another (inside or
702 zonkPat env pat = wrapLocSndM (zonk_pat env) pat
704 zonk_pat env (ParPat p)
705 = do { (env', p') <- zonkPat env p
706 ; return (env', ParPat p') }
708 zonk_pat env (WildPat ty)
709 = do { ty' <- zonkTcTypeToType env ty
710 ; return (env, WildPat ty') }
712 zonk_pat env (VarPat v)
713 = do { v' <- zonkIdBndr env v
714 ; return (extendZonkEnv1 env v', VarPat v') }
716 zonk_pat env (VarPatOut v binds)
717 = do { v' <- zonkIdBndr env v
718 ; (env', binds') <- zonkRecMonoBinds (extendZonkEnv1 env v') binds
719 ; returnM (env', VarPatOut v' binds') }
721 zonk_pat env (LazyPat pat)
722 = do { (env', pat') <- zonkPat env pat
723 ; return (env', LazyPat pat') }
725 zonk_pat env (AsPat (L loc v) pat)
726 = do { v' <- zonkIdBndr env v
727 ; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
728 ; return (env', AsPat (L loc v') pat') }
730 zonk_pat env (ListPat pats ty)
731 = do { ty' <- zonkTcTypeToType env ty
732 ; (env', pats') <- zonkPats env pats
733 ; return (env', ListPat pats' ty') }
735 zonk_pat env (PArrPat pats ty)
736 = do { ty' <- zonkTcTypeToType env ty
737 ; (env', pats') <- zonkPats env pats
738 ; return (env', PArrPat pats' ty') }
740 zonk_pat env (TuplePat pats boxed)
741 = do { (env', pats') <- zonkPats env pats
742 ; return (env', TuplePat pats' boxed) }
744 zonk_pat env (ConPatOut n tvs dicts binds stuff ty)
745 = ASSERT( all isImmutableTyVar tvs )
746 do { new_ty <- zonkTcTypeToType env ty
747 ; new_dicts <- zonkIdBndrs env dicts
748 ; let env1 = extendZonkEnv env new_dicts
749 ; (env2, new_binds) <- zonkRecMonoBinds env1 binds
750 ; (env', new_stuff) <- zonkConStuff env2 stuff
751 ; returnM (env', ConPatOut n tvs new_dicts new_binds new_stuff new_ty) }
753 zonk_pat env (LitPat lit) = return (env, LitPat lit)
755 zonk_pat env (SigPatOut pat ty)
756 = do { ty' <- zonkTcTypeToType env ty
757 ; (env', pat') <- zonkPat env pat
758 ; return (env', SigPatOut pat' ty') }
760 zonk_pat env (NPat lit mb_neg eq_expr ty)
761 = do { lit' <- zonkOverLit env lit
762 ; mb_neg' <- case mb_neg of
763 Nothing -> return Nothing
764 Just neg -> do { neg' <- zonkExpr env neg
765 ; return (Just neg') }
766 ; eq_expr' <- zonkExpr env eq_expr
767 ; ty' <- zonkTcTypeToType env ty
768 ; return (env, NPat lit' mb_neg' eq_expr' ty') }
770 zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
771 = do { n' <- zonkIdBndr env n
772 ; lit' <- zonkOverLit env lit
773 ; e1' <- zonkExpr env e1
774 ; e2' <- zonkExpr env e2
775 ; return (extendZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
777 zonk_pat env (DictPat ds ms)
778 = do { ds' <- zonkIdBndrs env ds
779 ; ms' <- zonkIdBndrs env ms
780 ; return (extendZonkEnv env (ds' ++ ms'), DictPat ds' ms') }
782 ---------------------------
783 zonkConStuff env (PrefixCon pats)
784 = do { (env', pats') <- zonkPats env pats
785 ; return (env', PrefixCon pats') }
787 zonkConStuff env (InfixCon p1 p2)
788 = do { (env1, p1') <- zonkPat env p1
789 ; (env', p2') <- zonkPat env1 p2
790 ; return (env', InfixCon p1' p2') }
792 zonkConStuff env (RecCon rpats)
793 = do { (env', pats') <- zonkPats env pats
794 ; returnM (env', RecCon (fields `zip` pats')) }
796 (fields, pats) = unzip rpats
798 ---------------------------
799 zonkPats env [] = return (env, [])
800 zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
801 ; (env', pats') <- zonkPats env1 pats
802 ; return (env', pat':pats') }
805 %************************************************************************
807 \subsection[BackSubst-Foreign]{Foreign exports}
809 %************************************************************************
813 zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
814 zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
816 zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
817 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec) =
818 returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec isDeprec)
819 zonkForeignExport env for_imp
820 = returnM for_imp -- Foreign imports don't need zonking
824 zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
825 zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
827 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
828 zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs rhs)
829 = mappM zonk_bndr vars `thenM` \ new_bndrs ->
830 newMutVar emptyVarSet `thenM` \ unbound_tv_set ->
832 env_rhs = extendZonkEnv env [id | b <- new_bndrs, let id = unLoc b, isId id]
833 -- Type variables don't need an envt
834 -- They are bound through the mutable mechanism
836 env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
837 -- We need to gather the type variables mentioned on the LHS so we can
838 -- quantify over them. Example:
844 -- {-# RULES "myrule" foo C = 1 #-}
846 -- After type checking the LHS becomes (foo a (C a))
847 -- and we do not want to zap the unbound tyvar 'a' to (), because
848 -- that limits the applicability of the rule. Instead, we
849 -- want to quantify over it!
851 -- It's easiest to find the free tyvars here. Attempts to do so earlier
852 -- are tiresome, because (a) the data type is big and (b) finding the
853 -- free type vars of an expression is necessarily monadic operation.
854 -- (consider /\a -> f @ b, where b is side-effected to a)
856 zonkLExpr env_lhs lhs `thenM` \ new_lhs ->
857 zonkLExpr env_rhs rhs `thenM` \ new_rhs ->
859 readMutVar unbound_tv_set `thenM` \ unbound_tvs ->
861 final_bndrs :: [Located Var]
862 final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs
864 returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs new_rhs)
865 -- I hate this map RuleBndr stuff
867 zonk_bndr (RuleBndr v)
868 | isId (unLoc v) = wrapLocM (zonkIdBndr env) v
869 | otherwise = ASSERT( isImmutableTyVar (unLoc v) )
874 %************************************************************************
876 \subsection[BackSubst-Foreign]{Foreign exports}
878 %************************************************************************
881 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
882 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
884 zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
885 zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
887 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
888 -- This variant collects unbound type variables in a mutable variable
889 zonkTypeCollecting unbound_tv_set
890 = zonkType zonk_unbound_tyvar True
892 zonk_unbound_tyvar tv
893 = zonkQuantifiedTyVar tv `thenM` \ tv' ->
894 readMutVar unbound_tv_set `thenM` \ tv_set ->
895 writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_`
896 return (mkTyVarTy tv')
898 zonkTypeZapping :: TcType -> TcM Type
899 -- This variant is used for everything except the LHS of rules
900 -- It zaps unbound type variables to (), or some other arbitrary type
902 = zonkType zonk_unbound_tyvar True ty
904 -- Zonk a mutable but unbound type variable to an arbitrary type
905 -- We know it's unbound even though we don't carry an environment,
906 -- because at the binding site for a type variable we bind the
907 -- mutable tyvar to a fresh immutable one. So the mutable store
908 -- plays the role of an environment. If we come across a mutable
909 -- type variable that isn't so bound, it must be completely free.
910 zonk_unbound_tyvar tv = do { putMetaTyVar tv ty; return ty }
912 ty = mkArbitraryType tv
915 -- When the type checker finds a type variable with no binding,
916 -- which means it can be instantiated with an arbitrary type, it
917 -- usually instantiates it to Void. Eg.
921 -- length Void (Nil Void)
923 -- But in really obscure programs, the type variable might have
924 -- a kind other than *, so we need to invent a suitably-kinded type.
928 -- List for kind *->*
929 -- Tuple for kind *->...*->*
931 -- which deals with most cases. (Previously, it only dealt with
934 -- In the other cases, it just makes up a TyCon with a suitable
935 -- kind. If this gets into an interface file, anyone reading that
936 -- file won't understand it. This is fixable (by making the client
937 -- of the interface file make up a TyCon too) but it is tiresome and
938 -- never happens, so I am leaving it
940 mkArbitraryType :: TcTyVar -> Type
941 -- Make up an arbitrary type whose kind is the same as the tyvar.
942 -- We'll use this to instantiate the (unbound) tyvar.
944 | liftedTypeKind `isSubKind` kind = voidTy -- The vastly common case
945 | otherwise = mkTyConApp tycon []
948 (args,res) = splitKindFunTys kind
950 tycon | kind == tyConKind listTyCon -- *->*
951 = listTyCon -- No tuples this size
953 | all isLiftedTypeKind args && isLiftedTypeKind res
954 = tupleTyCon Boxed (length args) -- *-> ... ->*->*
957 = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
958 mkPrimTyCon tc_name kind 0 [] VoidRep
959 -- Same name as the tyvar, apart from making it start with a colon (sigh)
960 -- I dread to think what will happen if this gets out into an
961 -- interface file. Catastrophe likely. Major sigh.
963 tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc