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}