X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcArrows.lhs;h=7ce5fc1a575abb70d1993b1cd2b2efe8a37ed078;hp=ee14eb85eddd215e259cfe9abc69d8d1c2336a3a;hb=febf1ced754a3996ac1a5877dcded87828560d1c;hpb=259d5ea8479dbbf0220335c740efebec1bc19a7f diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index ee14eb8..7ce5fc1 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -7,27 +7,24 @@ Typecheck arrow notation \begin{code} module TcArrows ( tcProc ) where -import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho ) +import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId ) import HsSyn -import TcHsSyn - import TcMatches - import TcType import TcMType import TcBinds -import TcSimplify import TcPat import TcUnify import TcRnMonad +import TcEnv import Coercion +import Id( mkLocalId ) import Inst import Name import TysWiredIn import VarSet import TysPrim -import Type import SrcLoc import Outputable @@ -45,19 +42,18 @@ import Control.Monad \begin{code} tcProc :: InPat Name -> LHsCmdTop Name -- proc pat -> expr - -> BoxyRhoType -- Expected type of whole proc expression - -> TcM (OutPat TcId, LHsCmdTop TcId, CoercionI) + -> TcRhoType -- Expected type of whole proc expression + -> TcM (OutPat TcId, LHsCmdTop TcId, Coercion) tcProc pat cmd exp_ty = newArrowScope $ - do { ((exp_ty1, res_ty), coi) <- boxySplitAppTy exp_ty - ; ((arr_ty, arg_ty), coi1) <- boxySplitAppTy exp_ty1 + do { (coi, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty + ; (coi1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 ; let cmd_env = CmdEnv { cmd_arr = arr_ty } - ; (pat', cmd') <- tcPat ProcExpr pat arg_ty res_ty $ - tcCmdTop cmd_env cmd [] - ; let res_coi = mkTransCoI coi (mkAppTyCoI exp_ty1 coi1 res_ty IdCo) - ; return (pat', cmd', res_coi) - } + ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $ + tcCmdTop cmd_env cmd [] res_ty + ; let res_coi = mkTransCo coi (mkAppCo coi1 (mkReflCo res_ty)) + ; return (pat', cmd', res_coi) } \end{code} @@ -89,20 +85,12 @@ tcCmdTop :: CmdEnv tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_stk res_ty = setSrcSpan loc $ - do { cmd' <- tcGuardedCmd env cmd cmd_stk res_ty + do { cmd' <- tcCmd env cmd (cmd_stk, res_ty) ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') } ---------------------------------------- -tcGuardedCmd :: CmdEnv -> LHsExpr Name -> CmdStack - -> TcTauType -> TcM (LHsExpr TcId) --- A wrapper that deals with the refinement (if any) -tcGuardedCmd env expr stk res_ty - = do { body <- tcCmd env expr (stk, res_ty) - ; return body - } - tcCmd :: CmdEnv -> LHsExpr Name -> (CmdStack, TcTauType) -> TcM (LHsExpr TcId) -- The main recursive function tcCmd env (L loc expr) res_ty @@ -129,13 +117,19 @@ tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty) where match_ctxt = MC { mc_what = CaseAlt, mc_body = mc_body } - mc_body body res_ty' = tcGuardedCmd env body stk res_ty' - -tc_cmd env (HsIf pred b1 b2) res_ty - = do { pred' <- tcMonoExpr pred boolTy - ; b1' <- tcCmd env b1 res_ty - ; b2' <- tcCmd env b2 res_ty - ; return (HsIf pred' b1' b2') + mc_body body res_ty' = tcCmd env body (stk, res_ty') + +tc_cmd env (HsIf mb_fun pred b1 b2) (stack_ty,res_ty) + = do { pred_ty <- newFlexiTyVarTy openTypeKind + ; b_ty <- newFlexiTyVarTy openTypeKind + ; let if_ty = mkFunTys [pred_ty, b_ty, b_ty] res_ty + ; mb_fun' <- case mb_fun of + Nothing -> return Nothing + Just fun -> liftM Just (tcSyntaxOp IfOrigin fun if_ty) + ; pred' <- tcMonoExpr pred pred_ty + ; b1' <- tcCmd env b1 (stack_ty,b_ty) + ; b2' <- tcCmd env b2 (stack_ty,b_ty) + ; return (HsIf mb_fun' pred' b1' b2') } ------------------------------------------- @@ -186,9 +180,9 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig (kappaUnderflow cmd) -- Check the patterns, and the GRHSs inside - ; (pats', grhss') <- setSrcSpan mtch_loc $ - tcPats LambdaExpr pats cmd_stk res_ty $ - tc_grhss grhss + ; (pats', grhss') <- setSrcSpan mtch_loc $ + tcPats LambdaExpr pats cmd_stk $ + tc_grhss grhss res_ty ; let match' = L mtch_loc (Match pats' Nothing grhss') ; return (HsLam (MatchGroup [match'] res_ty)) @@ -206,23 +200,18 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig ; return (GRHSs grhss' binds') } tc_grhs res_ty (GRHS guards body) - = do { (guards', rhs') <- tcStmts pg_ctxt tcGuardStmt guards res_ty $ - tcGuardedCmd env body stk' + = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ + \ res_ty -> tcCmd env body (stk', res_ty) ; return (GRHS guards' rhs') } ------------------------------------------- -- Do notation -tc_cmd env cmd@(HsDo do_or_lc stmts body _ty) (cmd_stk, res_ty) +tc_cmd env cmd@(HsDo do_or_lc stmts _) (cmd_stk, res_ty) = do { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd) - ; (stmts', body') <- tcStmts do_or_lc tc_stmt stmts res_ty $ - tcGuardedCmd env body [] - ; return (HsDo do_or_lc stmts' body' res_ty) } + ; stmts' <- tcStmts do_or_lc (tcArrDoStmt env) stmts res_ty + ; return (HsDo do_or_lc stmts' res_ty) } where - tc_stmt = tcMDoStmt tc_rhs - tc_rhs rhs = do { ty <- newFlexiTyVarTy liftedTypeKind - ; rhs' <- tcCmd env rhs ([], ty) - ; return (rhs', ty) } ----------------------------------------------------------------- @@ -238,7 +227,7 @@ tc_cmd env cmd@(HsDo do_or_lc stmts body _ty) (cmd_stk, res_ty) tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..] - ; [w_tv] <- tcInstSkolTyVars ArrowSkol [alphaTyVar] + ; [w_tv] <- tcInstSkolTyVars [alphaTyVar] ; let w_ty = mkTyVarTy w_tv -- Just a convenient starting point -- a ((w,t1) .. tn) t @@ -250,22 +239,15 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) e_res_ty -- Check expr - ; (expr', lie) <- escapeArrowScope (getLIE (tcMonoExpr expr e_ty)) - ; loc <- getInstLoc (SigOrigin ArrowSkol) - ; inst_binds <- tcSimplifyCheck loc [w_tv] [] lie - - -- Check that the polymorphic variable hasn't been unified with anything - -- and is not free in res_ty or the cmd_stk (i.e. t, t1..tn) - ; checkSigTyVarsWrt (tyVarsOfTypes (res_ty:cmd_stk)) [w_tv] + ; (inst_binds, expr') <- checkConstraints ArrowSkol [w_tv] [] $ + escapeArrowScope (tcMonoExpr expr e_ty) -- OK, now we are in a position to unscramble -- the s1..sm and check each cmd ; cmds' <- mapM (tc_cmd w_tv) cmds_w_tys - ; return (HsArrForm (noLoc $ HsWrap (WpTyLam w_tv) - (unLoc $ mkHsDictLet inst_binds expr')) - fixity cmds') - } + ; let wrap = WpTyLam w_tv <.> mkWpLet inst_binds + ; return (HsArrForm (mkLHsWrap wrap expr') fixity cmds') } where -- Make the types -- b, ((e,s1) .. sm), s @@ -287,7 +269,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) -- Check that it has the right shape: -- ((w,s1) .. sn) -- where the si do not mention w - ; checkTc (corner_ty `tcEqType` mkTyVarTy w_tv && + ; checkTc (corner_ty `eqType` mkTyVarTy w_tv && not (w_tv `elemVarSet` tyVarsOfTypes arg_tys)) (badFormFun i tup_ty') @@ -295,14 +277,13 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) unscramble :: TcType -> (TcType, [TcType]) -- unscramble ((w,s1) .. sn) = (w, [s1..sn]) - unscramble ty + unscramble ty = unscramble' ty [] + + unscramble' ty ss = case tcSplitTyConApp_maybe ty of Just (tc, [t,s]) | tc == pairTyCon - -> let - (w,ss) = unscramble t - in (w, s:ss) - - _ -> (ty, []) + -> unscramble' t (s:ss) + _ -> (ty, ss) ----------------------------------------------------------------- -- Base case for illegal commands @@ -316,6 +297,69 @@ tc_cmd _ cmd _ %************************************************************************ %* * + Stmts +%* * +%************************************************************************ + +\begin{code} +-------------------------------- +-- Mdo-notation +-- The distinctive features here are +-- (a) RecStmts, and +-- (b) no rebindable syntax + +tcArrDoStmt :: CmdEnv -> TcStmtChecker +tcArrDoStmt env _ (LastStmt rhs _) res_ty thing_inside + = do { rhs' <- tcCmd env rhs ([], res_ty) + ; thing <- thing_inside (panic "tcArrDoStmt") + ; return (LastStmt rhs' noSyntaxExpr, thing) } + +tcArrDoStmt env _ (ExprStmt rhs _ _ _) res_ty thing_inside + = do { (rhs', elt_ty) <- tc_arr_rhs env rhs + ; thing <- thing_inside res_ty + ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) } + +tcArrDoStmt env ctxt (BindStmt pat rhs _ _) res_ty thing_inside + = do { (rhs', pat_ty) <- tc_arr_rhs env rhs + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ + thing_inside res_ty + ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } + +tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames + , recS_rec_ids = recNames }) res_ty thing_inside + = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind + ; let rec_ids = zipWith mkLocalId recNames rec_tys + ; tcExtendIdEnv rec_ids $ do + { (stmts', (later_ids, rec_rets)) + <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' -> + -- ToDo: res_ty not really right + do { rec_rets <- zipWithM tcCheckId recNames rec_tys + ; later_ids <- tcLookupLocalIds laterNames + ; return (later_ids, rec_rets) } + + ; thing <- tcExtendIdEnv later_ids (thing_inside res_ty) + -- NB: The rec_ids for the recursive things + -- already scope over this part. This binding may shadow + -- some of them with polymorphic things with the same Name + -- (see note [RecStmt] in HsExpr) + + ; return (emptyRecStmt { recS_stmts = stmts', recS_later_ids = later_ids + , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets + , recS_ret_ty = res_ty }, thing) + }} + +tcArrDoStmt _ _ stmt _ _ + = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt) + +tc_arr_rhs :: CmdEnv -> LHsExpr Name -> TcM (LHsExpr TcId, TcType) +tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind + ; rhs' <- tcCmd env rhs ([], ty) + ; return (rhs', ty) } +\end{code} + + +%************************************************************************ +%* * Helpers %* * %************************************************************************ @@ -343,15 +387,15 @@ cmdCtxt cmd = ptext (sLit "In the command:") <+> ppr cmd nonEmptyCmdStkErr :: HsExpr Name -> SDoc nonEmptyCmdStkErr cmd = hang (ptext (sLit "Non-empty command stack at command:")) - 4 (ppr cmd) + 2 (ppr cmd) kappaUnderflow :: HsExpr Name -> SDoc kappaUnderflow cmd = hang (ptext (sLit "Command stack underflow at command:")) - 4 (ppr cmd) + 2 (ppr cmd) badFormFun :: Int -> TcType -> SDoc badFormFun i tup_ty' = hang (ptext (sLit "The type of the") <+> speakNth i <+> ptext (sLit "argument of a command form has the wrong shape")) - 4 (ptext (sLit "Argument type:") <+> ppr tup_ty') + 2 (ptext (sLit "Argument type:") <+> ppr tup_ty') \end{code}