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 (ExprWithTySigOut e ty)
 486   = do { e' <- zonkLExpr env e
 487        ; return (ExprWithTySigOut e' ty) }
 488
 489 zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
 490 zonkExpr env (ArithSeqIn _)      = panic "zonkExpr env:ArithSeqIn"
 491 zonkExpr env (PArrSeqIn _)       = panic "zonkExpr env:PArrSeqIn"
 492
 493 zonkExpr env (ArithSeqOut expr info)
 494   = zonkLExpr env expr          `thenM` \ new_expr ->
 495     zonkArithSeq env info       `thenM` \ new_info ->
 496     returnM (ArithSeqOut new_expr new_info)
 497
 498 zonkExpr env (PArrSeqOut expr info)
 499   = zonkLExpr env expr          `thenM` \ new_expr ->
 500     zonkArithSeq env info       `thenM` \ new_info ->
 501     returnM (PArrSeqOut new_expr new_info)
 502
 503 zonkExpr env (HsSCC lbl expr)
 504   = zonkLExpr env expr  `thenM` \ new_expr ->
 505     returnM (HsSCC lbl new_expr)
 506
 507 -- hdaume: core annotations
 508 zonkExpr env (HsCoreAnn lbl expr)
 509   = zonkLExpr env expr   `thenM` \ new_expr ->
 510     returnM (HsCoreAnn lbl new_expr)
 511
 512 zonkExpr env (TyLam tyvars expr)
 513   = mappM zonkTcTyVarToTyVar tyvars     `thenM` \ new_tyvars ->
 514         -- No need to extend tyvar env; see AbsBinds
 515
 516     zonkLExpr env expr                  `thenM` \ new_expr ->
 517     returnM (TyLam new_tyvars new_expr)
 518
 519 zonkExpr env (TyApp expr tys)
 520   = zonkLExpr env expr                  `thenM` \ new_expr ->
 521     mappM (zonkTcTypeToType env) tys    `thenM` \ new_tys ->
 522     returnM (TyApp new_expr new_tys)
 523
 524 zonkExpr env (DictLam dicts expr)
 525   = zonkIdBndrs env dicts       `thenM` \ new_dicts ->
 526     let
 527         env1 = extendZonkEnv env new_dicts
 528     in
 529     zonkLExpr env1 expr         `thenM` \ new_expr ->
 530     returnM (DictLam new_dicts new_expr)
 531
 532 zonkExpr env (DictApp expr dicts)
 533   = zonkLExpr env expr                  `thenM` \ new_expr ->
 534     returnM (DictApp new_expr (zonkIdOccs env dicts))
 535
 536 -- arrow notation extensions
 537 zonkExpr env (HsProc pat body)
 538   = zonkPat env pat                     `thenM` \ (new_pat, new_ids) ->
 539     let
 540         env1 = extendZonkEnv env (bagToList new_ids)
 541     in
 542     zonkCmdTop env1 body                `thenM` \ new_body ->
 543     returnM (HsProc new_pat new_body)
 544
 545 zonkExpr env (HsArrApp e1 e2 ty ho rl)
 546   = zonkLExpr env e1                    `thenM` \ new_e1 ->
 547     zonkLExpr env e2                    `thenM` \ new_e2 ->
 548     zonkTcTypeToType env ty             `thenM` \ new_ty ->
 549     returnM (HsArrApp new_e1 new_e2 new_ty ho rl)
 550
 551 zonkExpr env (HsArrForm op fixity args)
 552   = zonkLExpr env op                    `thenM` \ new_op ->
 553     mappM (zonkCmdTop env) args         `thenM` \ new_args ->
 554     returnM (HsArrForm new_op fixity new_args)
 555
 556 zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
 557 zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
 558
 559 zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
 560   = zonkLExpr env cmd                   `thenM` \ new_cmd ->
 561     mappM (zonkTcTypeToType env) stack_tys
 562                                         `thenM` \ new_stack_tys ->
 563     zonkTcTypeToType env ty             `thenM` \ new_ty ->
 564     zonkReboundNames env ids            `thenM` \ new_ids ->
 565     returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
 566
 567 -------------------------------------------------------------------------
 568 zonkReboundNames :: ZonkEnv -> ReboundNames Id -> TcM (ReboundNames Id)
 569 zonkReboundNames env prs
 570   = mapM zonk prs
 571   where
 572     zonk (n, e) = zonkExpr env e `thenM` \ new_e ->
 573                   returnM (n, new_e)
 574
 575
 576 -------------------------------------------------------------------------
 577 zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
 578
 579 zonkArithSeq env (From e)
 580   = zonkLExpr env e             `thenM` \ new_e ->
 581     returnM (From new_e)
 582
 583 zonkArithSeq env (FromThen e1 e2)
 584   = zonkLExpr env e1    `thenM` \ new_e1 ->
 585     zonkLExpr env e2    `thenM` \ new_e2 ->
 586     returnM (FromThen new_e1 new_e2)
 587
 588 zonkArithSeq env (FromTo e1 e2)
 589   = zonkLExpr env e1    `thenM` \ new_e1 ->
 590     zonkLExpr env e2    `thenM` \ new_e2 ->
 591     returnM (FromTo new_e1 new_e2)
 592
 593 zonkArithSeq env (FromThenTo e1 e2 e3)
 594   = zonkLExpr env e1    `thenM` \ new_e1 ->
 595     zonkLExpr env e2    `thenM` \ new_e2 ->
 596     zonkLExpr env e3    `thenM` \ new_e3 ->
 597     returnM (FromThenTo new_e1 new_e2 new_e3)
 598
 599
 600 -------------------------------------------------------------------------
 601 zonkStmts  :: ZonkEnv -> [LStmt TcId] -> TcM [LStmt Id]
 602
 603 zonkStmts env stmts = zonk_stmts env stmts      `thenM` \ (_, stmts) ->
 604                       returnM stmts
 605
 606 zonk_stmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id])
 607 zonk_stmts env []     = return (env, [])
 608 zonk_stmts env (s:ss) = do { (env1, s')  <- wrapLocSndM (zonkStmt env) s
 609                            ; (env2, ss') <- zonk_stmts env1 ss
 610                            ; return (env2, s' : ss') }
 611
 612 zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
 613 zonkStmt env (ParStmt stmts_w_bndrs)
 614   = mappM zonk_branch stmts_w_bndrs     `thenM` \ new_stmts_w_bndrs ->
 615     let
 616         new_binders = concat (map snd new_stmts_w_bndrs)
 617         env1 = extendZonkEnv env new_binders
 618     in
 619     return (env1, ParStmt new_stmts_w_bndrs)
 620   where
 621     zonk_branch (stmts, bndrs) = zonk_stmts env stmts   `thenM` \ (env1, new_stmts) ->
 622                                  returnM (new_stmts, zonkIdOccs env1 bndrs)
 623
 624 zonkStmt env (RecStmt segStmts lvs rvs rets)
 625   = zonkIdBndrs env rvs         `thenM` \ new_rvs ->
 626     let
 627         env1 = extendZonkEnv env new_rvs
 628     in
 629     zonk_stmts env1 segStmts    `thenM` \ (env2, new_segStmts) ->
 630         -- Zonk the ret-expressions in an envt that
 631         -- has the polymorphic bindings in the envt
 632     zonkLExprs env2 rets        `thenM` \ new_rets ->
 633     let
 634         new_lvs = zonkIdOccs env2 lvs
 635         env3 = extendZonkEnv env new_lvs        -- Only the lvs are needed
 636     in
 637     returnM (env3, RecStmt new_segStmts new_lvs new_rvs new_rets)
 638
 639 zonkStmt env (ResultStmt expr)
 640   = zonkLExpr env expr  `thenM` \ new_expr ->
 641     returnM (env, ResultStmt new_expr)
 642
 643 zonkStmt env (ExprStmt expr ty)
 644   = zonkLExpr env expr          `thenM` \ new_expr ->
 645     zonkTcTypeToType env ty     `thenM` \ new_ty ->
 646     returnM (env, ExprStmt new_expr new_ty)
 647
 648 zonkStmt env (LetStmt binds)
 649   = zonkNestedBinds env binds   `thenM` \ (env1, new_binds) ->
 650     returnM (env1, LetStmt new_binds)
 651
 652 zonkStmt env (BindStmt pat expr)
 653   = zonkLExpr env expr                  `thenM` \ new_expr ->
 654     zonkPat env pat                     `thenM` \ (new_pat, new_ids) ->
 655     let
 656         env1 = extendZonkEnv env (bagToList new_ids)
 657     in
 658     returnM (env1, BindStmt new_pat new_expr)
 659
 660
 661
 662 -------------------------------------------------------------------------
 663 zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id)
 664
 665 zonkRbinds env rbinds
 666   = mappM zonk_rbind rbinds
 667   where
 668     zonk_rbind (field, expr)
 669       = zonkLExpr env expr      `thenM` \ new_expr ->
 670         returnM (fmap (zonkIdOcc env) field, new_expr)
 671
 672 -------------------------------------------------------------------------
 673 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
 674 mapIPNameTc f (Dupable n) = f n  `thenM` \ r -> returnM (Dupable r)
 675 mapIPNameTc f (Linear  n) = f n  `thenM` \ r -> returnM (Linear r)
 676 \end{code}
 677
 678
 679 %************************************************************************
 680 %*                                                                      *
 681 \subsection[BackSubst-Pats]{Patterns}
 682 %*                                                                      *
 683 %************************************************************************
 684
 685 \begin{code}
 686 zonkPat :: ZonkEnv -> OutPat TcId -> TcM (OutPat Id, Bag Id)
 687 zonkPat env pat = wrapLocFstM (zonk_pat env) pat
 688
 689 zonk_pat env (ParPat p)
 690   = zonkPat env p       `thenM` \ (new_p, ids) ->
 691     returnM (ParPat new_p, ids)
 692
 693 zonk_pat env (WildPat ty)
 694   = zonkTcTypeToType env ty   `thenM` \ new_ty ->
 695     returnM (WildPat new_ty, emptyBag)
 696
 697 zonk_pat env (VarPat v)
 698   = zonkIdBndr env v        `thenM` \ new_v ->
 699     returnM (VarPat new_v, unitBag new_v)
 700
 701 zonk_pat env (LazyPat pat)
 702   = zonkPat env pat         `thenM` \ (new_pat, ids) ->
 703     returnM (LazyPat new_pat, ids)
 704
 705 zonk_pat env (AsPat n pat)
 706   = wrapLocM (zonkIdBndr env) n `thenM` \ new_n ->
 707     zonkPat env pat             `thenM` \ (new_pat, ids) ->
 708     returnM (AsPat new_n new_pat, unLoc new_n `consBag` ids)
 709
 710 zonk_pat env (ListPat pats ty)
 711   = zonkTcTypeToType env ty     `thenM` \ new_ty ->
 712     zonkPats env pats           `thenM` \ (new_pats, ids) ->
 713     returnM (ListPat new_pats new_ty, ids)
 714
 715 zonk_pat env (PArrPat pats ty)
 716   = zonkTcTypeToType env ty     `thenM` \ new_ty ->
 717     zonkPats env pats           `thenM` \ (new_pats, ids) ->
 718     returnM (PArrPat new_pats new_ty, ids)
 719
 720 zonk_pat env (TuplePat pats boxed)
 721   = zonkPats env pats                   `thenM` \ (new_pats, ids) ->
 722     returnM (TuplePat new_pats boxed, ids)
 723
 724 zonk_pat env (ConPatOut n stuff ty tvs dicts)
 725   = zonkTcTypeToType env ty             `thenM` \ new_ty ->
 726     mappM zonkTcTyVarToTyVar tvs        `thenM` \ new_tvs ->
 727     zonkIdBndrs env dicts               `thenM` \ new_dicts ->
 728     let
 729         env1 = extendZonkEnv env new_dicts
 730     in
 731     zonkConStuff env1 stuff             `thenM` \ (new_stuff, ids) ->
 732     returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts,
 733                  listToBag new_dicts `unionBags` ids)
 734
 735 zonk_pat env (LitPat lit) = returnM (LitPat lit, emptyBag)
 736
 737 zonk_pat env (SigPatOut pat ty expr)
 738   = zonkPat env pat             `thenM` \ (new_pat, ids) ->
 739     zonkTcTypeToType env ty     `thenM` \ new_ty  ->
 740     zonkExpr env expr           `thenM` \ new_expr ->
 741     returnM (SigPatOut new_pat new_ty new_expr, ids)
 742
 743 zonk_pat env (NPatOut lit ty expr)
 744   = zonkTcTypeToType env ty     `thenM` \ new_ty   ->
 745     zonkExpr env expr           `thenM` \ new_expr ->
 746     returnM (NPatOut lit new_ty new_expr, emptyBag)
 747
 748 zonk_pat env (NPlusKPatOut n k e1 e2)
 749   = wrapLocM (zonkIdBndr env) n         `thenM` \ new_n ->
 750     zonkExpr env e1                     `thenM` \ new_e1 ->
 751     zonkExpr env e2                     `thenM` \ new_e2 ->
 752     returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag (unLoc new_n))
 753
 754 zonk_pat env (DictPat ds ms)
 755   = zonkIdBndrs env ds      `thenM` \ new_ds ->
 756     zonkIdBndrs env ms     `thenM` \ new_ms ->
 757     returnM (DictPat new_ds new_ms,
 758                  listToBag new_ds `unionBags` listToBag new_ms)
 759
 760 ---------------------------
 761 zonkConStuff env (PrefixCon pats)
 762   = zonkPats env pats           `thenM` \ (new_pats, ids) ->
 763     returnM (PrefixCon new_pats, ids)
 764
 765 zonkConStuff env (InfixCon p1 p2)
 766   = zonkPat env p1              `thenM` \ (new_p1, ids1) ->
 767     zonkPat env p2              `thenM` \ (new_p2, ids2) ->
 768     returnM (InfixCon new_p1 new_p2, ids1 `unionBags` ids2)
 769
 770 zonkConStuff env (RecCon rpats)
 771   = mapAndUnzipM zonk_rpat rpats        `thenM` \ (new_rpats, ids_s) ->
 772     returnM (RecCon new_rpats, unionManyBags ids_s)
 773   where
 774     zonk_rpat (f, pat)
 775       = zonkPat env pat         `thenM` \ (new_pat, ids) ->
 776         returnM ((f, new_pat), ids)
 777
 778 ---------------------------
 779 zonkPats env []
 780   = returnM ([], emptyBag)
 781
 782 zonkPats env (pat:pats)
 783   = zonkPat env pat     `thenM` \ (pat',  ids1) ->
 784     zonkPats env pats   `thenM` \ (pats', ids2) ->
 785     returnM (pat':pats', ids1 `unionBags` ids2)
 786 \end{code}
 787
 788 %************************************************************************
 789 %*                                                                      *
 790 \subsection[BackSubst-Foreign]{Foreign exports}
 791 %*                                                                      *
 792 %************************************************************************
 793
 794
 795 \begin{code}
 796 zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
 797 zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
 798
 799 zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
 800 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec) =
 801    returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec isDeprec)
 802 zonkForeignExport env for_imp
 803   = returnM for_imp     -- Foreign imports don't need zonking
 804 \end{code}
 805
 806 \begin{code}
 807 zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
 808 zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
 809
 810 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
 811 zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs rhs)
 812   = mappM zonk_bndr vars                `thenM` \ new_bndrs ->
 813     newMutVar emptyVarSet               `thenM` \ unbound_tv_set ->
 814     let
 815         env_rhs = extendZonkEnv env [id | b <- new_bndrs, let id = unLoc b, isId id]
 816         -- Type variables don't need an envt
 817         -- They are bound through the mutable mechanism
 818
 819         env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
 820         -- We need to gather the type variables mentioned on the LHS so we can
 821         -- quantify over them.  Example:
 822         --   data T a = C
 823         --
 824         --   foo :: T a -> Int
 825         --   foo C = 1
 826         --
 827         --   {-# RULES "myrule"  foo C = 1 #-}
 828         --
 829         -- After type checking the LHS becomes (foo a (C a))
 830         -- and we do not want to zap the unbound tyvar 'a' to (), because
 831         -- that limits the applicability of the rule.  Instead, we
 832         -- want to quantify over it!
 833         --
 834         -- It's easiest to find the free tyvars here. Attempts to do so earlier
 835         -- are tiresome, because (a) the data type is big and (b) finding the
 836         -- free type vars of an expression is necessarily monadic operation.
 837         --      (consider /\a -> f @ b, where b is side-effected to a)
 838     in
 839     zonkLExpr env_lhs lhs               `thenM` \ new_lhs ->
 840     zonkLExpr env_rhs rhs               `thenM` \ new_rhs ->
 841
 842     readMutVar unbound_tv_set           `thenM` \ unbound_tvs ->
 843     let
 844         final_bndrs :: [Located Var]
 845         final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs
 846     in
 847     returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs new_rhs)
 848                 -- I hate this map RuleBndr stuff
 849   where
 850    zonk_bndr (RuleBndr v)
 851         | isId (unLoc v) = wrapLocM (zonkIdBndr env)   v
 852         | otherwise      = wrapLocM zonkTcTyVarToTyVar v
 853 \end{code}
 854
 855
 856 %************************************************************************
 857 %*                                                                      *
 858 \subsection[BackSubst-Foreign]{Foreign exports}
 859 %*                                                                      *
 860 %************************************************************************
 861
 862 \begin{code}
 863 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
 864 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
 865
 866 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
 867 -- This variant collects unbound type variables in a mutable variable
 868 zonkTypeCollecting unbound_tv_set
 869   = zonkType zonk_unbound_tyvar
 870   where
 871     zonk_unbound_tyvar tv
 872         = zonkTcTyVarToTyVar tv                                 `thenM` \ tv' ->
 873           readMutVar unbound_tv_set                             `thenM` \ tv_set ->
 874           writeMutVar unbound_tv_set (extendVarSet tv_set tv')  `thenM_`
 875           return (mkTyVarTy tv')
 876
 877 zonkTypeZapping :: TcType -> TcM Type
 878 -- This variant is used for everything except the LHS of rules
 879 -- It zaps unbound type variables to (), or some other arbitrary type
 880 zonkTypeZapping ty
 881   = zonkType zonk_unbound_tyvar ty
 882   where
 883         -- Zonk a mutable but unbound type variable to an arbitrary type
 884         -- We know it's unbound even though we don't carry an environment,
 885         -- because at the binding site for a type variable we bind the
 886         -- mutable tyvar to a fresh immutable one.  So the mutable store
 887         -- plays the role of an environment.  If we come across a mutable
 888         -- type variable that isn't so bound, it must be completely free.
 889     zonk_unbound_tyvar tv = putTcTyVar tv (mkArbitraryType tv)
 890
 891
 892 -- When the type checker finds a type variable with no binding,
 893 -- which means it can be instantiated with an arbitrary type, it
 894 -- usually instantiates it to Void.  Eg.
 895 --
 896 --      length []
 897 -- ===>
 898 --      length Void (Nil Void)
 899 --
 900 -- But in really obscure programs, the type variable might have
 901 -- a kind other than *, so we need to invent a suitably-kinded type.
 902 --
 903 -- This commit uses
 904 --      Void for kind *
 905 --      List for kind *->*
 906 --      Tuple for kind *->...*->*
 907 --
 908 -- which deals with most cases.  (Previously, it only dealt with
 909 -- kind *.)
 910 --
 911 -- In the other cases, it just makes up a TyCon with a suitable
 912 -- kind.  If this gets into an interface file, anyone reading that
 913 -- file won't understand it.  This is fixable (by making the client
 914 -- of the interface file make up a TyCon too) but it is tiresome and
 915 -- never happens, so I am leaving it
 916
 917 mkArbitraryType :: TcTyVar -> Type
 918 -- Make up an arbitrary type whose kind is the same as the tyvar.
 919 -- We'll use this to instantiate the (unbound) tyvar.
 920 mkArbitraryType tv
 921   | liftedTypeKind `isSubKind` kind = voidTy            -- The vastly common case
 922   | otherwise                       = mkTyConApp tycon []
 923   where
 924     kind       = tyVarKind tv
 925     (args,res) = splitKindFunTys kind
 926
 927     tycon | kind == tyConKind listTyCon         -- *->*
 928           = listTyCon                           -- No tuples this size
 929
 930           | all isLiftedTypeKind args && isLiftedTypeKind res
 931           = tupleTyCon Boxed (length args)      -- *-> ... ->*->*
 932
 933           | otherwise
 934           = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
 935             mkPrimTyCon tc_name kind 0 [] VoidRep
 936                 -- Same name as the tyvar, apart from making it start with a colon (sigh)
 937                 -- I dread to think what will happen if this gets out into an
 938                 -- interface file.  Catastrophe likely.  Major sigh.
 939
 940     tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc
 941 \end{code}