Warning fix for unused and redundant imports
[ghc.git] / compiler / typecheck / TcHsSyn.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The AQUA Project, Glasgow University, 1996-1998
4 %
5
6 TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker
7
8 This module is an extension of @HsSyn@ syntax, for use in the type
9 checker.
10
11 \begin{code}
12 module TcHsSyn (
13         mkHsConApp, mkHsDictLet, mkHsApp,
14         hsLitType, hsLPatType, hsPatType, 
15         mkHsAppTy, mkSimpleHsAlt,
16         nlHsIntLit, mkVanillaTuplePat,
17         
18         mkArbitraryType,        -- Put this elsewhere?
19
20         -- re-exported from TcMonad
21         TcId, TcIdSet, TcDictBinds,
22
23         zonkTopDecls, zonkTopExpr, zonkTopLExpr,
24         zonkId, zonkTopBndrs
25   ) where
26
27 #include "HsVersions.h"
28
29 -- friends:
30 import HsSyn    -- oodles of it
31
32 -- others:
33 import Id
34
35 import TcRnMonad
36 import Type
37 import TcType
38 import TcMType
39 import TysPrim
40 import TysWiredIn
41 import TyCon
42 import Name
43 import Var
44 import VarSet
45 import VarEnv
46 import BasicTypes
47 import Maybes
48 import Unique
49 import SrcLoc
50 import Util
51 import Bag
52 import Outputable
53 \end{code}
54
55
56 %************************************************************************
57 %*                                                                      *
58 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
59 %*                                                                      *
60 %************************************************************************
61
62 Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
63 then something is wrong.
64 \begin{code}
65 mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
66 -- A vanilla tuple pattern simply gets its type from its sub-patterns
67 mkVanillaTuplePat pats box 
68   = TuplePat pats box (mkTupleTy box (length pats) (map hsLPatType pats))
69
70 hsLPatType :: OutPat Id -> Type
71 hsLPatType (L _ pat) = hsPatType pat
72
73 hsPatType (ParPat pat)              = hsLPatType pat
74 hsPatType (WildPat ty)              = ty
75 hsPatType (VarPat var)              = idType var
76 hsPatType (VarPatOut var _)         = idType var
77 hsPatType (BangPat pat)             = hsLPatType pat
78 hsPatType (LazyPat pat)             = hsLPatType pat
79 hsPatType (LitPat lit)              = hsLitType lit
80 hsPatType (AsPat var pat)           = idType (unLoc var)
81 hsPatType (ListPat _ ty)            = mkListTy ty
82 hsPatType (PArrPat _ ty)            = mkPArrTy ty
83 hsPatType (TuplePat pats box ty)    = ty
84 hsPatType (ConPatOut{ pat_ty = ty })= ty
85 hsPatType (SigPatOut pat ty)        = ty
86 hsPatType (NPat lit _ _ ty)         = ty
87 hsPatType (NPlusKPat id _ _ _)      = idType (unLoc id)
88 hsPatType (CoPat _ _ ty)            = ty
89 hsPatType (DictPat ds ms)           = case (ds ++ ms) of
90                                        []  -> unitTy
91                                        [d] -> idType d
92                                        ds  -> mkTupleTy Boxed (length ds) (map idType ds)
93
94
95 hsLitType :: HsLit -> TcType
96 hsLitType (HsChar c)       = charTy
97 hsLitType (HsCharPrim c)   = charPrimTy
98 hsLitType (HsString str)   = stringTy
99 hsLitType (HsStringPrim s) = addrPrimTy
100 hsLitType (HsInt i)        = intTy
101 hsLitType (HsIntPrim i)    = intPrimTy
102 hsLitType (HsInteger i ty) = ty
103 hsLitType (HsRat _ ty)     = ty
104 hsLitType (HsFloatPrim f)  = floatPrimTy
105 hsLitType (HsDoublePrim d) = doublePrimTy
106 \end{code}
107
108
109 %************************************************************************
110 %*                                                                      *
111 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
112 %*                                                                      *
113 %************************************************************************
114
115 \begin{code}
116 -- zonkId is used *during* typechecking just to zonk the Id's type
117 zonkId :: TcId -> TcM TcId
118 zonkId id
119   = zonkTcType (idType id) `thenM` \ ty' ->
120     returnM (Id.setIdType id ty')
121 \end{code}
122
123 The rest of the zonking is done *after* typechecking.
124 The main zonking pass runs over the bindings
125
126  a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
127  b) convert unbound TcTyVar to Void
128  c) convert each TcId to an Id by zonking its type
129
130 The type variables are converted by binding mutable tyvars to immutable ones
131 and then zonking as normal.
132
133 The Ids are converted by binding them in the normal Tc envt; that
134 way we maintain sharing; eg an Id is zonked at its binding site and they
135 all occurrences of that Id point to the common zonked copy
136
137 It's all pretty boring stuff, because HsSyn is such a large type, and 
138 the environment manipulation is tiresome.
139
140 \begin{code}
141 data ZonkEnv = ZonkEnv  (TcType -> TcM Type)    -- How to zonk a type
142                         (IdEnv Id)              -- What variables are in scope
143         -- Maps an Id to its zonked version; both have the same Name
144         -- Is only consulted lazily; hence knot-tying
145
146 emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
147
148 extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
149 extendZonkEnv (ZonkEnv zonk_ty env) ids 
150   = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
151
152 extendZonkEnv1 :: ZonkEnv -> Id -> ZonkEnv
153 extendZonkEnv1 (ZonkEnv zonk_ty env) id 
154   = ZonkEnv zonk_ty (extendVarEnv env id id)
155
156 setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
157 setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
158
159 zonkEnvIds :: ZonkEnv -> [Id]
160 zonkEnvIds (ZonkEnv _ env) = varEnvElts env
161
162 zonkIdOcc :: ZonkEnv -> TcId -> Id
163 -- Ids defined in this module should be in the envt; 
164 -- ignore others.  (Actually, data constructors are also
165 -- not LocalVars, even when locally defined, but that is fine.)
166 -- (Also foreign-imported things aren't currently in the ZonkEnv;
167 --  that's ok because they don't need zonking.)
168 --
169 -- Actually, Template Haskell works in 'chunks' of declarations, and
170 -- an earlier chunk won't be in the 'env' that the zonking phase 
171 -- carries around.  Instead it'll be in the tcg_gbl_env, already fully
172 -- zonked.  There's no point in looking it up there (except for error 
173 -- checking), and it's not conveniently to hand; hence the simple
174 -- 'orElse' case in the LocalVar branch.
175 --
176 -- Even without template splices, in module Main, the checking of
177 -- 'main' is done as a separate chunk.
178 zonkIdOcc (ZonkEnv zonk_ty env) id 
179   | isLocalVar id = lookupVarEnv env id `orElse` id
180   | otherwise     = id
181
182 zonkIdOccs env ids = map (zonkIdOcc env) ids
183
184 -- zonkIdBndr is used *after* typechecking to get the Id's type
185 -- to its final form.  The TyVarEnv give 
186 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
187 zonkIdBndr env id
188   = zonkTcTypeToType env (idType id)    `thenM` \ ty' ->
189     returnM (Id.setIdType id ty')
190
191 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
192 zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
193
194 zonkTopBndrs :: [TcId] -> TcM [Id]
195 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
196 \end{code}
197
198
199 \begin{code}
200 zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
201 zonkTopExpr e = zonkExpr emptyZonkEnv e
202
203 zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
204 zonkTopLExpr e = zonkLExpr emptyZonkEnv e
205
206 zonkTopDecls :: LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId]
207              -> TcM ([Id], 
208                      Bag (LHsBind  Id),
209                      [LForeignDecl Id],
210                      [LRuleDecl    Id])
211 zonkTopDecls binds rules fords
212   = do  { (env, binds') <- zonkRecMonoBinds emptyZonkEnv binds
213                         -- Top level is implicitly recursive
214         ; rules' <- zonkRules env rules
215         ; fords' <- zonkForeignExports env fords
216         ; return (zonkEnvIds env, binds', fords', rules') }
217
218 ---------------------------------------------
219 zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
220 zonkLocalBinds env EmptyLocalBinds
221   = return (env, EmptyLocalBinds)
222
223 zonkLocalBinds env (HsValBinds binds)
224   = do  { (env1, new_binds) <- zonkValBinds env binds
225         ; return (env1, HsValBinds new_binds) }
226
227 zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds))
228   = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds ->
229     let
230         env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
231     in
232     zonkRecMonoBinds env1 dict_binds    `thenM` \ (env2, new_dict_binds) -> 
233     returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
234   where
235     zonk_ip_bind (IPBind n e)
236         = mapIPNameTc (zonkIdBndr env) n        `thenM` \ n' ->
237           zonkLExpr env e                       `thenM` \ e' ->
238           returnM (IPBind n' e')
239
240
241 ---------------------------------------------
242 zonkValBinds :: ZonkEnv -> HsValBinds TcId -> TcM (ZonkEnv, HsValBinds Id)
243 zonkValBinds env bs@(ValBindsIn _ _) 
244   = panic "zonkValBinds"        -- Not in typechecker output
245 zonkValBinds env (ValBindsOut binds sigs) 
246   = do  { (env1, new_binds) <- go env binds
247         ; return (env1, ValBindsOut new_binds sigs) }
248   where
249     go env []         = return (env, [])
250     go env ((r,b):bs) = do { (env1, b')  <- zonkRecMonoBinds env b
251                            ; (env2, bs') <- go env1 bs
252                            ; return (env2, (r,b'):bs') }
253
254 ---------------------------------------------
255 zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
256 zonkRecMonoBinds env binds 
257  = fixM (\ ~(_, new_binds) -> do 
258         { let env1 = extendZonkEnv env (collectHsBindBinders new_binds)
259         ; binds' <- zonkMonoBinds env1 binds
260         ; return (env1, binds') })
261
262 ---------------------------------------------
263 zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
264 zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds
265
266 zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
267 zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
268   = do  { (_env, new_pat) <- zonkPat env pat            -- Env already extended
269         ; new_grhss <- zonkGRHSs env grhss
270         ; new_ty    <- zonkTcTypeToType env ty
271         ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
272
273 zonk_bind env (VarBind { var_id = var, var_rhs = expr })
274   = zonkIdBndr env var                  `thenM` \ new_var ->
275     zonkLExpr env expr                  `thenM` \ new_expr ->
276     returnM (VarBind { var_id = new_var, var_rhs = new_expr })
277
278 zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn })
279   = wrapLocM (zonkIdBndr env) var       `thenM` \ new_var ->
280     zonkCoFn env co_fn                  `thenM` \ (env1, new_co_fn) ->
281     zonkMatchGroup env1 ms              `thenM` \ new_ms ->
282     returnM (bind { fun_id = new_var, fun_matches = new_ms, fun_co_fn = new_co_fn })
283
284 zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts, 
285                           abs_exports = exports, abs_binds = val_binds })
286   = ASSERT( all isImmutableTyVar tyvars )
287     zonkIdBndrs env dicts               `thenM` \ new_dicts ->
288     fixM (\ ~(new_val_binds, _) ->
289         let
290           env1 = extendZonkEnv env new_dicts
291           env2 = extendZonkEnv env1 (collectHsBindBinders new_val_binds)
292         in
293         zonkMonoBinds env2 val_binds            `thenM` \ new_val_binds ->
294         mappM (zonkExport env2) exports         `thenM` \ new_exports ->
295         returnM (new_val_binds, new_exports)
296     )                                           `thenM` \ (new_val_bind, new_exports) ->
297     returnM (AbsBinds { abs_tvs = tyvars, abs_dicts = new_dicts, 
298                         abs_exports = new_exports, abs_binds = new_val_bind })
299   where
300     zonkExport env (tyvars, global, local, prags)
301         -- The tyvars are already zonked
302         = zonkIdBndr env global                 `thenM` \ new_global ->
303           mapM zonk_prag prags                  `thenM` \ new_prags -> 
304           returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
305     zonk_prag prag@(L _ (InlinePrag {}))  = return prag
306     zonk_prag (L loc (SpecPrag expr ty ds inl))
307         = do { expr' <- zonkExpr env expr 
308              ; ty'   <- zonkTcTypeToType env ty
309              ; let ds' = zonkIdOccs env ds
310              ; return (L loc (SpecPrag expr' ty' ds' inl)) }
311 \end{code}
312
313 %************************************************************************
314 %*                                                                      *
315 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
316 %*                                                                      *
317 %************************************************************************
318
319 \begin{code}
320 zonkMatchGroup :: ZonkEnv -> MatchGroup TcId-> TcM (MatchGroup Id)
321 zonkMatchGroup env (MatchGroup ms ty) 
322   = do  { ms' <- mapM (zonkMatch env) ms
323         ; ty' <- zonkTcTypeToType env ty
324         ; return (MatchGroup ms' ty') }
325
326 zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id)
327 zonkMatch env (L loc (Match pats _ grhss))
328   = do  { (env1, new_pats) <- zonkPats env pats
329         ; new_grhss <- zonkGRHSs env1 grhss
330         ; return (L loc (Match new_pats Nothing new_grhss)) }
331
332 -------------------------------------------------------------------------
333 zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id)
334
335 zonkGRHSs env (GRHSs grhss binds)
336   = zonkLocalBinds env binds    `thenM` \ (new_env, new_binds) ->
337     let
338         zonk_grhs (GRHS guarded rhs)
339           = zonkStmts new_env guarded   `thenM` \ (env2, new_guarded) ->
340             zonkLExpr env2 rhs          `thenM` \ new_rhs ->
341             returnM (GRHS new_guarded new_rhs)
342     in
343     mappM (wrapLocM zonk_grhs) grhss    `thenM` \ new_grhss ->
344     returnM (GRHSs new_grhss new_binds)
345 \end{code}
346
347 %************************************************************************
348 %*                                                                      *
349 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
350 %*                                                                      *
351 %************************************************************************
352
353 \begin{code}
354 zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
355 zonkLExpr  :: ZonkEnv -> LHsExpr TcId   -> TcM (LHsExpr Id)
356 zonkExpr   :: ZonkEnv -> HsExpr TcId    -> TcM (HsExpr Id)
357
358 zonkLExprs env exprs = mappM (zonkLExpr env) exprs
359 zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
360
361 zonkExpr env (HsVar id)
362   = returnM (HsVar (zonkIdOcc env id))
363
364 zonkExpr env (HsIPVar id)
365   = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
366
367 zonkExpr env (HsLit (HsRat f ty))
368   = zonkTcTypeToType env ty        `thenM` \ new_ty  ->
369     returnM (HsLit (HsRat f new_ty))
370
371 zonkExpr env (HsLit lit)
372   = returnM (HsLit lit)
373
374 zonkExpr env (HsOverLit lit)
375   = do  { lit' <- zonkOverLit env lit
376         ; return (HsOverLit lit') }
377
378 zonkExpr env (HsLam matches)
379   = zonkMatchGroup env matches  `thenM` \ new_matches ->
380     returnM (HsLam new_matches)
381
382 zonkExpr env (HsApp e1 e2)
383   = zonkLExpr env e1    `thenM` \ new_e1 ->
384     zonkLExpr env e2    `thenM` \ new_e2 ->
385     returnM (HsApp new_e1 new_e2)
386
387 zonkExpr env (HsBracketOut body bs) 
388   = mappM zonk_b bs     `thenM` \ bs' ->
389     returnM (HsBracketOut body bs')
390   where
391     zonk_b (n,e) = zonkLExpr env e      `thenM` \ e' ->
392                    returnM (n,e')
393
394 zonkExpr env (HsSpliceE s) = WARN( True, ppr s )        -- Should not happen
395                              returnM (HsSpliceE s)
396
397 zonkExpr env (OpApp e1 op fixity e2)
398   = zonkLExpr env e1    `thenM` \ new_e1 ->
399     zonkLExpr env op    `thenM` \ new_op ->
400     zonkLExpr env e2    `thenM` \ new_e2 ->
401     returnM (OpApp new_e1 new_op fixity new_e2)
402
403 zonkExpr env (NegApp expr op)
404   = zonkLExpr env expr  `thenM` \ new_expr ->
405     zonkExpr env op     `thenM` \ new_op ->
406     returnM (NegApp new_expr new_op)
407
408 zonkExpr env (HsPar e)    
409   = zonkLExpr env e     `thenM` \new_e ->
410     returnM (HsPar new_e)
411
412 zonkExpr env (SectionL expr op)
413   = zonkLExpr env expr  `thenM` \ new_expr ->
414     zonkLExpr env op            `thenM` \ new_op ->
415     returnM (SectionL new_expr new_op)
416
417 zonkExpr env (SectionR op expr)
418   = zonkLExpr env op            `thenM` \ new_op ->
419     zonkLExpr env expr          `thenM` \ new_expr ->
420     returnM (SectionR new_op new_expr)
421
422 zonkExpr env (HsCase expr ms)
423   = zonkLExpr env expr          `thenM` \ new_expr ->
424     zonkMatchGroup env ms       `thenM` \ new_ms ->
425     returnM (HsCase new_expr new_ms)
426
427 zonkExpr env (HsIf e1 e2 e3)
428   = zonkLExpr env e1    `thenM` \ new_e1 ->
429     zonkLExpr env e2    `thenM` \ new_e2 ->
430     zonkLExpr env e3    `thenM` \ new_e3 ->
431     returnM (HsIf new_e1 new_e2 new_e3)
432
433 zonkExpr env (HsLet binds expr)
434   = zonkLocalBinds env binds    `thenM` \ (new_env, new_binds) ->
435     zonkLExpr new_env expr      `thenM` \ new_expr ->
436     returnM (HsLet new_binds new_expr)
437
438 zonkExpr env (HsDo do_or_lc stmts body ty)
439   = zonkStmts env stmts         `thenM` \ (new_env, new_stmts) ->
440     zonkLExpr new_env body      `thenM` \ new_body ->
441     zonkTcTypeToType env ty     `thenM` \ new_ty   ->
442     returnM (HsDo (zonkDo env do_or_lc) 
443                   new_stmts new_body new_ty)
444
445 zonkExpr env (ExplicitList ty exprs)
446   = zonkTcTypeToType env ty     `thenM` \ new_ty ->
447     zonkLExprs env exprs        `thenM` \ new_exprs ->
448     returnM (ExplicitList new_ty new_exprs)
449
450 zonkExpr env (ExplicitPArr ty exprs)
451   = zonkTcTypeToType env ty     `thenM` \ new_ty ->
452     zonkLExprs env exprs        `thenM` \ new_exprs ->
453     returnM (ExplicitPArr new_ty new_exprs)
454
455 zonkExpr env (ExplicitTuple exprs boxed)
456   = zonkLExprs env exprs        `thenM` \ new_exprs ->
457     returnM (ExplicitTuple new_exprs boxed)
458
459 zonkExpr env (RecordCon data_con con_expr rbinds)
460   = zonkExpr env con_expr       `thenM` \ new_con_expr ->
461     zonkRbinds env rbinds       `thenM` \ new_rbinds ->
462     returnM (RecordCon data_con new_con_expr new_rbinds)
463
464 zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys)
465   = zonkLExpr env expr                  `thenM` \ new_expr ->
466     mapM (zonkTcTypeToType env) in_tys  `thenM` \ new_in_tys ->
467     mapM (zonkTcTypeToType env) out_tys `thenM` \ new_out_tys ->
468     zonkRbinds env rbinds               `thenM` \ new_rbinds ->
469     returnM (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys)
470
471 zonkExpr env (ExprWithTySigOut e ty) 
472   = do { e' <- zonkLExpr env e
473        ; return (ExprWithTySigOut e' ty) }
474
475 zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
476
477 zonkExpr env (ArithSeq expr info)
478   = zonkExpr env expr           `thenM` \ new_expr ->
479     zonkArithSeq env info       `thenM` \ new_info ->
480     returnM (ArithSeq new_expr new_info)
481
482 zonkExpr env (PArrSeq expr info)
483   = zonkExpr env expr           `thenM` \ new_expr ->
484     zonkArithSeq env info       `thenM` \ new_info ->
485     returnM (PArrSeq new_expr new_info)
486
487 zonkExpr env (HsSCC lbl expr)
488   = zonkLExpr env expr  `thenM` \ new_expr ->
489     returnM (HsSCC lbl new_expr)
490
491 zonkExpr env (HsTickPragma info expr)
492   = zonkLExpr env expr  `thenM` \ new_expr ->
493     returnM (HsTickPragma info new_expr)
494
495 -- hdaume: core annotations
496 zonkExpr env (HsCoreAnn lbl expr)
497   = zonkLExpr env expr   `thenM` \ new_expr ->
498     returnM (HsCoreAnn lbl new_expr)
499
500 -- arrow notation extensions
501 zonkExpr env (HsProc pat body)
502   = do  { (env1, new_pat) <- zonkPat env pat
503         ; new_body <- zonkCmdTop env1 body
504         ; return (HsProc new_pat new_body) }
505
506 zonkExpr env (HsArrApp e1 e2 ty ho rl)
507   = zonkLExpr env e1                    `thenM` \ new_e1 ->
508     zonkLExpr env e2                    `thenM` \ new_e2 ->
509     zonkTcTypeToType env ty             `thenM` \ new_ty ->
510     returnM (HsArrApp new_e1 new_e2 new_ty ho rl)
511
512 zonkExpr env (HsArrForm op fixity args)
513   = zonkLExpr env op                    `thenM` \ new_op ->
514     mappM (zonkCmdTop env) args         `thenM` \ new_args ->
515     returnM (HsArrForm new_op fixity new_args)
516
517 zonkExpr env (HsWrap co_fn expr)
518   = zonkCoFn env co_fn  `thenM` \ (env1, new_co_fn) ->
519     zonkExpr env1 expr  `thenM` \ new_expr ->
520     return (HsWrap new_co_fn new_expr)
521
522 zonkExpr env other = pprPanic "zonkExpr" (ppr other)
523
524 zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
525 zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
526
527 zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
528   = zonkLExpr env cmd                   `thenM` \ new_cmd ->
529     zonkTcTypeToTypes env stack_tys     `thenM` \ new_stack_tys ->
530     zonkTcTypeToType env ty             `thenM` \ new_ty ->
531     mapSndM (zonkExpr env) ids          `thenM` \ new_ids ->
532     returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
533
534 -------------------------------------------------------------------------
535 zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
536 zonkCoFn env WpHole = return (env, WpHole)
537 zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
538                                     ; (env2, c2') <- zonkCoFn env1 c2
539                                     ; return (env2, WpCompose c1' c2') }
540 zonkCoFn env (WpCo co)      = do { co' <- zonkTcTypeToType env co
541                                  ; return (env, WpCo co') }
542 zonkCoFn env (WpLam id)     = do { id' <- zonkIdBndr env id
543                                  ; let env1 = extendZonkEnv1 env id'
544                                  ; return (env1, WpLam id') }
545 zonkCoFn env (WpTyLam tv)   = ASSERT( isImmutableTyVar tv )
546                               do { return (env, WpTyLam tv) }
547 zonkCoFn env (WpApp id)     = do { return (env, WpApp (zonkIdOcc env id)) }
548 zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToType env ty
549                                  ; return (env, WpTyApp ty') }
550 zonkCoFn env (WpLet bs)     = do { (env1, bs') <- zonkRecMonoBinds env bs
551                                  ; return (env1, WpLet bs') }
552
553
554 -------------------------------------------------------------------------
555 zonkDo :: ZonkEnv -> HsStmtContext Name -> HsStmtContext Name
556 -- Only used for 'do', so the only Ids are in a MDoExpr table
557 zonkDo env (MDoExpr tbl) = MDoExpr (mapSnd (zonkIdOcc env) tbl)
558 zonkDo env do_or_lc      = do_or_lc
559
560 -------------------------------------------------------------------------
561 zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
562 zonkOverLit env (HsIntegral i e)
563   = do  { e' <- zonkExpr env e; return (HsIntegral i e') }
564 zonkOverLit env (HsFractional r e)
565   = do  { e' <- zonkExpr env e; return (HsFractional r e') }
566 zonkOverLit env (HsIsString s e)
567   = do  { e' <- zonkExpr env e; return (HsIsString s e') }
568
569 -------------------------------------------------------------------------
570 zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
571
572 zonkArithSeq env (From e)
573   = zonkLExpr env e             `thenM` \ new_e ->
574     returnM (From new_e)
575
576 zonkArithSeq env (FromThen e1 e2)
577   = zonkLExpr env e1    `thenM` \ new_e1 ->
578     zonkLExpr env e2    `thenM` \ new_e2 ->
579     returnM (FromThen new_e1 new_e2)
580
581 zonkArithSeq env (FromTo e1 e2)
582   = zonkLExpr env e1    `thenM` \ new_e1 ->
583     zonkLExpr env e2    `thenM` \ new_e2 ->
584     returnM (FromTo new_e1 new_e2)
585
586 zonkArithSeq env (FromThenTo e1 e2 e3)
587   = zonkLExpr env e1    `thenM` \ new_e1 ->
588     zonkLExpr env e2    `thenM` \ new_e2 ->
589     zonkLExpr env e3    `thenM` \ new_e3 ->
590     returnM (FromThenTo new_e1 new_e2 new_e3)
591
592
593 -------------------------------------------------------------------------
594 zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id])
595 zonkStmts env []     = return (env, [])
596 zonkStmts env (s:ss) = do { (env1, s')  <- wrapLocSndM (zonkStmt env) s
597                           ; (env2, ss') <- zonkStmts env1 ss
598                           ; return (env2, s' : ss') }
599
600 zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
601 zonkStmt env (ParStmt stmts_w_bndrs)
602   = mappM zonk_branch stmts_w_bndrs     `thenM` \ new_stmts_w_bndrs ->
603     let 
604         new_binders = concat (map snd new_stmts_w_bndrs)
605         env1 = extendZonkEnv env new_binders
606     in
607     return (env1, ParStmt new_stmts_w_bndrs)
608   where
609     zonk_branch (stmts, bndrs) = zonkStmts env stmts    `thenM` \ (env1, new_stmts) ->
610                                  returnM (new_stmts, zonkIdOccs env1 bndrs)
611
612 zonkStmt env (RecStmt segStmts lvs rvs rets binds)
613   = zonkIdBndrs env rvs         `thenM` \ new_rvs ->
614     let
615         env1 = extendZonkEnv env new_rvs
616     in
617     zonkStmts env1 segStmts     `thenM` \ (env2, new_segStmts) ->
618         -- Zonk the ret-expressions in an envt that 
619         -- has the polymorphic bindings in the envt
620     mapM (zonkExpr env2) rets   `thenM` \ new_rets ->
621     let
622         new_lvs = zonkIdOccs env2 lvs
623         env3 = extendZonkEnv env new_lvs        -- Only the lvs are needed
624     in
625     zonkRecMonoBinds env3 binds `thenM` \ (env4, new_binds) ->
626     returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets new_binds)
627
628 zonkStmt env (ExprStmt expr then_op ty)
629   = zonkLExpr env expr          `thenM` \ new_expr ->
630     zonkExpr env then_op        `thenM` \ new_then ->
631     zonkTcTypeToType env ty     `thenM` \ new_ty ->
632     returnM (env, ExprStmt new_expr new_then new_ty)
633
634 zonkStmt env (LetStmt binds)
635   = zonkLocalBinds env binds    `thenM` \ (env1, new_binds) ->
636     returnM (env1, LetStmt new_binds)
637
638 zonkStmt env (BindStmt pat expr bind_op fail_op)
639   = do  { new_expr <- zonkLExpr env expr
640         ; (env1, new_pat) <- zonkPat env pat
641         ; new_bind <- zonkExpr env bind_op
642         ; new_fail <- zonkExpr env fail_op
643         ; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
644
645
646 -------------------------------------------------------------------------
647 zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id)
648
649 zonkRbinds env (HsRecordBinds rbinds)
650   = mappM zonk_rbind rbinds >>= return . HsRecordBinds
651   where
652     zonk_rbind (field, expr)
653       = zonkLExpr env expr      `thenM` \ new_expr ->
654         returnM (fmap (zonkIdOcc env) field, new_expr)
655
656 -------------------------------------------------------------------------
657 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
658 mapIPNameTc f (IPName n) = f n  `thenM` \ r -> returnM (IPName r)
659 \end{code}
660
661
662 %************************************************************************
663 %*                                                                      *
664 \subsection[BackSubst-Pats]{Patterns}
665 %*                                                                      *
666 %************************************************************************
667
668 \begin{code}
669 zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
670 -- Extend the environment as we go, because it's possible for one
671 -- pattern to bind something that is used in another (inside or
672 -- to the right)
673 zonkPat env pat = wrapLocSndM (zonk_pat env) pat
674
675 zonk_pat env (ParPat p)
676   = do  { (env', p') <- zonkPat env p
677         ; return (env', ParPat p') }
678
679 zonk_pat env (WildPat ty)
680   = do  { ty' <- zonkTcTypeToType env ty
681         ; return (env, WildPat ty') }
682
683 zonk_pat env (VarPat v)
684   = do  { v' <- zonkIdBndr env v
685         ; return (extendZonkEnv1 env v', VarPat v') }
686
687 zonk_pat env (VarPatOut v binds)
688   = do  { v' <- zonkIdBndr env v
689         ; (env', binds') <- zonkRecMonoBinds (extendZonkEnv1 env v') binds
690         ; returnM (env', VarPatOut v' binds') }
691
692 zonk_pat env (LazyPat pat)
693   = do  { (env', pat') <- zonkPat env pat
694         ; return (env',  LazyPat pat') }
695
696 zonk_pat env (BangPat pat)
697   = do  { (env', pat') <- zonkPat env pat
698         ; return (env',  BangPat pat') }
699
700 zonk_pat env (AsPat (L loc v) pat)
701   = do  { v' <- zonkIdBndr env v
702         ; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
703         ; return (env', AsPat (L loc v') pat') }
704
705 zonk_pat env (ListPat pats ty)
706   = do  { ty' <- zonkTcTypeToType env ty
707         ; (env', pats') <- zonkPats env pats
708         ; return (env', ListPat pats' ty') }
709
710 zonk_pat env (PArrPat pats ty)
711   = do  { ty' <- zonkTcTypeToType env ty
712         ; (env', pats') <- zonkPats env pats
713         ; return (env', PArrPat pats' ty') }
714
715 zonk_pat env (TuplePat pats boxed ty)
716   = do  { ty' <- zonkTcTypeToType env ty
717         ; (env', pats') <- zonkPats env pats
718         ; return (env', TuplePat pats' boxed ty') }
719
720 zonk_pat env p@(ConPatOut { pat_ty = ty, pat_dicts = dicts, pat_binds = binds, pat_args = args })
721   = ASSERT( all isImmutableTyVar (pat_tvs p) ) 
722     do  { new_ty <- zonkTcTypeToType env ty
723         ; new_dicts <- zonkIdBndrs env dicts
724         ; let env1 = extendZonkEnv env new_dicts
725         ; (env2, new_binds) <- zonkRecMonoBinds env1 binds
726         ; (env', new_args) <- zonkConStuff env2 args
727         ; returnM (env', p { pat_ty = new_ty, pat_dicts = new_dicts, 
728                              pat_binds = new_binds, pat_args = new_args }) }
729
730 zonk_pat env (LitPat lit) = return (env, LitPat lit)
731
732 zonk_pat env (SigPatOut pat ty)
733   = do  { ty' <- zonkTcTypeToType env ty
734         ; (env', pat') <- zonkPat env pat
735         ; return (env', SigPatOut pat' ty') }
736
737 zonk_pat env (NPat lit mb_neg eq_expr ty)
738   = do  { lit' <- zonkOverLit env lit
739         ; mb_neg' <- case mb_neg of
740                         Nothing  -> return Nothing
741                         Just neg -> do { neg' <- zonkExpr env neg
742                                        ; return (Just neg') }
743         ; eq_expr' <- zonkExpr env eq_expr
744         ; ty' <- zonkTcTypeToType env ty
745         ; return (env, NPat lit' mb_neg' eq_expr' ty') }
746
747 zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
748   = do  { n' <- zonkIdBndr env n
749         ; lit' <- zonkOverLit env lit
750         ; e1' <- zonkExpr env e1
751         ; e2' <- zonkExpr env e2
752         ; return (extendZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
753
754 zonk_pat env (DictPat ds ms)
755   = do  { ds' <- zonkIdBndrs env ds
756         ; ms' <- zonkIdBndrs env ms
757         ; return (extendZonkEnv env (ds' ++ ms'), DictPat ds' ms') }
758
759 zonk_pat env (CoPat co_fn pat ty) 
760   = do { (env', co_fn') <- zonkCoFn env co_fn
761        ; (env'', pat') <- zonkPat env' (noLoc pat)
762        ; ty' <- zonkTcTypeToType env'' ty
763        ; return (env'', CoPat co_fn' (unLoc pat') ty') }
764
765 zonk_pat env pat = pprPanic "zonk_pat" (ppr pat)
766
767 ---------------------------
768 zonkConStuff env (PrefixCon pats)
769   = do  { (env', pats') <- zonkPats env pats
770         ; return (env', PrefixCon pats') }
771
772 zonkConStuff env (InfixCon p1 p2)
773   = do  { (env1, p1') <- zonkPat env  p1
774         ; (env', p2') <- zonkPat env1 p2
775         ; return (env', InfixCon p1' p2') }
776
777 zonkConStuff env (RecCon rpats)
778   = do  { let (fields, pats) = unzip [ (f, p) | HsRecField f p _  <- rpats ]
779         ; (env', pats') <- zonkPats env pats
780         ; let recCon = RecCon [ mkRecField f p | (f, p) <- zip fields pats' ]
781         ; returnM (env', recCon) }
782
783 ---------------------------
784 zonkPats env []         = return (env, [])
785 zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
786                      ; (env', pats') <- zonkPats env1 pats
787                      ; return (env', pat':pats') }
788 \end{code}
789
790 %************************************************************************
791 %*                                                                      *
792 \subsection[BackSubst-Foreign]{Foreign exports}
793 %*                                                                      *
794 %************************************************************************
795
796
797 \begin{code}
798 zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
799 zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
800
801 zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
802 zonkForeignExport env (ForeignExport i hs_ty spec) =
803    returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec)
804 zonkForeignExport env for_imp 
805   = returnM for_imp     -- Foreign imports don't need zonking
806 \end{code}
807
808 \begin{code}
809 zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
810 zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
811
812 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
813 zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs fv_lhs rhs fv_rhs)
814   = mappM zonk_bndr vars                `thenM` \ new_bndrs ->
815     newMutVar emptyVarSet               `thenM` \ unbound_tv_set ->
816     let
817         env_rhs = extendZonkEnv env [id | b <- new_bndrs, let id = unLoc b, isId id]
818         -- Type variables don't need an envt
819         -- They are bound through the mutable mechanism
820
821         env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
822         -- We need to gather the type variables mentioned on the LHS so we can 
823         -- quantify over them.  Example:
824         --   data T a = C
825         -- 
826         --   foo :: T a -> Int
827         --   foo C = 1
828         --
829         --   {-# RULES "myrule"  foo C = 1 #-}
830         -- 
831         -- After type checking the LHS becomes (foo a (C a))
832         -- and we do not want to zap the unbound tyvar 'a' to (), because
833         -- that limits the applicability of the rule.  Instead, we
834         -- want to quantify over it!  
835         --
836         -- It's easiest to find the free tyvars here. Attempts to do so earlier
837         -- are tiresome, because (a) the data type is big and (b) finding the 
838         -- free type vars of an expression is necessarily monadic operation.
839         --      (consider /\a -> f @ b, where b is side-effected to a)
840     in
841     zonkLExpr env_lhs lhs               `thenM` \ new_lhs ->
842     zonkLExpr env_rhs rhs               `thenM` \ new_rhs ->
843
844     readMutVar unbound_tv_set           `thenM` \ unbound_tvs ->
845     let
846         final_bndrs :: [Located Var]
847         final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs
848     in
849     returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs fv_lhs new_rhs fv_rhs)
850                 -- I hate this map RuleBndr stuff
851   where
852    zonk_bndr (RuleBndr v) 
853         | isId (unLoc v) = wrapLocM (zonkIdBndr env)   v
854         | otherwise      = ASSERT( isImmutableTyVar (unLoc v) )
855                            return v
856 \end{code}
857
858
859 %************************************************************************
860 %*                                                                      *
861 \subsection[BackSubst-Foreign]{Foreign exports}
862 %*                                                                      *
863 %************************************************************************
864
865 \begin{code}
866 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
867 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
868
869 zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
870 zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
871
872 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
873 -- This variant collects unbound type variables in a mutable variable
874 zonkTypeCollecting unbound_tv_set
875   = zonkType zonk_unbound_tyvar
876   where
877     zonk_unbound_tyvar tv 
878         = zonkQuantifiedTyVar tv                                `thenM` \ tv' ->
879           readMutVar unbound_tv_set                             `thenM` \ tv_set ->
880           writeMutVar unbound_tv_set (extendVarSet tv_set tv')  `thenM_`
881           return (mkTyVarTy tv')
882
883 zonkTypeZapping :: TcType -> TcM Type
884 -- This variant is used for everything except the LHS of rules
885 -- It zaps unbound type variables to (), or some other arbitrary type
886 zonkTypeZapping ty 
887   = zonkType zonk_unbound_tyvar ty 
888   where
889         -- Zonk a mutable but unbound type variable to an arbitrary type
890         -- We know it's unbound even though we don't carry an environment,
891         -- because at the binding site for a type variable we bind the
892         -- mutable tyvar to a fresh immutable one.  So the mutable store
893         -- plays the role of an environment.  If we come across a mutable
894         -- type variable that isn't so bound, it must be completely free.
895     zonk_unbound_tyvar tv = do { writeMetaTyVar tv ty; return ty }
896                           where 
897                             ty = mkArbitraryType tv
898
899
900 -- When the type checker finds a type variable with no binding,
901 -- which means it can be instantiated with an arbitrary type, it
902 -- usually instantiates it to Void.  Eg.
903 -- 
904 --      length []
905 -- ===>
906 --      length Void (Nil Void)
907 -- 
908 -- But in really obscure programs, the type variable might have
909 -- a kind other than *, so we need to invent a suitably-kinded type.
910 -- 
911 -- This commit uses
912 --      Void for kind *
913 --      List for kind *->*
914 --      Tuple for kind *->...*->*
915 -- 
916 -- which deals with most cases.  (Previously, it only dealt with
917 -- kind *.)   
918 -- 
919 -- In the other cases, it just makes up a TyCon with a suitable
920 -- kind.  If this gets into an interface file, anyone reading that
921 -- file won't understand it.  This is fixable (by making the client
922 -- of the interface file make up a TyCon too) but it is tiresome and
923 -- never happens, so I am leaving it 
924
925 mkArbitraryType :: TcTyVar -> Type
926 -- Make up an arbitrary type whose kind is the same as the tyvar.
927 -- We'll use this to instantiate the (unbound) tyvar.
928 mkArbitraryType tv 
929   | liftedTypeKind `isSubKind` kind = anyPrimTy         -- The vastly common case
930   | otherwise                       = mkTyConApp tycon []
931   where
932     kind       = tyVarKind tv
933     (args,res) = splitKindFunTys kind
934
935     tycon | eqKind kind (tyConKind anyPrimTyCon1)       --  *->*
936           = anyPrimTyCon1                               -- No tuples this size
937
938           | all isLiftedTypeKind args && isLiftedTypeKind res
939           = tupleTyCon Boxed (length args)      --  *-> ... ->*->*
940                 -- Horrible hack to make less use of mkAnyPrimTyCon
941
942           | otherwise
943           = mkAnyPrimTyCon (getUnique tv) kind
944                 -- Same name as the tyvar, apart from making it start with a colon (sigh)
945                 -- I dread to think what will happen if this gets out into an 
946                 -- interface file.  Catastrophe likely.  Major sigh.
947 \end{code}