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, mkHsLet, mkHsApp,
  13         hsLitType, hsPatType, mkHsAppTy, mkSimpleHsAlt,
  14         nlHsIntLit, glueBindsOnGRHSs,
  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, tcGetTyVar, mkTyConApp, isImmutableTyVar )
  40 import Kind       ( isLiftedTypeKind, liftedTypeKind, isSubKind )
  41 import qualified  Type
  42 import TcMType    ( zonkQuantifiedTyVar, zonkType, zonkTcType, zonkTcTyVars,
  43                     putMetaTyVar )
  44 import TysPrim    ( charPrimTy, intPrimTy, floatPrimTy,
  45                     doublePrimTy, addrPrimTy
  46                   )
  47 import TysWiredIn ( charTy, stringTy, intTy,
  48                     mkListTy, mkPArrTy, mkTupleTy, unitTy,
  49                     voidTy, listTyCon, tupleTyCon )
  50 import TyCon      ( mkPrimTyCon, tyConKind, PrimRep(..) )
  51 import Kind       ( splitKindFunTys )
  52 import Name       ( getOccName, mkInternalName, mkDerivedTyConOcc )
  53 import Var        ( Var, isId, isLocalVar, tyVarKind )
  54 import VarSet
  55 import VarEnv
  56 import BasicTypes ( Boxity(..), IPName(..), ipNameName, mapIPName )
  57 import Maybes     ( orElse )
  58 import Maybe      ( isNothing )
  59 import Unique     ( Uniquable(..) )
  60 import SrcLoc     ( noSrcLoc, noLoc, Located(..), unLoc )
  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 (NPatOut lit ty _)        = ty
  91 pat_type (NPlusKPatOut 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 --
 203 -- Actually, Template Haskell works in 'chunks' of declarations, and
 204 -- an earlier chunk won't be in the 'env' that the zonking phase
 205 -- carries around.  Instead it'll be in the tcg_gbl_env, already fully
 206 -- zonked.  There's no point in looking it up there (except for error
 207 -- checking), and it's not conveniently to hand; hence the simple
 208 -- 'orElse' case in the LocalVar branch.
 209 --
 210 -- Even without template splices, in module Main, the checking of
 211 -- 'main' is done as a separte chunk.
 212 zonkIdOcc (ZonkEnv zonk_ty env) id
 213   | isLocalVar id = lookupVarEnv env id `orElse` id
 214   | otherwise     = id
 215
 216 zonkIdOccs env ids = map (zonkIdOcc env) ids
 217
 218 -- zonkIdBndr is used *after* typechecking to get the Id's type
 219 -- to its final form.  The TyVarEnv give
 220 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
 221 zonkIdBndr env id
 222   = zonkTcTypeToType env (idType id)    `thenM` \ ty' ->
 223     returnM (setIdType id ty')
 224
 225 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
 226 zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
 227
 228 zonkTopBndrs :: [TcId] -> TcM [Id]
 229 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
 230 \end{code}
 231
 232
 233 \begin{code}
 234 zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
 235 zonkTopExpr e = zonkExpr emptyZonkEnv e
 236
 237 zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
 238 zonkTopLExpr e = zonkLExpr emptyZonkEnv e
 239
 240 zonkTopDecls :: LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId]
 241              -> TcM ([Id],
 242                      Bag (LHsBind  Id),
 243                      [LForeignDecl Id],
 244                      [LRuleDecl    Id])
 245 zonkTopDecls binds rules fords
 246   = do  { (env, binds') <- zonkRecMonoBinds emptyZonkEnv binds
 247                         -- Top level is implicitly recursive
 248         ; rules' <- zonkRules env rules
 249         ; fords' <- zonkForeignExports env fords
 250         ; return (zonkEnvIds env, binds', fords', rules') }
 251
 252 ---------------------------------------------
 253 zonkGroup :: ZonkEnv -> HsBindGroup TcId -> TcM (ZonkEnv, HsBindGroup Id)
 254 zonkGroup env (HsBindGroup bs sigs is_rec)
 255   = ASSERT( null sigs )
 256     do  { (env1, bs') <- zonkRecMonoBinds env bs
 257         ; return (env1, HsBindGroup bs' [] is_rec) }
 258
 259 zonkGroup env (HsIPBinds binds)
 260   = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds ->
 261     let
 262         env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
 263     in
 264     returnM (env1, HsIPBinds new_binds)
 265   where
 266     zonk_ip_bind (IPBind n e)
 267         = mapIPNameTc (zonkIdBndr env) n        `thenM` \ n' ->
 268           zonkLExpr env e                       `thenM` \ e' ->
 269           returnM (IPBind n' e')
 270
 271 ---------------------------------------------
 272 zonkNestedBinds :: ZonkEnv -> [HsBindGroup TcId] -> TcM (ZonkEnv, [HsBindGroup Id])
 273 zonkNestedBinds env []     = return (env, [])
 274 zonkNestedBinds env (b:bs) = do { (env1, b') <- zonkGroup env b
 275                                 ; (env2, bs') <- zonkNestedBinds env1 bs
 276                                 ; return (env2, b':bs') }
 277
 278 ---------------------------------------------
 279 zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
 280 zonkRecMonoBinds env binds
 281  = fixM (\ ~(_, new_binds) -> do
 282         { let env1 = extendZonkEnv env (collectHsBindBinders new_binds)
 283         ; binds' <- zonkMonoBinds env1 binds
 284         ; return (env1, binds') })
 285
 286 zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
 287 zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds
 288
 289 zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
 290 zonk_bind env (PatBind pat grhss ty)
 291   = do  { (_env, new_pat) <- zonkPat env pat            -- Env already extended
 292         ; new_grhss <- zonkGRHSs env grhss
 293         ; new_ty    <- zonkTcTypeToType env ty
 294         ; return (PatBind new_pat new_grhss new_ty) }
 295
 296 zonk_bind env (VarBind var expr)
 297   = zonkIdBndr env var                  `thenM` \ new_var ->
 298     zonkLExpr env expr                  `thenM` \ new_expr ->
 299     returnM (VarBind new_var new_expr)
 300
 301 zonk_bind env (FunBind var inf ms)
 302   = wrapLocM (zonkIdBndr env) var       `thenM` \ new_var ->
 303     zonkMatchGroup env ms               `thenM` \ new_ms ->
 304     returnM (FunBind new_var inf new_ms)
 305
 306 zonk_bind env (AbsBinds tyvars dicts exports inlines val_binds)
 307   = ASSERT( all isImmutableTyVar tyvars )
 308     zonkIdBndrs env dicts               `thenM` \ new_dicts ->
 309     fixM (\ ~(new_val_binds, _) ->
 310         let
 311           env1 = extendZonkEnv (extendZonkEnv env new_dicts)
 312                                (collectHsBindBinders new_val_binds)
 313         in
 314         zonkMonoBinds env1 val_binds            `thenM` \ new_val_binds ->
 315         mappM (zonkExport env1) exports         `thenM` \ new_exports ->
 316         returnM (new_val_binds, new_exports)
 317     )                                           `thenM` \ (new_val_bind, new_exports) ->
 318     returnM (AbsBinds tyvars new_dicts new_exports inlines new_val_bind)
 319   where
 320     zonkExport env (tyvars, global, local)
 321         = ASSERT( all isImmutableTyVar tyvars )
 322           zonkIdBndr env global         `thenM` \ new_global ->
 323           returnM (tyvars, new_global, zonkIdOcc env local)
 324 \end{code}
 325
 326 %************************************************************************
 327 %*                                                                      *
 328 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
 329 %*                                                                      *
 330 %************************************************************************
 331
 332 \begin{code}
 333 zonkMatchGroup :: ZonkEnv -> MatchGroup TcId-> TcM (MatchGroup Id)
 334 zonkMatchGroup env (MatchGroup ms ty)
 335   = do  { ms' <- mapM (zonkMatch env) ms
 336         ; ty' <- zonkTcTypeToType env ty
 337         ; return (MatchGroup ms' ty') }
 338
 339 zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id)
 340 zonkMatch env (L loc (Match pats _ grhss))
 341   = do  { (env1, new_pats) <- zonkPats env pats
 342         ; new_grhss <- zonkGRHSs env1 grhss
 343         ; return (L loc (Match new_pats Nothing new_grhss)) }
 344
 345 -------------------------------------------------------------------------
 346 zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id)
 347
 348 zonkGRHSs env (GRHSs grhss binds)
 349   = zonkNestedBinds env binds           `thenM` \ (new_env, new_binds) ->
 350     let
 351         zonk_grhs (GRHS guarded)
 352           = zonkStmts new_env guarded   `thenM` \ new_guarded ->
 353             returnM (GRHS new_guarded)
 354     in
 355     mappM (wrapLocM zonk_grhs) grhss    `thenM` \ new_grhss ->
 356     returnM (GRHSs new_grhss new_binds)
 357 \end{code}
 358
 359 %************************************************************************
 360 %*                                                                      *
 361 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
 362 %*                                                                      *
 363 %************************************************************************
 364
 365 \begin{code}
 366 zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
 367 zonkLExpr  :: ZonkEnv -> LHsExpr TcId   -> TcM (LHsExpr Id)
 368 zonkExpr   :: ZonkEnv -> HsExpr TcId    -> TcM (HsExpr Id)
 369
 370 zonkLExprs env exprs = mappM (zonkLExpr env) exprs
 371 zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
 372
 373 zonkExpr env (HsVar id)
 374   = returnM (HsVar (zonkIdOcc env id))
 375
 376 zonkExpr env (HsIPVar id)
 377   = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
 378
 379 zonkExpr env (HsLit (HsRat f ty))
 380   = zonkTcTypeToType env ty        `thenM` \ new_ty  ->
 381     returnM (HsLit (HsRat f new_ty))
 382
 383 zonkExpr env (HsLit lit)
 384   = returnM (HsLit lit)
 385 -- HsOverLit doesn't appear in typechecker output
 386
 387 zonkExpr env (HsLam matches)
 388   = zonkMatchGroup env matches  `thenM` \ new_matches ->
 389     returnM (HsLam new_matches)
 390
 391 zonkExpr env (HsApp e1 e2)
 392   = zonkLExpr env e1    `thenM` \ new_e1 ->
 393     zonkLExpr env e2    `thenM` \ new_e2 ->
 394     returnM (HsApp new_e1 new_e2)
 395
 396 zonkExpr env (HsBracketOut body bs)
 397   = mappM zonk_b bs     `thenM` \ bs' ->
 398     returnM (HsBracketOut body bs')
 399   where
 400     zonk_b (n,e) = zonkLExpr env e      `thenM` \ e' ->
 401                    returnM (n,e')
 402
 403 zonkExpr env (HsSpliceE s) = WARN( True, ppr s )        -- Should not happen
 404                              returnM (HsSpliceE s)
 405
 406 zonkExpr env (OpApp e1 op fixity e2)
 407   = zonkLExpr env e1    `thenM` \ new_e1 ->
 408     zonkLExpr env op    `thenM` \ new_op ->
 409     zonkLExpr env e2    `thenM` \ new_e2 ->
 410     returnM (OpApp new_e1 new_op fixity new_e2)
 411
 412 zonkExpr env (NegApp _ _) = panic "zonkExpr env: NegApp"
 413
 414 zonkExpr env (HsPar e)
 415   = zonkLExpr env e     `thenM` \new_e ->
 416     returnM (HsPar new_e)
 417
 418 zonkExpr env (SectionL expr op)
 419   = zonkLExpr env expr  `thenM` \ new_expr ->
 420     zonkLExpr env op            `thenM` \ new_op ->
 421     returnM (SectionL new_expr new_op)
 422
 423 zonkExpr env (SectionR op expr)
 424   = zonkLExpr env op            `thenM` \ new_op ->
 425     zonkLExpr env expr          `thenM` \ new_expr ->
 426     returnM (SectionR new_op new_expr)
 427
 428 -- gaw 2004
 429 zonkExpr env (HsCase expr ms)
 430   = zonkLExpr env expr          `thenM` \ new_expr ->
 431     zonkMatchGroup env ms       `thenM` \ new_ms ->
 432     returnM (HsCase new_expr new_ms)
 433
 434 zonkExpr env (HsIf e1 e2 e3)
 435   = zonkLExpr env e1    `thenM` \ new_e1 ->
 436     zonkLExpr env e2    `thenM` \ new_e2 ->
 437     zonkLExpr env e3    `thenM` \ new_e3 ->
 438     returnM (HsIf new_e1 new_e2 new_e3)
 439
 440 zonkExpr env (HsLet binds expr)
 441   = zonkNestedBinds env binds   `thenM` \ (new_env, new_binds) ->
 442     zonkLExpr new_env expr      `thenM` \ new_expr ->
 443     returnM (HsLet new_binds new_expr)
 444
 445 zonkExpr env (HsDo do_or_lc stmts ids ty)
 446   = zonkStmts env stmts         `thenM` \ new_stmts ->
 447     zonkTcTypeToType env ty     `thenM` \ new_ty   ->
 448     zonkReboundNames env ids    `thenM` \ new_ids ->
 449     returnM (HsDo do_or_lc new_stmts new_ids new_ty)
 450
 451 zonkExpr env (ExplicitList ty exprs)
 452   = zonkTcTypeToType env ty     `thenM` \ new_ty ->
 453     zonkLExprs env exprs        `thenM` \ new_exprs ->
 454     returnM (ExplicitList new_ty new_exprs)
 455
 456 zonkExpr env (ExplicitPArr ty exprs)
 457   = zonkTcTypeToType env ty     `thenM` \ new_ty ->
 458     zonkLExprs env exprs        `thenM` \ new_exprs ->
 459     returnM (ExplicitPArr new_ty new_exprs)
 460
 461 zonkExpr env (ExplicitTuple exprs boxed)
 462   = zonkLExprs env exprs        `thenM` \ new_exprs ->
 463     returnM (ExplicitTuple new_exprs boxed)
 464
 465 zonkExpr env (RecordConOut data_con con_expr rbinds)
 466   = zonkLExpr env con_expr      `thenM` \ new_con_expr ->
 467     zonkRbinds env rbinds       `thenM` \ new_rbinds ->
 468     returnM (RecordConOut data_con new_con_expr new_rbinds)
 469
 470 zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd"
 471
 472 zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds)
 473   = zonkLExpr env expr          `thenM` \ new_expr ->
 474     zonkTcTypeToType env in_ty  `thenM` \ new_in_ty ->
 475     zonkTcTypeToType env out_ty `thenM` \ new_out_ty ->
 476     zonkRbinds env rbinds       `thenM` \ new_rbinds ->
 477     returnM (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
 478
 479 zonkExpr env (ExprWithTySigOut e ty)
 480   = do { e' <- zonkLExpr env e
 481        ; return (ExprWithTySigOut e' ty) }
 482
 483 zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
 484 zonkExpr env (ArithSeqIn _)      = panic "zonkExpr env:ArithSeqIn"
 485 zonkExpr env (PArrSeqIn _)       = panic "zonkExpr env:PArrSeqIn"
 486
 487 zonkExpr env (ArithSeqOut expr info)
 488   = zonkLExpr env expr          `thenM` \ new_expr ->
 489     zonkArithSeq env info       `thenM` \ new_info ->
 490     returnM (ArithSeqOut new_expr new_info)
 491
 492 zonkExpr env (PArrSeqOut expr info)
 493   = zonkLExpr env expr          `thenM` \ new_expr ->
 494     zonkArithSeq env info       `thenM` \ new_info ->
 495     returnM (PArrSeqOut new_expr new_info)
 496
 497 zonkExpr env (HsSCC lbl expr)
 498   = zonkLExpr env expr  `thenM` \ new_expr ->
 499     returnM (HsSCC lbl new_expr)
 500
 501 -- hdaume: core annotations
 502 zonkExpr env (HsCoreAnn lbl expr)
 503   = zonkLExpr env expr   `thenM` \ new_expr ->
 504     returnM (HsCoreAnn lbl new_expr)
 505
 506 zonkExpr env (TyLam tyvars expr)
 507   = ASSERT( all isImmutableTyVar tyvars )
 508     zonkLExpr env expr                  `thenM` \ new_expr ->
 509     returnM (TyLam tyvars new_expr)
 510
 511 zonkExpr env (TyApp expr tys)
 512   = zonkLExpr env expr                  `thenM` \ new_expr ->
 513     mappM (zonkTcTypeToType env) tys    `thenM` \ new_tys ->
 514     returnM (TyApp new_expr new_tys)
 515
 516 zonkExpr env (DictLam dicts expr)
 517   = zonkIdBndrs env dicts       `thenM` \ new_dicts ->
 518     let
 519         env1 = extendZonkEnv env new_dicts
 520     in
 521     zonkLExpr env1 expr         `thenM` \ new_expr ->
 522     returnM (DictLam new_dicts new_expr)
 523
 524 zonkExpr env (DictApp expr dicts)
 525   = zonkLExpr env expr                  `thenM` \ new_expr ->
 526     returnM (DictApp new_expr (zonkIdOccs env dicts))
 527
 528 -- arrow notation extensions
 529 zonkExpr env (HsProc pat body)
 530   = do  { (env1, new_pat) <- zonkPat env pat
 531         ; new_body <- zonkCmdTop env1 body
 532         ; return (HsProc new_pat new_body) }
 533
 534 zonkExpr env (HsArrApp e1 e2 ty ho rl)
 535   = zonkLExpr env e1                    `thenM` \ new_e1 ->
 536     zonkLExpr env e2                    `thenM` \ new_e2 ->
 537     zonkTcTypeToType env ty             `thenM` \ new_ty ->
 538     returnM (HsArrApp new_e1 new_e2 new_ty ho rl)
 539
 540 zonkExpr env (HsArrForm op fixity args)
 541   = zonkLExpr env op                    `thenM` \ new_op ->
 542     mappM (zonkCmdTop env) args         `thenM` \ new_args ->
 543     returnM (HsArrForm new_op fixity new_args)
 544
 545 zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
 546 zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
 547
 548 zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
 549   = zonkLExpr env cmd                   `thenM` \ new_cmd ->
 550     mappM (zonkTcTypeToType env) stack_tys
 551                                         `thenM` \ new_stack_tys ->
 552     zonkTcTypeToType env ty             `thenM` \ new_ty ->
 553     zonkReboundNames env ids            `thenM` \ new_ids ->
 554     returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
 555
 556 -------------------------------------------------------------------------
 557 zonkReboundNames :: ZonkEnv -> ReboundNames Id -> TcM (ReboundNames Id)
 558 zonkReboundNames env prs
 559   = mapM zonk prs
 560   where
 561     zonk (n, e) = zonkExpr env e `thenM` \ new_e ->
 562                   returnM (n, new_e)
 563
 564
 565 -------------------------------------------------------------------------
 566 zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
 567
 568 zonkArithSeq env (From e)
 569   = zonkLExpr env e             `thenM` \ new_e ->
 570     returnM (From new_e)
 571
 572 zonkArithSeq env (FromThen e1 e2)
 573   = zonkLExpr env e1    `thenM` \ new_e1 ->
 574     zonkLExpr env e2    `thenM` \ new_e2 ->
 575     returnM (FromThen new_e1 new_e2)
 576
 577 zonkArithSeq env (FromTo e1 e2)
 578   = zonkLExpr env e1    `thenM` \ new_e1 ->
 579     zonkLExpr env e2    `thenM` \ new_e2 ->
 580     returnM (FromTo new_e1 new_e2)
 581
 582 zonkArithSeq env (FromThenTo e1 e2 e3)
 583   = zonkLExpr env e1    `thenM` \ new_e1 ->
 584     zonkLExpr env e2    `thenM` \ new_e2 ->
 585     zonkLExpr env e3    `thenM` \ new_e3 ->
 586     returnM (FromThenTo new_e1 new_e2 new_e3)
 587
 588
 589 -------------------------------------------------------------------------
 590 zonkStmts  :: ZonkEnv -> [LStmt TcId] -> TcM [LStmt Id]
 591
 592 zonkStmts env stmts = zonk_stmts env stmts      `thenM` \ (_, stmts) ->
 593                       returnM stmts
 594
 595 zonk_stmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id])
 596 zonk_stmts env []     = return (env, [])
 597 zonk_stmts env (s:ss) = do { (env1, s')  <- wrapLocSndM (zonkStmt env) s
 598                            ; (env2, ss') <- zonk_stmts env1 ss
 599                            ; return (env2, s' : ss') }
 600
 601 zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
 602 zonkStmt env (ParStmt stmts_w_bndrs)
 603   = mappM zonk_branch stmts_w_bndrs     `thenM` \ new_stmts_w_bndrs ->
 604     let
 605         new_binders = concat (map snd new_stmts_w_bndrs)
 606         env1 = extendZonkEnv env new_binders
 607     in
 608     return (env1, ParStmt new_stmts_w_bndrs)
 609   where
 610     zonk_branch (stmts, bndrs) = zonk_stmts env stmts   `thenM` \ (env1, new_stmts) ->
 611                                  returnM (new_stmts, zonkIdOccs env1 bndrs)
 612
 613 zonkStmt env (RecStmt segStmts lvs rvs rets)
 614   = zonkIdBndrs env rvs         `thenM` \ new_rvs ->
 615     let
 616         env1 = extendZonkEnv env new_rvs
 617     in
 618     zonk_stmts env1 segStmts    `thenM` \ (env2, new_segStmts) ->
 619         -- Zonk the ret-expressions in an envt that
 620         -- has the polymorphic bindings in the envt
 621     zonkLExprs env2 rets        `thenM` \ new_rets ->
 622     let
 623         new_lvs = zonkIdOccs env2 lvs
 624         env3 = extendZonkEnv env new_lvs        -- Only the lvs are needed
 625     in
 626     returnM (env3, RecStmt new_segStmts new_lvs new_rvs new_rets)
 627
 628 zonkStmt env (ResultStmt expr)
 629   = zonkLExpr env expr  `thenM` \ new_expr ->
 630     returnM (env, ResultStmt new_expr)
 631
 632 zonkStmt env (ExprStmt expr ty)
 633   = zonkLExpr env expr          `thenM` \ new_expr ->
 634     zonkTcTypeToType env ty     `thenM` \ new_ty ->
 635     returnM (env, ExprStmt new_expr new_ty)
 636
 637 zonkStmt env (LetStmt binds)
 638   = zonkNestedBinds env binds   `thenM` \ (env1, new_binds) ->
 639     returnM (env1, LetStmt new_binds)
 640
 641 zonkStmt env (BindStmt pat expr)
 642   = do  { new_expr <- zonkLExpr env expr
 643         ; (env1, new_pat) <- zonkPat env pat
 644         ; return (env1, BindStmt new_pat new_expr) }
 645
 646
 647 -------------------------------------------------------------------------
 648 zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id)
 649
 650 zonkRbinds env rbinds
 651   = mappM zonk_rbind rbinds
 652   where
 653     zonk_rbind (field, expr)
 654       = zonkLExpr env expr      `thenM` \ new_expr ->
 655         returnM (fmap (zonkIdOcc env) field, new_expr)
 656
 657 -------------------------------------------------------------------------
 658 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
 659 mapIPNameTc f (Dupable n) = f n  `thenM` \ r -> returnM (Dupable r)
 660 mapIPNameTc f (Linear  n) = f n  `thenM` \ r -> returnM (Linear r)
 661 \end{code}
 662
 663
 664 %************************************************************************
 665 %*                                                                      *
 666 \subsection[BackSubst-Pats]{Patterns}
 667 %*                                                                      *
 668 %************************************************************************
 669
 670 \begin{code}
 671 zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
 672 -- Extend the environment as we go, because it's possible for one
 673 -- pattern to bind something that is used in another (inside or
 674 -- to the right)
 675 zonkPat env pat = wrapLocSndM (zonk_pat env) pat
 676
 677 zonk_pat env (ParPat p)
 678   = do  { (env', p') <- zonkPat env p
 679         ; return (env', ParPat p') }
 680
 681 zonk_pat env (WildPat ty)
 682   = do  { ty' <- zonkTcTypeToType env ty
 683         ; return (env, WildPat ty') }
 684
 685 zonk_pat env (VarPat v)
 686   = do  { v' <- zonkIdBndr env v
 687         ; return (extendZonkEnv1 env v', VarPat v') }
 688
 689 zonk_pat env (VarPatOut v binds)
 690   = do  { v' <- zonkIdBndr env v
 691         ; (env', binds') <- zonkRecMonoBinds (extendZonkEnv1 env v') binds
 692         ; returnM (env', VarPatOut v' binds') }
 693
 694 zonk_pat env (LazyPat pat)
 695   = do  { (env', pat') <- zonkPat env pat
 696         ; return (env',  LazyPat pat') }
 697
 698 zonk_pat env (AsPat (L loc v) pat)
 699   = do  { v' <- zonkIdBndr env v
 700         ; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
 701         ; return (env', AsPat (L loc v') pat') }
 702
 703 zonk_pat env (ListPat pats ty)
 704   = do  { ty' <- zonkTcTypeToType env ty
 705         ; (env', pats') <- zonkPats env pats
 706         ; return (env', ListPat pats' ty') }
 707
 708 zonk_pat env (PArrPat pats ty)
 709   = do  { ty' <- zonkTcTypeToType env ty
 710         ; (env', pats') <- zonkPats env pats
 711         ; return (env', PArrPat pats' ty') }
 712
 713 zonk_pat env (TuplePat pats boxed)
 714   = do  { (env', pats') <- zonkPats env pats
 715         ; return (env', TuplePat pats' boxed) }
 716
 717 zonk_pat env (ConPatOut n tvs dicts binds stuff ty)
 718   = ASSERT( all isImmutableTyVar tvs )
 719     do  { new_ty <- zonkTcTypeToType env ty
 720         ; new_dicts <- zonkIdBndrs env dicts
 721         ; let env1 = extendZonkEnv env new_dicts
 722         ; (env2, new_binds) <- zonkRecMonoBinds env1 binds
 723         ; (env', new_stuff) <- zonkConStuff env2 stuff
 724         ; returnM (env', ConPatOut n tvs new_dicts new_binds new_stuff new_ty) }
 725
 726 zonk_pat env (LitPat lit) = return (env, LitPat lit)
 727
 728 zonk_pat env (SigPatOut pat ty)
 729   = do  { ty' <- zonkTcTypeToType env ty
 730         ; (env', pat') <- zonkPat env pat
 731         ; return (env', SigPatOut pat' ty') }
 732
 733 zonk_pat env (NPatOut lit ty expr)
 734   = do  { ty' <- zonkTcTypeToType env ty
 735         ; expr' <- zonkExpr env expr
 736         ; return (env, NPatOut lit ty' expr') }
 737
 738 zonk_pat env (NPlusKPatOut (L loc n) k e1 e2)
 739   = do  { n' <- zonkIdBndr env n
 740         ; e1' <- zonkExpr env e1
 741         ; e2' <- zonkExpr env e2
 742         ; return (extendZonkEnv1 env n', NPlusKPatOut (L loc n') k e1' e2') }
 743
 744 zonk_pat env (DictPat ds ms)
 745   = do  { ds' <- zonkIdBndrs env ds
 746         ; ms' <- zonkIdBndrs env ms
 747         ; return (extendZonkEnv env (ds' ++ ms'), DictPat ds' ms') }
 748
 749 ---------------------------
 750 zonkConStuff env (PrefixCon pats)
 751   = do  { (env', pats') <- zonkPats env pats
 752         ; return (env', PrefixCon pats') }
 753
 754 zonkConStuff env (InfixCon p1 p2)
 755   = do  { (env1, p1') <- zonkPat env  p1
 756         ; (env', p2') <- zonkPat env1 p2
 757         ; return (env', InfixCon p1' p2') }
 758
 759 zonkConStuff env (RecCon rpats)
 760   = do  { (env', pats') <- zonkPats env pats
 761         ; returnM (env', RecCon (fields `zip` pats')) }
 762   where
 763     (fields, pats) = unzip rpats
 764
 765 ---------------------------
 766 zonkPats env []         = return (env, [])
 767 zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
 768                              ; (env', pats') <- zonkPats env1 pats
 769                              ; return (env', pat':pats') }
 770 \end{code}
 771
 772 %************************************************************************
 773 %*                                                                      *
 774 \subsection[BackSubst-Foreign]{Foreign exports}
 775 %*                                                                      *
 776 %************************************************************************
 777
 778
 779 \begin{code}
 780 zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
 781 zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
 782
 783 zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
 784 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec) =
 785    returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec isDeprec)
 786 zonkForeignExport env for_imp
 787   = returnM for_imp     -- Foreign imports don't need zonking
 788 \end{code}
 789
 790 \begin{code}
 791 zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
 792 zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
 793
 794 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
 795 zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs rhs)
 796   = mappM zonk_bndr vars                `thenM` \ new_bndrs ->
 797     newMutVar emptyVarSet               `thenM` \ unbound_tv_set ->
 798     let
 799         env_rhs = extendZonkEnv env [id | b <- new_bndrs, let id = unLoc b, isId id]
 800         -- Type variables don't need an envt
 801         -- They are bound through the mutable mechanism
 802
 803         env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
 804         -- We need to gather the type variables mentioned on the LHS so we can
 805         -- quantify over them.  Example:
 806         --   data T a = C
 807         --
 808         --   foo :: T a -> Int
 809         --   foo C = 1
 810         --
 811         --   {-# RULES "myrule"  foo C = 1 #-}
 812         --
 813         -- After type checking the LHS becomes (foo a (C a))
 814         -- and we do not want to zap the unbound tyvar 'a' to (), because
 815         -- that limits the applicability of the rule.  Instead, we
 816         -- want to quantify over it!
 817         --
 818         -- It's easiest to find the free tyvars here. Attempts to do so earlier
 819         -- are tiresome, because (a) the data type is big and (b) finding the
 820         -- free type vars of an expression is necessarily monadic operation.
 821         --      (consider /\a -> f @ b, where b is side-effected to a)
 822     in
 823     zonkLExpr env_lhs lhs               `thenM` \ new_lhs ->
 824     zonkLExpr env_rhs rhs               `thenM` \ new_rhs ->
 825
 826     readMutVar unbound_tv_set           `thenM` \ unbound_tvs ->
 827     let
 828         final_bndrs :: [Located Var]
 829         final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs
 830     in
 831     returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs new_rhs)
 832                 -- I hate this map RuleBndr stuff
 833   where
 834    zonk_bndr (RuleBndr v)
 835         | isId (unLoc v) = wrapLocM (zonkIdBndr env)   v
 836         | otherwise      = ASSERT( isImmutableTyVar (unLoc v) )
 837                            return v
 838 \end{code}
 839
 840
 841 %************************************************************************
 842 %*                                                                      *
 843 \subsection[BackSubst-Foreign]{Foreign exports}
 844 %*                                                                      *
 845 %************************************************************************
 846
 847 \begin{code}
 848 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
 849 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
 850
 851 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
 852 -- This variant collects unbound type variables in a mutable variable
 853 zonkTypeCollecting unbound_tv_set
 854   = zonkType zonk_unbound_tyvar True
 855   where
 856     zonk_unbound_tyvar tv
 857         = zonkQuantifiedTyVar tv                                `thenM` \ tv' ->
 858           readMutVar unbound_tv_set                             `thenM` \ tv_set ->
 859           writeMutVar unbound_tv_set (extendVarSet tv_set tv')  `thenM_`
 860           return (mkTyVarTy tv')
 861
 862 zonkTypeZapping :: TcType -> TcM Type
 863 -- This variant is used for everything except the LHS of rules
 864 -- It zaps unbound type variables to (), or some other arbitrary type
 865 zonkTypeZapping ty
 866   = zonkType zonk_unbound_tyvar True ty
 867   where
 868         -- Zonk a mutable but unbound type variable to an arbitrary type
 869         -- We know it's unbound even though we don't carry an environment,
 870         -- because at the binding site for a type variable we bind the
 871         -- mutable tyvar to a fresh immutable one.  So the mutable store
 872         -- plays the role of an environment.  If we come across a mutable
 873         -- type variable that isn't so bound, it must be completely free.
 874     zonk_unbound_tyvar tv = do { putMetaTyVar tv ty; return ty }
 875                           where
 876                             ty = mkArbitraryType tv
 877
 878
 879 -- When the type checker finds a type variable with no binding,
 880 -- which means it can be instantiated with an arbitrary type, it
 881 -- usually instantiates it to Void.  Eg.
 882 --
 883 --      length []
 884 -- ===>
 885 --      length Void (Nil Void)
 886 --
 887 -- But in really obscure programs, the type variable might have
 888 -- a kind other than *, so we need to invent a suitably-kinded type.
 889 --
 890 -- This commit uses
 891 --      Void for kind *
 892 --      List for kind *->*
 893 --      Tuple for kind *->...*->*
 894 --
 895 -- which deals with most cases.  (Previously, it only dealt with
 896 -- kind *.)
 897 --
 898 -- In the other cases, it just makes up a TyCon with a suitable
 899 -- kind.  If this gets into an interface file, anyone reading that
 900 -- file won't understand it.  This is fixable (by making the client
 901 -- of the interface file make up a TyCon too) but it is tiresome and
 902 -- never happens, so I am leaving it
 903
 904 mkArbitraryType :: TcTyVar -> Type
 905 -- Make up an arbitrary type whose kind is the same as the tyvar.
 906 -- We'll use this to instantiate the (unbound) tyvar.
 907 mkArbitraryType tv
 908   | liftedTypeKind `isSubKind` kind = voidTy            -- The vastly common case
 909   | otherwise                       = mkTyConApp tycon []
 910   where
 911     kind       = tyVarKind tv
 912     (args,res) = splitKindFunTys kind
 913
 914     tycon | kind == tyConKind listTyCon         -- *->*
 915           = listTyCon                           -- No tuples this size
 916
 917           | all isLiftedTypeKind args && isLiftedTypeKind res
 918           = tupleTyCon Boxed (length args)      -- *-> ... ->*->*
 919
 920           | otherwise
 921           = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
 922             mkPrimTyCon tc_name kind 0 [] VoidRep
 923                 -- Same name as the tyvar, apart from making it start with a colon (sigh)
 924                 -- I dread to think what will happen if this gets out into an
 925                 -- interface file.  Catastrophe likely.  Major sigh.
 926
 927     tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc
 928 \end{code}