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