ghc/compiler/typecheck/TcHsSyn.lhs

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