X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=c2355a04aaf346f0e82db881e8ed8e2fe8c5ea38;hb=3c245de9199f522f75ace92219256badbd928bd6;hp=24dc515b084d7da59b154f54f6ddcb1d750029f5;hpb=c86e9006fbdc9cb229080dd6a64ce462e9e460af;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 24dc515..c2355a0 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -8,34 +8,16 @@ checker. \begin{code} module TcHsSyn ( - TcMonoBinds, TcHsBinds, TcPat, - TcExpr, TcGRHSs, TcGRHS, TcMatch, - TcStmt, TcArithSeqInfo, TcRecordBinds, - TcHsModule, TcDictBinds, - TcForeignDecl, - - TypecheckedHsBinds, TypecheckedRuleDecl, - TypecheckedMonoBinds, TypecheckedPat, - TypecheckedHsExpr, TypecheckedArithSeqInfo, - TypecheckedStmt, TypecheckedForeignDecl, - TypecheckedMatch, TypecheckedHsModule, - TypecheckedGRHSs, TypecheckedGRHS, - TypecheckedRecordBinds, TypecheckedDictBinds, - TypecheckedMatchContext, TypecheckedCoreBind, - mkHsTyApp, mkHsDictApp, mkHsConApp, - mkHsTyLam, mkHsDictLam, mkHsLet, - hsLitType, hsPatType, - - -- Coercions - Coercion, ExprCoFn, PatCoFn, - (<$>), (<.>), mkCoercion, - idCoercion, isIdCoercion, + mkHsTyLam, mkHsDictLam, mkHsDictLet, mkHsApp, + hsLitType, hsPatType, mkHsAppTy, mkSimpleHsAlt, + nlHsIntLit, mkVanillaTuplePat, + -- re-exported from TcMonad - TcId, TcIdSet, + TcId, TcIdSet, TcDictBinds, - zonkTopBinds, zonkTopDecls, zonkTopExpr, + zonkTopDecls, zonkTopExpr, zonkTopLExpr, zonkId, zonkTopBndrs ) where @@ -46,104 +28,35 @@ import HsSyn -- oodles of it -- others: import Id ( idType, setIdType, Id ) -import DataCon ( dataConWrapId ) import TcRnMonad import Type ( Type ) -import TcType ( TcType, TcTyVar, eqKind, isTypeKind, mkTyVarTy, - tcGetTyVar, isAnyTypeKind, mkTyConApp ) +import TcType ( TcType, TcTyVar, mkTyVarTy, mkTyConApp, isImmutableTyVar ) +import Kind ( isLiftedTypeKind, liftedTypeKind, isSubKind ) import qualified Type -import TcMType ( zonkTcTyVarToTyVar, zonkType, zonkTcType, zonkTcTyVars, - putTcTyVar ) +import TcMType ( zonkQuantifiedTyVar, zonkType, zonkTcType, writeMetaTyVar ) import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, doublePrimTy, addrPrimTy ) -import TysWiredIn ( charTy, stringTy, intTy, integerTy, +import TysWiredIn ( charTy, stringTy, intTy, mkListTy, mkPArrTy, mkTupleTy, unitTy, voidTy, listTyCon, tupleTyCon ) -import TyCon ( mkPrimTyCon, tyConKind ) -import PrimRep ( PrimRep(VoidRep) ) -import CoreSyn ( CoreExpr ) +import TyCon ( mkPrimTyCon, tyConKind, PrimRep(..) ) +import Kind ( splitKindFunTys ) import Name ( Name, getOccName, mkInternalName, mkDerivedTyConOcc ) -import Var ( isId, isLocalVar, tyVarKind ) +import Var ( Var, isId, isLocalVar, tyVarKind ) import VarSet import VarEnv -import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName, mapIPName ) +import BasicTypes ( Boxity(..), IPName(..), ipNameName, mapIPName ) import Maybes ( orElse ) -import Maybe ( isNothing ) import Unique ( Uniquable(..) ) -import SrcLoc ( noSrcLoc ) +import SrcLoc ( noSrcLoc, noLoc, Located(..), unLoc ) +import Util ( mapSnd ) import Bag import Outputable \end{code} -Type definitions -~~~~~~~~~~~~~~~~ - -The @Tc...@ datatypes are the ones that apply {\em during} type checking. -All the types in @Tc...@ things have mutable type-variables in them for -unification. - -At the end of type checking we zonk everything to @Typechecked...@ datatypes, -which have immutable type variables in them. - -\begin{code} -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 TypecheckedPat = OutPat Id -type TypecheckedMonoBinds = MonoBinds Id -type TypecheckedDictBinds = TypecheckedMonoBinds -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 TypecheckedMatchContext = HsMatchContext Name -- Keeps consistency with - -- HsDo arg StmtContext -\end{code} - -\begin{code} -mkHsTyApp expr [] = expr -mkHsTyApp expr tys = TyApp expr tys - -mkHsDictApp expr [] = expr -mkHsDictApp expr dict_vars = DictApp expr dict_vars - -mkHsTyLam [] expr = expr -mkHsTyLam tyvars expr = TyLam tyvars expr - -mkHsDictLam [] expr = expr -mkHsDictLam dicts expr = DictLam dicts expr - -mkHsLet EmptyMonoBinds expr = expr -mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr - -mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args -\end{code} - - %************************************************************************ %* * \subsection[mkFailurePair]{Code for pattern-matching and other failures} @@ -153,22 +66,30 @@ mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHs 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 +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) @@ -181,44 +102,10 @@ hsLitType (HsString str) = stringTy hsLitType (HsStringPrim s) = addrPrimTy hsLitType (HsInt i) = intTy hsLitType (HsIntPrim i) = intPrimTy -hsLitType (HsInteger i) = integerTy +hsLitType (HsInteger i ty) = ty hsLitType (HsRat _ ty) = ty hsLitType (HsFloatPrim f) = floatPrimTy hsLitType (HsDoublePrim d) = doublePrimTy -hsLitType (HsLitLit _ ty) = ty -\end{code} - -%************************************************************************ -%* * -\subsection{Coercion functions} -%* * -%************************************************************************ - -\begin{code} -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} @@ -265,16 +152,22 @@ 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 -mkZonkEnv :: [Id] -> ZonkEnv -mkZonkEnv ids = extendZonkEnv emptyZonkEnv ids +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 @@ -284,7 +177,7 @@ zonkIdOcc :: ZonkEnv -> TcId -> Id -- 'orElse' case in the LocalVar branch. -- -- Even without template splices, in module Main, the checking of --- 'main' is done as a separte chunk. +-- 'main' is done as a separate chunk. zonkIdOcc (ZonkEnv zonk_ty env) id | isLocalVar id = lookupVarEnv env id `orElse` id | otherwise = id @@ -307,127 +200,115 @@ zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids \begin{code} -zonkTopExpr :: TcExpr -> TcM TypecheckedHsExpr +zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id) 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') - ) +zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id) +zonkTopLExpr e = zonkLExpr emptyZonkEnv e -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') - ) +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') } --------------------------------------------- -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) +zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id) +zonkLocalBinds env EmptyLocalBinds + = return (env, EmptyLocalBinds) -zonkBinds env (IPBinds binds is_with) - = mappM zonk_ip_bind binds `thenM` \ new_binds -> +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 (map (ipNameName . fst) new_binds) + env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds] in - returnM (env1, IPBinds new_binds is_with) + zonkRecMonoBinds env1 dict_binds `thenM` \ (env2, new_dict_binds) -> + returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds)) where - zonk_ip_bind (n, e) + zonk_ip_bind (IPBind n e) = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' -> - zonkExpr env e `thenM` \ e' -> - returnM (n', e') + zonkLExpr env e `thenM` \ e' -> + returnM (IPBind 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) - +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') } -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 +--------------------------------------------- +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 (\ ~(_, _, val_bind_ids) -> + fixM (\ ~(new_val_binds, _) -> let - env1 = extendZonkEnv (extendZonkEnv env new_dicts) - (bagToList val_bind_ids) + env1 = extendZonkEnv env new_dicts + env2 = extendZonkEnv env1 (collectHsBindBinders new_val_binds) 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] - in - returnM (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind, - new_globals) + 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) - = 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) + 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} %************************************************************************ @@ -437,26 +318,31 @@ zonkMonoBinds env (AbsBinds tyvars dicts exports inlines val_bind) %************************************************************************ \begin{code} -zonkMatch :: ZonkEnv -> TcMatch -> TcM TypecheckedMatch - -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) +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 -> TcGRHSs -> TcM TypecheckedGRHSs +zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id) -zonkGRHSs env (GRHSs grhss binds ty) - = zonkBinds env binds `thenM` \ (new_env, new_binds) -> +zonkGRHSs env (GRHSs grhss binds) + = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) -> let - zonk_grhs (GRHS guarded locn) - = zonkStmts new_env guarded `thenM` \ new_guarded -> - returnM (GRHS new_guarded locn) + 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 zonk_grhs grhss `thenM` \ new_grhss -> - zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (GRHSs new_grhss new_binds new_ty) + mappM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss -> + returnM (GRHSs new_grhss new_binds) \end{code} %************************************************************************ @@ -466,11 +352,12 @@ zonkGRHSs env (GRHSs grhss binds ty) %************************************************************************ \begin{code} -zonkExprs :: ZonkEnv -> [TcExpr] -> TcM [TypecheckedHsExpr] -zonkExpr :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr - -zonkExprs env exprs = mappM (zonkExpr env) exprs +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)) @@ -482,147 +369,139 @@ zonkExpr env (HsLit (HsRat f ty)) = zonkTcTypeToType env ty `thenM` \ new_ty -> returnM (HsLit (HsRat f new_ty)) -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) --- HsOverLit doesn't appear in typechecker output +zonkExpr env (HsOverLit lit) + = do { lit' <- zonkOverLit env lit + ; return (HsOverLit lit') } -zonkExpr env (HsLam match) - = zonkMatch env match `thenM` \ new_match -> - returnM (HsLam new_match) +zonkExpr env (HsLam matches) + = zonkMatchGroup env matches `thenM` \ new_matches -> + returnM (HsLam new_matches) zonkExpr env (HsApp e1 e2) - = zonkExpr env e1 `thenM` \ new_e1 -> - zonkExpr env e2 `thenM` \ new_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) = zonkExpr env e `thenM` \ e' -> + zonk_b (n,e) = zonkLExpr 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 (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen + returnM (HsSpliceE s) 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 -> + = 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 _ _) = panic "zonkExpr env: NegApp" +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) - = zonkExpr env e `thenM` \new_e -> + = zonkLExpr 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 -> + = zonkLExpr env expr `thenM` \ new_expr -> + zonkLExpr 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 -> + = zonkLExpr env op `thenM` \ new_op -> + zonkLExpr 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 (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 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 (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) - = zonkBinds env binds `thenM` \ (new_env, new_binds) -> - zonkExpr new_env expr `thenM` \ new_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 ids ty src_loc) - = zonkStmts env stmts `thenM` \ new_stmts -> +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 do_or_lc new_stmts - (zonkIdOccs env ids) - new_ty src_loc) + returnM (HsDo (zonkDo env do_or_lc) + new_stmts new_body new_ty) zonkExpr env (ExplicitList ty exprs) = zonkTcTypeToType env ty `thenM` \ new_ty -> - zonkExprs env exprs `thenM` \ new_exprs -> + zonkLExprs 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 -> + zonkLExprs env exprs `thenM` \ new_exprs -> returnM (ExplicitPArr new_ty new_exprs) zonkExpr env (ExplicitTuple exprs boxed) - = zonkExprs env exprs `thenM` \ new_exprs -> + = zonkLExprs env exprs `thenM` \ new_exprs -> returnM (ExplicitTuple new_exprs boxed) -zonkExpr env (RecordConOut data_con con_expr rbinds) +zonkExpr env (RecordCon 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" + returnM (RecordCon data_con new_con_expr new_rbinds) -zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds) - = zonkExpr env expr `thenM` \ new_expr -> +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 (RecordUpdOut new_expr new_in_ty new_out_ty 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 (ArithSeqIn _) = panic "zonkExpr env:ArithSeqIn" -zonkExpr env (PArrSeqIn _) = panic "zonkExpr env:PArrSeqIn" -zonkExpr env (ArithSeqOut expr info) +zonkExpr env (ArithSeq expr info) = zonkExpr env expr `thenM` \ new_expr -> zonkArithSeq env info `thenM` \ new_info -> - returnM (ArithSeqOut new_expr new_info) + returnM (ArithSeq new_expr new_info) -zonkExpr env (PArrSeqOut expr info) +zonkExpr env (PArrSeq 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) + returnM (PArrSeq new_expr new_info) zonkExpr env (HsSCC lbl expr) - = zonkExpr env expr `thenM` \ new_expr -> + = zonkLExpr env expr `thenM` \ new_expr -> returnM (HsSCC lbl new_expr) -- hdaume: core annotations zonkExpr env (HsCoreAnn lbl expr) - = zonkExpr env expr `thenM` \ new_expr -> + = zonkLExpr 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) + = ASSERT( all isImmutableTyVar tyvars ) + zonkLExpr env expr `thenM` \ new_expr -> + returnM (TyLam tyvars new_expr) zonkExpr env (TyApp expr tys) - = zonkExpr env expr `thenM` \ new_expr -> - mappM (zonkTcTypeToType env) tys `thenM` \ new_tys -> + = zonkLExpr env expr `thenM` \ new_expr -> + zonkTcTypeToTypes env tys `thenM` \ new_tys -> returnM (TyApp new_expr new_tys) zonkExpr env (DictLam dicts expr) @@ -630,109 +509,169 @@ zonkExpr env (DictLam dicts expr) let env1 = extendZonkEnv env new_dicts in - zonkExpr env1 expr `thenM` \ new_expr -> + zonkLExpr env1 expr `thenM` \ new_expr -> returnM (DictLam new_dicts new_expr) zonkExpr env (DictApp expr dicts) - = zonkExpr env expr `thenM` \ new_expr -> + = 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) ------------------------------------------------------------------------- -zonkArithSeq :: ZonkEnv -> TcArithSeqInfo -> TcM TypecheckedArithSeqInfo +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) - = zonkExpr env e `thenM` \ new_e -> + = zonkLExpr env e `thenM` \ new_e -> returnM (From new_e) zonkArithSeq env (FromThen e1 e2) - = zonkExpr env e1 `thenM` \ new_e1 -> - zonkExpr env e2 `thenM` \ new_e2 -> + = zonkLExpr env e1 `thenM` \ new_e1 -> + zonkLExpr env e2 `thenM` \ new_e2 -> returnM (FromThen new_e1 new_e2) zonkArithSeq env (FromTo e1 e2) - = zonkExpr env e1 `thenM` \ new_e1 -> - zonkExpr env e2 `thenM` \ new_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) - = zonkExpr env e1 `thenM` \ new_e1 -> - zonkExpr env e2 `thenM` \ new_e2 -> - zonkExpr env e3 `thenM` \ new_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 -> [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 (ParStmtOut bndrstmtss : stmts) - = mappM (mappM zonkId) bndrss `thenM` \ new_bndrss -> - mappM (zonkStmts env) stmtss `thenM` \ new_stmtss -> +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 new_bndrss + 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, ParStmtOut (zip new_bndrss new_stmtss) : new_stmts) + return (env1, ParStmt new_stmts_w_bndrs) where - (bndrss, stmtss) = unzip bndrstmtss + zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) -> + returnM (new_stmts, zonkIdOccs env1 bndrs) -zonk_stmts env (RecStmt vs segStmts rets : stmts) - = mappM zonkId vs `thenM` \ new_vs -> +zonkStmt env (RecStmt segStmts lvs rvs rets binds) + = zonkIdBndrs env rvs `thenM` \ new_rvs -> let - env1 = extendZonkEnv env new_vs + env1 = extendZonkEnv env new_rvs in - zonk_stmts env1 segStmts `thenM` \ (env2, new_segStmts) -> + zonkStmts 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 -> - zonk_stmts env1 stmts `thenM` \ (env3, new_stmts) -> - returnM (env3, RecStmt new_vs new_segStmts 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]) + 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) -zonk_stmts env (ExprStmt expr ty locn : stmts) - = zonkExpr env expr `thenM` \ new_expr -> +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 -> - zonk_stmts env stmts `thenM` \ (env1, new_stmts) -> - returnM (env1, ExprStmt new_expr new_ty locn : new_stmts) + returnM (env, ExprStmt new_expr new_then new_ty) -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) +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 -> TcRecordBinds -> TcM TypecheckedRecordBinds +zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id) zonkRbinds env rbinds = mappM zonk_rbind rbinds where zonk_rbind (field, expr) - = zonkExpr env expr `thenM` \ new_expr -> - returnM (zonkIdOcc env field, new_expr) + = zonkLExpr env expr `thenM` \ new_expr -> + returnM (fmap (zonkIdOcc env) field, new_expr) ------------------------------------------------------------------------- mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b) @@ -748,105 +687,116 @@ mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r) %************************************************************************ \begin{code} -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) +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) - = zonkPats env pats `thenM` \ (new_pats, ids) -> - returnM (PrefixCon new_pats, ids) + = do { (env', pats') <- zonkPats env pats + ; return (env', PrefixCon pats') } 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) + = do { (env1, p1') <- zonkPat env p1 + ; (env', p2') <- zonkPat env1 p2 + ; return (env', InfixCon p1' p2') } zonkConStuff env (RecCon rpats) - = mapAndUnzipM zonk_rpat rpats `thenM` \ (new_rpats, ids_s) -> - returnM (RecCon new_rpats, unionManyBags ids_s) + = do { (env', pats') <- zonkPats env pats + ; returnM (env', RecCon (fields `zip` pats')) } where - zonk_rpat (f, pat) - = zonkPat env pat `thenM` \ (new_pat, ids) -> - returnM ((f, new_pat), ids) + (fields, pats) = unzip rpats --------------------------- -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) +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} %************************************************************************ @@ -857,25 +807,26 @@ zonkPats env (pat:pats) \begin{code} -zonkForeignExports :: ZonkEnv -> [TcForeignDecl] -> TcM [TypecheckedForeignDecl] -zonkForeignExports env ls = mappM (zonkForeignExport env) ls +zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id] +zonkForeignExports env ls = mappM (wrapLocM (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 :: 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 -> [TcRuleDecl] -> TcM [TypecheckedRuleDecl] -zonkRules env rs = mappM (zonkRule env) rs +zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id] +zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs -zonkRule env (HsRule name act vars lhs rhs loc) +zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id) +zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs rhs) = mappM zonk_bndr vars `thenM` \ new_bndrs -> newMutVar emptyVarSet `thenM` \ unbound_tv_set -> let - env_rhs = extendZonkEnv env (filter isId new_bndrs) + 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 @@ -899,22 +850,21 @@ zonkRule env (HsRule name act vars lhs rhs loc) -- 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 -> + zonkLExpr env_lhs lhs `thenM` \ new_lhs -> + zonkLExpr 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 + final_bndrs :: [Located Var] + final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs in - returnM (HsRule name act final_bndrs new_lhs new_rhs loc) + returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs new_rhs) + -- I hate this map RuleBndr stuff where zonk_bndr (RuleBndr v) - | isId v = zonkIdBndr env v - | otherwise = zonkTcTyVarToTyVar v - -zonkRule env (IfaceRuleOut fun rule) - = returnM (IfaceRuleOut (zonkIdOcc env fun) rule) + | isId (unLoc v) = wrapLocM (zonkIdBndr env) v + | otherwise = ASSERT( isImmutableTyVar (unLoc v) ) + return v \end{code} @@ -928,13 +878,16 @@ zonkRule env (IfaceRuleOut fun rule) 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 - = zonkTcTyVarToTyVar tv `thenM` \ tv' -> + = zonkQuantifiedTyVar tv `thenM` \ tv' -> readMutVar unbound_tv_set `thenM` \ tv_set -> writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_` return (mkTyVarTy tv') @@ -943,7 +896,7 @@ 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 + = 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, @@ -951,7 +904,9 @@ zonkTypeZapping ty -- 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) + 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, @@ -983,17 +938,17 @@ 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 [] + | liftedTypeKind `isSubKind` kind = voidTy -- The vastly common case + | otherwise = mkTyConApp tycon [] where kind = tyVarKind tv - (args,res) = Type.splitFunTys kind -- Kinds are simple; use Type.splitFunTys + (args,res) = splitKindFunTys kind - tycon | kind `eqKind` tyConKind listTyCon -- *->* + tycon | kind == tyConKind listTyCon -- *->* = listTyCon -- No tuples this size - | all isTypeKind args && isTypeKind res - = tupleTyCon Boxed (length args) -- *-> ... ->*->* + | all isLiftedTypeKind args && isLiftedTypeKind res + = tupleTyCon Boxed (length args) -- *-> ... ->*->* | otherwise = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $