compiler/typecheck/TcHsSyn.lhs

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