compiler/typecheck/TcHsSyn.lhs

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