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