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