compiler/typecheck/TcHsSyn.lhs

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