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 zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
 612 zonkStmt env (ParStmt stmts_w_bndrs)
 613   = mappM zonk_branch stmts_w_bndrs     `thenM` \ new_stmts_w_bndrs ->
 614     let
 615         new_binders = concat (map snd new_stmts_w_bndrs)
 616         env1 = extendZonkEnv env new_binders
 617     in
 618     return (env1, ParStmt new_stmts_w_bndrs)
 619   where
 620     zonk_branch (stmts, bndrs) = zonkStmts env stmts    `thenM` \ (env1, new_stmts) ->
 621                                  returnM (new_stmts, zonkIdOccs env1 bndrs)
 622
 623 zonkStmt env (RecStmt segStmts lvs rvs rets binds)
 624   = zonkIdBndrs env rvs         `thenM` \ new_rvs ->
 625     let
 626         env1 = extendZonkEnv env new_rvs
 627     in
 628     zonkStmts env1 segStmts     `thenM` \ (env2, new_segStmts) ->
 629         -- Zonk the ret-expressions in an envt that
 630         -- has the polymorphic bindings in the envt
 631     mapM (zonkExpr env2) rets   `thenM` \ new_rets ->
 632     let
 633         new_lvs = zonkIdOccs env2 lvs
 634         env3 = extendZonkEnv env new_lvs        -- Only the lvs are needed
 635     in
 636     zonkRecMonoBinds env3 binds `thenM` \ (env4, new_binds) ->
 637     returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets new_binds)
 638
 639 zonkStmt env (ExprStmt expr then_op ty)
 640   = zonkLExpr env expr          `thenM` \ new_expr ->
 641     zonkExpr env then_op        `thenM` \ new_then ->
 642     zonkTcTypeToType env ty     `thenM` \ new_ty ->
 643     returnM (env, ExprStmt new_expr new_then new_ty)
 644
 645 zonkStmt env (LetStmt binds)
 646   = zonkNestedBinds env binds   `thenM` \ (env1, new_binds) ->
 647     returnM (env1, LetStmt new_binds)
 648
 649 zonkStmt env (BindStmt pat expr bind_op fail_op)
 650   = do  { new_expr <- zonkLExpr env expr
 651         ; (env1, new_pat) <- zonkPat env pat
 652         ; new_bind <- zonkExpr env bind_op
 653         ; new_fail <- zonkExpr env fail_op
 654         ; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
 655
 656
 657 -------------------------------------------------------------------------
 658 zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id)
 659
 660 zonkRbinds env rbinds
 661   = mappM zonk_rbind rbinds
 662   where
 663     zonk_rbind (field, expr)
 664       = zonkLExpr env expr      `thenM` \ new_expr ->
 665         returnM (fmap (zonkIdOcc env) field, new_expr)
 666
 667 -------------------------------------------------------------------------
 668 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
 669 mapIPNameTc f (Dupable n) = f n  `thenM` \ r -> returnM (Dupable r)
 670 mapIPNameTc f (Linear  n) = f n  `thenM` \ r -> returnM (Linear r)
 671 \end{code}
 672
 673
 674 %************************************************************************
 675 %*                                                                      *
 676 \subsection[BackSubst-Pats]{Patterns}
 677 %*                                                                      *
 678 %************************************************************************
 679
 680 \begin{code}
 681 zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
 682 -- Extend the environment as we go, because it's possible for one
 683 -- pattern to bind something that is used in another (inside or
 684 -- to the right)
 685 zonkPat env pat = wrapLocSndM (zonk_pat env) pat
 686
 687 zonk_pat env (ParPat p)
 688   = do  { (env', p') <- zonkPat env p
 689         ; return (env', ParPat p') }
 690
 691 zonk_pat env (WildPat ty)
 692   = do  { ty' <- zonkTcTypeToType env ty
 693         ; return (env, WildPat ty') }
 694
 695 zonk_pat env (VarPat v)
 696   = do  { v' <- zonkIdBndr env v
 697         ; return (extendZonkEnv1 env v', VarPat v') }
 698
 699 zonk_pat env (VarPatOut v binds)
 700   = do  { v' <- zonkIdBndr env v
 701         ; (env', binds') <- zonkRecMonoBinds (extendZonkEnv1 env v') binds
 702         ; returnM (env', VarPatOut v' binds') }
 703
 704 zonk_pat env (LazyPat pat)
 705   = do  { (env', pat') <- zonkPat env pat
 706         ; return (env',  LazyPat pat') }
 707
 708 zonk_pat env (AsPat (L loc v) pat)
 709   = do  { v' <- zonkIdBndr env v
 710         ; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
 711         ; return (env', AsPat (L loc v') pat') }
 712
 713 zonk_pat env (ListPat pats ty)
 714   = do  { ty' <- zonkTcTypeToType env ty
 715         ; (env', pats') <- zonkPats env pats
 716         ; return (env', ListPat pats' ty') }
 717
 718 zonk_pat env (PArrPat pats ty)
 719   = do  { ty' <- zonkTcTypeToType env ty
 720         ; (env', pats') <- zonkPats env pats
 721         ; return (env', PArrPat pats' ty') }
 722
 723 zonk_pat env (TuplePat pats boxed)
 724   = do  { (env', pats') <- zonkPats env pats
 725         ; return (env', TuplePat pats' boxed) }
 726
 727 zonk_pat env (ConPatOut n tvs dicts binds stuff ty)
 728   = ASSERT( all isImmutableTyVar tvs )
 729     do  { new_ty <- zonkTcTypeToType env ty
 730         ; new_dicts <- zonkIdBndrs env dicts
 731         ; let env1 = extendZonkEnv env new_dicts
 732         ; (env2, new_binds) <- zonkRecMonoBinds env1 binds
 733         ; (env', new_stuff) <- zonkConStuff env2 stuff
 734         ; returnM (env', ConPatOut n tvs new_dicts new_binds new_stuff new_ty) }
 735
 736 zonk_pat env (LitPat lit) = return (env, LitPat lit)
 737
 738 zonk_pat env (SigPatOut pat ty)
 739   = do  { ty' <- zonkTcTypeToType env ty
 740         ; (env', pat') <- zonkPat env pat
 741         ; return (env', SigPatOut pat' ty') }
 742
 743 zonk_pat env (NPat lit mb_neg eq_expr ty)
 744   = do  { lit' <- zonkOverLit env lit
 745         ; mb_neg' <- case mb_neg of
 746                         Nothing  -> return Nothing
 747                         Just neg -> do { neg' <- zonkExpr env neg
 748                                        ; return (Just neg') }
 749         ; eq_expr' <- zonkExpr env eq_expr
 750         ; ty' <- zonkTcTypeToType env ty
 751         ; return (env, NPat lit' mb_neg' eq_expr' ty') }
 752
 753 zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
 754   = do  { n' <- zonkIdBndr env n
 755         ; lit' <- zonkOverLit env lit
 756         ; e1' <- zonkExpr env e1
 757         ; e2' <- zonkExpr env e2
 758         ; return (extendZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
 759
 760 zonk_pat env (DictPat ds ms)
 761   = do  { ds' <- zonkIdBndrs env ds
 762         ; ms' <- zonkIdBndrs env ms
 763         ; return (extendZonkEnv env (ds' ++ ms'), DictPat ds' ms') }
 764
 765 ---------------------------
 766 zonkConStuff env (PrefixCon pats)
 767   = do  { (env', pats') <- zonkPats env pats
 768         ; return (env', PrefixCon pats') }
 769
 770 zonkConStuff env (InfixCon p1 p2)
 771   = do  { (env1, p1') <- zonkPat env  p1
 772         ; (env', p2') <- zonkPat env1 p2
 773         ; return (env', InfixCon p1' p2') }
 774
 775 zonkConStuff env (RecCon rpats)
 776   = do  { (env', pats') <- zonkPats env pats
 777         ; returnM (env', RecCon (fields `zip` pats')) }
 778   where
 779     (fields, pats) = unzip rpats
 780
 781 ---------------------------
 782 zonkPats env []         = return (env, [])
 783 zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
 784                              ; (env', pats') <- zonkPats env1 pats
 785                              ; return (env', pat':pats') }
 786 \end{code}
 787
 788 %************************************************************************
 789 %*                                                                      *
 790 \subsection[BackSubst-Foreign]{Foreign exports}
 791 %*                                                                      *
 792 %************************************************************************
 793
 794
 795 \begin{code}
 796 zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
 797 zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
 798
 799 zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
 800 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec) =
 801    returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec isDeprec)
 802 zonkForeignExport env for_imp
 803   = returnM for_imp     -- Foreign imports don't need zonking
 804 \end{code}
 805
 806 \begin{code}
 807 zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
 808 zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
 809
 810 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
 811 zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs rhs)
 812   = mappM zonk_bndr vars                `thenM` \ new_bndrs ->
 813     newMutVar emptyVarSet               `thenM` \ unbound_tv_set ->
 814     let
 815         env_rhs = extendZonkEnv env [id | b <- new_bndrs, let id = unLoc b, isId id]
 816         -- Type variables don't need an envt
 817         -- They are bound through the mutable mechanism
 818
 819         env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
 820         -- We need to gather the type variables mentioned on the LHS so we can
 821         -- quantify over them.  Example:
 822         --   data T a = C
 823         --
 824         --   foo :: T a -> Int
 825         --   foo C = 1
 826         --
 827         --   {-# RULES "myrule"  foo C = 1 #-}
 828         --
 829         -- After type checking the LHS becomes (foo a (C a))
 830         -- and we do not want to zap the unbound tyvar 'a' to (), because
 831         -- that limits the applicability of the rule.  Instead, we
 832         -- want to quantify over it!
 833         --
 834         -- It's easiest to find the free tyvars here. Attempts to do so earlier
 835         -- are tiresome, because (a) the data type is big and (b) finding the
 836         -- free type vars of an expression is necessarily monadic operation.
 837         --      (consider /\a -> f @ b, where b is side-effected to a)
 838     in
 839     zonkLExpr env_lhs lhs               `thenM` \ new_lhs ->
 840     zonkLExpr env_rhs rhs               `thenM` \ new_rhs ->
 841
 842     readMutVar unbound_tv_set           `thenM` \ unbound_tvs ->
 843     let
 844         final_bndrs :: [Located Var]
 845         final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs
 846     in
 847     returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs new_rhs)
 848                 -- I hate this map RuleBndr stuff
 849   where
 850    zonk_bndr (RuleBndr v)
 851         | isId (unLoc v) = wrapLocM (zonkIdBndr env)   v
 852         | otherwise      = ASSERT( isImmutableTyVar (unLoc v) )
 853                            return v
 854 \end{code}
 855
 856
 857 %************************************************************************
 858 %*                                                                      *
 859 \subsection[BackSubst-Foreign]{Foreign exports}
 860 %*                                                                      *
 861 %************************************************************************
 862
 863 \begin{code}
 864 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
 865 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
 866
 867 zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
 868 zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
 869
 870 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
 871 -- This variant collects unbound type variables in a mutable variable
 872 zonkTypeCollecting unbound_tv_set
 873   = zonkType zonk_unbound_tyvar True
 874   where
 875     zonk_unbound_tyvar tv
 876         = zonkQuantifiedTyVar tv                                `thenM` \ tv' ->
 877           readMutVar unbound_tv_set                             `thenM` \ tv_set ->
 878           writeMutVar unbound_tv_set (extendVarSet tv_set tv')  `thenM_`
 879           return (mkTyVarTy tv')
 880
 881 zonkTypeZapping :: TcType -> TcM Type
 882 -- This variant is used for everything except the LHS of rules
 883 -- It zaps unbound type variables to (), or some other arbitrary type
 884 zonkTypeZapping ty
 885   = zonkType zonk_unbound_tyvar True ty
 886   where
 887         -- Zonk a mutable but unbound type variable to an arbitrary type
 888         -- We know it's unbound even though we don't carry an environment,
 889         -- because at the binding site for a type variable we bind the
 890         -- mutable tyvar to a fresh immutable one.  So the mutable store
 891         -- plays the role of an environment.  If we come across a mutable
 892         -- type variable that isn't so bound, it must be completely free.
 893     zonk_unbound_tyvar tv = do { putMetaTyVar tv ty; return ty }
 894                           where
 895                             ty = mkArbitraryType tv
 896
 897
 898 -- When the type checker finds a type variable with no binding,
 899 -- which means it can be instantiated with an arbitrary type, it
 900 -- usually instantiates it to Void.  Eg.
 901 --
 902 --      length []
 903 -- ===>
 904 --      length Void (Nil Void)
 905 --
 906 -- But in really obscure programs, the type variable might have
 907 -- a kind other than *, so we need to invent a suitably-kinded type.
 908 --
 909 -- This commit uses
 910 --      Void for kind *
 911 --      List for kind *->*
 912 --      Tuple for kind *->...*->*
 913 --
 914 -- which deals with most cases.  (Previously, it only dealt with
 915 -- kind *.)
 916 --
 917 -- In the other cases, it just makes up a TyCon with a suitable
 918 -- kind.  If this gets into an interface file, anyone reading that
 919 -- file won't understand it.  This is fixable (by making the client
 920 -- of the interface file make up a TyCon too) but it is tiresome and
 921 -- never happens, so I am leaving it
 922
 923 mkArbitraryType :: TcTyVar -> Type
 924 -- Make up an arbitrary type whose kind is the same as the tyvar.
 925 -- We'll use this to instantiate the (unbound) tyvar.
 926 mkArbitraryType tv
 927   | liftedTypeKind `isSubKind` kind = voidTy            -- The vastly common case
 928   | otherwise                       = mkTyConApp tycon []
 929   where
 930     kind       = tyVarKind tv
 931     (args,res) = splitKindFunTys kind
 932
 933     tycon | kind == tyConKind listTyCon         --  *->*
 934           = listTyCon                           -- No tuples this size
 935
 936           | all isLiftedTypeKind args && isLiftedTypeKind res
 937           = tupleTyCon Boxed (length args)      --  *-> ... ->*->*
 938
 939           | otherwise
 940           = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
 941             mkPrimTyCon tc_name kind 0 [] VoidRep
 942                 -- Same name as the tyvar, apart from making it start with a colon (sigh)
 943                 -- I dread to think what will happen if this gets out into an
 944                 -- interface file.  Catastrophe likely.  Major sigh.
 945
 946     tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc
 947 \end{code}