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