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