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