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