+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1996-1998
-%
-\section[TcHsSyn]{Specialisations of the @HsSyn@ syntax for the typechecker}
-
-This module is an extension of @HsSyn@ syntax, for use in the type
-checker.
-
-\begin{code}
-module TcHsSyn (
- mkHsTyApp, mkHsDictApp, mkHsConApp,
- mkHsTyLam, mkHsDictLam, mkHsDictLet, mkHsApp,
- hsLitType, hsPatType, mkHsAppTy, mkSimpleHsAlt,
- nlHsIntLit, mkVanillaTuplePat,
-
-
- -- re-exported from TcMonad
- TcId, TcIdSet, TcDictBinds,
-
- zonkTopDecls, zonkTopExpr, zonkTopLExpr,
- zonkId, zonkTopBndrs
- ) where
-
-#include "HsVersions.h"
-
--- friends:
-import HsSyn -- oodles of it
-
--- others:
-import Id ( idType, setIdType, Id )
-
-import TcRnMonad
-import Type ( Type )
-import TcType ( TcType, TcTyVar, mkTyVarTy, mkTyConApp, isImmutableTyVar )
-import Kind ( isLiftedTypeKind, liftedTypeKind, isSubKind )
-import qualified Type
-import TcMType ( zonkQuantifiedTyVar, zonkType, zonkTcType, writeMetaTyVar )
-import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
- doublePrimTy, addrPrimTy
- )
-import TysWiredIn ( charTy, stringTy, intTy,
- mkListTy, mkPArrTy, mkTupleTy, unitTy,
- voidTy, listTyCon, tupleTyCon )
-import TyCon ( mkPrimTyCon, tyConKind, PrimRep(..) )
-import Kind ( splitKindFunTys )
-import Name ( Name, getOccName, mkInternalName, mkDerivedTyConOcc )
-import Var ( Var, isId, isLocalVar, tyVarKind )
-import VarSet
-import VarEnv
-import BasicTypes ( Boxity(..), IPName(..), ipNameName, mapIPName )
-import Maybes ( orElse )
-import Unique ( Uniquable(..) )
-import SrcLoc ( noSrcLoc, noLoc, Located(..), unLoc )
-import Util ( mapSnd )
-import Bag
-import Outputable
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[mkFailurePair]{Code for pattern-matching and other failures}
-%* *
-%************************************************************************
-
-Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@,
-then something is wrong.
-\begin{code}
-mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
--- A vanilla tuple pattern simply gets its type from its sub-patterns
-mkVanillaTuplePat pats box
- = TuplePat pats box (mkTupleTy box (length pats) (map hsPatType pats))
-
-hsPatType :: OutPat Id -> Type
-hsPatType (L _ pat) = pat_type pat
-
-pat_type (ParPat pat) = hsPatType pat
-pat_type (WildPat ty) = ty
-pat_type (VarPat var) = idType var
-pat_type (VarPatOut var _) = idType var
-pat_type (BangPat pat) = hsPatType pat
-pat_type (LazyPat pat) = hsPatType pat
-pat_type (LitPat lit) = hsLitType lit
-pat_type (AsPat var pat) = idType (unLoc var)
-pat_type (ListPat _ ty) = mkListTy ty
-pat_type (PArrPat _ ty) = mkPArrTy ty
-pat_type (TuplePat pats box ty) = ty
-pat_type (ConPatOut _ _ _ _ _ ty) = ty
-pat_type (SigPatOut pat ty) = ty
-pat_type (NPat lit _ _ ty) = ty
-pat_type (NPlusKPat id _ _ _) = idType (unLoc id)
-pat_type (DictPat ds ms) = case (ds ++ ms) of
- [] -> unitTy
- [d] -> idType d
- ds -> mkTupleTy Boxed (length ds) (map idType ds)
-
-
-hsLitType :: HsLit -> TcType
-hsLitType (HsChar c) = charTy
-hsLitType (HsCharPrim c) = charPrimTy
-hsLitType (HsString str) = stringTy
-hsLitType (HsStringPrim s) = addrPrimTy
-hsLitType (HsInt i) = intTy
-hsLitType (HsIntPrim i) = intPrimTy
-hsLitType (HsInteger i ty) = ty
-hsLitType (HsRat _ ty) = ty
-hsLitType (HsFloatPrim f) = floatPrimTy
-hsLitType (HsDoublePrim d) = doublePrimTy
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
-%* *
-%************************************************************************
-
-\begin{code}
--- zonkId is used *during* typechecking just to zonk the Id's type
-zonkId :: TcId -> TcM TcId
-zonkId id
- = zonkTcType (idType id) `thenM` \ ty' ->
- returnM (setIdType id ty')
-\end{code}
-
-The rest of the zonking is done *after* typechecking.
-The main zonking pass runs over the bindings
-
- a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
- b) convert unbound TcTyVar to Void
- c) convert each TcId to an Id by zonking its type
-
-The type variables are converted by binding mutable tyvars to immutable ones
-and then zonking as normal.
-
-The Ids are converted by binding them in the normal Tc envt; that
-way we maintain sharing; eg an Id is zonked at its binding site and they
-all occurrences of that Id point to the common zonked copy
-
-It's all pretty boring stuff, because HsSyn is such a large type, and
-the environment manipulation is tiresome.
-
-\begin{code}
-data ZonkEnv = ZonkEnv (TcType -> TcM Type) -- How to zonk a type
- (IdEnv Id) -- What variables are in scope
- -- Maps an Id to its zonked version; both have the same Name
- -- Is only consulted lazily; hence knot-tying
-
-emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
-
-extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
-extendZonkEnv (ZonkEnv zonk_ty env) ids
- = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
-
-extendZonkEnv1 :: ZonkEnv -> Id -> ZonkEnv
-extendZonkEnv1 (ZonkEnv zonk_ty env) id
- = ZonkEnv zonk_ty (extendVarEnv env id id)
-
-setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
-setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
-
-zonkEnvIds :: ZonkEnv -> [Id]
-zonkEnvIds (ZonkEnv _ env) = varEnvElts env
-
-zonkIdOcc :: ZonkEnv -> TcId -> Id
--- Ids defined in this module should be in the envt;
--- ignore others. (Actually, data constructors are also
--- not LocalVars, even when locally defined, but that is fine.)
--- (Also foreign-imported things aren't currently in the ZonkEnv;
--- that's ok because they don't need zonking.)
---
--- Actually, Template Haskell works in 'chunks' of declarations, and
--- an earlier chunk won't be in the 'env' that the zonking phase
--- carries around. Instead it'll be in the tcg_gbl_env, already fully
--- zonked. There's no point in looking it up there (except for error
--- checking), and it's not conveniently to hand; hence the simple
--- 'orElse' case in the LocalVar branch.
---
--- Even without template splices, in module Main, the checking of
--- 'main' is done as a separate chunk.
-zonkIdOcc (ZonkEnv zonk_ty env) id
- | isLocalVar id = lookupVarEnv env id `orElse` id
- | otherwise = id
-
-zonkIdOccs env ids = map (zonkIdOcc env) ids
-
--- zonkIdBndr is used *after* typechecking to get the Id's type
--- to its final form. The TyVarEnv give
-zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
-zonkIdBndr env id
- = zonkTcTypeToType env (idType id) `thenM` \ ty' ->
- returnM (setIdType id ty')
-
-zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
-zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
-
-zonkTopBndrs :: [TcId] -> TcM [Id]
-zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
-\end{code}
-
-
-\begin{code}
-zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
-zonkTopExpr e = zonkExpr emptyZonkEnv e
-
-zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
-zonkTopLExpr e = zonkLExpr emptyZonkEnv e
-
-zonkTopDecls :: LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId]
- -> TcM ([Id],
- Bag (LHsBind Id),
- [LForeignDecl Id],
- [LRuleDecl Id])
-zonkTopDecls binds rules fords
- = do { (env, binds') <- zonkRecMonoBinds emptyZonkEnv binds
- -- Top level is implicitly recursive
- ; rules' <- zonkRules env rules
- ; fords' <- zonkForeignExports env fords
- ; return (zonkEnvIds env, binds', fords', rules') }
-
----------------------------------------------
-zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
-zonkLocalBinds env EmptyLocalBinds
- = return (env, EmptyLocalBinds)
-
-zonkLocalBinds env (HsValBinds binds)
- = do { (env1, new_binds) <- zonkValBinds env binds
- ; return (env1, HsValBinds new_binds) }
-
-zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds))
- = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds ->
- let
- env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
- in
- zonkRecMonoBinds env1 dict_binds `thenM` \ (env2, new_dict_binds) ->
- returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
- where
- zonk_ip_bind (IPBind n e)
- = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' ->
- zonkLExpr env e `thenM` \ e' ->
- returnM (IPBind n' e')
-
-
----------------------------------------------
-zonkValBinds :: ZonkEnv -> HsValBinds TcId -> TcM (ZonkEnv, HsValBinds Id)
-zonkValBinds env bs@(ValBindsIn _ _)
- = panic "zonkValBinds" -- Not in typechecker output
-zonkValBinds env (ValBindsOut binds sigs)
- = do { (env1, new_binds) <- go env binds
- ; return (env1, ValBindsOut new_binds sigs) }
- where
- go env [] = return (env, [])
- go env ((r,b):bs) = do { (env1, b') <- zonkRecMonoBinds env b
- ; (env2, bs') <- go env1 bs
- ; return (env2, (r,b'):bs') }
-
----------------------------------------------
-zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
-zonkRecMonoBinds env binds
- = fixM (\ ~(_, new_binds) -> do
- { let env1 = extendZonkEnv env (collectHsBindBinders new_binds)
- ; binds' <- zonkMonoBinds env1 binds
- ; return (env1, binds') })
-
----------------------------------------------
-zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
-zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds
-
-zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
-zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
- = do { (_env, new_pat) <- zonkPat env pat -- Env already extended
- ; new_grhss <- zonkGRHSs env grhss
- ; new_ty <- zonkTcTypeToType env ty
- ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
-
-zonk_bind env (VarBind { var_id = var, var_rhs = expr })
- = zonkIdBndr env var `thenM` \ new_var ->
- zonkLExpr env expr `thenM` \ new_expr ->
- returnM (VarBind { var_id = new_var, var_rhs = new_expr })
-
-zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn })
- = wrapLocM (zonkIdBndr env) var `thenM` \ new_var ->
- zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) ->
- zonkMatchGroup env1 ms `thenM` \ new_ms ->
- returnM (bind { fun_id = new_var, fun_matches = new_ms, fun_co_fn = new_co_fn })
-
-zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts,
- abs_exports = exports, abs_binds = val_binds })
- = ASSERT( all isImmutableTyVar tyvars )
- zonkIdBndrs env dicts `thenM` \ new_dicts ->
- fixM (\ ~(new_val_binds, _) ->
- let
- env1 = extendZonkEnv env new_dicts
- env2 = extendZonkEnv env1 (collectHsBindBinders new_val_binds)
- in
- zonkMonoBinds env2 val_binds `thenM` \ new_val_binds ->
- mappM (zonkExport env2) exports `thenM` \ new_exports ->
- returnM (new_val_binds, new_exports)
- ) `thenM` \ (new_val_bind, new_exports) ->
- returnM (AbsBinds { abs_tvs = tyvars, abs_dicts = new_dicts,
- abs_exports = new_exports, abs_binds = new_val_bind })
- where
- zonkExport env (tyvars, global, local, prags)
- = zonkIdBndr env global `thenM` \ new_global ->
- mapM zonk_prag prags `thenM` \ new_prags ->
- returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
- zonk_prag prag@(InlinePrag {}) = return prag
- zonk_prag (SpecPrag expr ty ds inl) = do { expr' <- zonkExpr env expr
- ; ty' <- zonkTcTypeToType env ty
- ; let ds' = zonkIdOccs env ds
- ; return (SpecPrag expr' ty' ds' inl) }
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
-%* *
-%************************************************************************
-
-\begin{code}
-zonkMatchGroup :: ZonkEnv -> MatchGroup TcId-> TcM (MatchGroup Id)
-zonkMatchGroup env (MatchGroup ms ty)
- = do { ms' <- mapM (zonkMatch env) ms
- ; ty' <- zonkTcTypeToType env ty
- ; return (MatchGroup ms' ty') }
-
-zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id)
-zonkMatch env (L loc (Match pats _ grhss))
- = do { (env1, new_pats) <- zonkPats env pats
- ; new_grhss <- zonkGRHSs env1 grhss
- ; return (L loc (Match new_pats Nothing new_grhss)) }
-
--------------------------------------------------------------------------
-zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id)
-
-zonkGRHSs env (GRHSs grhss binds)
- = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) ->
- let
- zonk_grhs (GRHS guarded rhs)
- = zonkStmts new_env guarded `thenM` \ (env2, new_guarded) ->
- zonkLExpr env2 rhs `thenM` \ new_rhs ->
- returnM (GRHS new_guarded new_rhs)
- in
- mappM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss ->
- returnM (GRHSs new_grhss new_binds)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
-%* *
-%************************************************************************
-
-\begin{code}
-zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
-zonkLExpr :: ZonkEnv -> LHsExpr TcId -> TcM (LHsExpr Id)
-zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id)
-
-zonkLExprs env exprs = mappM (zonkLExpr env) exprs
-zonkLExpr env expr = wrapLocM (zonkExpr env) expr
-
-zonkExpr env (HsVar id)
- = returnM (HsVar (zonkIdOcc env id))
-
-zonkExpr env (HsIPVar id)
- = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
-
-zonkExpr env (HsLit (HsRat f ty))
- = zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (HsLit (HsRat f new_ty))
-
-zonkExpr env (HsLit lit)
- = returnM (HsLit lit)
-
-zonkExpr env (HsOverLit lit)
- = do { lit' <- zonkOverLit env lit
- ; return (HsOverLit lit') }
-
-zonkExpr env (HsLam matches)
- = zonkMatchGroup env matches `thenM` \ new_matches ->
- returnM (HsLam new_matches)
-
-zonkExpr env (HsApp e1 e2)
- = zonkLExpr env e1 `thenM` \ new_e1 ->
- zonkLExpr env e2 `thenM` \ new_e2 ->
- returnM (HsApp new_e1 new_e2)
-
-zonkExpr env (HsBracketOut body bs)
- = mappM zonk_b bs `thenM` \ bs' ->
- returnM (HsBracketOut body bs')
- where
- zonk_b (n,e) = zonkLExpr env e `thenM` \ e' ->
- returnM (n,e')
-
-zonkExpr env (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
- returnM (HsSpliceE s)
-
-zonkExpr env (OpApp e1 op fixity e2)
- = zonkLExpr env e1 `thenM` \ new_e1 ->
- zonkLExpr env op `thenM` \ new_op ->
- zonkLExpr env e2 `thenM` \ new_e2 ->
- returnM (OpApp new_e1 new_op fixity new_e2)
-
-zonkExpr env (NegApp expr op)
- = zonkLExpr env expr `thenM` \ new_expr ->
- zonkExpr env op `thenM` \ new_op ->
- returnM (NegApp new_expr new_op)
-
-zonkExpr env (HsPar e)
- = zonkLExpr env e `thenM` \new_e ->
- returnM (HsPar new_e)
-
-zonkExpr env (SectionL expr op)
- = zonkLExpr env expr `thenM` \ new_expr ->
- zonkLExpr env op `thenM` \ new_op ->
- returnM (SectionL new_expr new_op)
-
-zonkExpr env (SectionR op expr)
- = zonkLExpr env op `thenM` \ new_op ->
- zonkLExpr env expr `thenM` \ new_expr ->
- returnM (SectionR new_op new_expr)
-
-zonkExpr env (HsCase expr ms)
- = zonkLExpr env expr `thenM` \ new_expr ->
- zonkMatchGroup env ms `thenM` \ new_ms ->
- returnM (HsCase new_expr new_ms)
-
-zonkExpr env (HsIf e1 e2 e3)
- = zonkLExpr env e1 `thenM` \ new_e1 ->
- zonkLExpr env e2 `thenM` \ new_e2 ->
- zonkLExpr env e3 `thenM` \ new_e3 ->
- returnM (HsIf new_e1 new_e2 new_e3)
-
-zonkExpr env (HsLet binds expr)
- = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) ->
- zonkLExpr new_env expr `thenM` \ new_expr ->
- returnM (HsLet new_binds new_expr)
-
-zonkExpr env (HsDo do_or_lc stmts body ty)
- = zonkStmts env stmts `thenM` \ (new_env, new_stmts) ->
- zonkLExpr new_env body `thenM` \ new_body ->
- zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (HsDo (zonkDo env do_or_lc)
- new_stmts new_body new_ty)
-
-zonkExpr env (ExplicitList ty exprs)
- = zonkTcTypeToType env ty `thenM` \ new_ty ->
- zonkLExprs env exprs `thenM` \ new_exprs ->
- returnM (ExplicitList new_ty new_exprs)
-
-zonkExpr env (ExplicitPArr ty exprs)
- = zonkTcTypeToType env ty `thenM` \ new_ty ->
- zonkLExprs env exprs `thenM` \ new_exprs ->
- returnM (ExplicitPArr new_ty new_exprs)
-
-zonkExpr env (ExplicitTuple exprs boxed)
- = zonkLExprs env exprs `thenM` \ new_exprs ->
- returnM (ExplicitTuple new_exprs boxed)
-
-zonkExpr env (RecordCon data_con con_expr rbinds)
- = zonkExpr env con_expr `thenM` \ new_con_expr ->
- zonkRbinds env rbinds `thenM` \ new_rbinds ->
- returnM (RecordCon data_con new_con_expr new_rbinds)
-
-zonkExpr env (RecordUpd expr rbinds in_ty out_ty)
- = zonkLExpr env expr `thenM` \ new_expr ->
- zonkTcTypeToType env in_ty `thenM` \ new_in_ty ->
- zonkTcTypeToType env out_ty `thenM` \ new_out_ty ->
- zonkRbinds env rbinds `thenM` \ new_rbinds ->
- returnM (RecordUpd new_expr new_rbinds new_in_ty new_out_ty)
-
-zonkExpr env (ExprWithTySigOut e ty)
- = do { e' <- zonkLExpr env e
- ; return (ExprWithTySigOut e' ty) }
-
-zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
-
-zonkExpr env (ArithSeq expr info)
- = zonkExpr env expr `thenM` \ new_expr ->
- zonkArithSeq env info `thenM` \ new_info ->
- returnM (ArithSeq new_expr new_info)
-
-zonkExpr env (PArrSeq expr info)
- = zonkExpr env expr `thenM` \ new_expr ->
- zonkArithSeq env info `thenM` \ new_info ->
- returnM (PArrSeq new_expr new_info)
-
-zonkExpr env (HsSCC lbl expr)
- = zonkLExpr env expr `thenM` \ new_expr ->
- returnM (HsSCC lbl new_expr)
-
--- hdaume: core annotations
-zonkExpr env (HsCoreAnn lbl expr)
- = zonkLExpr env expr `thenM` \ new_expr ->
- returnM (HsCoreAnn lbl new_expr)
-
-zonkExpr env (TyLam tyvars expr)
- = ASSERT( all isImmutableTyVar tyvars )
- zonkLExpr env expr `thenM` \ new_expr ->
- returnM (TyLam tyvars new_expr)
-
-zonkExpr env (TyApp expr tys)
- = zonkLExpr env expr `thenM` \ new_expr ->
- zonkTcTypeToTypes env tys `thenM` \ new_tys ->
- returnM (TyApp new_expr new_tys)
-
-zonkExpr env (DictLam dicts expr)
- = zonkIdBndrs env dicts `thenM` \ new_dicts ->
- let
- env1 = extendZonkEnv env new_dicts
- in
- zonkLExpr env1 expr `thenM` \ new_expr ->
- returnM (DictLam new_dicts new_expr)
-
-zonkExpr env (DictApp expr dicts)
- = zonkLExpr env expr `thenM` \ new_expr ->
- returnM (DictApp new_expr (zonkIdOccs env dicts))
-
--- arrow notation extensions
-zonkExpr env (HsProc pat body)
- = do { (env1, new_pat) <- zonkPat env pat
- ; new_body <- zonkCmdTop env1 body
- ; return (HsProc new_pat new_body) }
-
-zonkExpr env (HsArrApp e1 e2 ty ho rl)
- = zonkLExpr env e1 `thenM` \ new_e1 ->
- zonkLExpr env e2 `thenM` \ new_e2 ->
- zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (HsArrApp new_e1 new_e2 new_ty ho rl)
-
-zonkExpr env (HsArrForm op fixity args)
- = zonkLExpr env op `thenM` \ new_op ->
- mappM (zonkCmdTop env) args `thenM` \ new_args ->
- returnM (HsArrForm new_op fixity new_args)
-
-zonkExpr env (HsCoerce co_fn expr)
- = zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) ->
- zonkExpr env1 expr `thenM` \ new_expr ->
- return (HsCoerce new_co_fn new_expr)
-
-zonkExpr env other = pprPanic "zonkExpr" (ppr other)
-
-zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
-zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
-
-zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
- = zonkLExpr env cmd `thenM` \ new_cmd ->
- zonkTcTypeToTypes env stack_tys `thenM` \ new_stack_tys ->
- zonkTcTypeToType env ty `thenM` \ new_ty ->
- mapSndM (zonkExpr env) ids `thenM` \ new_ids ->
- returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
-
--------------------------------------------------------------------------
-zonkCoFn :: ZonkEnv -> ExprCoFn -> TcM (ZonkEnv, ExprCoFn)
-zonkCoFn env CoHole = return (env, CoHole)
-zonkCoFn env (CoCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
- ; (env2, c2') <- zonkCoFn env1 c2
- ; return (env2, CoCompose c1' c2') }
-zonkCoFn env (CoLams ids c) = do { ids' <- zonkIdBndrs env ids
- ; let env1 = extendZonkEnv env ids'
- ; (env2, c') <- zonkCoFn env1 c
- ; return (env2, CoLams ids' c') }
-zonkCoFn env (CoTyLams tvs c) = ASSERT( all isImmutableTyVar tvs )
- do { (env1, c') <- zonkCoFn env c
- ; return (env1, CoTyLams tvs c') }
-zonkCoFn env (CoApps c ids) = do { (env1, c') <- zonkCoFn env c
- ; return (env1, CoApps c' (zonkIdOccs env ids)) }
-zonkCoFn env (CoTyApps c tys) = do { tys' <- zonkTcTypeToTypes env tys
- ; (env1, c') <- zonkCoFn env c
- ; return (env1, CoTyApps c' tys') }
-zonkCoFn env (CoLet bs c) = do { (env1, bs') <- zonkRecMonoBinds env bs
- ; (env2, c') <- zonkCoFn env1 c
- ; return (env2, CoLet bs' c') }
-
-
--------------------------------------------------------------------------
-zonkDo :: ZonkEnv -> HsStmtContext Name -> HsStmtContext Name
--- Only used for 'do', so the only Ids are in a MDoExpr table
-zonkDo env (MDoExpr tbl) = MDoExpr (mapSnd (zonkIdOcc env) tbl)
-zonkDo env do_or_lc = do_or_lc
-
--------------------------------------------------------------------------
-zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
-zonkOverLit env (HsIntegral i e)
- = do { e' <- zonkExpr env e; return (HsIntegral i e') }
-zonkOverLit env (HsFractional r e)
- = do { e' <- zonkExpr env e; return (HsFractional r e') }
-
--------------------------------------------------------------------------
-zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
-
-zonkArithSeq env (From e)
- = zonkLExpr env e `thenM` \ new_e ->
- returnM (From new_e)
-
-zonkArithSeq env (FromThen e1 e2)
- = zonkLExpr env e1 `thenM` \ new_e1 ->
- zonkLExpr env e2 `thenM` \ new_e2 ->
- returnM (FromThen new_e1 new_e2)
-
-zonkArithSeq env (FromTo e1 e2)
- = zonkLExpr env e1 `thenM` \ new_e1 ->
- zonkLExpr env e2 `thenM` \ new_e2 ->
- returnM (FromTo new_e1 new_e2)
-
-zonkArithSeq env (FromThenTo e1 e2 e3)
- = zonkLExpr env e1 `thenM` \ new_e1 ->
- zonkLExpr env e2 `thenM` \ new_e2 ->
- zonkLExpr env e3 `thenM` \ new_e3 ->
- returnM (FromThenTo new_e1 new_e2 new_e3)
-
-
--------------------------------------------------------------------------
-zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id])
-zonkStmts env [] = return (env, [])
-zonkStmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s
- ; (env2, ss') <- zonkStmts env1 ss
- ; return (env2, s' : ss') }
-
-zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
-zonkStmt env (ParStmt stmts_w_bndrs)
- = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs ->
- let
- new_binders = concat (map snd new_stmts_w_bndrs)
- env1 = extendZonkEnv env new_binders
- in
- return (env1, ParStmt new_stmts_w_bndrs)
- where
- zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) ->
- returnM (new_stmts, zonkIdOccs env1 bndrs)
-
-zonkStmt env (RecStmt segStmts lvs rvs rets binds)
- = zonkIdBndrs env rvs `thenM` \ new_rvs ->
- let
- env1 = extendZonkEnv env new_rvs
- in
- zonkStmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
- -- Zonk the ret-expressions in an envt that
- -- has the polymorphic bindings in the envt
- mapM (zonkExpr env2) rets `thenM` \ new_rets ->
- let
- new_lvs = zonkIdOccs env2 lvs
- env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
- in
- zonkRecMonoBinds env3 binds `thenM` \ (env4, new_binds) ->
- returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets new_binds)
-
-zonkStmt env (ExprStmt expr then_op ty)
- = zonkLExpr env expr `thenM` \ new_expr ->
- zonkExpr env then_op `thenM` \ new_then ->
- zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (env, ExprStmt new_expr new_then new_ty)
-
-zonkStmt env (LetStmt binds)
- = zonkLocalBinds env binds `thenM` \ (env1, new_binds) ->
- returnM (env1, LetStmt new_binds)
-
-zonkStmt env (BindStmt pat expr bind_op fail_op)
- = do { new_expr <- zonkLExpr env expr
- ; (env1, new_pat) <- zonkPat env pat
- ; new_bind <- zonkExpr env bind_op
- ; new_fail <- zonkExpr env fail_op
- ; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
-
-
--------------------------------------------------------------------------
-zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id)
-
-zonkRbinds env rbinds
- = mappM zonk_rbind rbinds
- where
- zonk_rbind (field, expr)
- = zonkLExpr env expr `thenM` \ new_expr ->
- returnM (fmap (zonkIdOcc env) field, new_expr)
-
--------------------------------------------------------------------------
-mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
-mapIPNameTc f (Dupable n) = f n `thenM` \ r -> returnM (Dupable r)
-mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[BackSubst-Pats]{Patterns}
-%* *
-%************************************************************************
-
-\begin{code}
-zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
--- Extend the environment as we go, because it's possible for one
--- pattern to bind something that is used in another (inside or
--- to the right)
-zonkPat env pat = wrapLocSndM (zonk_pat env) pat
-
-zonk_pat env (ParPat p)
- = do { (env', p') <- zonkPat env p
- ; return (env', ParPat p') }
-
-zonk_pat env (WildPat ty)
- = do { ty' <- zonkTcTypeToType env ty
- ; return (env, WildPat ty') }
-
-zonk_pat env (VarPat v)
- = do { v' <- zonkIdBndr env v
- ; return (extendZonkEnv1 env v', VarPat v') }
-
-zonk_pat env (VarPatOut v binds)
- = do { v' <- zonkIdBndr env v
- ; (env', binds') <- zonkRecMonoBinds (extendZonkEnv1 env v') binds
- ; returnM (env', VarPatOut v' binds') }
-
-zonk_pat env (LazyPat pat)
- = do { (env', pat') <- zonkPat env pat
- ; return (env', LazyPat pat') }
-
-zonk_pat env (BangPat pat)
- = do { (env', pat') <- zonkPat env pat
- ; return (env', BangPat pat') }
-
-zonk_pat env (AsPat (L loc v) pat)
- = do { v' <- zonkIdBndr env v
- ; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat
- ; return (env', AsPat (L loc v') pat') }
-
-zonk_pat env (ListPat pats ty)
- = do { ty' <- zonkTcTypeToType env ty
- ; (env', pats') <- zonkPats env pats
- ; return (env', ListPat pats' ty') }
-
-zonk_pat env (PArrPat pats ty)
- = do { ty' <- zonkTcTypeToType env ty
- ; (env', pats') <- zonkPats env pats
- ; return (env', PArrPat pats' ty') }
-
-zonk_pat env (TuplePat pats boxed ty)
- = do { ty' <- zonkTcTypeToType env ty
- ; (env', pats') <- zonkPats env pats
- ; return (env', TuplePat pats' boxed ty') }
-
-zonk_pat env (ConPatOut n tvs dicts binds stuff ty)
- = ASSERT( all isImmutableTyVar tvs )
- do { new_ty <- zonkTcTypeToType env ty
- ; new_dicts <- zonkIdBndrs env dicts
- ; let env1 = extendZonkEnv env new_dicts
- ; (env2, new_binds) <- zonkRecMonoBinds env1 binds
- ; (env', new_stuff) <- zonkConStuff env2 stuff
- ; returnM (env', ConPatOut n tvs new_dicts new_binds new_stuff new_ty) }
-
-zonk_pat env (LitPat lit) = return (env, LitPat lit)
-
-zonk_pat env (SigPatOut pat ty)
- = do { ty' <- zonkTcTypeToType env ty
- ; (env', pat') <- zonkPat env pat
- ; return (env', SigPatOut pat' ty') }
-
-zonk_pat env (NPat lit mb_neg eq_expr ty)
- = do { lit' <- zonkOverLit env lit
- ; mb_neg' <- case mb_neg of
- Nothing -> return Nothing
- Just neg -> do { neg' <- zonkExpr env neg
- ; return (Just neg') }
- ; eq_expr' <- zonkExpr env eq_expr
- ; ty' <- zonkTcTypeToType env ty
- ; return (env, NPat lit' mb_neg' eq_expr' ty') }
-
-zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
- = do { n' <- zonkIdBndr env n
- ; lit' <- zonkOverLit env lit
- ; e1' <- zonkExpr env e1
- ; e2' <- zonkExpr env e2
- ; return (extendZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
-
-zonk_pat env (DictPat ds ms)
- = do { ds' <- zonkIdBndrs env ds
- ; ms' <- zonkIdBndrs env ms
- ; return (extendZonkEnv env (ds' ++ ms'), DictPat ds' ms') }
-
----------------------------
-zonkConStuff env (PrefixCon pats)
- = do { (env', pats') <- zonkPats env pats
- ; return (env', PrefixCon pats') }
-
-zonkConStuff env (InfixCon p1 p2)
- = do { (env1, p1') <- zonkPat env p1
- ; (env', p2') <- zonkPat env1 p2
- ; return (env', InfixCon p1' p2') }
-
-zonkConStuff env (RecCon rpats)
- = do { (env', pats') <- zonkPats env pats
- ; returnM (env', RecCon (fields `zip` pats')) }
- where
- (fields, pats) = unzip rpats
-
----------------------------
-zonkPats env [] = return (env, [])
-zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
- ; (env', pats') <- zonkPats env1 pats
- ; return (env', pat':pats') }
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[BackSubst-Foreign]{Foreign exports}
-%* *
-%************************************************************************
-
-
-\begin{code}
-zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
-zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
-
-zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
-zonkForeignExport env (ForeignExport i hs_ty spec isDeprec) =
- returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec isDeprec)
-zonkForeignExport env for_imp
- = returnM for_imp -- Foreign imports don't need zonking
-\end{code}
-
-\begin{code}
-zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
-zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
-
-zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
-zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs fv_lhs rhs fv_rhs)
- = mappM zonk_bndr vars `thenM` \ new_bndrs ->
- newMutVar emptyVarSet `thenM` \ unbound_tv_set ->
- let
- env_rhs = extendZonkEnv env [id | b <- new_bndrs, let id = unLoc b, isId id]
- -- Type variables don't need an envt
- -- They are bound through the mutable mechanism
-
- env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
- -- We need to gather the type variables mentioned on the LHS so we can
- -- quantify over them. Example:
- -- data T a = C
- --
- -- foo :: T a -> Int
- -- foo C = 1
- --
- -- {-# RULES "myrule" foo C = 1 #-}
- --
- -- After type checking the LHS becomes (foo a (C a))
- -- and we do not want to zap the unbound tyvar 'a' to (), because
- -- that limits the applicability of the rule. Instead, we
- -- want to quantify over it!
- --
- -- It's easiest to find the free tyvars here. Attempts to do so earlier
- -- are tiresome, because (a) the data type is big and (b) finding the
- -- free type vars of an expression is necessarily monadic operation.
- -- (consider /\a -> f @ b, where b is side-effected to a)
- in
- zonkLExpr env_lhs lhs `thenM` \ new_lhs ->
- zonkLExpr env_rhs rhs `thenM` \ new_rhs ->
-
- readMutVar unbound_tv_set `thenM` \ unbound_tvs ->
- let
- final_bndrs :: [Located Var]
- final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs
- in
- returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs fv_lhs new_rhs fv_rhs)
- -- I hate this map RuleBndr stuff
- where
- zonk_bndr (RuleBndr v)
- | isId (unLoc v) = wrapLocM (zonkIdBndr env) v
- | otherwise = ASSERT( isImmutableTyVar (unLoc v) )
- return v
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[BackSubst-Foreign]{Foreign exports}
-%* *
-%************************************************************************
-
-\begin{code}
-zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
-zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
-
-zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
-zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
-
-zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
--- This variant collects unbound type variables in a mutable variable
-zonkTypeCollecting unbound_tv_set
- = zonkType zonk_unbound_tyvar
- where
- zonk_unbound_tyvar tv
- = zonkQuantifiedTyVar tv `thenM` \ tv' ->
- readMutVar unbound_tv_set `thenM` \ tv_set ->
- writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_`
- return (mkTyVarTy tv')
-
-zonkTypeZapping :: TcType -> TcM Type
--- This variant is used for everything except the LHS of rules
--- It zaps unbound type variables to (), or some other arbitrary type
-zonkTypeZapping ty
- = zonkType zonk_unbound_tyvar ty
- where
- -- Zonk a mutable but unbound type variable to an arbitrary type
- -- We know it's unbound even though we don't carry an environment,
- -- because at the binding site for a type variable we bind the
- -- mutable tyvar to a fresh immutable one. So the mutable store
- -- plays the role of an environment. If we come across a mutable
- -- type variable that isn't so bound, it must be completely free.
- zonk_unbound_tyvar tv = do { writeMetaTyVar tv ty; return ty }
- where
- ty = mkArbitraryType tv
-
-
--- When the type checker finds a type variable with no binding,
--- which means it can be instantiated with an arbitrary type, it
--- usually instantiates it to Void. Eg.
---
--- length []
--- ===>
--- length Void (Nil Void)
---
--- But in really obscure programs, the type variable might have
--- a kind other than *, so we need to invent a suitably-kinded type.
---
--- This commit uses
--- Void for kind *
--- List for kind *->*
--- Tuple for kind *->...*->*
---
--- which deals with most cases. (Previously, it only dealt with
--- kind *.)
---
--- In the other cases, it just makes up a TyCon with a suitable
--- kind. If this gets into an interface file, anyone reading that
--- file won't understand it. This is fixable (by making the client
--- of the interface file make up a TyCon too) but it is tiresome and
--- never happens, so I am leaving it
-
-mkArbitraryType :: TcTyVar -> Type
--- Make up an arbitrary type whose kind is the same as the tyvar.
--- We'll use this to instantiate the (unbound) tyvar.
-mkArbitraryType tv
- | liftedTypeKind `isSubKind` kind = voidTy -- The vastly common case
- | otherwise = mkTyConApp tycon []
- where
- kind = tyVarKind tv
- (args,res) = splitKindFunTys kind
-
- tycon | kind == tyConKind listTyCon -- *->*
- = listTyCon -- No tuples this size
-
- | all isLiftedTypeKind args && isLiftedTypeKind res
- = tupleTyCon Boxed (length args) -- *-> ... ->*->*
-
- | otherwise
- = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
- mkPrimTyCon tc_name kind 0 [] VoidRep
- -- Same name as the tyvar, apart from making it start with a colon (sigh)
- -- I dread to think what will happen if this gets out into an
- -- interface file. Catastrophe likely. Major sigh.
-
- tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc
-\end{code}
projects / ghc-hetmet.git / blobdiff