ghc/compiler/typecheck/TcHsSyn.lhs

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