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