X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcArrows.lhs;h=7ce5fc1a575abb70d1993b1cd2b2efe8a37ed078;hp=f0cb72aa4c6dd82c1e9b550e4e451cfa42ef028f;hb=86add45dbfb6f962b65e371143dd467ae783f9e7;hpb=4226903dd2bd0a08e1b7e10547a57588e8371e78 diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index f0cb72a..7ce5fc1 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -5,42 +5,30 @@ Typecheck arrow notation \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module TcArrows ( tcProc ) where -#include "HsVersions.h" - -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 TcGadt 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 +import FastString import Util import Control.Monad @@ -54,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') <- tcProcPat 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} @@ -98,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 @@ -119,6 +98,7 @@ tcCmd env (L loc expr) res_ty { expr' <- tc_cmd env expr res_ty ; return (L loc expr') } +tc_cmd :: CmdEnv -> HsExpr Name -> (CmdStack, TcTauType) -> TcM (HsExpr TcId) tc_cmd env (HsPar cmd) res_ty = do { cmd' <- tcCmd env cmd res_ty ; return (HsPar cmd') } @@ -131,20 +111,25 @@ tc_cmd env (HsLet binds (L body_loc body)) res_ty tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty) = addErrCtxt (cmdCtxt in_cmd) $ do - (scrut', scrut_ty) <- addErrCtxt (caseScrutCtxt scrut) $ - tcInferRho scrut + (scrut', scrut_ty) <- tcInferRho scrut matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty return (HsCase scrut' matches') 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 +171,9 @@ tc_cmd env cmd@(HsApp fun arg) (cmd_stk, res_ty) ------------------------------------------- -- Lambda -tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats maybe_rhs_sig grhss))] _)) +tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig grhss))] _)) (cmd_stk, res_ty) - = addErrCtxt (matchCtxt match_ctxt match) $ + = addErrCtxt (pprMatchInCtxt match_ctxt match) $ do { -- Check the cmd stack is big enough ; checkTc (lengthAtLeast cmd_stk n_pats) @@ -196,8 +181,8 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats maybe_rhs_sig g -- Check the patterns, and the GRHSs inside ; (pats', grhss') <- setSrcSpan mtch_loc $ - tcLamPats pats cmd_stk res_ty $ - tc_grhss grhss + 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)) @@ -215,23 +200,18 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats maybe_rhs_sig g ; 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) } ----------------------------------------------------------------- @@ -247,8 +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..] - ; span <- getSrcSpanM - ; [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 @@ -260,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 @@ -297,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') @@ -305,22 +277,84 @@ 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) - - other -> (ty, []) + -> unscramble' t (s:ss) + _ -> (ty, ss) ----------------------------------------------------------------- -- Base case for illegal commands -- This is where expressions that aren't commands get rejected -tc_cmd env cmd _ - = failWithTc (vcat [ptext SLIT("The expression"), nest 2 (ppr cmd), - ptext SLIT("was found where an arrow command was expected")]) +tc_cmd _ cmd _ + = failWithTc (vcat [ptext (sLit "The expression"), nest 2 (ppr cmd), + ptext (sLit "was found where an arrow command was expected")]) +\end{code} + + +%************************************************************************ +%* * + 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} @@ -332,6 +366,7 @@ tc_cmd env cmd _ \begin{code} +mkPairTy :: Type -> Type -> Type mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2] arrowTyConKind :: Kind -- *->*->* @@ -346,20 +381,21 @@ arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind %************************************************************************ \begin{code} -cmdCtxt cmd = ptext SLIT("In the command:") <+> ppr cmd - -caseScrutCtxt cmd - = hang (ptext SLIT("In the scrutinee of a case command:")) 4 (ppr cmd) +cmdCtxt :: HsExpr Name -> SDoc +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) + = hang (ptext (sLit "Non-empty command stack at command:")) + 2 (ppr cmd) +kappaUnderflow :: HsExpr Name -> SDoc kappaUnderflow cmd - = hang (ptext SLIT("Command stack underflow at command:")) - 4 (ppr cmd) + = hang (ptext (sLit "Command stack underflow at command:")) + 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') + = hang (ptext (sLit "The type of the") <+> speakNth i <+> ptext (sLit "argument of a command form has the wrong shape")) + 2 (ptext (sLit "Argument type:") <+> ppr tup_ty') \end{code}