X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=2b30c3c27d85a1b60a33baaa0526a4a49260ccb2;hb=16e4ce4c0c02650082f2e11982017c903c549ad5;hp=fbe5fbecf7d732a8c6b149c29781d4b27160906f;hpb=a3a372f9d89b84c3299a35845afd4e878c704495;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index fbe5fbe..2b30c3c 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1996 +% (c) The AQUA Project, Glasgow University, 1996-1998 % \section[TcHsSyn]{Specialisations of the @HsSyn@ syntax for the typechecker} @@ -7,65 +7,76 @@ This module is an extension of @HsSyn@ syntax, for use in the type checker. \begin{code} -#include "HsVersions.h" - module TcHsSyn ( - SYN_IE(TcMonoBinds), SYN_IE(TcHsBinds), SYN_IE(TcPat), - SYN_IE(TcExpr), SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS), SYN_IE(TcMatch), - SYN_IE(TcStmt), SYN_IE(TcArithSeqInfo), SYN_IE(TcRecordBinds), - SYN_IE(TcHsModule), SYN_IE(TcCoreExpr), SYN_IE(TcDictBinds), + TcMonoBinds, TcHsBinds, TcPat, + TcExpr, TcGRHSs, TcGRHS, TcMatch, + TcStmt, TcArithSeqInfo, TcRecordBinds, + TcHsModule, TcDictBinds, + TcForeignDecl, + TcCmd, TcCmdTop, - SYN_IE(TypecheckedHsBinds), - SYN_IE(TypecheckedMonoBinds), SYN_IE(TypecheckedPat), - SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedArithSeqInfo), - SYN_IE(TypecheckedStmt), - SYN_IE(TypecheckedMatch), SYN_IE(TypecheckedHsModule), - SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS), - SYN_IE(TypecheckedRecordBinds), SYN_IE(TypecheckedDictBinds), - - mkHsTyApp, mkHsDictApp, - mkHsTyLam, mkHsDictLam, - tcIdType, tcIdTyVars, - - zonkTopBinds, zonkBinds, zonkMonoBinds + TypecheckedHsBinds, TypecheckedRuleDecl, + TypecheckedMonoBinds, TypecheckedPat, + TypecheckedHsExpr, TypecheckedArithSeqInfo, + TypecheckedStmt, TypecheckedForeignDecl, + TypecheckedMatch, TypecheckedHsModule, + TypecheckedGRHSs, TypecheckedGRHS, + TypecheckedRecordBinds, TypecheckedDictBinds, + TypecheckedMatchContext, TypecheckedCoreBind, + TypecheckedHsCmd, TypecheckedHsCmdTop, + + mkHsTyApp, mkHsDictApp, mkHsConApp, + mkHsTyLam, mkHsDictLam, mkHsLet, + hsLitType, hsPatType, + + -- Coercions + Coercion, ExprCoFn, PatCoFn, + (<$>), (<.>), mkCoercion, + idCoercion, isIdCoercion, + + -- re-exported from TcMonad + TcId, TcIdSet, + + zonkTopBinds, zonkTopDecls, zonkTopExpr, + zonkId, zonkTopBndrs ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -- friends: import HsSyn -- oodles of it -import Id ( GenId(..), IdDetails, -- Can meddle modestly with Ids - SYN_IE(DictVar), idType, - SYN_IE(Id) - ) -- others: -import Name ( Name{--O only-}, NamedThing(..) ) -import BasicTypes ( IfaceFlavour ) -import TcEnv ( tcLookupGlobalValueMaybe, tcExtendGlobalValEnv ) -import TcMonad -import TcType ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar), - zonkTcTypeToType, zonkTcTyVarToTyVar - ) -import Usage ( SYN_IE(UVar) ) -import Util ( zipEqual, panic, - pprPanic, pprTrace -#ifdef DEBUG - , assertPanic -#endif - ) - -import PprType ( GenType, GenTyVar ) -- instances -import Type ( mkTyVarTy, tyVarsOfType, SYN_IE(Type) ) -import TyVar ( GenTyVar {- instances -}, SYN_IE(TyVar), - SYN_IE(TyVarEnv), nullTyVarEnv, growTyVarEnvList, emptyTyVarSet ) -import TysPrim ( voidTy ) -import CoreSyn ( GenCoreExpr ) -import Unique ( Unique ) -- instances +import Id ( idType, setIdType, Id ) +import DataCon ( dataConWrapId ) + +import TcRnMonad +import Type ( Type ) +import TcType ( TcType, TcTyVar, eqKind, isTypeKind, mkTyVarTy, + tcGetTyVar, isAnyTypeKind, mkTyConApp ) +import qualified Type +import TcMType ( zonkTcTyVarToTyVar, zonkType, zonkTcType, zonkTcTyVars, + putTcTyVar ) +import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, + doublePrimTy, addrPrimTy + ) +import TysWiredIn ( charTy, stringTy, intTy, integerTy, + mkListTy, mkPArrTy, mkTupleTy, unitTy, + voidTy, listTyCon, tupleTyCon ) +import TyCon ( mkPrimTyCon, tyConKind ) +import PrimRep ( PrimRep(VoidRep) ) +import CoreSyn ( CoreExpr ) +import Name ( Name, getOccName, mkInternalName, mkDerivedTyConOcc ) +import Var ( isId, isLocalVar, tyVarKind ) +import VarSet +import VarEnv +import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName, mapIPName ) +import Maybes ( orElse ) +import Maybe ( isNothing ) +import Unique ( Uniquable(..) ) +import SrcLoc ( noSrcLoc ) import Bag -import UniqFM import Outputable -import Pretty \end{code} @@ -80,33 +91,43 @@ At the end of type checking we zonk everything to @Typechecked...@ datatypes, which have immutable type variables in them. \begin{code} -type TcHsBinds s = HsBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcMonoBinds s = MonoBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcDictBinds s = TcMonoBinds s -type TcPat s = OutPat (TcTyVar s) UVar (TcIdOcc s) -type TcExpr s = HsExpr (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcGRHSsAndBinds s = GRHSsAndBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcGRHS s = GRHS (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcMatch s = Match (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcStmt s = Stmt (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcArithSeqInfo s = ArithSeqInfo (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcRecordBinds s = HsRecordBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcHsModule s = HsModule (TcTyVar s) UVar (TcIdOcc s) (TcPat s) - -type TcCoreExpr s = GenCoreExpr (TcIdOcc s) (TcIdOcc s) (TcTyVar s) UVar - -type TypecheckedPat = OutPat TyVar UVar Id -type TypecheckedMonoBinds = MonoBinds TyVar UVar Id TypecheckedPat +type TcHsBinds = HsBinds TcId +type TcMonoBinds = MonoBinds TcId +type TcDictBinds = TcMonoBinds +type TcPat = OutPat TcId +type TcExpr = HsExpr TcId +type TcGRHSs = GRHSs TcId +type TcGRHS = GRHS TcId +type TcMatch = Match TcId +type TcStmt = Stmt TcId +type TcArithSeqInfo = ArithSeqInfo TcId +type TcRecordBinds = HsRecordBinds TcId +type TcHsModule = HsModule TcId +type TcForeignDecl = ForeignDecl TcId +type TcRuleDecl = RuleDecl TcId +type TcCmd = HsCmd TcId +type TcCmdTop = HsCmdTop TcId + +type TypecheckedPat = OutPat Id +type TypecheckedMonoBinds = MonoBinds Id type TypecheckedDictBinds = TypecheckedMonoBinds -type TypecheckedHsBinds = HsBinds TyVar UVar Id TypecheckedPat -type TypecheckedHsExpr = HsExpr TyVar UVar Id TypecheckedPat -type TypecheckedArithSeqInfo = ArithSeqInfo TyVar UVar Id TypecheckedPat -type TypecheckedStmt = Stmt TyVar UVar Id TypecheckedPat -type TypecheckedMatch = Match TyVar UVar Id TypecheckedPat -type TypecheckedGRHSsAndBinds = GRHSsAndBinds TyVar UVar Id TypecheckedPat -type TypecheckedGRHS = GRHS TyVar UVar Id TypecheckedPat -type TypecheckedRecordBinds = HsRecordBinds TyVar UVar Id TypecheckedPat -type TypecheckedHsModule = HsModule TyVar UVar Id TypecheckedPat +type TypecheckedHsBinds = HsBinds Id +type TypecheckedHsExpr = HsExpr Id +type TypecheckedArithSeqInfo = ArithSeqInfo Id +type TypecheckedStmt = Stmt Id +type TypecheckedMatch = Match Id +type TypecheckedGRHSs = GRHSs Id +type TypecheckedGRHS = GRHS Id +type TypecheckedRecordBinds = HsRecordBinds Id +type TypecheckedHsModule = HsModule Id +type TypecheckedForeignDecl = ForeignDecl Id +type TypecheckedRuleDecl = RuleDecl Id +type TypecheckedCoreBind = (Id, CoreExpr) +type TypecheckedHsCmd = HsCmd Id +type TypecheckedHsCmdTop = HsCmdTop Id + +type TypecheckedMatchContext = HsMatchContext Name -- Keeps consistency with + -- HsDo arg StmtContext \end{code} \begin{code} @@ -122,210 +143,326 @@ mkHsTyLam tyvars expr = TyLam tyvars expr mkHsDictLam [] expr = expr mkHsDictLam dicts expr = DictLam dicts expr -tcIdType :: TcIdOcc s -> TcType s -tcIdType (TcId id) = idType id -tcIdType (RealId id) = pprPanic "tcIdType:" (ppr PprDebug id) +mkHsLet EmptyMonoBinds expr = expr +mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr -tcIdTyVars (TcId id) = tyVarsOfType (idType id) -tcIdTyVars (RealId _) = emptyTyVarSet -- Top level Ids have no free type variables +mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args \end{code} + %************************************************************************ %* * -\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@} +\subsection[mkFailurePair]{Code for pattern-matching and other failures} %* * %************************************************************************ -This 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 TcIdBndr to an Id by zonking its type - -We pass an environment around so that +Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@, +then something is wrong. +\begin{code} +hsPatType :: TypecheckedPat -> Type + +hsPatType (ParPat pat) = hsPatType pat +hsPatType (WildPat ty) = ty +hsPatType (VarPat var) = idType var +hsPatType (LazyPat pat) = hsPatType pat +hsPatType (LitPat lit) = hsLitType lit +hsPatType (AsPat var pat) = idType var +hsPatType (ListPat _ ty) = mkListTy ty +hsPatType (PArrPat _ ty) = mkPArrTy ty +hsPatType (TuplePat pats box) = mkTupleTy box (length pats) (map hsPatType pats) +hsPatType (ConPatOut _ _ ty _ _) = ty +hsPatType (SigPatOut _ ty _) = ty +hsPatType (NPatOut lit ty _) = ty +hsPatType (NPlusKPatOut id _ _ _) = idType id +hsPatType (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) = integerTy +hsLitType (HsRat _ ty) = ty +hsLitType (HsFloatPrim f) = floatPrimTy +hsLitType (HsDoublePrim d) = doublePrimTy +hsLitType (HsLitLit _ ty) = ty +\end{code} - a) we know which TyVars are unbound - b) 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 +%************************************************************************ +%* * +\subsection{Coercion functions} +%* * +%************************************************************************ -Actually, since this is all in the Tc monad, it's convenient to keep the -mapping from TcIds to Ids in the GVE of the Tc monad. (Those TcIds -were previously in the LVE of the Tc monad.) +\begin{code} +type Coercion a = Maybe (a -> a) + -- Nothing => identity fn -It's all pretty boring stuff, because HsSyn is such a large type, and -the environment manipulation is tiresome. +type ExprCoFn = Coercion TypecheckedHsExpr +type PatCoFn = Coercion TcPat +(<.>) :: Coercion a -> Coercion a -> Coercion a -- Composition +Nothing <.> Nothing = Nothing +Nothing <.> Just f = Just f +Just f <.> Nothing = Just f +Just f1 <.> Just f2 = Just (f1 . f2) -\begin{code} -extend_te te tyvars = growTyVarEnvList te [(tyvar, mkTyVarTy tyvar) | tyvar <- tyvars] +(<$>) :: Coercion a -> a -> a +Just f <$> e = f e +Nothing <$> e = e -zonkIdBndr :: TyVarEnv Type -> TcIdOcc s -> NF_TcM s Id -zonkIdBndr te (TcId (Id u n ty details prags info)) - = zonkTcTypeToType te ty `thenNF_Tc` \ ty' -> - returnNF_Tc (Id u n ty' details prags info) +mkCoercion :: (a -> a) -> Coercion a +mkCoercion f = Just f -zonkIdBndr te (RealId id) = returnNF_Tc id +idCoercion :: Coercion a +idCoercion = Nothing -zonkIdOcc :: TcIdOcc s -> NF_TcM s Id -zonkIdOcc (RealId id) = returnNF_Tc id -zonkIdOcc (TcId id) - = tcLookupGlobalValueMaybe (getName id) `thenNF_Tc` \ maybe_id' -> - let - new_id = case maybe_id' of - Just id' -> id' - Nothing -> pprTrace "zonkIdOcc: " (ppr PprDebug id) $ - Id u n voidTy details prags info - where - Id u n _ details prags info = id - in - returnNF_Tc new_id +isIdCoercion :: Coercion a -> Bool +isIdCoercion = isNothing \end{code} -\begin{code} -zonkTopBinds :: TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, TcEnv s) -zonkTopBinds binds -- Top level is implicitly recursive - = fixNF_Tc (\ ~(_, new_ids) -> - tcExtendGlobalValEnv (bagToList new_ids) $ - zonkMonoBinds nullTyVarEnv binds `thenNF_Tc` \ (binds', new_ids) -> - tcGetEnv `thenNF_Tc` \ env -> - returnNF_Tc ((binds', env), new_ids) - ) `thenNF_Tc` \ (stuff, _) -> - returnNF_Tc stuff - - -zonkBinds :: TyVarEnv Type - -> TcHsBinds s - -> NF_TcM s (TypecheckedHsBinds, TcEnv s) - -zonkBinds te binds - = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env -> returnNF_Tc (binds', env)) - where - -- go :: TcHsBinds s -> (TypecheckedHsBinds -> NF_TcM s (TypecheckedHsBinds, TcEnv s)) - -- -> NF_TcM s (TypecheckedHsBinds, TcEnv s) - go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' -> - go b2 $ \ b2' -> - thing_inside (b1' `ThenBinds` b2') - - go EmptyBinds thing_inside = thing_inside EmptyBinds - - go (MonoBind bind sigs is_rec) thing_inside - = ASSERT( null sigs ) - fixNF_Tc (\ ~(_, new_ids) -> - tcExtendGlobalValEnv (bagToList new_ids) $ - zonkMonoBinds te bind `thenNF_Tc` \ (new_bind, new_ids) -> - thing_inside (MonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff -> - returnNF_Tc (stuff, new_ids) - ) `thenNF_Tc` \ (stuff, _) -> - returnNF_Tc stuff -\end{code} +%************************************************************************ +%* * +\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@} +%* * +%************************************************************************ \begin{code} -------------------------------------------------------------------------- -zonkMonoBinds :: TyVarEnv Type - -> TcMonoBinds s - -> NF_TcM s (TypecheckedMonoBinds, Bag Id) +-- 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} -zonkMonoBinds te EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag) +The rest of the zonking is done *after* typechecking. +The main zonking pass runs over the bindings -zonkMonoBinds te (AndMonoBinds mbinds1 mbinds2) - = zonkMonoBinds te mbinds1 `thenNF_Tc` \ (b1', ids1) -> - zonkMonoBinds te mbinds2 `thenNF_Tc` \ (b2', ids2) -> - returnNF_Tc (b1' `AndMonoBinds` b2', ids1 `unionBags` ids2) + 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 -zonkMonoBinds te (PatMonoBind pat grhss_w_binds locn) - = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) -> - zonkGRHSsAndBinds te grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds -> - returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn, ids) +The type variables are converted by binding mutable tyvars to immutable ones +and then zonking as normal. -zonkMonoBinds te (VarMonoBind var expr) - = zonkIdBndr te var `thenNF_Tc` \ new_var -> - zonkExpr te expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var) +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 -zonkMonoBinds te (CoreMonoBind var core_expr) - = zonkIdBndr te var `thenNF_Tc` \ new_var -> - returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var) +It's all pretty boring stuff, because HsSyn is such a large type, and +the environment manipulation is tiresome. -zonkMonoBinds te (FunMonoBind var inf ms locn) - = zonkIdBndr te var `thenNF_Tc` \ new_var -> - mapNF_Tc (zonkMatch te) ms `thenNF_Tc` \ new_ms -> - returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var) +\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]) + +setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv +setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env + +mkZonkEnv :: [Id] -> ZonkEnv +mkZonkEnv ids = extendZonkEnv emptyZonkEnv ids + +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.) +-- +-- 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 separte 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} -zonkMonoBinds te (AbsBinds tyvars dicts exports val_bind) - = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars -> +\begin{code} +zonkTopExpr :: TcExpr -> TcM TypecheckedHsExpr +zonkTopExpr e = zonkExpr emptyZonkEnv e + +zonkTopDecls :: TcMonoBinds -> [TcRuleDecl] -> [TcForeignDecl] + -> TcM ([Id], + TypecheckedMonoBinds, + [TypecheckedForeignDecl], + [TypecheckedRuleDecl]) +zonkTopDecls binds rules fords -- Top level is implicitly recursive + = fixM (\ ~(new_ids, _, _, _) -> + let + zonk_env = mkZonkEnv new_ids + in + zonkMonoBinds zonk_env binds `thenM` \ (binds', new_ids) -> + zonkRules zonk_env rules `thenM` \ rules' -> + zonkForeignExports zonk_env fords `thenM` \ fords' -> + + returnM (bagToList new_ids, binds', fords', rules') + ) + +zonkTopBinds :: TcMonoBinds -> TcM ([Id], TypecheckedMonoBinds) +zonkTopBinds binds + = fixM (\ ~(new_ids, _) -> + let + zonk_env = mkZonkEnv new_ids + in + zonkMonoBinds zonk_env binds `thenM` \ (binds', new_ids) -> + returnM (bagToList new_ids, binds') + ) + +--------------------------------------------- +zonkBinds :: ZonkEnv -> TcHsBinds -> TcM (ZonkEnv, TypecheckedHsBinds) +zonkBinds env EmptyBinds = returnM (env, EmptyBinds) + +zonkBinds env (ThenBinds b1 b2) + = zonkBinds env b1 `thenM` \ (env1, b1') -> + zonkBinds env1 b2 `thenM` \ (env2, b2') -> + returnM (env2, b1' `ThenBinds` b2') + +zonkBinds env (MonoBind bind sigs is_rec) + = ASSERT( null sigs ) + fixM (\ ~(_, _, new_ids) -> + let + env1 = extendZonkEnv env (bagToList new_ids) + in + zonkMonoBinds env1 bind `thenM` \ (new_bind, new_ids) -> + returnM (env1, new_bind, new_ids) + ) `thenM` \ (env1, new_bind, _) -> + returnM (env1, mkMonoBind is_rec new_bind) + +zonkBinds env (IPBinds binds is_with) + = mappM zonk_ip_bind binds `thenM` \ new_binds -> let - new_te = extend_te te new_tyvars + env1 = extendZonkEnv env (map (ipNameName . fst) new_binds) in - mapNF_Tc (zonkIdBndr new_te) dicts `thenNF_Tc` \ new_dicts -> - - tcExtendGlobalValEnv new_dicts $ - fixNF_Tc (\ ~(_, _, val_bind_ids) -> - tcExtendGlobalValEnv (bagToList val_bind_ids) $ - zonkMonoBinds new_te val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) -> - mapNF_Tc (zonkExport new_te) exports `thenNF_Tc` \ new_exports -> - returnNF_Tc (new_val_bind, new_exports, val_bind_ids) - ) `thenNF_Tc ` \ (new_val_bind, new_exports, _) -> + returnM (env1, IPBinds new_binds is_with) + where + zonk_ip_bind (n, e) + = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' -> + zonkExpr env e `thenM` \ e' -> + returnM (n', e') + + +--------------------------------------------- +zonkMonoBinds :: ZonkEnv -> TcMonoBinds + -> TcM (TypecheckedMonoBinds, Bag Id) + +zonkMonoBinds env EmptyMonoBinds = returnM (EmptyMonoBinds, emptyBag) + +zonkMonoBinds env (AndMonoBinds mbinds1 mbinds2) + = zonkMonoBinds env mbinds1 `thenM` \ (b1', ids1) -> + zonkMonoBinds env mbinds2 `thenM` \ (b2', ids2) -> + returnM (b1' `AndMonoBinds` b2', + ids1 `unionBags` ids2) + +zonkMonoBinds env (PatMonoBind pat grhss locn) + = zonkPat env pat `thenM` \ (new_pat, ids) -> + zonkGRHSs env grhss `thenM` \ new_grhss -> + returnM (PatMonoBind new_pat new_grhss locn, ids) + +zonkMonoBinds env (VarMonoBind var expr) + = zonkIdBndr env var `thenM` \ new_var -> + zonkExpr env expr `thenM` \ new_expr -> + returnM (VarMonoBind new_var new_expr, unitBag new_var) + +zonkMonoBinds env (FunMonoBind var inf ms locn) + = zonkIdBndr env var `thenM` \ new_var -> + mappM (zonkMatch env) ms `thenM` \ new_ms -> + returnM (FunMonoBind new_var inf new_ms locn, unitBag new_var) + + +zonkMonoBinds env (AbsBinds tyvars dicts exports inlines val_bind) + = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars -> + -- No need to extend tyvar env: the effects are + -- propagated through binding the tyvars themselves + + zonkIdBndrs env dicts `thenM` \ new_dicts -> + fixM (\ ~(_, _, val_bind_ids) -> + let + env1 = extendZonkEnv (extendZonkEnv env new_dicts) + (bagToList val_bind_ids) + in + zonkMonoBinds env1 val_bind `thenM` \ (new_val_bind, val_bind_ids) -> + mappM (zonkExport env1) exports `thenM` \ new_exports -> + returnM (new_val_bind, new_exports, val_bind_ids) + ) `thenM ` \ (new_val_bind, new_exports, _) -> let - new_globals = listToBag [global | (_, global, local) <- new_exports] + new_globals = listToBag [global | (_, global, local) <- new_exports] in - returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports new_val_bind, + returnM (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind, new_globals) where - zonkExport te (tyvars, global, local) - = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars -> - zonkIdBndr te global `thenNF_Tc` \ new_global -> - zonkIdOcc local `thenNF_Tc` \ new_local -> - returnNF_Tc (new_tyvars, new_global, new_local) + zonkExport env (tyvars, global, local) + = zonkTcTyVars tyvars `thenM` \ tys -> + let + new_tyvars = map (tcGetTyVar "zonkExport") tys + -- This isn't the binding occurrence of these tyvars + -- but they should *be* tyvars. Hence tcGetTyVar. + in + zonkIdBndr env global `thenM` \ new_global -> + returnM (new_tyvars, new_global, zonkIdOcc env local) \end{code} %************************************************************************ %* * -\subsection[BackSubst-Match-GRHSs]{Match and GRHSsAndBinds} +\subsection[BackSubst-Match-GRHSs]{Match and GRHSs} %* * %************************************************************************ \begin{code} -zonkMatch :: TyVarEnv Type - -> TcMatch s -> NF_TcM s TypecheckedMatch - -zonkMatch te (PatMatch pat match) - = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) -> - tcExtendGlobalValEnv (bagToList ids) $ - zonkMatch te match `thenNF_Tc` \ new_match -> - returnNF_Tc (PatMatch new_pat new_match) - -zonkMatch te (GRHSMatch grhss_w_binds) - = zonkGRHSsAndBinds te grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds -> - returnNF_Tc (GRHSMatch new_grhss_w_binds) +zonkMatch :: ZonkEnv -> TcMatch -> TcM TypecheckedMatch -zonkMatch te (SimpleMatch expr) - = zonkExpr te expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (SimpleMatch new_expr) +zonkMatch env (Match pats _ grhss) + = zonkPats env pats `thenM` \ (new_pats, new_ids) -> + zonkGRHSs (extendZonkEnv env (bagToList new_ids)) grhss `thenM` \ new_grhss -> + returnM (Match new_pats Nothing new_grhss) ------------------------------------------------------------------------- -zonkGRHSsAndBinds :: TyVarEnv Type - -> TcGRHSsAndBinds s - -> NF_TcM s TypecheckedGRHSsAndBinds +zonkGRHSs :: ZonkEnv -> TcGRHSs -> TcM TypecheckedGRHSs -zonkGRHSsAndBinds te (GRHSsAndBindsOut grhss binds ty) - = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_env) -> - tcSetEnv new_env $ +zonkGRHSs env (GRHSs grhss binds ty) + = zonkBinds env binds `thenM` \ (new_env, new_binds) -> let - zonk_grhs (GRHS guard expr locn) - = zonkStmts te guard `thenNF_Tc` \ (new_guard, new_env) -> - tcSetEnv new_env $ - zonkExpr te expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (GRHS new_guard new_expr locn) - - zonk_grhs (OtherwiseGRHS expr locn) - = zonkExpr te expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (OtherwiseGRHS new_expr locn) + zonk_grhs (GRHS guarded locn) + = zonkStmts new_env guarded `thenM` \ new_guarded -> + returnM (GRHS new_guarded locn) in - mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss -> - zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty) + mappM zonk_grhs grhss `thenM` \ new_grhss -> + zonkTcTypeToType env ty `thenM` \ new_ty -> + returnM (GRHSs new_grhss new_binds new_ty) \end{code} %************************************************************************ @@ -335,232 +472,321 @@ zonkGRHSsAndBinds te (GRHSsAndBindsOut grhss binds ty) %************************************************************************ \begin{code} -zonkExpr :: TyVarEnv Type - -> TcExpr s -> NF_TcM s TypecheckedHsExpr - -zonkExpr te (HsVar id) - = zonkIdOcc id `thenNF_Tc` \ id' -> - returnNF_Tc (HsVar id') - -zonkExpr te (HsLit _) = panic "zonkExpr te:HsLit" - -zonkExpr te (HsLitOut lit ty) - = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (HsLitOut lit new_ty) - -zonkExpr te (HsLam match) - = zonkMatch te match `thenNF_Tc` \ new_match -> - returnNF_Tc (HsLam new_match) - -zonkExpr te (HsApp e1 e2) - = zonkExpr te e1 `thenNF_Tc` \ new_e1 -> - zonkExpr te e2 `thenNF_Tc` \ new_e2 -> - returnNF_Tc (HsApp new_e1 new_e2) - -zonkExpr te (OpApp e1 op fixity e2) - = zonkExpr te e1 `thenNF_Tc` \ new_e1 -> - zonkExpr te op `thenNF_Tc` \ new_op -> - zonkExpr te e2 `thenNF_Tc` \ new_e2 -> - returnNF_Tc (OpApp new_e1 new_op fixity new_e2) - -zonkExpr te (NegApp _ _) = panic "zonkExpr te:NegApp" -zonkExpr te (HsPar _) = panic "zonkExpr te:HsPar" - -zonkExpr te (SectionL expr op) - = zonkExpr te expr `thenNF_Tc` \ new_expr -> - zonkExpr te op `thenNF_Tc` \ new_op -> - returnNF_Tc (SectionL new_expr new_op) - -zonkExpr te (SectionR op expr) - = zonkExpr te op `thenNF_Tc` \ new_op -> - zonkExpr te expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (SectionR new_op new_expr) - -zonkExpr te (HsCase expr ms src_loc) - = zonkExpr te expr `thenNF_Tc` \ new_expr -> - mapNF_Tc (zonkMatch te) ms `thenNF_Tc` \ new_ms -> - returnNF_Tc (HsCase new_expr new_ms src_loc) - -zonkExpr te (HsIf e1 e2 e3 src_loc) - = zonkExpr te e1 `thenNF_Tc` \ new_e1 -> - zonkExpr te e2 `thenNF_Tc` \ new_e2 -> - zonkExpr te e3 `thenNF_Tc` \ new_e3 -> - returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc) - -zonkExpr te (HsLet binds expr) - = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_env) -> - tcSetEnv new_env $ - zonkExpr te expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (HsLet new_binds new_expr) - -zonkExpr te (HsDo _ _ _) = panic "zonkExpr te:HsDo" - -zonkExpr te (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc) - = zonkStmts te stmts `thenNF_Tc` \ (new_stmts, _) -> - zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - zonkIdOcc return_id `thenNF_Tc` \ new_return_id -> - zonkIdOcc then_id `thenNF_Tc` \ new_then_id -> - zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id -> - returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id - new_ty src_loc) - -zonkExpr te (ExplicitList _) = panic "zonkExpr te:ExplicitList" - -zonkExpr te (ExplicitListOut ty exprs) - = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs -> - returnNF_Tc (ExplicitListOut new_ty new_exprs) - -zonkExpr te (ExplicitTuple exprs) - = mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs -> - returnNF_Tc (ExplicitTuple new_exprs) - -zonkExpr te (RecordConOut con_id con_expr rbinds) - = zonkIdOcc con_id `thenNF_Tc` \ new_con_id -> - zonkExpr te con_expr `thenNF_Tc` \ new_con_expr -> - zonkRbinds te rbinds `thenNF_Tc` \ new_rbinds -> - returnNF_Tc (RecordConOut new_con_id new_con_expr new_rbinds) - -zonkExpr te (RecordUpd _ _) = panic "zonkExpr te:RecordUpd" - -zonkExpr te (RecordUpdOut expr ty dicts rbinds) - = zonkExpr te expr `thenNF_Tc` \ new_expr -> - zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts -> - zonkRbinds te rbinds `thenNF_Tc` \ new_rbinds -> - returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds) - -zonkExpr te (ExprWithTySig _ _) = panic "zonkExpr te:ExprWithTySig" -zonkExpr te (ArithSeqIn _) = panic "zonkExpr te:ArithSeqIn" - -zonkExpr te (ArithSeqOut expr info) - = zonkExpr te expr `thenNF_Tc` \ new_expr -> - zonkArithSeq te info `thenNF_Tc` \ new_info -> - returnNF_Tc (ArithSeqOut new_expr new_info) - -zonkExpr te (CCall fun args may_gc is_casm result_ty) - = mapNF_Tc (zonkExpr te) args `thenNF_Tc` \ new_args -> - zonkTcTypeToType te result_ty `thenNF_Tc` \ new_result_ty -> - returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty) - -zonkExpr te (HsSCC label expr) - = zonkExpr te expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (HsSCC label new_expr) - -zonkExpr te (TyLam tyvars expr) - = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars -> - let - new_te = extend_te te new_tyvars - in - zonkExpr new_te expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (TyLam new_tyvars new_expr) +zonkExprs :: ZonkEnv -> [TcExpr] -> TcM [TypecheckedHsExpr] +zonkExpr :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr -zonkExpr te (TyApp expr tys) - = zonkExpr te expr `thenNF_Tc` \ new_expr -> - mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys -> - returnNF_Tc (TyApp new_expr new_tys) +zonkExprs env exprs = mappM (zonkExpr env) exprs -zonkExpr te (DictLam dicts expr) - = mapNF_Tc (zonkIdBndr te) dicts `thenNF_Tc` \ new_dicts -> - tcExtendGlobalValEnv new_dicts $ - zonkExpr te expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (DictLam new_dicts new_expr) -zonkExpr te (DictApp expr dicts) - = zonkExpr te expr `thenNF_Tc` \ new_expr -> - mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts -> - returnNF_Tc (DictApp new_expr new_dicts) +zonkExpr env (HsVar id) + = returnM (HsVar (zonkIdOcc env id)) -zonkExpr te (ClassDictLam dicts methods expr) - = zonkExpr te expr `thenNF_Tc` \ new_expr -> - mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts -> - mapNF_Tc zonkIdOcc methods `thenNF_Tc` \ new_methods -> - returnNF_Tc (ClassDictLam new_dicts new_methods new_expr) +zonkExpr env (HsIPVar id) + = returnM (HsIPVar (mapIPName (zonkIdOcc env) id)) -zonkExpr te (Dictionary dicts methods) - = mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts -> - mapNF_Tc zonkIdOcc methods `thenNF_Tc` \ new_methods -> - returnNF_Tc (Dictionary new_dicts new_methods) +zonkExpr env (HsLit (HsRat f ty)) + = zonkTcTypeToType env ty `thenM` \ new_ty -> + returnM (HsLit (HsRat f new_ty)) -zonkExpr te (SingleDict name) - = zonkIdOcc name `thenNF_Tc` \ name' -> - returnNF_Tc (SingleDict name') +zonkExpr env (HsLit (HsLitLit lit ty)) + = zonkTcTypeToType env ty `thenM` \ new_ty -> + returnM (HsLit (HsLitLit lit new_ty)) +zonkExpr env (HsLit lit) + = returnM (HsLit lit) -------------------------------------------------------------------------- -zonkArithSeq :: TyVarEnv Type - -> TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo +-- HsOverLit doesn't appear in typechecker output + +zonkExpr env (HsLam match) + = zonkMatch env match `thenM` \ new_match -> + returnM (HsLam new_match) + +zonkExpr env (HsApp e1 e2) + = zonkExpr env e1 `thenM` \ new_e1 -> + zonkExpr 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) = zonkExpr env e `thenM` \ e' -> + returnM (n,e') + +zonkExpr env (HsReify r) = returnM (HsReify r) -- Nothing to zonk; only top + -- level things can be reified (for now) +zonkExpr env (HsSplice n e loc) = WARN( True, ppr e ) -- Should not happen + returnM (HsSplice n e loc) + +zonkExpr env (OpApp e1 op fixity e2) + = zonkExpr env e1 `thenM` \ new_e1 -> + zonkExpr env op `thenM` \ new_op -> + zonkExpr env e2 `thenM` \ new_e2 -> + returnM (OpApp new_e1 new_op fixity new_e2) + +zonkExpr env (NegApp _ _) = panic "zonkExpr env: NegApp" + +zonkExpr env (HsPar e) + = zonkExpr env e `thenM` \new_e -> + returnM (HsPar new_e) + +zonkExpr env (SectionL expr op) + = zonkExpr env expr `thenM` \ new_expr -> + zonkExpr env op `thenM` \ new_op -> + returnM (SectionL new_expr new_op) + +zonkExpr env (SectionR op expr) + = zonkExpr env op `thenM` \ new_op -> + zonkExpr env expr `thenM` \ new_expr -> + returnM (SectionR new_op new_expr) + +zonkExpr env (HsCase expr ms src_loc) + = zonkExpr env expr `thenM` \ new_expr -> + mappM (zonkMatch env) ms `thenM` \ new_ms -> + returnM (HsCase new_expr new_ms src_loc) + +zonkExpr env (HsIf e1 e2 e3 src_loc) + = zonkExpr env e1 `thenM` \ new_e1 -> + zonkExpr env e2 `thenM` \ new_e2 -> + zonkExpr env e3 `thenM` \ new_e3 -> + returnM (HsIf new_e1 new_e2 new_e3 src_loc) + +zonkExpr env (HsLet binds expr) + = zonkBinds env binds `thenM` \ (new_env, new_binds) -> + zonkExpr new_env expr `thenM` \ new_expr -> + returnM (HsLet new_binds new_expr) + +zonkExpr env (HsDo do_or_lc stmts ids ty src_loc) + = zonkStmts env stmts `thenM` \ new_stmts -> + zonkTcTypeToType env ty `thenM` \ new_ty -> + zonkReboundNames env ids `thenM` \ new_ids -> + returnM (HsDo do_or_lc new_stmts new_ids + new_ty src_loc) + +zonkExpr env (ExplicitList ty exprs) + = zonkTcTypeToType env ty `thenM` \ new_ty -> + zonkExprs env exprs `thenM` \ new_exprs -> + returnM (ExplicitList new_ty new_exprs) + +zonkExpr env (ExplicitPArr ty exprs) + = zonkTcTypeToType env ty `thenM` \ new_ty -> + zonkExprs env exprs `thenM` \ new_exprs -> + returnM (ExplicitPArr new_ty new_exprs) + +zonkExpr env (ExplicitTuple exprs boxed) + = zonkExprs env exprs `thenM` \ new_exprs -> + returnM (ExplicitTuple new_exprs boxed) + +zonkExpr env (RecordConOut data_con con_expr rbinds) + = zonkExpr env con_expr `thenM` \ new_con_expr -> + zonkRbinds env rbinds `thenM` \ new_rbinds -> + returnM (RecordConOut data_con new_con_expr new_rbinds) + +zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd" + +zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds) + = zonkExpr 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 (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds) + +zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig" +zonkExpr env (ArithSeqIn _) = panic "zonkExpr env:ArithSeqIn" +zonkExpr env (PArrSeqIn _) = panic "zonkExpr env:PArrSeqIn" + +zonkExpr env (ArithSeqOut expr info) + = zonkExpr env expr `thenM` \ new_expr -> + zonkArithSeq env info `thenM` \ new_info -> + returnM (ArithSeqOut new_expr new_info) + +zonkExpr env (PArrSeqOut expr info) + = zonkExpr env expr `thenM` \ new_expr -> + zonkArithSeq env info `thenM` \ new_info -> + returnM (PArrSeqOut new_expr new_info) + +zonkExpr env (HsCCall fun args may_gc is_casm result_ty) + = zonkExprs env args `thenM` \ new_args -> + zonkTcTypeToType env result_ty `thenM` \ new_result_ty -> + returnM (HsCCall fun new_args may_gc is_casm new_result_ty) + +zonkExpr env (HsSCC lbl expr) + = zonkExpr env expr `thenM` \ new_expr -> + returnM (HsSCC lbl new_expr) + +-- hdaume: core annotations +zonkExpr env (HsCoreAnn lbl expr) + = zonkExpr env expr `thenM` \ new_expr -> + returnM (HsCoreAnn lbl new_expr) + +zonkExpr env (TyLam tyvars expr) + = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars -> + -- No need to extend tyvar env; see AbsBinds + + zonkExpr env expr `thenM` \ new_expr -> + returnM (TyLam new_tyvars new_expr) + +zonkExpr env (TyApp expr tys) + = zonkExpr env expr `thenM` \ new_expr -> + mappM (zonkTcTypeToType 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 + zonkExpr env1 expr `thenM` \ new_expr -> + returnM (DictLam new_dicts new_expr) -zonkArithSeq te (From e) - = zonkExpr te e `thenNF_Tc` \ new_e -> - returnNF_Tc (From new_e) +zonkExpr env (DictApp expr dicts) + = zonkExpr env expr `thenM` \ new_expr -> + returnM (DictApp new_expr (zonkIdOccs env dicts)) -zonkArithSeq te (FromThen e1 e2) - = zonkExpr te e1 `thenNF_Tc` \ new_e1 -> - zonkExpr te e2 `thenNF_Tc` \ new_e2 -> - returnNF_Tc (FromThen new_e1 new_e2) +-- arrow notation extensions +zonkExpr env (HsProc pat body src_loc) + = zonkPat env pat `thenM` \ (new_pat, new_ids) -> + let + env1 = extendZonkEnv env (bagToList new_ids) + in + zonkCmdTop env1 body `thenM` \ new_body -> + returnM (HsProc new_pat new_body src_loc) + +zonkExpr env (HsArrApp e1 e2 ty ho rl src_loc) + = zonkExpr env e1 `thenM` \ new_e1 -> + zonkExpr env e2 `thenM` \ new_e2 -> + zonkTcTypeToType env ty `thenM` \ new_ty -> + returnM (HsArrApp new_e1 new_e2 new_ty ho rl src_loc) + +zonkExpr env (HsArrForm op fixity args src_loc) + = zonkExpr env op `thenM` \ new_op -> + mappM (zonkCmdTop env) args `thenM` \ new_args -> + returnM (HsArrForm new_op fixity new_args src_loc) + +zonkCmdTop :: ZonkEnv -> TcCmdTop -> TcM TypecheckedHsCmdTop +zonkCmdTop env (HsCmdTop cmd stack_tys ty ids) + = zonkExpr env cmd `thenM` \ new_cmd -> + mappM (zonkTcTypeToType env) stack_tys + `thenM` \ new_stack_tys -> + zonkTcTypeToType env ty `thenM` \ new_ty -> + zonkReboundNames env ids `thenM` \ new_ids -> + returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids) -zonkArithSeq te (FromTo e1 e2) - = zonkExpr te e1 `thenNF_Tc` \ new_e1 -> - zonkExpr te e2 `thenNF_Tc` \ new_e2 -> - returnNF_Tc (FromTo new_e1 new_e2) +------------------------------------------------------------------------- +zonkReboundNames :: ZonkEnv -> ReboundNames Id -> TcM (ReboundNames Id) +zonkReboundNames env prs + = mapM zonk prs + where + zonk (n, e) = zonkExpr env e `thenM` \ new_e -> + returnM (n, new_e) -zonkArithSeq te (FromThenTo e1 e2 e3) - = zonkExpr te e1 `thenNF_Tc` \ new_e1 -> - zonkExpr te e2 `thenNF_Tc` \ new_e2 -> - zonkExpr te e3 `thenNF_Tc` \ new_e3 -> - returnNF_Tc (FromThenTo new_e1 new_e2 new_e3) ------------------------------------------------------------------------- -zonkStmts :: TyVarEnv Type - -> [TcStmt s] -> NF_TcM s ([TypecheckedStmt], TcEnv s) +zonkArithSeq :: ZonkEnv -> TcArithSeqInfo -> TcM TypecheckedArithSeqInfo + +zonkArithSeq env (From e) + = zonkExpr env e `thenM` \ new_e -> + returnM (From new_e) -zonkStmts te [] = tcGetEnv `thenNF_Tc` \ env -> - returnNF_Tc ([], env) +zonkArithSeq env (FromThen e1 e2) + = zonkExpr env e1 `thenM` \ new_e1 -> + zonkExpr env e2 `thenM` \ new_e2 -> + returnM (FromThen new_e1 new_e2) -zonkStmts te [ReturnStmt expr] - = zonkExpr te expr `thenNF_Tc` \ new_expr -> - tcGetEnv `thenNF_Tc` \ env -> - returnNF_Tc ([ReturnStmt new_expr], env) +zonkArithSeq env (FromTo e1 e2) + = zonkExpr env e1 `thenM` \ new_e1 -> + zonkExpr env e2 `thenM` \ new_e2 -> + returnM (FromTo new_e1 new_e2) -zonkStmts te (ExprStmt expr locn : stmts) - = zonkExpr te expr `thenNF_Tc` \ new_expr -> - zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env) -> - returnNF_Tc (ExprStmt new_expr locn : new_stmts, new_env) +zonkArithSeq env (FromThenTo e1 e2 e3) + = zonkExpr env e1 `thenM` \ new_e1 -> + zonkExpr env e2 `thenM` \ new_e2 -> + zonkExpr env e3 `thenM` \ new_e3 -> + returnM (FromThenTo new_e1 new_e2 new_e3) -zonkStmts te (GuardStmt expr locn : stmts) - = zonkExpr te expr `thenNF_Tc` \ new_expr -> - zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env) -> - returnNF_Tc (GuardStmt new_expr locn : new_stmts, new_env) -zonkStmts te (LetStmt binds : stmts) - = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_env) -> - tcSetEnv new_env $ - zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env2) -> - returnNF_Tc (LetStmt new_binds : new_stmts, new_env2) +------------------------------------------------------------------------- +zonkStmts :: ZonkEnv -> [TcStmt] -> TcM [TypecheckedStmt] + +zonkStmts env stmts = zonk_stmts env stmts `thenM` \ (_, stmts) -> + returnM stmts + +zonk_stmts :: ZonkEnv -> [TcStmt] -> TcM (ZonkEnv, [TypecheckedStmt]) + +zonk_stmts env [] = returnM (env, []) + +zonk_stmts env (ParStmt stmts_w_bndrs : stmts) + = 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 + zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) -> + returnM (env2, ParStmt new_stmts_w_bndrs : new_stmts) + where + zonk_branch (stmts, bndrs) = zonk_stmts env stmts `thenM` \ (env1, new_stmts) -> + returnM (new_stmts, zonkIdOccs env1 bndrs) -zonkStmts te (BindStmt pat expr locn : stmts) - = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) -> - zonkExpr te expr `thenNF_Tc` \ new_expr -> - tcExtendGlobalValEnv (bagToList ids) $ - zonkStmts te stmts `thenNF_Tc` \ (new_stmts, new_env) -> - returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts, new_env) +zonk_stmts env (RecStmt segStmts lvs rvs rets : stmts) + = zonkIdBndrs env rvs `thenM` \ new_rvs -> + let + env1 = extendZonkEnv env new_rvs + in + zonk_stmts env1 segStmts `thenM` \ (env2, new_segStmts) -> + -- Zonk the ret-expressions in an envt that + -- has the polymorphic bindings in the envt + zonkExprs env2 rets `thenM` \ new_rets -> + let + new_lvs = zonkIdOccs env2 lvs + env3 = extendZonkEnv env new_lvs -- Only the lvs are needed + in + zonk_stmts env3 stmts `thenM` \ (env4, new_stmts) -> + returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets : new_stmts) + +zonk_stmts env (ResultStmt expr locn : stmts) + = ASSERT( null stmts ) + zonkExpr env expr `thenM` \ new_expr -> + returnM (env, [ResultStmt new_expr locn]) + +zonk_stmts env (ExprStmt expr ty locn : stmts) + = zonkExpr env expr `thenM` \ new_expr -> + zonkTcTypeToType env ty `thenM` \ new_ty -> + zonk_stmts env stmts `thenM` \ (env1, new_stmts) -> + returnM (env1, ExprStmt new_expr new_ty locn : new_stmts) + +zonk_stmts env (LetStmt binds : stmts) + = zonkBinds env binds `thenM` \ (env1, new_binds) -> + zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) -> + returnM (env2, LetStmt new_binds : new_stmts) + +zonk_stmts env (BindStmt pat expr locn : stmts) + = zonkExpr env expr `thenM` \ new_expr -> + zonkPat env pat `thenM` \ (new_pat, new_ids) -> + let + env1 = extendZonkEnv env (bagToList new_ids) + in + zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) -> + returnM (env2, BindStmt new_pat new_expr locn : new_stmts) ------------------------------------------------------------------------- -zonkRbinds :: TyVarEnv Type - -> TcRecordBinds s -> NF_TcM s TypecheckedRecordBinds +zonkRbinds :: ZonkEnv -> TcRecordBinds -> TcM TypecheckedRecordBinds -zonkRbinds te rbinds - = mapNF_Tc zonk_rbind rbinds +zonkRbinds env rbinds + = mappM zonk_rbind rbinds where - zonk_rbind (field, expr, pun) - = zonkExpr te expr `thenNF_Tc` \ new_expr -> - zonkIdOcc field `thenNF_Tc` \ new_field -> - returnNF_Tc (new_field, new_expr, pun) + zonk_rbind (field, expr) + = zonkExpr env expr `thenM` \ new_expr -> + returnM (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} @@ -568,84 +794,259 @@ zonkRbinds te rbinds %************************************************************************ \begin{code} -zonkPat :: TyVarEnv Type - -> TcPat s -> NF_TcM s (TypecheckedPat, Bag Id) - -zonkPat te (WildPat ty) - = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (WildPat new_ty, emptyBag) - -zonkPat te (VarPat v) - = zonkIdBndr te v `thenNF_Tc` \ new_v -> - returnNF_Tc (VarPat new_v, unitBag new_v) - -zonkPat te (LazyPat pat) - = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) -> - returnNF_Tc (LazyPat new_pat, ids) - -zonkPat te (AsPat n pat) - = zonkIdBndr te n `thenNF_Tc` \ new_n -> - zonkPat te pat `thenNF_Tc` \ (new_pat, ids) -> - returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids) - -zonkPat te (ConPat n ty pats) - = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - zonkPats te pats `thenNF_Tc` \ (new_pats, ids) -> - returnNF_Tc (ConPat n new_ty new_pats, ids) - -zonkPat te (ConOpPat pat1 op pat2 ty) - = zonkPat te pat1 `thenNF_Tc` \ (new_pat1, ids1) -> - zonkPat te pat2 `thenNF_Tc` \ (new_pat2, ids2) -> - zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (ConOpPat new_pat1 op new_pat2 new_ty, ids1 `unionBags` ids2) - -zonkPat te (ListPat ty pats) - = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - zonkPats te pats `thenNF_Tc` \ (new_pats, ids) -> - returnNF_Tc (ListPat new_ty new_pats, ids) - -zonkPat te (TuplePat pats) - = zonkPats te pats `thenNF_Tc` \ (new_pats, ids) -> - returnNF_Tc (TuplePat new_pats, ids) - -zonkPat te (RecPat n ty rpats) - = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) -> - returnNF_Tc (RecPat n new_ty new_rpats, unionManyBags ids_s) - where - zonk_rpat (f, pat, pun) - = zonkPat te pat `thenNF_Tc` \ (new_pat, ids) -> - returnNF_Tc ((f, new_pat, pun), ids) - -zonkPat te (LitPat lit ty) - = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (LitPat lit new_ty, emptyBag) - -zonkPat te (NPat lit ty expr) - = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - zonkExpr te expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (NPat lit new_ty new_expr, emptyBag) - -zonkPat te (NPlusKPat n k ty e1 e2) - = zonkIdBndr te n `thenNF_Tc` \ new_n -> - zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - zonkExpr te e1 `thenNF_Tc` \ new_e1 -> - zonkExpr te e2 `thenNF_Tc` \ new_e2 -> - returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n) - -zonkPat te (DictPat ds ms) - = mapNF_Tc (zonkIdBndr te) ds `thenNF_Tc` \ new_ds -> - mapNF_Tc (zonkIdBndr te) ms `thenNF_Tc` \ new_ms -> - returnNF_Tc (DictPat new_ds new_ms, +zonkPat :: ZonkEnv -> TcPat -> TcM (TypecheckedPat, Bag Id) + +zonkPat env (ParPat p) + = zonkPat env p `thenM` \ (new_p, ids) -> + returnM (ParPat new_p, ids) + +zonkPat env (WildPat ty) + = zonkTcTypeToType env ty `thenM` \ new_ty -> + returnM (WildPat new_ty, emptyBag) + +zonkPat env (VarPat v) + = zonkIdBndr env v `thenM` \ new_v -> + returnM (VarPat new_v, unitBag new_v) + +zonkPat env (LazyPat pat) + = zonkPat env pat `thenM` \ (new_pat, ids) -> + returnM (LazyPat new_pat, ids) + +zonkPat env (AsPat n pat) + = zonkIdBndr env n `thenM` \ new_n -> + zonkPat env pat `thenM` \ (new_pat, ids) -> + returnM (AsPat new_n new_pat, new_n `consBag` ids) + +zonkPat env (ListPat pats ty) + = zonkTcTypeToType env ty `thenM` \ new_ty -> + zonkPats env pats `thenM` \ (new_pats, ids) -> + returnM (ListPat new_pats new_ty, ids) + +zonkPat env (PArrPat pats ty) + = zonkTcTypeToType env ty `thenM` \ new_ty -> + zonkPats env pats `thenM` \ (new_pats, ids) -> + returnM (PArrPat new_pats new_ty, ids) + +zonkPat env (TuplePat pats boxed) + = zonkPats env pats `thenM` \ (new_pats, ids) -> + returnM (TuplePat new_pats boxed, ids) + +zonkPat env (ConPatOut n stuff ty tvs dicts) + = zonkTcTypeToType env ty `thenM` \ new_ty -> + mappM zonkTcTyVarToTyVar tvs `thenM` \ new_tvs -> + zonkIdBndrs env dicts `thenM` \ new_dicts -> + let + env1 = extendZonkEnv env new_dicts + in + zonkConStuff env stuff `thenM` \ (new_stuff, ids) -> + returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts, + listToBag new_dicts `unionBags` ids) + +zonkPat env (LitPat lit) = returnM (LitPat lit, emptyBag) + +zonkPat env (SigPatOut pat ty expr) + = zonkPat env pat `thenM` \ (new_pat, ids) -> + zonkTcTypeToType env ty `thenM` \ new_ty -> + zonkExpr env expr `thenM` \ new_expr -> + returnM (SigPatOut new_pat new_ty new_expr, ids) + +zonkPat env (NPatOut lit ty expr) + = zonkTcTypeToType env ty `thenM` \ new_ty -> + zonkExpr env expr `thenM` \ new_expr -> + returnM (NPatOut lit new_ty new_expr, emptyBag) + +zonkPat env (NPlusKPatOut n k e1 e2) + = zonkIdBndr env n `thenM` \ new_n -> + zonkExpr env e1 `thenM` \ new_e1 -> + zonkExpr env e2 `thenM` \ new_e2 -> + returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag new_n) + +zonkPat env (DictPat ds ms) + = zonkIdBndrs env ds `thenM` \ new_ds -> + zonkIdBndrs env ms `thenM` \ new_ms -> + returnM (DictPat new_ds new_ms, listToBag new_ds `unionBags` listToBag new_ms) +--------------------------- +zonkConStuff env (PrefixCon pats) + = zonkPats env pats `thenM` \ (new_pats, ids) -> + returnM (PrefixCon new_pats, ids) + +zonkConStuff env (InfixCon p1 p2) + = zonkPat env p1 `thenM` \ (new_p1, ids1) -> + zonkPat env p2 `thenM` \ (new_p2, ids2) -> + returnM (InfixCon new_p1 new_p2, ids1 `unionBags` ids2) + +zonkConStuff env (RecCon rpats) + = mapAndUnzipM zonk_rpat rpats `thenM` \ (new_rpats, ids_s) -> + returnM (RecCon new_rpats, unionManyBags ids_s) + where + zonk_rpat (f, pat) + = zonkPat env pat `thenM` \ (new_pat, ids) -> + returnM ((f, new_pat), ids) + +--------------------------- +zonkPats env [] + = returnM ([], emptyBag) + +zonkPats env (pat:pats) + = zonkPat env pat `thenM` \ (pat', ids1) -> + zonkPats env pats `thenM` \ (pats', ids2) -> + returnM (pat':pats', ids1 `unionBags` ids2) +\end{code} + +%************************************************************************ +%* * +\subsection[BackSubst-Foreign]{Foreign exports} +%* * +%************************************************************************ + + +\begin{code} +zonkForeignExports :: ZonkEnv -> [TcForeignDecl] -> TcM [TypecheckedForeignDecl] +zonkForeignExports env ls = mappM (zonkForeignExport env) ls + +zonkForeignExport :: ZonkEnv -> TcForeignDecl -> TcM (TypecheckedForeignDecl) +zonkForeignExport env (ForeignExport i hs_ty spec isDeprec src_loc) = + returnM (ForeignExport (zonkIdOcc env i) undefined spec isDeprec src_loc) +zonkForeignExport env for_imp + = returnM for_imp -- Foreign imports don't need zonking +\end{code} + +\begin{code} +zonkRules :: ZonkEnv -> [TcRuleDecl] -> TcM [TypecheckedRuleDecl] +zonkRules env rs = mappM (zonkRule env) rs + +zonkRule env (HsRule name act vars lhs rhs loc) + = mappM zonk_bndr vars `thenM` \ new_bndrs -> + newMutVar emptyVarSet `thenM` \ unbound_tv_set -> + let + env_rhs = extendZonkEnv env (filter isId new_bndrs) + -- 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 + zonkExpr env_lhs lhs `thenM` \ new_lhs -> + zonkExpr env_rhs rhs `thenM` \ new_rhs -> -zonkPats te [] - = returnNF_Tc ([], emptyBag) -zonkPats te (pat:pats) - = zonkPat te pat `thenNF_Tc` \ (pat', ids1) -> - zonkPats te pats `thenNF_Tc` \ (pats', ids2) -> - returnNF_Tc (pat':pats', ids1 `unionBags` ids2) + readMutVar unbound_tv_set `thenM` \ unbound_tvs -> + let + final_bndrs = map RuleBndr (varSetElems unbound_tvs ++ new_bndrs) + -- I hate this map RuleBndr stuff + in + returnM (HsRule name act final_bndrs new_lhs new_rhs loc) + where + zonk_bndr (RuleBndr v) + | isId v = zonkIdBndr env v + | otherwise = zonkTcTyVarToTyVar v + +zonkRule env (IfaceRuleOut fun rule) + = returnM (IfaceRuleOut (zonkIdOcc env fun) rule) \end{code} +%************************************************************************ +%* * +\subsection[BackSubst-Foreign]{Foreign exports} +%* * +%************************************************************************ + +\begin{code} +zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type +zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty + +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 + = zonkTcTyVarToTyVar 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 = putTcTyVar tv (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 + | isAnyTypeKind kind = voidTy -- The vastly common case + | otherwise = mkTyConApp tycon [] + where + kind = tyVarKind tv + (args,res) = Type.splitFunTys kind -- Kinds are simple; use Type.splitFunTys + + tycon | kind `eqKind` tyConKind listTyCon -- *->* + = listTyCon -- No tuples this size + + | all isTypeKind args && isTypeKind 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}