2 % (c) The University of Glasgow 2006
3 % (c) The AQUA Project, Glasgow University, 1996-1998
6 TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker
8 This module is an extension of @HsSyn@ syntax, for use in the type
13 mkHsConApp, mkHsDictLet, mkHsApp,
14 hsLitType, hsLPatType, hsPatType,
15 mkHsAppTy, mkSimpleHsAlt,
17 shortCutLit, hsOverLitName,
19 -- re-exported from TcMonad
22 zonkTopDecls, zonkTopExpr, zonkTopLExpr,
26 #include "HsVersions.h"
29 import HsSyn -- oodles of it
55 thenM :: Monad a => a b -> (b -> a c) -> a c
58 returnM :: Monad m => a -> m a
61 mappM :: (Monad m) => (a -> m b) -> [a] -> m [b]
66 %************************************************************************
68 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
70 %************************************************************************
72 Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
73 then something is wrong.
75 hsLPatType :: OutPat Id -> Type
76 hsLPatType (L _ pat) = hsPatType pat
78 hsPatType :: Pat Id -> Type
79 hsPatType (ParPat pat) = hsLPatType pat
80 hsPatType (WildPat ty) = ty
81 hsPatType (VarPat var) = idType var
82 hsPatType (VarPatOut var _) = idType var
83 hsPatType (BangPat pat) = hsLPatType pat
84 hsPatType (LazyPat pat) = hsLPatType pat
85 hsPatType (LitPat lit) = hsLitType lit
86 hsPatType (AsPat var _) = idType (unLoc var)
87 hsPatType (ViewPat _ _ ty) = ty
88 hsPatType (ListPat _ ty) = mkListTy ty
89 hsPatType (PArrPat _ ty) = mkPArrTy ty
90 hsPatType (TuplePat _ _ ty) = ty
91 hsPatType (ConPatOut { pat_ty = ty }) = ty
92 hsPatType (SigPatOut _ ty) = ty
93 hsPatType (NPat lit _ _) = overLitType lit
94 hsPatType (NPlusKPat id _ _ _) = idType (unLoc id)
95 hsPatType (CoPat _ _ ty) = ty
96 hsPatType p = pprPanic "hsPatType" (ppr p)
98 hsLitType :: HsLit -> TcType
99 hsLitType (HsChar _) = charTy
100 hsLitType (HsCharPrim _) = charPrimTy
101 hsLitType (HsString _) = stringTy
102 hsLitType (HsStringPrim _) = addrPrimTy
103 hsLitType (HsInt _) = intTy
104 hsLitType (HsIntPrim _) = intPrimTy
105 hsLitType (HsWordPrim _) = wordPrimTy
106 hsLitType (HsInteger _ ty) = ty
107 hsLitType (HsRat _ ty) = ty
108 hsLitType (HsFloatPrim _) = floatPrimTy
109 hsLitType (HsDoublePrim _) = doublePrimTy
112 Overloaded literals. Here mainly becuase it uses isIntTy etc
115 shortCutLit :: OverLitVal -> TcType -> Maybe (HsExpr TcId)
116 shortCutLit (HsIntegral i) ty
117 | isIntTy ty && inIntRange i = Just (HsLit (HsInt i))
118 | isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i))
119 | isIntegerTy ty = Just (HsLit (HsInteger i ty))
120 | otherwise = shortCutLit (HsFractional (fromInteger i)) ty
121 -- The 'otherwise' case is important
122 -- Consider (3 :: Float). Syntactically it looks like an IntLit,
123 -- so we'll call shortCutIntLit, but of course it's a float
124 -- This can make a big difference for programs with a lot of
125 -- literals, compiled without -O
127 shortCutLit (HsFractional f) ty
128 | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim f))
129 | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f))
130 | otherwise = Nothing
132 shortCutLit (HsIsString s) ty
133 | isStringTy ty = Just (HsLit (HsString s))
134 | otherwise = Nothing
136 mkLit :: DataCon -> HsLit -> HsExpr Id
137 mkLit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
139 ------------------------------
140 hsOverLitName :: OverLitVal -> Name
141 -- Get the canonical 'fromX' name for a particular OverLitVal
142 hsOverLitName (HsIntegral {}) = fromIntegerName
143 hsOverLitName (HsFractional {}) = fromRationalName
144 hsOverLitName (HsIsString {}) = fromStringName
147 %************************************************************************
149 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
151 %************************************************************************
154 -- zonkId is used *during* typechecking just to zonk the Id's type
155 zonkId :: TcId -> TcM TcId
157 = zonkTcType (idType id) `thenM` \ ty' ->
158 returnM (Id.setIdType id ty')
161 The rest of the zonking is done *after* typechecking.
162 The main zonking pass runs over the bindings
164 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
165 b) convert unbound TcTyVar to Void
166 c) convert each TcId to an Id by zonking its type
168 The type variables are converted by binding mutable tyvars to immutable ones
169 and then zonking as normal.
171 The Ids are converted by binding them in the normal Tc envt; that
172 way we maintain sharing; eg an Id is zonked at its binding site and they
173 all occurrences of that Id point to the common zonked copy
175 It's all pretty boring stuff, because HsSyn is such a large type, and
176 the environment manipulation is tiresome.
179 data ZonkEnv = ZonkEnv (TcType -> TcM Type) -- How to zonk a type
180 (VarEnv Var) -- What variables are in scope
181 -- Maps an Id or EvVar to its zonked version; both have the same Name
182 -- Note that all evidence (coercion variables as well as dictionaries)
183 -- are kept in the ZonkEnv
184 -- Only *type* abstraction is done by side effect
185 -- Is only consulted lazily; hence knot-tying
187 emptyZonkEnv :: ZonkEnv
188 emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
190 extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
191 extendZonkEnv (ZonkEnv zonk_ty env) ids
192 = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
194 extendZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
195 extendZonkEnv1 (ZonkEnv zonk_ty env) id
196 = ZonkEnv zonk_ty (extendVarEnv env id id)
198 setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
199 setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
201 zonkEnvIds :: ZonkEnv -> [Id]
202 zonkEnvIds (ZonkEnv _ env) = varEnvElts env
204 zonkIdOcc :: ZonkEnv -> TcId -> Id
205 -- Ids defined in this module should be in the envt;
206 -- ignore others. (Actually, data constructors are also
207 -- not LocalVars, even when locally defined, but that is fine.)
208 -- (Also foreign-imported things aren't currently in the ZonkEnv;
209 -- that's ok because they don't need zonking.)
211 -- Actually, Template Haskell works in 'chunks' of declarations, and
212 -- an earlier chunk won't be in the 'env' that the zonking phase
213 -- carries around. Instead it'll be in the tcg_gbl_env, already fully
214 -- zonked. There's no point in looking it up there (except for error
215 -- checking), and it's not conveniently to hand; hence the simple
216 -- 'orElse' case in the LocalVar branch.
218 -- Even without template splices, in module Main, the checking of
219 -- 'main' is done as a separate chunk.
220 zonkIdOcc (ZonkEnv _zonk_ty env) id
221 | isLocalVar id = lookupVarEnv env id `orElse` id
224 zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
225 zonkIdOccs env ids = map (zonkIdOcc env) ids
227 -- zonkIdBndr is used *after* typechecking to get the Id's type
228 -- to its final form. The TyVarEnv give
229 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
231 = zonkTcTypeToType env (idType id) `thenM` \ ty' ->
232 returnM (Id.setIdType id ty')
234 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
235 zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
237 zonkTopBndrs :: [TcId] -> TcM [Id]
238 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
240 zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
241 zonkEvBndrsX = mapAccumLM zonkEvBndrX
243 zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
244 -- Works for dictionaries and coercions
246 = do { var' <- zonkEvBndr env var
247 ; return (extendZonkEnv1 env var', var') }
249 zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
250 -- Works for dictionaries and coercions
251 -- Does not extend the ZonkEnv
253 = do { ty' <- zonkTcTypeToType env (varType var)
254 ; return (setVarType var ty') }
256 zonkEvVarOcc :: ZonkEnv -> EvVar -> EvVar
257 zonkEvVarOcc env v = zonkIdOcc env v
262 zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
263 zonkTopExpr e = zonkExpr emptyZonkEnv e
265 zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
266 zonkTopLExpr e = zonkLExpr emptyZonkEnv e
268 zonkTopDecls :: Bag EvBind -> LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId]
274 zonkTopDecls ev_binds binds rules fords
275 = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
277 ; (env2, binds') <- zonkRecMonoBinds env1 binds
278 -- Top level is implicitly recursive
279 ; rules' <- zonkRules env2 rules
280 ; fords' <- zonkForeignExports env2 fords
281 ; return (zonkEnvIds env2, ev_binds', binds', fords', rules') }
283 ---------------------------------------------
284 zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
285 zonkLocalBinds env EmptyLocalBinds
286 = return (env, EmptyLocalBinds)
288 zonkLocalBinds env (HsValBinds binds)
289 = do { (env1, new_binds) <- zonkValBinds env binds
290 ; return (env1, HsValBinds new_binds) }
292 zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds))
293 = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds ->
295 env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
297 zonkTcEvBinds env1 dict_binds `thenM` \ (env2, new_dict_binds) ->
298 returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
300 zonk_ip_bind (IPBind n e)
301 = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' ->
302 zonkLExpr env e `thenM` \ e' ->
303 returnM (IPBind n' e')
306 ---------------------------------------------
307 zonkValBinds :: ZonkEnv -> HsValBinds TcId -> TcM (ZonkEnv, HsValBinds Id)
308 zonkValBinds _ (ValBindsIn _ _)
309 = panic "zonkValBinds" -- Not in typechecker output
310 zonkValBinds env (ValBindsOut binds sigs)
311 = do { (env1, new_binds) <- go env binds
312 ; return (env1, ValBindsOut new_binds sigs) }
314 go env [] = return (env, [])
315 go env ((r,b):bs) = do { (env1, b') <- zonkRecMonoBinds env b
316 ; (env2, bs') <- go env1 bs
317 ; return (env2, (r,b'):bs') }
319 ---------------------------------------------
320 zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
321 zonkRecMonoBinds env binds
322 = fixM (\ ~(_, new_binds) -> do
323 { let env1 = extendZonkEnv env (collectHsBindsBinders new_binds)
324 ; binds' <- zonkMonoBinds env1 binds
325 ; return (env1, binds') })
327 ---------------------------------------------
328 zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
329 zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds
331 zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
332 zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
333 = do { (_env, new_pat) <- zonkPat env pat -- Env already extended
334 ; new_grhss <- zonkGRHSs env grhss
335 ; new_ty <- zonkTcTypeToType env ty
336 ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
338 zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
339 = zonkIdBndr env var `thenM` \ new_var ->
340 zonkLExpr env expr `thenM` \ new_expr ->
341 returnM (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl })
343 zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms
344 , fun_co_fn = co_fn })
345 = wrapLocM (zonkIdBndr env) var `thenM` \ new_var ->
346 zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) ->
347 zonkMatchGroup env1 ms `thenM` \ new_ms ->
348 returnM (bind { fun_id = new_var, fun_matches = new_ms
349 , fun_co_fn = new_co_fn })
351 zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs, abs_ev_binds = ev_binds,
352 abs_exports = exports, abs_binds = val_binds })
353 = ASSERT( all isImmutableTyVar tyvars )
354 do { (env1, new_evs) <- zonkEvBndrsX env evs
355 ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds
356 ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
357 do { let env3 = extendZonkEnv env2 (collectHsBindsBinders new_val_binds)
358 ; new_val_binds <- zonkMonoBinds env3 val_binds
359 ; new_exports <- mapM (zonkExport env3) exports
360 ; return (new_val_binds, new_exports) }
361 ; return (AbsBinds { abs_tvs = tyvars, abs_ev_vars = new_evs, abs_ev_binds = new_ev_binds
362 , abs_exports = new_exports, abs_binds = new_val_bind }) }
364 zonkExport env (tyvars, global, local, prags)
365 -- The tyvars are already zonked
366 = zonkIdBndr env global `thenM` \ new_global ->
367 zonkSpecPrags env prags `thenM` \ new_prags ->
368 returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
370 zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
371 zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod
372 zonkSpecPrags env (SpecPrags ps) = do { ps' <- mapM zonk_prag ps
373 ; return (SpecPrags ps') }
375 zonk_prag (L loc (SpecPrag co_fn inl))
376 = do { (_, co_fn') <- zonkCoFn env co_fn
377 ; return (L loc (SpecPrag co_fn' inl)) }
380 %************************************************************************
382 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
384 %************************************************************************
387 zonkMatchGroup :: ZonkEnv -> MatchGroup TcId-> TcM (MatchGroup Id)
388 zonkMatchGroup env (MatchGroup ms ty)
389 = do { ms' <- mapM (zonkMatch env) ms
390 ; ty' <- zonkTcTypeToType env ty
391 ; return (MatchGroup ms' ty') }
393 zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id)
394 zonkMatch env (L loc (Match pats _ grhss))
395 = do { (env1, new_pats) <- zonkPats env pats
396 ; new_grhss <- zonkGRHSs env1 grhss
397 ; return (L loc (Match new_pats Nothing new_grhss)) }
399 -------------------------------------------------------------------------
400 zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id)
402 zonkGRHSs env (GRHSs grhss binds)
403 = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) ->
405 zonk_grhs (GRHS guarded rhs)
406 = zonkStmts new_env guarded `thenM` \ (env2, new_guarded) ->
407 zonkLExpr env2 rhs `thenM` \ new_rhs ->
408 returnM (GRHS new_guarded new_rhs)
410 mappM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss ->
411 returnM (GRHSs new_grhss new_binds)
414 %************************************************************************
416 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
418 %************************************************************************
421 zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
422 zonkLExpr :: ZonkEnv -> LHsExpr TcId -> TcM (LHsExpr Id)
423 zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id)
425 zonkLExprs env exprs = mappM (zonkLExpr env) exprs
426 zonkLExpr env expr = wrapLocM (zonkExpr env) expr
428 zonkExpr env (HsVar id)
429 = returnM (HsVar (zonkIdOcc env id))
431 zonkExpr env (HsIPVar id)
432 = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
434 zonkExpr env (HsLit (HsRat f ty))
435 = zonkTcTypeToType env ty `thenM` \ new_ty ->
436 returnM (HsLit (HsRat f new_ty))
438 zonkExpr _ (HsLit lit)
439 = returnM (HsLit lit)
441 zonkExpr env (HsOverLit lit)
442 = do { lit' <- zonkOverLit env lit
443 ; return (HsOverLit lit') }
445 zonkExpr env (HsLam matches)
446 = zonkMatchGroup env matches `thenM` \ new_matches ->
447 returnM (HsLam new_matches)
449 zonkExpr env (HsApp e1 e2)
450 = zonkLExpr env e1 `thenM` \ new_e1 ->
451 zonkLExpr env e2 `thenM` \ new_e2 ->
452 returnM (HsApp new_e1 new_e2)
454 zonkExpr env (HsBracketOut body bs)
455 = mappM zonk_b bs `thenM` \ bs' ->
456 returnM (HsBracketOut body bs')
458 zonk_b (n,e) = zonkLExpr env e `thenM` \ e' ->
461 zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
462 returnM (HsSpliceE s)
464 zonkExpr env (OpApp e1 op fixity e2)
465 = zonkLExpr env e1 `thenM` \ new_e1 ->
466 zonkLExpr env op `thenM` \ new_op ->
467 zonkLExpr env e2 `thenM` \ new_e2 ->
468 returnM (OpApp new_e1 new_op fixity new_e2)
470 zonkExpr env (NegApp expr op)
471 = zonkLExpr env expr `thenM` \ new_expr ->
472 zonkExpr env op `thenM` \ new_op ->
473 returnM (NegApp new_expr new_op)
475 zonkExpr env (HsPar e)
476 = zonkLExpr env e `thenM` \new_e ->
477 returnM (HsPar new_e)
479 zonkExpr env (SectionL expr op)
480 = zonkLExpr env expr `thenM` \ new_expr ->
481 zonkLExpr env op `thenM` \ new_op ->
482 returnM (SectionL new_expr new_op)
484 zonkExpr env (SectionR op expr)
485 = zonkLExpr env op `thenM` \ new_op ->
486 zonkLExpr env expr `thenM` \ new_expr ->
487 returnM (SectionR new_op new_expr)
489 zonkExpr env (ExplicitTuple tup_args boxed)
490 = do { new_tup_args <- mapM zonk_tup_arg tup_args
491 ; return (ExplicitTuple new_tup_args boxed) }
493 zonk_tup_arg (Present e) = do { e' <- zonkLExpr env e; return (Present e') }
494 zonk_tup_arg (Missing t) = do { t' <- zonkTcTypeToType env t; return (Missing t') }
496 zonkExpr env (HsCase expr ms)
497 = zonkLExpr env expr `thenM` \ new_expr ->
498 zonkMatchGroup env ms `thenM` \ new_ms ->
499 returnM (HsCase new_expr new_ms)
501 zonkExpr env (HsIf e1 e2 e3)
502 = zonkLExpr env e1 `thenM` \ new_e1 ->
503 zonkLExpr env e2 `thenM` \ new_e2 ->
504 zonkLExpr env e3 `thenM` \ new_e3 ->
505 returnM (HsIf new_e1 new_e2 new_e3)
507 zonkExpr env (HsLet binds expr)
508 = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) ->
509 zonkLExpr new_env expr `thenM` \ new_expr ->
510 returnM (HsLet new_binds new_expr)
512 zonkExpr env (HsDo do_or_lc stmts body ty)
513 = zonkStmts env stmts `thenM` \ (new_env, new_stmts) ->
514 zonkLExpr new_env body `thenM` \ new_body ->
515 zonkTcTypeToType env ty `thenM` \ new_ty ->
516 zonkDo env do_or_lc `thenM` \ new_do_or_lc ->
517 returnM (HsDo new_do_or_lc new_stmts new_body new_ty)
519 zonkExpr env (ExplicitList ty exprs)
520 = zonkTcTypeToType env ty `thenM` \ new_ty ->
521 zonkLExprs env exprs `thenM` \ new_exprs ->
522 returnM (ExplicitList new_ty new_exprs)
524 zonkExpr env (ExplicitPArr ty exprs)
525 = zonkTcTypeToType env ty `thenM` \ new_ty ->
526 zonkLExprs env exprs `thenM` \ new_exprs ->
527 returnM (ExplicitPArr new_ty new_exprs)
529 zonkExpr env (RecordCon data_con con_expr rbinds)
530 = do { new_con_expr <- zonkExpr env con_expr
531 ; new_rbinds <- zonkRecFields env rbinds
532 ; return (RecordCon data_con new_con_expr new_rbinds) }
534 zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys)
535 = do { new_expr <- zonkLExpr env expr
536 ; new_in_tys <- mapM (zonkTcTypeToType env) in_tys
537 ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
538 ; new_rbinds <- zonkRecFields env rbinds
539 ; return (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys) }
541 zonkExpr env (ExprWithTySigOut e ty)
542 = do { e' <- zonkLExpr env e
543 ; return (ExprWithTySigOut e' ty) }
545 zonkExpr _ (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
547 zonkExpr env (ArithSeq expr info)
548 = zonkExpr env expr `thenM` \ new_expr ->
549 zonkArithSeq env info `thenM` \ new_info ->
550 returnM (ArithSeq new_expr new_info)
552 zonkExpr env (PArrSeq expr info)
553 = zonkExpr env expr `thenM` \ new_expr ->
554 zonkArithSeq env info `thenM` \ new_info ->
555 returnM (PArrSeq new_expr new_info)
557 zonkExpr env (HsSCC lbl expr)
558 = zonkLExpr env expr `thenM` \ new_expr ->
559 returnM (HsSCC lbl new_expr)
561 zonkExpr env (HsTickPragma info expr)
562 = zonkLExpr env expr `thenM` \ new_expr ->
563 returnM (HsTickPragma info new_expr)
565 -- hdaume: core annotations
566 zonkExpr env (HsCoreAnn lbl expr)
567 = zonkLExpr env expr `thenM` \ new_expr ->
568 returnM (HsCoreAnn lbl new_expr)
570 -- arrow notation extensions
571 zonkExpr env (HsProc pat body)
572 = do { (env1, new_pat) <- zonkPat env pat
573 ; new_body <- zonkCmdTop env1 body
574 ; return (HsProc new_pat new_body) }
576 zonkExpr env (HsArrApp e1 e2 ty ho rl)
577 = zonkLExpr env e1 `thenM` \ new_e1 ->
578 zonkLExpr env e2 `thenM` \ new_e2 ->
579 zonkTcTypeToType env ty `thenM` \ new_ty ->
580 returnM (HsArrApp new_e1 new_e2 new_ty ho rl)
582 zonkExpr env (HsArrForm op fixity args)
583 = zonkLExpr env op `thenM` \ new_op ->
584 mappM (zonkCmdTop env) args `thenM` \ new_args ->
585 returnM (HsArrForm new_op fixity new_args)
587 zonkExpr env (HsWrap co_fn expr)
588 = zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) ->
589 zonkExpr env1 expr `thenM` \ new_expr ->
590 return (HsWrap new_co_fn new_expr)
592 zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
594 zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
595 zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
597 zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id)
598 zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
599 = zonkLExpr env cmd `thenM` \ new_cmd ->
600 zonkTcTypeToTypes env stack_tys `thenM` \ new_stack_tys ->
601 zonkTcTypeToType env ty `thenM` \ new_ty ->
602 mapSndM (zonkExpr env) ids `thenM` \ new_ids ->
603 returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
605 -------------------------------------------------------------------------
606 zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
607 zonkCoFn env WpHole = return (env, WpHole)
608 zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
609 ; (env2, c2') <- zonkCoFn env1 c2
610 ; return (env2, WpCompose c1' c2') }
611 zonkCoFn env (WpCast co) = do { co' <- zonkTcTypeToType env co
612 ; return (env, WpCast co') }
613 zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev
614 ; return (env', WpEvLam ev') }
615 zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg
616 ; return (env, WpEvApp arg') }
617 zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv )
618 return (env, WpTyLam tv)
619 zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty
620 ; return (env, WpTyApp ty') }
621 zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs
622 ; return (env1, WpLet bs') }
624 -------------------------------------------------------------------------
625 zonkDo :: ZonkEnv -> HsStmtContext Name -> TcM (HsStmtContext Name)
626 -- Only used for 'do', so the only Ids are in a MDoExpr table
627 zonkDo env (MDoExpr tbl) = do { tbl' <- mapSndM (zonkExpr env) tbl
628 ; return (MDoExpr tbl') }
629 zonkDo _ do_or_lc = return do_or_lc
631 -------------------------------------------------------------------------
632 zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
633 zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
634 = do { ty' <- zonkTcTypeToType env ty
635 ; e' <- zonkExpr env e
636 ; return (lit { ol_witness = e', ol_type = ty' }) }
638 -------------------------------------------------------------------------
639 zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
641 zonkArithSeq env (From e)
642 = zonkLExpr env e `thenM` \ new_e ->
645 zonkArithSeq env (FromThen e1 e2)
646 = zonkLExpr env e1 `thenM` \ new_e1 ->
647 zonkLExpr env e2 `thenM` \ new_e2 ->
648 returnM (FromThen new_e1 new_e2)
650 zonkArithSeq env (FromTo e1 e2)
651 = zonkLExpr env e1 `thenM` \ new_e1 ->
652 zonkLExpr env e2 `thenM` \ new_e2 ->
653 returnM (FromTo new_e1 new_e2)
655 zonkArithSeq env (FromThenTo e1 e2 e3)
656 = zonkLExpr env e1 `thenM` \ new_e1 ->
657 zonkLExpr env e2 `thenM` \ new_e2 ->
658 zonkLExpr env e3 `thenM` \ new_e3 ->
659 returnM (FromThenTo new_e1 new_e2 new_e3)
662 -------------------------------------------------------------------------
663 zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id])
664 zonkStmts env [] = return (env, [])
665 zonkStmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s
666 ; (env2, ss') <- zonkStmts env1 ss
667 ; return (env2, s' : ss') }
669 zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
670 zonkStmt env (ParStmt stmts_w_bndrs)
671 = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs ->
673 new_binders = concat (map snd new_stmts_w_bndrs)
674 env1 = extendZonkEnv env new_binders
676 return (env1, ParStmt new_stmts_w_bndrs)
678 zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) ->
679 returnM (new_stmts, zonkIdOccs env1 bndrs)
681 zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
682 , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id
683 , recS_rec_rets = rets, recS_dicts = binds })
684 = do { new_rvs <- zonkIdBndrs env rvs
685 ; new_lvs <- zonkIdBndrs env lvs
686 ; new_ret_id <- zonkExpr env ret_id
687 ; new_mfix_id <- zonkExpr env mfix_id
688 ; new_bind_id <- zonkExpr env bind_id
689 ; let env1 = extendZonkEnv env new_rvs
690 ; (env2, new_segStmts) <- zonkStmts env1 segStmts
691 -- Zonk the ret-expressions in an envt that
692 -- has the polymorphic bindings in the envt
693 ; new_rets <- mapM (zonkExpr env2) rets
694 ; let env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
695 ; (env4, new_binds) <- zonkTcEvBinds env3 binds
697 RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
698 , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
699 , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
700 , recS_rec_rets = new_rets, recS_dicts = new_binds }) }
702 zonkStmt env (ExprStmt expr then_op ty)
703 = zonkLExpr env expr `thenM` \ new_expr ->
704 zonkExpr env then_op `thenM` \ new_then ->
705 zonkTcTypeToType env ty `thenM` \ new_ty ->
706 returnM (env, ExprStmt new_expr new_then new_ty)
708 zonkStmt env (TransformStmt stmts binders usingExpr maybeByExpr)
709 = do { (env', stmts') <- zonkStmts env stmts
710 ; let binders' = zonkIdOccs env' binders
711 ; usingExpr' <- zonkLExpr env' usingExpr
712 ; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr
713 ; return (env', TransformStmt stmts' binders' usingExpr' maybeByExpr') }
715 zonkStmt env (GroupStmt stmts binderMap by using)
716 = do { (env', stmts') <- zonkStmts env stmts
717 ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
718 ; by' <- fmapMaybeM (zonkLExpr env') by
719 ; using' <- fmapEitherM (zonkLExpr env) (zonkExpr env) using
720 ; let env'' = extendZonkEnv env' (map snd binderMap')
721 ; return (env'', GroupStmt stmts' binderMap' by' using') }
723 zonkBinderMapEntry env (oldBinder, newBinder) = do
724 let oldBinder' = zonkIdOcc env oldBinder
725 newBinder' <- zonkIdBndr env newBinder
726 return (oldBinder', newBinder')
728 zonkStmt env (LetStmt binds)
729 = zonkLocalBinds env binds `thenM` \ (env1, new_binds) ->
730 returnM (env1, LetStmt new_binds)
732 zonkStmt env (BindStmt pat expr bind_op fail_op)
733 = do { new_expr <- zonkLExpr env expr
734 ; (env1, new_pat) <- zonkPat env pat
735 ; new_bind <- zonkExpr env bind_op
736 ; new_fail <- zonkExpr env fail_op
737 ; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
739 zonkMaybeLExpr :: ZonkEnv -> Maybe (LHsExpr TcId) -> TcM (Maybe (LHsExpr Id))
740 zonkMaybeLExpr _ Nothing = return Nothing
741 zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just)
744 -------------------------------------------------------------------------
745 zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
746 zonkRecFields env (HsRecFields flds dd)
747 = do { flds' <- mappM zonk_rbind flds
748 ; return (HsRecFields flds' dd) }
751 = do { new_id <- wrapLocM (zonkIdBndr env) (hsRecFieldId fld)
752 ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
753 ; return (fld { hsRecFieldId = new_id, hsRecFieldArg = new_expr }) }
755 -------------------------------------------------------------------------
756 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
757 mapIPNameTc f (IPName n) = f n `thenM` \ r -> returnM (IPName r)
761 %************************************************************************
763 \subsection[BackSubst-Pats]{Patterns}
765 %************************************************************************
768 zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
769 -- Extend the environment as we go, because it's possible for one
770 -- pattern to bind something that is used in another (inside or
772 zonkPat env pat = wrapLocSndM (zonk_pat env) pat
774 zonk_pat :: ZonkEnv -> Pat TcId -> TcM (ZonkEnv, Pat Id)
775 zonk_pat env (ParPat p)
776 = do { (env', p') <- zonkPat env p
777 ; return (env', ParPat p') }
779 zonk_pat env (WildPat ty)
780 = do { ty' <- zonkTcTypeToType env ty
781 ; return (env, WildPat ty') }
783 zonk_pat env (VarPat v)
784 = do { v' <- zonkIdBndr env v
785 ; return (extendZonkEnv1 env v', VarPat v') }
787 zonk_pat env (VarPatOut v binds)
788 = do { v' <- zonkIdBndr env v
789 ; (env', binds') <- zonkTcEvBinds (extendZonkEnv1 env v') binds
790 ; returnM (env', VarPatOut v' binds') }
792 zonk_pat env (LazyPat pat)
793 = do { (env', pat') <- zonkPat env pat
794 ; return (env', LazyPat pat') }
796 zonk_pat env (BangPat pat)
797 = do { (env', pat') <- zonkPat env pat
798 ; return (env', BangPat pat') }
800 zonk_pat env (AsPat (L loc v) pat)
801 = do { v' <- zonkIdBndr env v
802 ; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
803 ; return (env', AsPat (L loc v') pat') }
805 zonk_pat env (ViewPat expr pat ty)
806 = do { expr' <- zonkLExpr env expr
807 ; (env', pat') <- zonkPat env pat
808 ; ty' <- zonkTcTypeToType env ty
809 ; return (env', ViewPat expr' pat' ty') }
811 zonk_pat env (ListPat pats ty)
812 = do { ty' <- zonkTcTypeToType env ty
813 ; (env', pats') <- zonkPats env pats
814 ; return (env', ListPat pats' ty') }
816 zonk_pat env (PArrPat pats ty)
817 = do { ty' <- zonkTcTypeToType env ty
818 ; (env', pats') <- zonkPats env pats
819 ; return (env', PArrPat pats' ty') }
821 zonk_pat env (TuplePat pats boxed ty)
822 = do { ty' <- zonkTcTypeToType env ty
823 ; (env', pats') <- zonkPats env pats
824 ; return (env', TuplePat pats' boxed ty') }
826 zonk_pat env p@(ConPatOut { pat_ty = ty, pat_dicts = evs, pat_binds = binds, pat_args = args })
827 = ASSERT( all isImmutableTyVar (pat_tvs p) )
828 do { new_ty <- zonkTcTypeToType env ty
829 ; (env1, new_evs) <- zonkEvBndrsX env evs
830 ; (env2, new_binds) <- zonkTcEvBinds env1 binds
831 ; (env', new_args) <- zonkConStuff env2 args
832 ; returnM (env', p { pat_ty = new_ty, pat_dicts = new_evs,
833 pat_binds = new_binds, pat_args = new_args }) }
835 zonk_pat env (LitPat lit) = return (env, LitPat lit)
837 zonk_pat env (SigPatOut pat ty)
838 = do { ty' <- zonkTcTypeToType env ty
839 ; (env', pat') <- zonkPat env pat
840 ; return (env', SigPatOut pat' ty') }
842 zonk_pat env (NPat lit mb_neg eq_expr)
843 = do { lit' <- zonkOverLit env lit
844 ; mb_neg' <- case mb_neg of
845 Nothing -> return Nothing
846 Just neg -> do { neg' <- zonkExpr env neg
847 ; return (Just neg') }
848 ; eq_expr' <- zonkExpr env eq_expr
849 ; return (env, NPat lit' mb_neg' eq_expr') }
851 zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
852 = do { n' <- zonkIdBndr env n
853 ; lit' <- zonkOverLit env lit
854 ; e1' <- zonkExpr env e1
855 ; e2' <- zonkExpr env e2
856 ; return (extendZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
858 zonk_pat env (CoPat co_fn pat ty)
859 = do { (env', co_fn') <- zonkCoFn env co_fn
860 ; (env'', pat') <- zonkPat env' (noLoc pat)
861 ; ty' <- zonkTcTypeToType env'' ty
862 ; return (env'', CoPat co_fn' (unLoc pat') ty') }
864 zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
866 ---------------------------
867 zonkConStuff :: ZonkEnv
868 -> HsConDetails (OutPat TcId) (HsRecFields id (OutPat TcId))
870 HsConDetails (OutPat Id) (HsRecFields id (OutPat Id)))
871 zonkConStuff env (PrefixCon pats)
872 = do { (env', pats') <- zonkPats env pats
873 ; return (env', PrefixCon pats') }
875 zonkConStuff env (InfixCon p1 p2)
876 = do { (env1, p1') <- zonkPat env p1
877 ; (env', p2') <- zonkPat env1 p2
878 ; return (env', InfixCon p1' p2') }
880 zonkConStuff env (RecCon (HsRecFields rpats dd))
881 = do { (env', pats') <- zonkPats env (map hsRecFieldArg rpats)
882 ; let rpats' = zipWith (\rp p' -> rp { hsRecFieldArg = p' }) rpats pats'
883 ; returnM (env', RecCon (HsRecFields rpats' dd)) }
884 -- Field selectors have declared types; hence no zonking
886 ---------------------------
887 zonkPats :: ZonkEnv -> [OutPat TcId] -> TcM (ZonkEnv, [OutPat Id])
888 zonkPats env [] = return (env, [])
889 zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
890 ; (env', pats') <- zonkPats env1 pats
891 ; return (env', pat':pats') }
894 %************************************************************************
896 \subsection[BackSubst-Foreign]{Foreign exports}
898 %************************************************************************
902 zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
903 zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
905 zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
906 zonkForeignExport env (ForeignExport i _hs_ty spec) =
907 returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec)
908 zonkForeignExport _ for_imp
909 = returnM for_imp -- Foreign imports don't need zonking
913 zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
914 zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
916 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
917 zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
918 = do { (env_rhs, new_bndrs) <- mapAccumLM zonk_bndr env vars
920 ; unbound_tv_set <- newMutVar emptyVarSet
921 ; let env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
922 -- We need to gather the type variables mentioned on the LHS so we can
923 -- quantify over them. Example:
929 -- {-# RULES "myrule" foo C = 1 #-}
931 -- After type checking the LHS becomes (foo a (C a))
932 -- and we do not want to zap the unbound tyvar 'a' to (), because
933 -- that limits the applicability of the rule. Instead, we
934 -- want to quantify over it!
936 -- It's easiest to find the free tyvars here. Attempts to do so earlier
937 -- are tiresome, because (a) the data type is big and (b) finding the
938 -- free type vars of an expression is necessarily monadic operation.
939 -- (consider /\a -> f @ b, where b is side-effected to a)
941 ; new_lhs <- zonkLExpr env_lhs lhs
942 ; new_rhs <- zonkLExpr env_rhs rhs
944 ; unbound_tvs <- readMutVar unbound_tv_set
945 ; let final_bndrs :: [RuleBndr Var]
946 final_bndrs = map (RuleBndr . noLoc) (varSetElems unbound_tvs) ++ new_bndrs
948 ; return (HsRule name act final_bndrs new_lhs fv_lhs new_rhs fv_rhs) }
950 zonk_bndr env (RuleBndr (L loc v))
951 = do { (env', v') <- zonk_it env v; return (env', RuleBndr (L loc v')) }
952 zonk_bndr _ (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig"
955 | isId v = do { v' <- zonkIdBndr env v; return (extendZonkEnv1 env v', v') }
956 | isCoVar v = do { v' <- zonkEvBndr env v; return (extendZonkEnv1 env v', v') }
957 | otherwise = ASSERT( isImmutableTyVar v) return (env, v)
961 %************************************************************************
963 Constraints and evidence
965 %************************************************************************
968 zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
969 zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v )
970 return (EvId (zonkIdOcc env v))
971 zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcTypeToType env co
972 ; return (EvCoercion co') }
973 zonkEvTerm env (EvCast v co) = ASSERT( isId v)
974 do { co' <- zonkTcTypeToType env co
975 ; return (EvCast (zonkIdOcc env v) co') }
976 zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n)
977 zonkEvTerm env (EvDFunApp df tys tms)
978 = do { tys' <- zonkTcTypeToTypes env tys
979 ; let tms' = map (zonkEvVarOcc env) tms
980 ; return (EvDFunApp (zonkIdOcc env df) tys' tms') }
982 zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
983 zonkTcEvBinds env (TcEvBinds var) = do { (env', bs') <- zonkEvBindsVar env var
984 ; return (env', EvBinds bs') }
985 zonkTcEvBinds env (EvBinds bs) = do { (env', bs') <- zonkEvBinds env bs
986 ; return (env', EvBinds bs') }
988 zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)
989 zonkEvBindsVar env (EvBindsVar ref _) = do { bs <- readMutVar ref
990 ; zonkEvBinds env (evBindMapBinds bs) }
992 zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
993 zonkEvBinds env binds
994 = fixM (\ ~( _, new_binds) -> do
995 { let env1 = extendZonkEnv env (collect_ev_bndrs new_binds)
996 ; binds' <- mapBagM (zonkEvBind env1) binds
997 ; return (env1, binds') })
999 collect_ev_bndrs :: Bag EvBind -> [EvVar]
1000 collect_ev_bndrs = foldrBag add []
1001 add (EvBind var _) vars = var : vars
1003 zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
1004 zonkEvBind env (EvBind var term)
1005 = do { var' <- zonkEvBndr env var
1006 ; term' <- zonkEvTerm env term
1007 ; return (EvBind var' term') }
1010 %************************************************************************
1012 \subsection[BackSubst-Foreign]{Foreign exports}
1014 %************************************************************************
1017 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
1018 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
1020 zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
1021 zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
1023 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
1024 -- This variant collects unbound type variables in a mutable variable
1025 zonkTypeCollecting unbound_tv_set
1026 = zonkType (mkZonkTcTyVar zonk_unbound_tyvar)
1028 zonk_unbound_tyvar tv
1029 = do { tv' <- zonkQuantifiedTyVar tv
1030 ; tv_set <- readMutVar unbound_tv_set
1031 ; writeMutVar unbound_tv_set (extendVarSet tv_set tv')
1032 ; return (mkTyVarTy tv') }
1034 zonkTypeZapping :: TcType -> TcM Type
1035 -- This variant is used for everything except the LHS of rules
1036 -- It zaps unbound type variables to (), or some other arbitrary type
1038 = zonkType (mkZonkTcTyVar zonk_unbound_tyvar) ty
1040 -- Zonk a mutable but unbound type variable to an arbitrary type
1041 -- We know it's unbound even though we don't carry an environment,
1042 -- because at the binding site for a type variable we bind the
1043 -- mutable tyvar to a fresh immutable one. So the mutable store
1044 -- plays the role of an environment. If we come across a mutable
1045 -- type variable that isn't so bound, it must be completely free.
1046 zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv)
1047 ; writeMetaTyVar tv ty