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