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