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