X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=2b30c3c27d85a1b60a33baaa0526a4a49260ccb2;hb=16e4ce4c0c02650082f2e11982017c903c549ad5;hp=ac0579293144b752c25a69e23888052ba85d8c52;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index ac05792..2b30c3c 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -13,6 +13,7 @@ module TcHsSyn ( TcStmt, TcArithSeqInfo, TcRecordBinds, TcHsModule, TcDictBinds, TcForeignDecl, + TcCmd, TcCmdTop, TypecheckedHsBinds, TypecheckedRuleDecl, TypecheckedMonoBinds, TypecheckedPat, @@ -22,16 +23,22 @@ module TcHsSyn ( 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, zonkIdBndr + zonkId, zonkTopBndrs ) where #include "HsVersions.h" @@ -45,18 +52,29 @@ import DataCon ( dataConWrapId ) import TcRnMonad import Type ( Type ) -import TcType ( TcType, tcGetTyVar ) -import TcMType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcTyVars ) +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 ) + mkListTy, mkPArrTy, mkTupleTy, unitTy, + voidTy, listTyCon, tupleTyCon ) +import TyCon ( mkPrimTyCon, tyConKind ) +import PrimRep ( PrimRep(VoidRep) ) import CoreSyn ( CoreExpr ) -import Var ( isId, isLocalVar ) +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 Outputable \end{code} @@ -87,6 +105,8 @@ 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 @@ -96,7 +116,6 @@ type TypecheckedHsExpr = HsExpr Id type TypecheckedArithSeqInfo = ArithSeqInfo Id type TypecheckedStmt = Stmt Id type TypecheckedMatch = Match Id -type TypecheckedMatchContext = HsMatchContext Id type TypecheckedGRHSs = GRHSs Id type TypecheckedGRHS = GRHS Id type TypecheckedRecordBinds = HsRecordBinds Id @@ -104,6 +123,11 @@ 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} @@ -170,12 +194,37 @@ hsLitType (HsDoublePrim d) = doublePrimTy hsLitType (HsLitLit _ ty) = ty \end{code} +%************************************************************************ +%* * +\subsection{Coercion functions} +%* * +%************************************************************************ + \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') +type Coercion a = Maybe (a -> a) + -- Nothing => identity fn + +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) + +(<$>) :: Coercion a -> a -> a +Just f <$> e = f e +Nothing <$> e = e + +mkCoercion :: (a -> a) -> Coercion a +mkCoercion f = Just f + +idCoercion :: Coercion a +idCoercion = Nothing + +isIdCoercion :: Coercion a -> Bool +isIdCoercion = isNothing \end{code} @@ -185,7 +234,16 @@ zonkId id %* * %************************************************************************ -This zonking pass runs over the bindings +\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 @@ -202,14 +260,19 @@ It's all pretty boring stuff, because HsSyn is such a large type, and the environment manipulation is tiresome. \begin{code} -type ZonkEnv = IdEnv Id +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 = emptyVarEnv +emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv -extendZonkEnv env ids = extendVarEnvList env [(id,id) | id <- ids] +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 @@ -228,7 +291,7 @@ zonkIdOcc :: ZonkEnv -> TcId -> Id -- -- Even without template splices, in module Main, the checking of -- 'main' is done as a separte chunk. -zonkIdOcc env id +zonkIdOcc (ZonkEnv zonk_ty env) id | isLocalVar id = lookupVarEnv env id `orElse` id | otherwise = id @@ -236,10 +299,16 @@ 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 :: TcId -> TcM Id -zonkIdBndr id - = zonkTcTypeToType (idType id) `thenM` \ ty' -> +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} @@ -285,13 +354,27 @@ zonkBinds env (ThenBinds b1 b2) zonkBinds env (MonoBind bind sigs is_rec) = ASSERT( null sigs ) - fixM (\ ~(env1, _) -> - zonkMonoBinds env1 bind `thenM` \ (new_bind, new_ids) -> + fixM (\ ~(_, _, new_ids) -> let - env2 = extendZonkEnv env (bagToList new_ids) + env1 = extendZonkEnv env (bagToList new_ids) in - returnM (env2, mkMonoBind new_bind [] is_rec) - ) + 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 + env1 = extendZonkEnv env (map (ipNameName . fst) new_binds) + in + 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 @@ -303,7 +386,7 @@ zonkMonoBinds env (AndMonoBinds mbinds1 mbinds2) = zonkMonoBinds env mbinds1 `thenM` \ (b1', ids1) -> zonkMonoBinds env mbinds2 `thenM` \ (b2', ids2) -> returnM (b1' `AndMonoBinds` b2', - ids1 `unionBags` ids2) + ids1 `unionBags` ids2) zonkMonoBinds env (PatMonoBind pat grhss locn) = zonkPat env pat `thenM` \ (new_pat, ids) -> @@ -311,16 +394,12 @@ zonkMonoBinds env (PatMonoBind pat grhss locn) returnM (PatMonoBind new_pat new_grhss locn, ids) zonkMonoBinds env (VarMonoBind var expr) - = zonkIdBndr var `thenM` \ new_var -> + = zonkIdBndr env var `thenM` \ new_var -> zonkExpr env expr `thenM` \ new_expr -> returnM (VarMonoBind new_var new_expr, unitBag new_var) -zonkMonoBinds env (CoreMonoBind var core_expr) - = zonkIdBndr var `thenM` \ new_var -> - returnM (CoreMonoBind new_var core_expr, unitBag new_var) - zonkMonoBinds env (FunMonoBind var inf ms locn) - = zonkIdBndr var `thenM` \ new_var -> + = zonkIdBndr env var `thenM` \ new_var -> mappM (zonkMatch env) ms `thenM` \ new_ms -> returnM (FunMonoBind new_var inf new_ms locn, unitBag new_var) @@ -330,7 +409,7 @@ zonkMonoBinds env (AbsBinds tyvars dicts exports inlines val_bind) -- No need to extend tyvar env: the effects are -- propagated through binding the tyvars themselves - mappM zonkIdBndr dicts `thenM` \ new_dicts -> + zonkIdBndrs env dicts `thenM` \ new_dicts -> fixM (\ ~(_, _, val_bind_ids) -> let env1 = extendZonkEnv (extendZonkEnv env new_dicts) @@ -353,7 +432,7 @@ zonkMonoBinds env (AbsBinds tyvars dicts exports inlines val_bind) -- This isn't the binding occurrence of these tyvars -- but they should *be* tyvars. Hence tcGetTyVar. in - zonkIdBndr global `thenM` \ new_global -> + zonkIdBndr env global `thenM` \ new_global -> returnM (new_tyvars, new_global, zonkIdOcc env local) \end{code} @@ -382,7 +461,7 @@ zonkGRHSs env (GRHSs grhss binds ty) returnM (GRHS new_guarded locn) in mappM zonk_grhs grhss `thenM` \ new_grhss -> - zonkTcTypeToType ty `thenM` \ new_ty -> + zonkTcTypeToType env ty `thenM` \ new_ty -> returnM (GRHSs new_grhss new_binds new_ty) \end{code} @@ -393,7 +472,11 @@ zonkGRHSs env (GRHSs grhss binds ty) %************************************************************************ \begin{code} -zonkExpr :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr +zonkExprs :: ZonkEnv -> [TcExpr] -> TcM [TypecheckedHsExpr] +zonkExpr :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr + +zonkExprs env exprs = mappM (zonkExpr env) exprs + zonkExpr env (HsVar id) = returnM (HsVar (zonkIdOcc env id)) @@ -402,11 +485,11 @@ zonkExpr env (HsIPVar id) = returnM (HsIPVar (mapIPName (zonkIdOcc env) id)) zonkExpr env (HsLit (HsRat f ty)) - = zonkTcTypeToType ty `thenM` \ new_ty -> + = zonkTcTypeToType env ty `thenM` \ new_ty -> returnM (HsLit (HsRat f new_ty)) zonkExpr env (HsLit (HsLitLit lit ty)) - = zonkTcTypeToType ty `thenM` \ new_ty -> + = zonkTcTypeToType env ty `thenM` \ new_ty -> returnM (HsLit (HsLitLit lit new_ty)) zonkExpr env (HsLit lit) @@ -430,8 +513,10 @@ zonkExpr env (HsBracketOut body bs) zonk_b (n,e) = zonkExpr env e `thenM` \ e' -> returnM (n,e') -zonkExpr env (HsSplice n e) = WARN( True, ppr e ) -- Should not happen - returnM (HsSplice 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 -> @@ -471,38 +556,25 @@ zonkExpr env (HsLet binds expr) zonkExpr new_env expr `thenM` \ new_expr -> returnM (HsLet new_binds new_expr) -zonkExpr env (HsWith expr binds is_with) - = mappM zonk_ip_bind binds `thenM` \ new_binds -> - let - env1 = extendZonkEnv env (map (ipNameName . fst) new_binds) - in - zonkExpr env1 expr `thenM` \ new_expr -> - returnM (HsWith new_expr new_binds is_with) - where - zonk_ip_bind (n, e) - = mapIPNameTc zonkIdBndr n `thenM` \ n' -> - zonkExpr env e `thenM` \ e' -> - returnM (n', e') - zonkExpr env (HsDo do_or_lc stmts ids ty src_loc) = zonkStmts env stmts `thenM` \ new_stmts -> - zonkTcTypeToType ty `thenM` \ new_ty -> - returnM (HsDo do_or_lc new_stmts - (zonkIdOccs env ids) - new_ty src_loc) + 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 ty `thenM` \ new_ty -> - mappM (zonkExpr env) exprs `thenM` \ new_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 ty `thenM` \ new_ty -> - mappM (zonkExpr env) exprs `thenM` \ new_exprs -> + = zonkTcTypeToType env ty `thenM` \ new_ty -> + zonkExprs env exprs `thenM` \ new_exprs -> returnM (ExplicitPArr new_ty new_exprs) zonkExpr env (ExplicitTuple exprs boxed) - = mappM (zonkExpr env) exprs `thenM` \ new_exprs -> + = zonkExprs env exprs `thenM` \ new_exprs -> returnM (ExplicitTuple new_exprs boxed) zonkExpr env (RecordConOut data_con con_expr rbinds) @@ -514,8 +586,8 @@ zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd" zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds) = zonkExpr env expr `thenM` \ new_expr -> - zonkTcTypeToType in_ty `thenM` \ new_in_ty -> - zonkTcTypeToType out_ty `thenM` \ new_out_ty -> + 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) @@ -534,14 +606,19 @@ zonkExpr env (PArrSeqOut expr info) returnM (PArrSeqOut new_expr new_info) zonkExpr env (HsCCall fun args may_gc is_casm result_ty) - = mappM (zonkExpr env) args `thenM` \ new_args -> - zonkTcTypeToType result_ty `thenM` \ new_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 @@ -550,22 +627,58 @@ zonkExpr env (TyLam tyvars expr) returnM (TyLam new_tyvars new_expr) zonkExpr env (TyApp expr tys) - = zonkExpr env expr `thenM` \ new_expr -> - mappM zonkTcTypeToType tys `thenM` \ new_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) - = mappM zonkIdBndr dicts `thenM` \ new_dicts -> + = zonkIdBndrs env dicts `thenM` \ new_dicts -> let env1 = extendZonkEnv env new_dicts in - zonkExpr env1 expr `thenM` \ new_expr -> + zonkExpr env1 expr `thenM` \ new_expr -> returnM (DictLam new_dicts new_expr) zonkExpr env (DictApp expr dicts) = zonkExpr env expr `thenM` \ new_expr -> returnM (DictApp new_expr (zonkIdOccs env dicts)) +-- 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) + +------------------------------------------------------------------------- +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) ------------------------------------------------------------------------- @@ -591,47 +704,69 @@ zonkArithSeq env (FromThenTo e1 e2 e3) zonkExpr env e3 `thenM` \ new_e3 -> returnM (FromThenTo new_e1 new_e2 new_e3) + ------------------------------------------------------------------------- -zonkStmts :: ZonkEnv -> [TcStmt] -> TcM [TypecheckedStmt] +zonkStmts :: ZonkEnv -> [TcStmt] -> TcM [TypecheckedStmt] + +zonkStmts env stmts = zonk_stmts env stmts `thenM` \ (_, stmts) -> + returnM stmts -zonkStmts env [] = returnM [] +zonk_stmts :: ZonkEnv -> [TcStmt] -> TcM (ZonkEnv, [TypecheckedStmt]) -zonkStmts env (ParStmtOut bndrstmtss : stmts) - = mappM (mappM zonkId) bndrss `thenM` \ new_bndrss -> - mappM (zonkStmts env) stmtss `thenM` \ new_stmtss -> +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 new_bndrss + new_binders = concat (map snd new_stmts_w_bndrs) env1 = extendZonkEnv env new_binders in - zonkStmts env1 stmts `thenM` \ new_stmts -> - returnM (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts) + zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) -> + returnM (env2, ParStmt new_stmts_w_bndrs : new_stmts) where - (bndrss, stmtss) = unzip bndrstmtss + zonk_branch (stmts, bndrs) = zonk_stmts env stmts `thenM` \ (env1, new_stmts) -> + returnM (new_stmts, zonkIdOccs env1 bndrs) -zonkStmts env (ResultStmt expr locn : stmts) - = zonkExpr env expr `thenM` \ new_expr -> - zonkStmts env stmts `thenM` \ new_stmts -> - returnM (ResultStmt new_expr locn : new_stmts) +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) -zonkStmts env (ExprStmt expr ty locn : stmts) - = zonkExpr env expr `thenM` \ new_expr -> - zonkTcTypeToType ty `thenM` \ new_ty -> - zonkStmts env stmts `thenM` \ new_stmts -> - returnM (ExprStmt new_expr new_ty locn : new_stmts) +zonk_stmts env (ResultStmt expr locn : stmts) + = ASSERT( null stmts ) + zonkExpr env expr `thenM` \ new_expr -> + returnM (env, [ResultStmt new_expr locn]) -zonkStmts env (LetStmt binds : stmts) - = zonkBinds env binds `thenM` \ (new_env, new_binds) -> - zonkStmts new_env stmts `thenM` \ new_stmts -> - returnM (LetStmt new_binds : new_stmts) +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) -zonkStmts env (BindStmt pat expr locn : 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 - zonkStmts env1 stmts `thenM` \ new_stmts -> - returnM (BindStmt new_pat new_expr locn : new_stmts) + zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) -> + returnM (env2, BindStmt new_pat new_expr locn : new_stmts) @@ -666,11 +801,11 @@ zonkPat env (ParPat p) returnM (ParPat new_p, ids) zonkPat env (WildPat ty) - = zonkTcTypeToType ty `thenM` \ new_ty -> + = zonkTcTypeToType env ty `thenM` \ new_ty -> returnM (WildPat new_ty, emptyBag) zonkPat env (VarPat v) - = zonkIdBndr v `thenM` \ new_v -> + = zonkIdBndr env v `thenM` \ new_v -> returnM (VarPat new_v, unitBag new_v) zonkPat env (LazyPat pat) @@ -678,17 +813,17 @@ zonkPat env (LazyPat pat) returnM (LazyPat new_pat, ids) zonkPat env (AsPat n pat) - = zonkIdBndr n `thenM` \ new_n -> + = 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 ty `thenM` \ new_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 ty `thenM` \ new_ty -> + = zonkTcTypeToType env ty `thenM` \ new_ty -> zonkPats env pats `thenM` \ (new_pats, ids) -> returnM (PArrPat new_pats new_ty, ids) @@ -697,9 +832,9 @@ zonkPat env (TuplePat pats boxed) returnM (TuplePat new_pats boxed, ids) zonkPat env (ConPatOut n stuff ty tvs dicts) - = zonkTcTypeToType ty `thenM` \ new_ty -> + = zonkTcTypeToType env ty `thenM` \ new_ty -> mappM zonkTcTyVarToTyVar tvs `thenM` \ new_tvs -> - mappM zonkIdBndr dicts `thenM` \ new_dicts -> + zonkIdBndrs env dicts `thenM` \ new_dicts -> let env1 = extendZonkEnv env new_dicts in @@ -710,25 +845,25 @@ zonkPat env (ConPatOut n stuff ty tvs dicts) zonkPat env (LitPat lit) = returnM (LitPat lit, emptyBag) zonkPat env (SigPatOut pat ty expr) - = zonkPat env pat `thenM` \ (new_pat, ids) -> - zonkTcTypeToType ty `thenM` \ new_ty -> + = 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 ty `thenM` \ new_ty -> + = 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 n `thenM` \ new_n -> + = 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) - = mappM zonkIdBndr ds `thenM` \ new_ds -> - mappM zonkIdBndr ms `thenM` \ new_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) @@ -774,6 +909,8 @@ 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} @@ -781,22 +918,135 @@ 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 -> + = mappM zonk_bndr vars `thenM` \ new_bndrs -> + newMutVar emptyVarSet `thenM` \ unbound_tv_set -> let - env1 = extendZonkEnv env (filter isId new_bndrs) + 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 env1 lhs `thenM` \ new_lhs -> - zonkExpr env1 rhs `thenM` \ new_rhs -> - returnM (HsRule name act (map RuleBndr new_bndrs) new_lhs new_rhs loc) + zonkExpr env_lhs lhs `thenM` \ new_lhs -> + zonkExpr env_rhs rhs `thenM` \ new_rhs -> + + 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 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}