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 -- The above warning supression flag is a temporary kludge.
14 -- While working on this module you are encouraged to remove it and fix
15 -- any warnings in the module. See
16 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
20 mkHsConApp, mkHsDictLet, mkHsApp,
21 hsLitType, hsLPatType, hsPatType,
22 mkHsAppTy, mkSimpleHsAlt,
23 nlHsIntLit, mkVanillaTuplePat,
25 mkArbitraryType, -- Put this elsewhere?
27 -- re-exported from TcMonad
28 TcId, TcIdSet, TcDictBinds,
30 zonkTopDecls, zonkTopExpr, zonkTopLExpr,
34 #include "HsVersions.h"
37 import HsSyn -- oodles of it
65 thenM :: Monad a => a b -> (b -> a c) -> a c
68 thenM_ :: Monad a => a b -> a c -> a c
71 returnM :: Monad m => a -> m a
74 mappM :: (Monad m) => (a -> m b) -> [a] -> m [b]
79 %************************************************************************
81 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
83 %************************************************************************
85 Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
86 then something is wrong.
88 mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
89 -- A vanilla tuple pattern simply gets its type from its sub-patterns
90 mkVanillaTuplePat pats box
91 = TuplePat pats box (mkTupleTy box (length pats) (map hsLPatType pats))
93 hsLPatType :: OutPat Id -> Type
94 hsLPatType (L _ pat) = hsPatType pat
96 hsPatType (ParPat pat) = hsLPatType pat
97 hsPatType (WildPat ty) = ty
98 hsPatType (VarPat var) = idType var
99 hsPatType (VarPatOut var _) = idType var
100 hsPatType (BangPat pat) = hsLPatType pat
101 hsPatType (LazyPat pat) = hsLPatType pat
102 hsPatType (LitPat lit) = hsLitType lit
103 hsPatType (AsPat var pat) = idType (unLoc var)
104 hsPatType (ViewPat expr pat ty) = ty
105 hsPatType (ListPat _ ty) = mkListTy ty
106 hsPatType (PArrPat _ ty) = mkPArrTy ty
107 hsPatType (TuplePat pats box ty) = ty
108 hsPatType (ConPatOut{ pat_ty = ty })= ty
109 hsPatType (SigPatOut pat ty) = ty
110 hsPatType (NPat lit _ _) = overLitType lit
111 hsPatType (NPlusKPat id _ _ _) = idType (unLoc id)
112 hsPatType (CoPat _ _ ty) = ty
114 hsLitType :: HsLit -> TcType
115 hsLitType (HsChar c) = charTy
116 hsLitType (HsCharPrim c) = charPrimTy
117 hsLitType (HsString str) = stringTy
118 hsLitType (HsStringPrim s) = addrPrimTy
119 hsLitType (HsInt i) = intTy
120 hsLitType (HsIntPrim i) = intPrimTy
121 hsLitType (HsWordPrim w) = wordPrimTy
122 hsLitType (HsInteger i ty) = ty
123 hsLitType (HsRat _ ty) = ty
124 hsLitType (HsFloatPrim f) = floatPrimTy
125 hsLitType (HsDoublePrim d) = doublePrimTy
129 %************************************************************************
131 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
133 %************************************************************************
136 -- zonkId is used *during* typechecking just to zonk the Id's type
137 zonkId :: TcId -> TcM TcId
139 = zonkTcType (idType id) `thenM` \ ty' ->
140 returnM (Id.setIdType id ty')
143 The rest of the zonking is done *after* typechecking.
144 The main zonking pass runs over the bindings
146 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
147 b) convert unbound TcTyVar to Void
148 c) convert each TcId to an Id by zonking its type
150 The type variables are converted by binding mutable tyvars to immutable ones
151 and then zonking as normal.
153 The Ids are converted by binding them in the normal Tc envt; that
154 way we maintain sharing; eg an Id is zonked at its binding site and they
155 all occurrences of that Id point to the common zonked copy
157 It's all pretty boring stuff, because HsSyn is such a large type, and
158 the environment manipulation is tiresome.
161 data ZonkEnv = ZonkEnv (TcType -> TcM Type) -- How to zonk a type
162 (IdEnv Id) -- What variables are in scope
163 -- Maps an Id to its zonked version; both have the same Name
164 -- Is only consulted lazily; hence knot-tying
166 emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
168 extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
169 extendZonkEnv (ZonkEnv zonk_ty env) ids
170 = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
172 extendZonkEnv1 :: ZonkEnv -> Id -> ZonkEnv
173 extendZonkEnv1 (ZonkEnv zonk_ty env) id
174 = ZonkEnv zonk_ty (extendVarEnv env id id)
176 setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
177 setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
179 zonkEnvIds :: ZonkEnv -> [Id]
180 zonkEnvIds (ZonkEnv _ env) = varEnvElts env
182 zonkIdOcc :: ZonkEnv -> TcId -> Id
183 -- Ids defined in this module should be in the envt;
184 -- ignore others. (Actually, data constructors are also
185 -- not LocalVars, even when locally defined, but that is fine.)
186 -- (Also foreign-imported things aren't currently in the ZonkEnv;
187 -- that's ok because they don't need zonking.)
189 -- Actually, Template Haskell works in 'chunks' of declarations, and
190 -- an earlier chunk won't be in the 'env' that the zonking phase
191 -- carries around. Instead it'll be in the tcg_gbl_env, already fully
192 -- zonked. There's no point in looking it up there (except for error
193 -- checking), and it's not conveniently to hand; hence the simple
194 -- 'orElse' case in the LocalVar branch.
196 -- Even without template splices, in module Main, the checking of
197 -- 'main' is done as a separate chunk.
198 zonkIdOcc (ZonkEnv zonk_ty env) id
199 | isLocalVar id = lookupVarEnv env id `orElse` id
202 zonkIdOccs env ids = map (zonkIdOcc env) ids
204 -- zonkIdBndr is used *after* typechecking to get the Id's type
205 -- to its final form. The TyVarEnv give
206 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
208 = zonkTcTypeToType env (idType id) `thenM` \ ty' ->
209 returnM (Id.setIdType id ty')
211 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
212 zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
214 zonkDictBndrs :: ZonkEnv -> [Var] -> TcM [Var]
215 -- "Dictionary" binders can be coercion variables or dictionary variables
216 zonkDictBndrs env ids = mappM (zonkDictBndr env) ids
218 zonkDictBndr env var | isTyVar var = return var
219 | otherwise = zonkIdBndr env var
221 zonkTopBndrs :: [TcId] -> TcM [Id]
222 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
227 zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
228 zonkTopExpr e = zonkExpr emptyZonkEnv e
230 zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
231 zonkTopLExpr e = zonkLExpr emptyZonkEnv e
233 zonkTopDecls :: LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId]
238 zonkTopDecls binds rules fords
239 = do { (env, binds') <- zonkRecMonoBinds emptyZonkEnv binds
240 -- Top level is implicitly recursive
241 ; rules' <- zonkRules env rules
242 ; fords' <- zonkForeignExports env fords
243 ; return (zonkEnvIds env, binds', fords', rules') }
245 ---------------------------------------------
246 zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
247 zonkLocalBinds env EmptyLocalBinds
248 = return (env, EmptyLocalBinds)
250 zonkLocalBinds env (HsValBinds binds)
251 = do { (env1, new_binds) <- zonkValBinds env binds
252 ; return (env1, HsValBinds new_binds) }
254 zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds))
255 = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds ->
257 env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
259 zonkRecMonoBinds env1 dict_binds `thenM` \ (env2, new_dict_binds) ->
260 returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
262 zonk_ip_bind (IPBind n e)
263 = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' ->
264 zonkLExpr env e `thenM` \ e' ->
265 returnM (IPBind n' e')
268 ---------------------------------------------
269 zonkValBinds :: ZonkEnv -> HsValBinds TcId -> TcM (ZonkEnv, HsValBinds Id)
270 zonkValBinds env bs@(ValBindsIn _ _)
271 = panic "zonkValBinds" -- Not in typechecker output
272 zonkValBinds env (ValBindsOut binds sigs)
273 = do { (env1, new_binds) <- go env binds
274 ; return (env1, ValBindsOut new_binds sigs) }
276 go env [] = return (env, [])
277 go env ((r,b):bs) = do { (env1, b') <- zonkRecMonoBinds env b
278 ; (env2, bs') <- go env1 bs
279 ; return (env2, (r,b'):bs') }
281 ---------------------------------------------
282 zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
283 zonkRecMonoBinds env binds
284 = fixM (\ ~(_, new_binds) -> do
285 { let env1 = extendZonkEnv env (collectHsBindBinders new_binds)
286 ; binds' <- zonkMonoBinds env1 binds
287 ; return (env1, binds') })
289 ---------------------------------------------
290 zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
291 zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds
293 zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
294 zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
295 = do { (_env, new_pat) <- zonkPat env pat -- Env already extended
296 ; new_grhss <- zonkGRHSs env grhss
297 ; new_ty <- zonkTcTypeToType env ty
298 ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
300 zonk_bind env (VarBind { var_id = var, var_rhs = expr })
301 = zonkIdBndr env var `thenM` \ new_var ->
302 zonkLExpr env expr `thenM` \ new_expr ->
303 returnM (VarBind { var_id = new_var, var_rhs = new_expr })
305 zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn })
306 = wrapLocM (zonkIdBndr env) var `thenM` \ new_var ->
307 zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) ->
308 zonkMatchGroup env1 ms `thenM` \ new_ms ->
309 returnM (bind { fun_id = new_var, fun_matches = new_ms, fun_co_fn = new_co_fn })
311 zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts,
312 abs_exports = exports, abs_binds = val_binds })
313 = ASSERT( all isImmutableTyVar tyvars )
314 zonkDictBndrs env dicts `thenM` \ new_dicts ->
315 fixM (\ ~(new_val_binds, _) ->
317 env1 = extendZonkEnv env new_dicts
318 env2 = extendZonkEnv env1 (collectHsBindBinders new_val_binds)
320 zonkMonoBinds env2 val_binds `thenM` \ new_val_binds ->
321 mappM (zonkExport env2) exports `thenM` \ new_exports ->
322 returnM (new_val_binds, new_exports)
323 ) `thenM` \ (new_val_bind, new_exports) ->
324 returnM (AbsBinds { abs_tvs = tyvars, abs_dicts = new_dicts,
325 abs_exports = new_exports, abs_binds = new_val_bind })
327 zonkExport env (tyvars, global, local, prags)
328 -- The tyvars are already zonked
329 = zonkIdBndr env global `thenM` \ new_global ->
330 mapM zonk_prag prags `thenM` \ new_prags ->
331 returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
332 zonk_prag prag@(L _ (InlinePrag {})) = return prag
333 zonk_prag (L loc (SpecPrag expr ty inl))
334 = do { expr' <- zonkExpr env expr
335 ; ty' <- zonkTcTypeToType env ty
336 ; return (L loc (SpecPrag expr' ty' inl)) }
339 %************************************************************************
341 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
343 %************************************************************************
346 zonkMatchGroup :: ZonkEnv -> MatchGroup TcId-> TcM (MatchGroup Id)
347 zonkMatchGroup env (MatchGroup ms ty)
348 = do { ms' <- mapM (zonkMatch env) ms
349 ; ty' <- zonkTcTypeToType env ty
350 ; return (MatchGroup ms' ty') }
352 zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id)
353 zonkMatch env (L loc (Match pats _ grhss))
354 = do { (env1, new_pats) <- zonkPats env pats
355 ; new_grhss <- zonkGRHSs env1 grhss
356 ; return (L loc (Match new_pats Nothing new_grhss)) }
358 -------------------------------------------------------------------------
359 zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id)
361 zonkGRHSs env (GRHSs grhss binds)
362 = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) ->
364 zonk_grhs (GRHS guarded rhs)
365 = zonkStmts new_env guarded `thenM` \ (env2, new_guarded) ->
366 zonkLExpr env2 rhs `thenM` \ new_rhs ->
367 returnM (GRHS new_guarded new_rhs)
369 mappM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss ->
370 returnM (GRHSs new_grhss new_binds)
373 %************************************************************************
375 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
377 %************************************************************************
380 zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
381 zonkLExpr :: ZonkEnv -> LHsExpr TcId -> TcM (LHsExpr Id)
382 zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id)
384 zonkLExprs env exprs = mappM (zonkLExpr env) exprs
385 zonkLExpr env expr = wrapLocM (zonkExpr env) expr
387 zonkExpr env (HsVar id)
388 = returnM (HsVar (zonkIdOcc env id))
390 zonkExpr env (HsIPVar id)
391 = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
393 zonkExpr env (HsLit (HsRat f ty))
394 = zonkTcTypeToType env ty `thenM` \ new_ty ->
395 returnM (HsLit (HsRat f new_ty))
397 zonkExpr env (HsLit lit)
398 = returnM (HsLit lit)
400 zonkExpr env (HsOverLit lit)
401 = do { lit' <- zonkOverLit env lit
402 ; return (HsOverLit lit') }
404 zonkExpr env (HsLam matches)
405 = zonkMatchGroup env matches `thenM` \ new_matches ->
406 returnM (HsLam new_matches)
408 zonkExpr env (HsApp e1 e2)
409 = zonkLExpr env e1 `thenM` \ new_e1 ->
410 zonkLExpr env e2 `thenM` \ new_e2 ->
411 returnM (HsApp new_e1 new_e2)
413 zonkExpr env (HsBracketOut body bs)
414 = mappM zonk_b bs `thenM` \ bs' ->
415 returnM (HsBracketOut body bs')
417 zonk_b (n,e) = zonkLExpr env e `thenM` \ e' ->
420 zonkExpr env (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
421 returnM (HsSpliceE s)
423 zonkExpr env (OpApp e1 op fixity e2)
424 = zonkLExpr env e1 `thenM` \ new_e1 ->
425 zonkLExpr env op `thenM` \ new_op ->
426 zonkLExpr env e2 `thenM` \ new_e2 ->
427 returnM (OpApp new_e1 new_op fixity new_e2)
429 zonkExpr env (NegApp expr op)
430 = zonkLExpr env expr `thenM` \ new_expr ->
431 zonkExpr env op `thenM` \ new_op ->
432 returnM (NegApp new_expr new_op)
434 zonkExpr env (HsPar e)
435 = zonkLExpr env e `thenM` \new_e ->
436 returnM (HsPar new_e)
438 zonkExpr env (SectionL expr op)
439 = zonkLExpr env expr `thenM` \ new_expr ->
440 zonkLExpr env op `thenM` \ new_op ->
441 returnM (SectionL new_expr new_op)
443 zonkExpr env (SectionR op expr)
444 = zonkLExpr env op `thenM` \ new_op ->
445 zonkLExpr env expr `thenM` \ new_expr ->
446 returnM (SectionR new_op new_expr)
448 zonkExpr env (HsCase expr ms)
449 = zonkLExpr env expr `thenM` \ new_expr ->
450 zonkMatchGroup env ms `thenM` \ new_ms ->
451 returnM (HsCase new_expr new_ms)
453 zonkExpr env (HsIf e1 e2 e3)
454 = zonkLExpr env e1 `thenM` \ new_e1 ->
455 zonkLExpr env e2 `thenM` \ new_e2 ->
456 zonkLExpr env e3 `thenM` \ new_e3 ->
457 returnM (HsIf new_e1 new_e2 new_e3)
459 zonkExpr env (HsLet binds expr)
460 = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) ->
461 zonkLExpr new_env expr `thenM` \ new_expr ->
462 returnM (HsLet new_binds new_expr)
464 zonkExpr env (HsDo do_or_lc stmts body ty)
465 = zonkStmts env stmts `thenM` \ (new_env, new_stmts) ->
466 zonkLExpr new_env body `thenM` \ new_body ->
467 zonkTcTypeToType env ty `thenM` \ new_ty ->
468 returnM (HsDo (zonkDo env do_or_lc)
469 new_stmts new_body new_ty)
471 zonkExpr env (ExplicitList ty exprs)
472 = zonkTcTypeToType env ty `thenM` \ new_ty ->
473 zonkLExprs env exprs `thenM` \ new_exprs ->
474 returnM (ExplicitList new_ty new_exprs)
476 zonkExpr env (ExplicitPArr ty exprs)
477 = zonkTcTypeToType env ty `thenM` \ new_ty ->
478 zonkLExprs env exprs `thenM` \ new_exprs ->
479 returnM (ExplicitPArr new_ty new_exprs)
481 zonkExpr env (ExplicitTuple exprs boxed)
482 = zonkLExprs env exprs `thenM` \ new_exprs ->
483 returnM (ExplicitTuple new_exprs boxed)
485 zonkExpr env (RecordCon data_con con_expr rbinds)
486 = do { new_con_expr <- zonkExpr env con_expr
487 ; new_rbinds <- zonkRecFields env rbinds
488 ; return (RecordCon data_con new_con_expr new_rbinds) }
490 zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys)
491 = do { new_expr <- zonkLExpr env expr
492 ; new_in_tys <- mapM (zonkTcTypeToType env) in_tys
493 ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
494 ; new_rbinds <- zonkRecFields env rbinds
495 ; return (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys) }
497 zonkExpr env (ExprWithTySigOut e ty)
498 = do { e' <- zonkLExpr env e
499 ; return (ExprWithTySigOut e' ty) }
501 zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
503 zonkExpr env (ArithSeq expr info)
504 = zonkExpr env expr `thenM` \ new_expr ->
505 zonkArithSeq env info `thenM` \ new_info ->
506 returnM (ArithSeq new_expr new_info)
508 zonkExpr env (PArrSeq expr info)
509 = zonkExpr env expr `thenM` \ new_expr ->
510 zonkArithSeq env info `thenM` \ new_info ->
511 returnM (PArrSeq new_expr new_info)
513 zonkExpr env (HsSCC lbl expr)
514 = zonkLExpr env expr `thenM` \ new_expr ->
515 returnM (HsSCC lbl new_expr)
517 zonkExpr env (HsTickPragma info expr)
518 = zonkLExpr env expr `thenM` \ new_expr ->
519 returnM (HsTickPragma info new_expr)
521 -- hdaume: core annotations
522 zonkExpr env (HsCoreAnn lbl expr)
523 = zonkLExpr env expr `thenM` \ new_expr ->
524 returnM (HsCoreAnn lbl new_expr)
526 -- arrow notation extensions
527 zonkExpr env (HsProc pat body)
528 = do { (env1, new_pat) <- zonkPat env pat
529 ; new_body <- zonkCmdTop env1 body
530 ; return (HsProc new_pat new_body) }
532 zonkExpr env (HsArrApp e1 e2 ty ho rl)
533 = zonkLExpr env e1 `thenM` \ new_e1 ->
534 zonkLExpr env e2 `thenM` \ new_e2 ->
535 zonkTcTypeToType env ty `thenM` \ new_ty ->
536 returnM (HsArrApp new_e1 new_e2 new_ty ho rl)
538 zonkExpr env (HsArrForm op fixity args)
539 = zonkLExpr env op `thenM` \ new_op ->
540 mappM (zonkCmdTop env) args `thenM` \ new_args ->
541 returnM (HsArrForm new_op fixity new_args)
543 zonkExpr env (HsWrap co_fn expr)
544 = zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) ->
545 zonkExpr env1 expr `thenM` \ new_expr ->
546 return (HsWrap new_co_fn new_expr)
548 zonkExpr env other = pprPanic "zonkExpr" (ppr other)
550 zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
551 zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
553 zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
554 = zonkLExpr env cmd `thenM` \ new_cmd ->
555 zonkTcTypeToTypes env stack_tys `thenM` \ new_stack_tys ->
556 zonkTcTypeToType env ty `thenM` \ new_ty ->
557 mapSndM (zonkExpr env) ids `thenM` \ new_ids ->
558 returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
560 -------------------------------------------------------------------------
561 zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
562 zonkCoFn env WpHole = return (env, WpHole)
563 zonkCoFn env WpInline = return (env, WpInline)
564 zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
565 ; (env2, c2') <- zonkCoFn env1 c2
566 ; return (env2, WpCompose c1' c2') }
567 zonkCoFn env (WpCast co) = do { co' <- zonkTcTypeToType env co
568 ; return (env, WpCast co') }
569 zonkCoFn env (WpLam id) = do { id' <- zonkDictBndr env id
570 ; let env1 = extendZonkEnv1 env id'
571 ; return (env1, WpLam id') }
572 zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv )
573 do { return (env, WpTyLam tv) }
574 zonkCoFn env (WpApp id) = do { return (env, WpApp (zonkIdOcc env id)) }
575 zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty
576 ; return (env, WpTyApp ty') }
577 zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkRecMonoBinds env bs
578 ; return (env1, WpLet bs') }
581 -------------------------------------------------------------------------
582 zonkDo :: ZonkEnv -> HsStmtContext Name -> HsStmtContext Name
583 -- Only used for 'do', so the only Ids are in a MDoExpr table
584 zonkDo env (MDoExpr tbl) = MDoExpr (mapSnd (zonkIdOcc env) tbl)
585 zonkDo env do_or_lc = do_or_lc
587 -------------------------------------------------------------------------
588 zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
591 zonkedStuff = do ty' <- zonkTcTypeToType env (overLitType ol)
592 e' <- zonkExpr env (overLitExpr ol)
594 ru f (x, y) = return (f x y)
597 (HsIntegral i _ _) -> ru (HsIntegral i) =<< zonkedStuff
598 (HsFractional r _ _) -> ru (HsFractional r) =<< zonkedStuff
599 (HsIsString s _ _) -> ru (HsIsString s) =<< zonkedStuff
601 -------------------------------------------------------------------------
602 zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
604 zonkArithSeq env (From e)
605 = zonkLExpr env e `thenM` \ new_e ->
608 zonkArithSeq env (FromThen e1 e2)
609 = zonkLExpr env e1 `thenM` \ new_e1 ->
610 zonkLExpr env e2 `thenM` \ new_e2 ->
611 returnM (FromThen new_e1 new_e2)
613 zonkArithSeq env (FromTo e1 e2)
614 = zonkLExpr env e1 `thenM` \ new_e1 ->
615 zonkLExpr env e2 `thenM` \ new_e2 ->
616 returnM (FromTo new_e1 new_e2)
618 zonkArithSeq env (FromThenTo e1 e2 e3)
619 = zonkLExpr env e1 `thenM` \ new_e1 ->
620 zonkLExpr env e2 `thenM` \ new_e2 ->
621 zonkLExpr env e3 `thenM` \ new_e3 ->
622 returnM (FromThenTo new_e1 new_e2 new_e3)
625 -------------------------------------------------------------------------
626 zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id])
627 zonkStmts env [] = return (env, [])
628 zonkStmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s
629 ; (env2, ss') <- zonkStmts env1 ss
630 ; return (env2, s' : ss') }
632 zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
633 zonkStmt env (ParStmt stmts_w_bndrs)
634 = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs ->
636 new_binders = concat (map snd new_stmts_w_bndrs)
637 env1 = extendZonkEnv env new_binders
639 return (env1, ParStmt new_stmts_w_bndrs)
641 zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) ->
642 returnM (new_stmts, zonkIdOccs env1 bndrs)
644 zonkStmt env (RecStmt segStmts lvs rvs rets binds)
645 = zonkIdBndrs env rvs `thenM` \ new_rvs ->
647 env1 = extendZonkEnv env new_rvs
649 zonkStmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
650 -- Zonk the ret-expressions in an envt that
651 -- has the polymorphic bindings in the envt
652 mapM (zonkExpr env2) rets `thenM` \ new_rets ->
654 new_lvs = zonkIdOccs env2 lvs
655 env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
657 zonkRecMonoBinds env3 binds `thenM` \ (env4, new_binds) ->
658 returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets new_binds)
660 zonkStmt env (ExprStmt expr then_op ty)
661 = zonkLExpr env expr `thenM` \ new_expr ->
662 zonkExpr env then_op `thenM` \ new_then ->
663 zonkTcTypeToType env ty `thenM` \ new_ty ->
664 returnM (env, ExprStmt new_expr new_then new_ty)
666 zonkStmt env (TransformStmt (stmts, binders) usingExpr maybeByExpr)
667 = do { (env', stmts') <- zonkStmts env stmts
668 ; let binders' = zonkIdOccs env' binders
669 ; usingExpr' <- zonkLExpr env' usingExpr
670 ; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr
671 ; return (env', TransformStmt (stmts', binders') usingExpr' maybeByExpr') }
673 zonkStmt env (GroupStmt (stmts, binderMap) groupByClause)
674 = do { (env', stmts') <- zonkStmts env stmts
675 ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
677 case groupByClause of
678 GroupByNothing usingExpr -> (zonkLExpr env' usingExpr) >>= (return . GroupByNothing)
679 GroupBySomething eitherUsingExpr byExpr -> do
680 eitherUsingExpr' <- mapEitherM (zonkLExpr env') (zonkExpr env') eitherUsingExpr
681 byExpr' <- zonkLExpr env' byExpr
682 return $ GroupBySomething eitherUsingExpr' byExpr'
684 ; let env'' = extendZonkEnv env' (map snd binderMap')
685 ; return (env'', GroupStmt (stmts', binderMap') groupByClause') }
687 mapEitherM f g x = do
689 Left a -> f a >>= (return . Left)
690 Right b -> g b >>= (return . Right)
692 zonkBinderMapEntry env (oldBinder, newBinder) = do
693 let oldBinder' = zonkIdOcc env oldBinder
694 newBinder' <- zonkIdBndr env newBinder
695 return (oldBinder', newBinder')
697 zonkStmt env (LetStmt binds)
698 = zonkLocalBinds env binds `thenM` \ (env1, new_binds) ->
699 returnM (env1, LetStmt new_binds)
701 zonkStmt env (BindStmt pat expr bind_op fail_op)
702 = do { new_expr <- zonkLExpr env expr
703 ; (env1, new_pat) <- zonkPat env pat
704 ; new_bind <- zonkExpr env bind_op
705 ; new_fail <- zonkExpr env fail_op
706 ; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
708 zonkMaybeLExpr env Nothing = return Nothing
709 zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just)
712 -------------------------------------------------------------------------
713 zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
714 zonkRecFields env (HsRecFields flds dd)
715 = do { flds' <- mappM zonk_rbind flds
716 ; return (HsRecFields flds' dd) }
719 = do { new_expr <- zonkLExpr env (hsRecFieldArg fld)
720 ; return (fld { hsRecFieldArg = new_expr }) }
721 -- Field selectors have declared types; hence no zonking
723 -------------------------------------------------------------------------
724 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
725 mapIPNameTc f (IPName n) = f n `thenM` \ r -> returnM (IPName r)
729 %************************************************************************
731 \subsection[BackSubst-Pats]{Patterns}
733 %************************************************************************
736 zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
737 -- Extend the environment as we go, because it's possible for one
738 -- pattern to bind something that is used in another (inside or
740 zonkPat env pat = wrapLocSndM (zonk_pat env) pat
742 zonk_pat env (ParPat p)
743 = do { (env', p') <- zonkPat env p
744 ; return (env', ParPat p') }
746 zonk_pat env (WildPat ty)
747 = do { ty' <- zonkTcTypeToType env ty
748 ; return (env, WildPat ty') }
750 zonk_pat env (VarPat v)
751 = do { v' <- zonkIdBndr env v
752 ; return (extendZonkEnv1 env v', VarPat v') }
754 zonk_pat env (VarPatOut v binds)
755 = do { v' <- zonkIdBndr env v
756 ; (env', binds') <- zonkRecMonoBinds (extendZonkEnv1 env v') binds
757 ; returnM (env', VarPatOut v' binds') }
759 zonk_pat env (LazyPat pat)
760 = do { (env', pat') <- zonkPat env pat
761 ; return (env', LazyPat pat') }
763 zonk_pat env (BangPat pat)
764 = do { (env', pat') <- zonkPat env pat
765 ; return (env', BangPat pat') }
767 zonk_pat env (AsPat (L loc v) pat)
768 = do { v' <- zonkIdBndr env v
769 ; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
770 ; return (env', AsPat (L loc v') pat') }
772 zonk_pat env (ViewPat expr pat ty)
773 = do { expr' <- zonkLExpr env expr
774 ; (env', pat') <- zonkPat env pat
775 ; return (env', ViewPat expr' pat' ty) }
777 zonk_pat env (ListPat pats ty)
778 = do { ty' <- zonkTcTypeToType env ty
779 ; (env', pats') <- zonkPats env pats
780 ; return (env', ListPat pats' ty') }
782 zonk_pat env (PArrPat pats ty)
783 = do { ty' <- zonkTcTypeToType env ty
784 ; (env', pats') <- zonkPats env pats
785 ; return (env', PArrPat pats' ty') }
787 zonk_pat env (TuplePat pats boxed ty)
788 = do { ty' <- zonkTcTypeToType env ty
789 ; (env', pats') <- zonkPats env pats
790 ; return (env', TuplePat pats' boxed ty') }
792 zonk_pat env p@(ConPatOut { pat_ty = ty, pat_dicts = dicts, pat_binds = binds, pat_args = args })
793 = ASSERT( all isImmutableTyVar (pat_tvs p) )
794 do { new_ty <- zonkTcTypeToType env ty
795 ; new_dicts <- zonkDictBndrs env dicts
796 ; let env1 = extendZonkEnv env new_dicts
797 ; (env2, new_binds) <- zonkRecMonoBinds env1 binds
798 ; (env', new_args) <- zonkConStuff env2 args
799 ; returnM (env', p { pat_ty = new_ty, pat_dicts = new_dicts,
800 pat_binds = new_binds, pat_args = new_args }) }
802 zonk_pat env (LitPat lit) = return (env, LitPat lit)
804 zonk_pat env (SigPatOut pat ty)
805 = do { ty' <- zonkTcTypeToType env ty
806 ; (env', pat') <- zonkPat env pat
807 ; return (env', SigPatOut pat' ty') }
809 zonk_pat env (NPat lit mb_neg eq_expr)
810 = do { lit' <- zonkOverLit env lit
811 ; mb_neg' <- case mb_neg of
812 Nothing -> return Nothing
813 Just neg -> do { neg' <- zonkExpr env neg
814 ; return (Just neg') }
815 ; eq_expr' <- zonkExpr env eq_expr
816 ; return (env, NPat lit' mb_neg' eq_expr') }
818 zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
819 = do { n' <- zonkIdBndr env n
820 ; lit' <- zonkOverLit env lit
821 ; e1' <- zonkExpr env e1
822 ; e2' <- zonkExpr env e2
823 ; return (extendZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
825 zonk_pat env (CoPat co_fn pat ty)
826 = do { (env', co_fn') <- zonkCoFn env co_fn
827 ; (env'', pat') <- zonkPat env' (noLoc pat)
828 ; ty' <- zonkTcTypeToType env'' ty
829 ; return (env'', CoPat co_fn' (unLoc pat') ty') }
831 zonk_pat env pat = pprPanic "zonk_pat" (ppr pat)
833 ---------------------------
834 zonkConStuff env (PrefixCon pats)
835 = do { (env', pats') <- zonkPats env pats
836 ; return (env', PrefixCon pats') }
838 zonkConStuff env (InfixCon p1 p2)
839 = do { (env1, p1') <- zonkPat env p1
840 ; (env', p2') <- zonkPat env1 p2
841 ; return (env', InfixCon p1' p2') }
843 zonkConStuff env (RecCon (HsRecFields rpats dd))
844 = do { (env', pats') <- zonkPats env (map hsRecFieldArg rpats)
845 ; let rpats' = zipWith (\rp p' -> rp { hsRecFieldArg = p' }) rpats pats'
846 ; returnM (env', RecCon (HsRecFields rpats' dd)) }
847 -- Field selectors have declared types; hence no zonking
849 ---------------------------
850 zonkPats env [] = return (env, [])
851 zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
852 ; (env', pats') <- zonkPats env1 pats
853 ; return (env', pat':pats') }
856 %************************************************************************
858 \subsection[BackSubst-Foreign]{Foreign exports}
860 %************************************************************************
864 zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
865 zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
867 zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
868 zonkForeignExport env (ForeignExport i hs_ty spec) =
869 returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec)
870 zonkForeignExport env for_imp
871 = returnM for_imp -- Foreign imports don't need zonking
875 zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
876 zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
878 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
879 zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
880 = mappM zonk_bndr vars `thenM` \ new_bndrs ->
881 newMutVar emptyVarSet `thenM` \ unbound_tv_set ->
883 env_rhs = extendZonkEnv env [id | b <- new_bndrs, let id = unLoc b, isId id]
884 -- Type variables don't need an envt
885 -- They are bound through the mutable mechanism
887 env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
888 -- We need to gather the type variables mentioned on the LHS so we can
889 -- quantify over them. Example:
895 -- {-# RULES "myrule" foo C = 1 #-}
897 -- After type checking the LHS becomes (foo a (C a))
898 -- and we do not want to zap the unbound tyvar 'a' to (), because
899 -- that limits the applicability of the rule. Instead, we
900 -- want to quantify over it!
902 -- It's easiest to find the free tyvars here. Attempts to do so earlier
903 -- are tiresome, because (a) the data type is big and (b) finding the
904 -- free type vars of an expression is necessarily monadic operation.
905 -- (consider /\a -> f @ b, where b is side-effected to a)
907 zonkLExpr env_lhs lhs `thenM` \ new_lhs ->
908 zonkLExpr env_rhs rhs `thenM` \ new_rhs ->
910 readMutVar unbound_tv_set `thenM` \ unbound_tvs ->
912 final_bndrs :: [Located Var]
913 final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs
915 returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs fv_lhs new_rhs fv_rhs)
916 -- I hate this map RuleBndr stuff
918 zonk_bndr (RuleBndr v)
919 | isId (unLoc v) = wrapLocM (zonkIdBndr env) v
920 | otherwise = ASSERT( isImmutableTyVar (unLoc v) )
925 %************************************************************************
927 \subsection[BackSubst-Foreign]{Foreign exports}
929 %************************************************************************
932 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
933 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
935 zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
936 zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
938 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
939 -- This variant collects unbound type variables in a mutable variable
940 zonkTypeCollecting unbound_tv_set
941 = zonkType zonk_unbound_tyvar
943 zonk_unbound_tyvar tv
944 = zonkQuantifiedTyVar tv `thenM` \ tv' ->
945 readMutVar unbound_tv_set `thenM` \ tv_set ->
946 writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_`
947 return (mkTyVarTy tv')
949 zonkTypeZapping :: TcType -> TcM Type
950 -- This variant is used for everything except the LHS of rules
951 -- It zaps unbound type variables to (), or some other arbitrary type
953 = zonkType zonk_unbound_tyvar ty
955 -- Zonk a mutable but unbound type variable to an arbitrary type
956 -- We know it's unbound even though we don't carry an environment,
957 -- because at the binding site for a type variable we bind the
958 -- mutable tyvar to a fresh immutable one. So the mutable store
959 -- plays the role of an environment. If we come across a mutable
960 -- type variable that isn't so bound, it must be completely free.
961 zonk_unbound_tyvar tv = do { ty <- mkArbitraryType warn tv
962 ; writeMetaTyVar tv ty
965 warn span msg = setSrcSpan span (addWarnTc msg)
968 {- Note [Strangely-kinded void TyCons]
969 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
970 See Trac #959 for more examples
972 When the type checker finds a type variable with no binding, which
973 means it can be instantiated with an arbitrary type, it usually
974 instantiates it to Void. Eg.
978 length Void (Nil Void)
980 But in really obscure programs, the type variable might have a kind
981 other than *, so we need to invent a suitably-kinded type.
986 Tuple for kind *->...*->*
988 which deals with most cases. (Previously, it only dealt with
991 In the other cases, it just makes up a TyCon with a suitable kind. If
992 this gets into an interface file, anyone reading that file won't
993 understand it. This is fixable (by making the client of the interface
994 file make up a TyCon too) but it is tiresome and never happens, so I
997 Meanwhile I have now fixed GHC to emit a civilized warning.
1000 mkArbitraryType :: (SrcSpan -> SDoc -> TcRnIf g l a) -- How to complain
1002 -> TcRnIf g l Type -- Used by desugarer too
1003 -- Make up an arbitrary type whose kind is the same as the tyvar.
1004 -- We'll use this to instantiate the (unbound) tyvar.
1006 -- Also used by the desugarer; hence the (tiresome) parameter
1007 -- to use when generating a warning
1008 mkArbitraryType warn tv
1009 | liftedTypeKind `isSubKind` kind -- The vastly common case
1011 | eqKind kind (tyConKind anyPrimTyCon1) -- *->*
1012 = return (mkTyConApp anyPrimTyCon1 []) -- No tuples this size
1013 | all isLiftedTypeKind args -- *-> ... ->*->*
1014 , isLiftedTypeKind res -- Horrible hack to make less use
1015 = return (mkTyConApp tup_tc []) -- of mkAnyPrimTyCon
1017 = do { warn (getSrcSpan tv) msg
1018 ; return (mkTyConApp (mkAnyPrimTyCon (getUnique tv) kind) []) }
1019 -- Same name as the tyvar, apart from making it start with a colon (sigh)
1020 -- I dread to think what will happen if this gets out into an
1021 -- interface file. Catastrophe likely. Major sigh.
1024 (args,res) = splitKindFunTys kind
1025 tup_tc = tupleTyCon Boxed (length args)
1027 msg = vcat [ hang (ptext (sLit "Inventing strangely-kinded Any TyCon"))
1028 2 (ptext (sLit "of kind") <+> quotes (ppr kind))
1029 , nest 2 (ptext (sLit "from an instantiation of type variable") <+> quotes (ppr tv))
1030 , ptext (sLit "This warning can be suppressed by a type signature fixing") <+> quotes (ppr tv)
1031 , nest 2 (ptext (sLit "but is harmless without -O (and usually harmless anyway)."))
1032 , ptext (sLit "See http://hackage.haskell.org/trac/ghc/ticket/959 for details") ]