X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=d10e3c0deba62011793b2f6fc0fc6a5431c359d7;hb=91944423d83620441d6d3b120654a10fb41cfb3c;hp=5e3c77498beac30d268909b10947352f77f43198;hpb=cb2be98ac73ffcc2e2cd631de403e83569a12b4d;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 5e3c774..d10e3c0 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -8,7 +8,6 @@ checker. \begin{code} module TcHsSyn ( - TcDictBinds, mkHsTyApp, mkHsDictApp, mkHsConApp, mkHsTyLam, mkHsDictLam, mkHsLet, mkHsApp, hsLitType, hsPatType, mkHsAppTy, mkSimpleHsAlt, @@ -21,7 +20,7 @@ module TcHsSyn ( idCoercion, isIdCoercion, -- re-exported from TcMonad - TcId, TcIdSet, + TcId, TcIdSet, TcDictBinds, zonkTopDecls, zonkTopExpr, zonkTopLExpr, zonkId, zonkTopBndrs @@ -37,20 +36,19 @@ import Id ( idType, setIdType, Id ) import TcRnMonad import Type ( Type ) -import TcType ( TcType, TcTyVar, eqKind, isTypeKind, mkTyVarTy, - tcGetTyVar, isAnyTypeKind, mkTyConApp ) +import TcType ( TcType, TcTyVar, mkTyVarTy, mkTyConApp, isImmutableTyVar, tcGetTyVar ) +import Kind ( isLiftedTypeKind, liftedTypeKind, isSubKind ) import qualified Type -import TcMType ( zonkTcTyVarToTyVar, zonkType, zonkTcType, zonkTcTyVars, - putTcTyVar ) +import TcMType ( zonkQuantifiedTyVar, zonkType, zonkTcType, zonkTcTyVars, putMetaTyVar ) import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, doublePrimTy, addrPrimTy ) import TysWiredIn ( charTy, stringTy, intTy, mkListTy, mkPArrTy, mkTupleTy, unitTy, voidTy, listTyCon, tupleTyCon ) -import TyCon ( mkPrimTyCon, tyConKind ) -import PrimRep ( PrimRep(VoidRep) ) -import Name ( getOccName, mkInternalName, mkDerivedTyConOcc ) +import TyCon ( mkPrimTyCon, tyConKind, PrimRep(..) ) +import Kind ( splitKindFunTys ) +import Name ( Name, getOccName, mkInternalName, mkDerivedTyConOcc ) import Var ( Var, isId, isLocalVar, tyVarKind ) import VarSet import VarEnv @@ -59,16 +57,12 @@ import Maybes ( orElse ) import Maybe ( isNothing ) import Unique ( Uniquable(..) ) import SrcLoc ( noSrcLoc, noLoc, Located(..), unLoc ) +import Util ( mapSnd ) import Bag import Outputable \end{code} -\begin{code} -type TcDictBinds = LHsBinds TcId -- Bag of dictionary bindings -\end{code} - - %************************************************************************ %* * \subsection[mkFailurePair]{Code for pattern-matching and other failures} @@ -81,20 +75,21 @@ then something is wrong. hsPatType :: OutPat Id -> Type hsPatType pat = pat_type (unLoc pat) -pat_type (ParPat pat) = hsPatType pat -pat_type (WildPat ty) = ty -pat_type (VarPat var) = idType var -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) = mkTupleTy box (length pats) (map hsPatType pats) -pat_type (ConPatOut _ _ ty _ _) = ty -pat_type (SigPatOut _ ty _) = ty -pat_type (NPatOut lit ty _) = ty -pat_type (NPlusKPatOut id _ _ _) = idType (unLoc id) -pat_type (DictPat ds ms) = case (ds ++ ms) of +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 (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) = mkTupleTy box (length pats) (map hsPatType pats) +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) @@ -190,16 +185,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 @@ -209,7 +210,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 @@ -238,34 +239,25 @@ zonkTopExpr e = zonkExpr emptyZonkEnv e zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id) zonkTopLExpr e = zonkLExpr emptyZonkEnv e -zonkTopDecls :: Bag (LHsBind TcId) -> [LRuleDecl TcId] -> [LForeignDecl TcId] +zonkTopDecls :: LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId] -> TcM ([Id], Bag (LHsBind Id), [LForeignDecl Id], [LRuleDecl Id]) -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' -> - zonkRules zonk_env rules `thenM` \ rules' -> - zonkForeignExports zonk_env fords `thenM` \ fords' -> - - returnM (collectHsBindBinders binds', binds', fords', rules') - ) +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') } --------------------------------------------- zonkGroup :: ZonkEnv -> HsBindGroup TcId -> TcM (ZonkEnv, HsBindGroup Id) zonkGroup env (HsBindGroup bs sigs is_rec) = ASSERT( null sigs ) - do { (env1, bs') <- fixM (\ ~(_, new_binds) -> do - { let env1 = extendZonkEnv env (collectHsBindBinders new_binds) - ; bs' <- zonkMonoBinds env1 bs - ; return (env1, bs') }) - ; return (env1, HsBindGroup bs' [] is_rec) } + do { (env1, bs') <- zonkRecMonoBinds env bs + ; return (env1, HsBindGroup bs' [] is_rec) } - zonkGroup env (HsIPBinds binds) = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds -> let @@ -286,14 +278,22 @@ zonkNestedBinds env (b:bs) = do { (env1, b') <- zonkGroup env b ; return (env2, b':bs') } --------------------------------------------- -zonkMonoBinds :: ZonkEnv -> Bag (LHsBind TcId) -> TcM (Bag (LHsBind Id)) +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 (PatBind pat grhss) - = zonkPat env pat `thenM` \ (new_pat, _) -> - zonkGRHSs env grhss `thenM` \ new_grhss -> - returnM (PatBind new_pat new_grhss) +zonk_bind env (PatBind pat grhss ty) + = do { (_env, new_pat) <- zonkPat env pat -- Env already extended + ; new_grhss <- zonkGRHSs env grhss + ; new_ty <- zonkTcTypeToType env ty + ; return (PatBind new_pat new_grhss new_ty) } zonk_bind env (VarBind var expr) = zonkIdBndr env var `thenM` \ new_var -> @@ -302,25 +302,22 @@ zonk_bind env (VarBind var expr) zonk_bind env (FunBind var inf ms) = wrapLocM (zonkIdBndr env) var `thenM` \ new_var -> - mappM (zonkMatch env) ms `thenM` \ new_ms -> + zonkMatchGroup env ms `thenM` \ new_ms -> returnM (FunBind new_var inf new_ms) zonk_bind env (AbsBinds tyvars dicts exports inlines val_binds) - = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars -> - -- No need to extend tyvar env: the effects are - -- propagated through binding the tyvars themselves - + = ASSERT( all isImmutableTyVar tyvars ) zonkIdBndrs env dicts `thenM` \ new_dicts -> fixM (\ ~(new_val_binds, _) -> let - env1 = extendZonkEnv (extendZonkEnv env new_dicts) + env1 = extendZonkEnv (extendZonkEnv env new_dicts) (collectHsBindBinders new_val_binds) in zonkMonoBinds env1 val_binds `thenM` \ new_val_binds -> mappM (zonkExport env1) exports `thenM` \ new_exports -> returnM (new_val_binds, new_exports) ) `thenM` \ (new_val_bind, new_exports) -> - returnM (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind) + returnM (AbsBinds tyvars new_dicts new_exports inlines new_val_bind) where zonkExport env (tyvars, global, local) = zonkTcTyVars tyvars `thenM` \ tys -> @@ -340,26 +337,31 @@ zonk_bind env (AbsBinds tyvars dicts exports inlines val_binds) %************************************************************************ \begin{code} -zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id) +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)) - = zonkPats env pats `thenM` \ (new_pats, new_ids) -> - zonkGRHSs (extendZonkEnv env (bagToList new_ids)) grhss `thenM` \ new_grhss -> - returnM (L loc (Match new_pats Nothing new_grhss)) + = do { (env1, new_pats) <- zonkPats env pats + ; new_grhss <- zonkGRHSs env1 grhss + ; return (L loc (Match new_pats Nothing new_grhss)) } ------------------------------------------------------------------------- zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id) -zonkGRHSs env (GRHSs grhss binds ty) +zonkGRHSs env (GRHSs grhss binds) = zonkNestedBinds env binds `thenM` \ (new_env, new_binds) -> let - zonk_grhs (GRHS guarded) - = zonkStmts new_env guarded `thenM` \ new_guarded -> - returnM (GRHS new_guarded) + zonk_grhs (GRHS guarded rhs) + = zonkStmts new_env guarded `thenM` \ (env2, new_guarded) -> + zonkLExpr env2 rhs `thenM` \ new_rhs -> + returnM (GRHS new_guarded new_rhs) in mappM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss -> - zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (GRHSs new_grhss new_binds new_ty) + returnM (GRHSs new_grhss new_binds) \end{code} %************************************************************************ @@ -389,11 +391,13 @@ zonkExpr env (HsLit (HsRat f 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) = zonkLExpr env e1 `thenM` \ new_e1 -> @@ -416,7 +420,10 @@ zonkExpr env (OpApp e1 op fixity e2) 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) = zonkLExpr env e `thenM` \new_e -> @@ -434,7 +441,7 @@ zonkExpr env (SectionR op expr) zonkExpr env (HsCase expr ms) = zonkLExpr env expr `thenM` \ new_expr -> - mappM (zonkMatch env) ms `thenM` \ new_ms -> + zonkMatchGroup env ms `thenM` \ new_ms -> returnM (HsCase new_expr new_ms) zonkExpr env (HsIf e1 e2 e3) @@ -448,11 +455,12 @@ zonkExpr env (HsLet binds expr) zonkLExpr new_env expr `thenM` \ new_expr -> returnM (HsLet new_binds new_expr) -zonkExpr env (HsDo do_or_lc stmts ids ty) - = 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 -> - zonkReboundNames env ids `thenM` \ new_ids -> - returnM (HsDo do_or_lc new_stmts new_ids new_ty) + returnM (HsDo (zonkDo env do_or_lc) + new_stmts new_body new_ty) zonkExpr env (ExplicitList ty exprs) = zonkTcTypeToType env ty `thenM` \ new_ty -> @@ -468,33 +476,33 @@ zonkExpr env (ExplicitTuple exprs boxed) = zonkLExprs env exprs `thenM` \ new_exprs -> returnM (ExplicitTuple new_exprs boxed) -zonkExpr env (RecordConOut data_con con_expr rbinds) - = zonkLExpr env con_expr `thenM` \ new_con_expr -> +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 (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) - = zonkLExpr env expr `thenM` \ new_expr -> +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) - = zonkLExpr env expr `thenM` \ new_expr -> +zonkExpr env (PArrSeq expr info) + = zonkExpr env expr `thenM` \ new_expr -> zonkArithSeq env info `thenM` \ new_info -> - returnM (PArrSeqOut new_expr new_info) + returnM (PArrSeq new_expr new_info) zonkExpr env (HsSCC lbl expr) = zonkLExpr env expr `thenM` \ new_expr -> @@ -506,15 +514,13 @@ zonkExpr env (HsCoreAnn lbl 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 - + = ASSERT( all isImmutableTyVar tyvars ) zonkLExpr env expr `thenM` \ new_expr -> - returnM (TyLam new_tyvars new_expr) + returnM (TyLam tyvars new_expr) zonkExpr env (TyApp expr tys) - = zonkLExpr 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) @@ -531,12 +537,9 @@ zonkExpr env (DictApp expr dicts) -- arrow notation extensions zonkExpr env (HsProc pat body) - = 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) + = 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 -> @@ -549,25 +552,30 @@ zonkExpr env (HsArrForm op fixity args) mappM (zonkCmdTop env) args `thenM` \ new_args -> returnM (HsArrForm new_op fixity new_args) +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 -> - mappM (zonkTcTypeToType env) stack_tys - `thenM` \ new_stack_tys -> + = zonkLExpr env cmd `thenM` \ new_cmd -> + zonkTcTypeToTypes env stack_tys `thenM` \ new_stack_tys -> zonkTcTypeToType env ty `thenM` \ new_ty -> - zonkReboundNames env ids `thenM` \ new_ids -> + mapSndM (zonkExpr 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) = zonkLExpr env e `thenM` \ new_e -> - returnM (n, new_e) +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) @@ -594,16 +602,11 @@ zonkArithSeq env (FromThenTo e1 e2 e3) ------------------------------------------------------------------------- -zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM [LStmt Id] - -zonkStmts env stmts = zonk_stmts env stmts `thenM` \ (_, stmts) -> - returnM stmts - -zonk_stmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id]) -zonk_stmts env [] = return (env, []) -zonk_stmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s - ; (env2, ss') <- zonk_stmts env1 ss - ; return (env2, s' : ss') } +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) @@ -614,45 +617,41 @@ zonkStmt env (ParStmt stmts_w_bndrs) in return (env1, ParStmt new_stmts_w_bndrs) where - zonk_branch (stmts, bndrs) = zonk_stmts env stmts `thenM` \ (env1, new_stmts) -> + zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) -> returnM (new_stmts, zonkIdOccs env1 bndrs) -zonkStmt env (RecStmt segStmts lvs rvs rets) +zonkStmt env (RecStmt segStmts lvs rvs rets binds) = zonkIdBndrs env rvs `thenM` \ new_rvs -> let 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 - zonkLExprs env2 rets `thenM` \ new_rets -> + mapM (zonkExpr env2) rets `thenM` \ new_rets -> let new_lvs = zonkIdOccs env2 lvs env3 = extendZonkEnv env new_lvs -- Only the lvs are needed in - returnM (env3, RecStmt new_segStmts new_lvs new_rvs new_rets) - -zonkStmt env (ResultStmt expr) - = zonkLExpr env expr `thenM` \ new_expr -> - returnM (env, ResultStmt new_expr) + zonkRecMonoBinds env3 binds `thenM` \ (env4, new_binds) -> + returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets new_binds) -zonkStmt env (ExprStmt expr ty) +zonkStmt env (ExprStmt expr then_op ty) = zonkLExpr env expr `thenM` \ new_expr -> + zonkExpr env then_op `thenM` \ new_then -> zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (env, ExprStmt new_expr new_ty) + returnM (env, ExprStmt new_expr new_then new_ty) zonkStmt env (LetStmt binds) = zonkNestedBinds env binds `thenM` \ (env1, new_binds) -> returnM (env1, LetStmt new_binds) -zonkStmt env (BindStmt pat expr) - = zonkLExpr env expr `thenM` \ new_expr -> - zonkPat env pat `thenM` \ (new_pat, new_ids) -> - let - env1 = extendZonkEnv env (bagToList new_ids) - in - returnM (env1, BindStmt new_pat new_expr) - +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) } ------------------------------------------------------------------------- @@ -679,106 +678,111 @@ mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r) %************************************************************************ \begin{code} -zonkPat :: ZonkEnv -> OutPat TcId -> TcM (OutPat Id, Bag Id) -zonkPat env pat = wrapLocFstM (zonk_pat env) pat +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) - = zonkPat env p `thenM` \ (new_p, ids) -> - returnM (ParPat new_p, ids) + = do { (env', p') <- zonkPat env p + ; return (env', ParPat p') } zonk_pat env (WildPat ty) - = zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (WildPat new_ty, emptyBag) + = do { ty' <- zonkTcTypeToType env ty + ; return (env, WildPat ty') } zonk_pat env (VarPat v) - = zonkIdBndr env v `thenM` \ new_v -> - returnM (VarPat new_v, unitBag new_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) - = zonkPat env pat `thenM` \ (new_pat, ids) -> - returnM (LazyPat new_pat, ids) + = do { (env', pat') <- zonkPat env pat + ; return (env', LazyPat pat') } -zonk_pat env (AsPat n pat) - = wrapLocM (zonkIdBndr env) n `thenM` \ new_n -> - zonkPat env pat `thenM` \ (new_pat, ids) -> - returnM (AsPat new_n new_pat, unLoc new_n `consBag` ids) +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) - = zonkTcTypeToType env ty `thenM` \ new_ty -> - zonkPats env pats `thenM` \ (new_pats, ids) -> - returnM (ListPat new_pats new_ty, ids) + = do { ty' <- zonkTcTypeToType env ty + ; (env', pats') <- zonkPats env pats + ; return (env', ListPat pats' ty') } zonk_pat env (PArrPat pats ty) - = zonkTcTypeToType env ty `thenM` \ new_ty -> - zonkPats env pats `thenM` \ (new_pats, ids) -> - returnM (PArrPat new_pats new_ty, ids) + = do { ty' <- zonkTcTypeToType env ty + ; (env', pats') <- zonkPats env pats + ; return (env', PArrPat pats' ty') } zonk_pat env (TuplePat pats boxed) - = zonkPats env pats `thenM` \ (new_pats, ids) -> - returnM (TuplePat new_pats boxed, ids) - -zonk_pat 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 env1 stuff `thenM` \ (new_stuff, ids) -> - returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts, - listToBag new_dicts `unionBags` ids) - -zonk_pat env (LitPat lit) = returnM (LitPat lit, emptyBag) - -zonk_pat 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) - -zonk_pat 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) - -zonk_pat env (NPlusKPatOut n k e1 e2) - = wrapLocM (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 (unLoc new_n)) + = do { (env', pats') <- zonkPats env pats + ; return (env', TuplePat pats' boxed) } + +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) - = 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) + = 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} %************************************************************************ @@ -845,7 +849,8 @@ zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs rhs) where zonk_bndr (RuleBndr v) | isId (unLoc v) = wrapLocM (zonkIdBndr env) v - | otherwise = wrapLocM zonkTcTyVarToTyVar v + | otherwise = ASSERT( isImmutableTyVar (unLoc v) ) + return v \end{code} @@ -859,13 +864,16 @@ zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs rhs) 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 + = zonkType zonk_unbound_tyvar True 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') @@ -874,7 +882,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 True 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, @@ -882,7 +890,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 { putMetaTyVar tv ty; return ty } + where + ty = mkArbitraryType tv -- When the type checker finds a type variable with no binding, @@ -914,17 +924,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) $