X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcArrows.lhs;h=5d9273880ff07f125851f70472aad17564190c11;hp=9fede384a7d2108d15ac65a1a9f9f53c4c8e1821;hb=d76d9636aeebe933d160157331b8c8c0087e73ac;hpb=d436c70d43fb905c63220040168295e473f4b90a diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index 9fede38..5d92738 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -7,17 +7,13 @@ Typecheck arrow notation \begin{code} module TcArrows ( tcProc ) where -import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho ) +import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp ) import HsSyn -import TcHsSyn - import TcMatches - import TcType import TcMType import TcBinds -import TcSimplify import TcPat import TcUnify import TcRnMonad @@ -44,19 +40,18 @@ import Control.Monad \begin{code} tcProc :: InPat Name -> LHsCmdTop Name -- proc pat -> expr - -> BoxyRhoType -- Expected type of whole proc expression + -> TcRhoType -- Expected type of whole proc expression -> TcM (OutPat TcId, LHsCmdTop TcId, CoercionI) 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 = mkTransCoI coi (mkAppTyCoI coi1 (IdCo res_ty)) + ; return (pat', cmd', res_coi) } \end{code} @@ -130,11 +125,17 @@ tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty) 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') +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') } ------------------------------------------- @@ -185,9 +186,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)) @@ -205,20 +206,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 $ + = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ tcGuardedCmd env body stk' ; 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 (tcMDoStmt tc_rhs) 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) } @@ -237,7 +236,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 @@ -249,22 +248,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 @@ -294,14 +286,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 @@ -342,15 +333,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}