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