compiler/typecheck/TcHsSyn.lhs

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