diff options
| -rw-r--r-- | compiler/deSugar/Coverage.lhs | 3 | ||||
| -rw-r--r-- | compiler/deSugar/DsArrows.lhs | 486 | ||||
| -rw-r--r-- | compiler/hsSyn/HsExpr.lhs | 13 | ||||
| -rw-r--r-- | compiler/hsSyn/HsUtils.lhs | 7 | ||||
| -rw-r--r-- | compiler/parser/Parser.y.pp | 4 | ||||
| -rw-r--r-- | compiler/parser/RdrHsSyn.lhs | 4 | ||||
| -rw-r--r-- | compiler/rename/RnExpr.lhs | 4 | ||||
| -rw-r--r-- | compiler/rename/RnTypes.lhs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcArrows.lhs | 272 | ||||
| -rw-r--r-- | compiler/typecheck/TcHsSyn.lhs | 6 | ||||
| -rw-r--r-- | docs/users_guide/glasgow_exts.xml | 48 |
11 files changed, 461 insertions, 388 deletions
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 45183ba3db..bdcf9c9f78 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -803,6 +803,9 @@ addTickHsCmd (HsCmdArrForm e fix cmdtop) = (return fix) (mapM (liftL (addTickHsCmdTop)) cmdtop) +addTickHsCmd (HsCmdCast co cmd) + = liftM2 HsCmdCast (return co) (addTickHsCmd cmd) + -- Others should never happen in a command context. --addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index 76b279655d..b825acb836 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -37,6 +37,7 @@ import CoreSyn import CoreFVs import CoreUtils import MkCore +import DsBinds (dsHsWrapper) import Name import Var @@ -124,6 +125,15 @@ mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr mkFailExpr ctxt ty = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt) +-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a +mkFstExpr :: Type -> Type -> DsM CoreExpr +mkFstExpr a_ty b_ty = do + a_var <- newSysLocalDs a_ty + b_var <- newSysLocalDs b_ty + pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty) + return (Lam pair_var + (coreCasePair pair_var a_var b_var (Var a_var))) + -- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b mkSndExpr :: Type -> Type -> DsM CoreExpr mkSndExpr a_ty b_ty = do @@ -158,91 +168,108 @@ mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2] mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr mkCorePairExpr e1 e2 = mkCoreTup [e1, e2] + +mkCoreUnitExpr :: CoreExpr +mkCoreUnitExpr = mkCoreTup [] \end{code} The input is divided into a local environment, which is a flat tuple -(unless it's too big), and a stack, each element of which is paired -with the environment in turn. In general, the input has the form +(unless it's too big), and a stack, which is a right-nested pair. +In general, the input has the form - (...((x1,...,xn),s1),...sk) + ((x1,...,xn), (s1,...(sk,())...)) where xi are the environment values, and si the ones on the stack, with s1 being the "top", the first one to be matched with a lambda. \begin{code} -envStackType :: [Id] -> [Type] -> Type -envStackType ids stack_tys = foldl mkCorePairTy (mkBigCoreVarTupTy ids) stack_tys +envStackType :: [Id] -> Type -> Type +envStackType ids stack_ty = mkCorePairTy (mkBigCoreVarTupTy ids) stack_ty + +-- splitTypeAt n (t1,... (tn,t)...) = ([t1, ..., tn], t) +splitTypeAt :: Int -> Type -> ([Type], Type) +splitTypeAt n ty + | n == 0 = ([], ty) + | otherwise = case tcTyConAppArgs ty of + [t, ty'] -> let (ts, ty_r) = splitTypeAt (n-1) ty' in (t:ts, ty_r) + _ -> pprPanic "splitTypeAt" (ppr ty) ---------------------------------------------- -- buildEnvStack -- --- (...((x1,...,xn),s1),...sk) +-- ((x1,...,xn),stk) -buildEnvStack :: [Id] -> [Id] -> CoreExpr -buildEnvStack env_ids stack_ids - = foldl mkCorePairExpr (mkBigCoreVarTup env_ids) (map Var stack_ids) +buildEnvStack :: [Id] -> Id -> CoreExpr +buildEnvStack env_ids stack_id + = mkCorePairExpr (mkBigCoreVarTup env_ids) (Var stack_id) ---------------------------------------------- -- matchEnvStack -- --- \ (...((x1,...,xn),s1),...sk) -> e +-- \ ((x1,...,xn),stk) -> body -- => --- \ zk -> --- case zk of (zk-1,sk) -> --- ... --- case z1 of (z0,s1) -> --- case z0 of (x1,...,xn) -> --- e +-- \ pair -> +-- case pair of (tup,stk) -> +-- case tup of (x1,...,xn) -> +-- body matchEnvStack :: [Id] -- x1..xn - -> [Id] -- s1..sk + -> Id -- stk -> CoreExpr -- e -> DsM CoreExpr -matchEnvStack env_ids stack_ids body = do +matchEnvStack env_ids stack_id body = do uniqs <- newUniqueSupply tup_var <- newSysLocalDs (mkBigCoreVarTupTy env_ids) - matchVarStack tup_var stack_ids - (coreCaseTuple uniqs tup_var env_ids body) + let match_env = coreCaseTuple uniqs tup_var env_ids body + pair_id <- newSysLocalDs (mkCorePairTy (idType tup_var) (idType stack_id)) + return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env)) +---------------------------------------------- +-- matchEnv +-- +-- \ (x1,...,xn) -> body +-- => +-- \ tup -> +-- case tup of (x1,...,xn) -> +-- body + +matchEnv :: [Id] -- x1..xn + -> CoreExpr -- e + -> DsM CoreExpr +matchEnv env_ids body = do + uniqs <- newUniqueSupply + tup_id <- newSysLocalDs (mkBigCoreVarTupTy env_ids) + return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body)) ---------------------------------------------- --- matchVarStack +-- matchVarStack -- --- \ (...(z0,s1),...sk) -> e +-- case (x1, ...(xn, s)...) -> e -- => --- \ zk -> --- case zk of (zk-1,sk) -> --- ... --- case z1 of (z0,s1) -> +-- case z0 of (x1,z1) -> +-- case zn-1 of (xn,s) -> -- e - -matchVarStack :: Id -- z0 - -> [Id] -- s1..sk - -> CoreExpr -- e - -> DsM CoreExpr -matchVarStack env_id [] body - = return (Lam env_id body) -matchVarStack env_id (stack_id:stack_ids) body = do - pair_id <- newSysLocalDs (mkCorePairTy (idType env_id) (idType stack_id)) - matchVarStack pair_id stack_ids - (coreCasePair pair_id env_id stack_id body) +matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr) +matchVarStack [] stack_id body = return (stack_id, body) +matchVarStack (param_id:param_ids) stack_id body = do + (tail_id, tail_code) <- matchVarStack param_ids stack_id body + pair_id <- newSysLocalDs (mkCorePairTy (idType param_id) (idType tail_id)) + return (pair_id, coreCasePair pair_id param_id tail_id tail_code) \end{code} \begin{code} -mkHsEnvStackExpr :: [Id] -> [Id] -> LHsExpr Id -mkHsEnvStackExpr env_ids stack_ids - = foldl (\a b -> mkLHsTupleExpr [a,b]) - (mkLHsVarTuple env_ids) - (map nlHsVar stack_ids) +mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr Id +mkHsEnvStackExpr env_ids stack_id + = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id] \end{code} Translation of arrow abstraction \begin{code} --- A | xs |- c :: [] t' ---> c' --- -------------------------- --- A |- proc p -> c :: a t t' ---> premap (\ p -> (xs)) c' +-- D; xs |-a c : () --> t' ---> c' +-- -------------------------- +-- D |- proc p -> c :: a t t' ---> premap (\ p -> ((xs),())) c' -- -- where (xs) is the tuple of variables bound by p @@ -250,35 +277,40 @@ dsProcExpr :: LPat Id -> LHsCmdTop Id -> DsM CoreExpr -dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) = do +dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do (meth_binds, meth_ids) <- mkCmdEnv ids let locals = mkVarSet (collectPatBinders pat) - (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals [] cmd_ty cmd + (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals unitTy cmd_ty cmd let env_ty = mkBigCoreVarTupTy env_ids - fail_expr <- mkFailExpr ProcExpr env_ty + let env_stk_ty = mkCorePairTy env_ty unitTy + let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr + fail_expr <- mkFailExpr ProcExpr env_stk_ty var <- selectSimpleMatchVarL pat - match_code <- matchSimply (Var var) ProcExpr pat (mkBigCoreVarTup env_ids) fail_expr + match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr let pat_ty = hsLPatType pat - proc_code = do_premap meth_ids pat_ty env_ty cmd_ty + proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty (Lam var match_code) core_cmd return (mkLets meth_binds proc_code) -dsProcExpr _ c = pprPanic "dsProcExpr" (ppr c) \end{code} -Translation of command judgements of the form +Translation of a command judgement of the form + + D; xs |-a c : stk --> t + +to an expression e such that - A | xs |- c :: [ts] t + D |- e :: a (xs, stk) t \begin{code} -dsLCmd :: DsCmdEnv -> IdSet -> [Type] -> Type -> LHsCmd Id -> [Id] +dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd Id -> [Id] -> DsM (CoreExpr, IdSet) -dsLCmd ids local_vars stack res_ty cmd env_ids - = dsCmd ids local_vars stack res_ty (unLoc cmd) env_ids +dsLCmd ids local_vars stk_ty res_ty cmd env_ids + = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids dsCmd :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this command - -> [Type] -- type of the stack + -> Type -- type of the stack (right-nested tuple) -> Type -- return type of the command -> HsCmd Id -- command to desugar -> [Id] -- list of vars in the input to this command @@ -287,14 +319,14 @@ dsCmd :: DsCmdEnv -- arrow combinators -> DsM (CoreExpr, -- desugared expression IdSet) -- subset of local vars that occur free --- A |- f :: a (t*ts) t' --- A, xs |- arg :: t --- ----------------------------- --- A | xs |- f -< arg :: [ts] t' +-- D |- fun :: a t1 t2 +-- D, xs |- arg :: t1 +-- ----------------------------- +-- D; xs |-a fun -< arg : stk --> t2 -- --- ---> premap (\ ((xs)*ts) -> (arg*ts)) f +-- ---> premap (\ ((xs), _stk) -> arg) fun -dsCmd ids local_vars stack res_ty +dsCmd ids local_vars stack_ty res_ty (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _) env_ids = do let @@ -302,25 +334,24 @@ dsCmd ids local_vars stack res_ty (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty core_arrow <- dsLExpr arrow core_arg <- dsLExpr arg - stack_ids <- mapM newSysLocalDs stack - core_make_arg <- matchEnvStack env_ids stack_ids - (foldl mkCorePairExpr core_arg (map Var stack_ids)) + stack_id <- newSysLocalDs stack_ty + core_make_arg <- matchEnvStack env_ids stack_id core_arg return (do_premap ids - (envStackType env_ids stack) + (envStackType env_ids stack_ty) arg_ty res_ty core_make_arg core_arrow, exprFreeIds core_arg `intersectVarSet` local_vars) --- A, xs |- f :: a (t*ts) t' --- A, xs |- arg :: t --- ------------------------------ --- A | xs |- f -<< arg :: [ts] t' +-- D, xs |- fun :: a t1 t2 +-- D, xs |- arg :: t1 +-- ------------------------------ +-- D; xs |-a fun -<< arg : stk --> t2 -- --- ---> premap (\ ((xs)*ts) -> (f,(arg*ts))) app +-- ---> premap (\ ((xs), _stk) -> (fun, arg)) app -dsCmd ids local_vars stack res_ty +dsCmd ids local_vars stack_ty res_ty (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _) env_ids = do let @@ -329,13 +360,12 @@ dsCmd ids local_vars stack res_ty core_arrow <- dsLExpr arrow core_arg <- dsLExpr arg - stack_ids <- mapM newSysLocalDs stack - core_make_pair <- matchEnvStack env_ids stack_ids - (mkCorePairExpr core_arrow - (foldl mkCorePairExpr core_arg (map Var stack_ids))) - + stack_id <- newSysLocalDs stack_ty + core_make_pair <- matchEnvStack env_ids stack_id + (mkCorePairExpr core_arrow core_arg) + return (do_premap ids - (envStackType env_ids stack) + (envStackType env_ids stack_ty) (mkCorePairTy arrow_ty arg_ty) res_ty core_make_pair @@ -343,90 +373,94 @@ dsCmd ids local_vars stack res_ty (exprFreeIds core_arrow `unionVarSet` exprFreeIds core_arg) `intersectVarSet` local_vars) --- A | ys |- c :: [t:ts] t' --- A, xs |- e :: t --- ------------------------ --- A | xs |- c e :: [ts] t' +-- D; ys |-a cmd : (t,stk) --> t' +-- D, xs |- exp :: t +-- ------------------------ +-- D; xs |-a cmd exp : stk --> t' -- --- ---> premap (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) c +-- ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd -dsCmd ids local_vars stack res_ty (HsCmdApp cmd arg) env_ids = do +dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do core_arg <- dsLExpr arg let arg_ty = exprType core_arg - stack' = arg_ty:stack + stack_ty' = mkCorePairTy arg_ty stack_ty (core_cmd, free_vars, env_ids') - <- dsfixCmd ids local_vars stack' res_ty cmd - stack_ids <- mapM newSysLocalDs stack + <- dsfixCmd ids local_vars stack_ty' res_ty cmd + stack_id <- newSysLocalDs stack_ty arg_id <- newSysLocalDs arg_ty -- push the argument expression onto the stack let + stack' = mkCorePairExpr (Var arg_id) (Var stack_id) core_body = bindNonRec arg_id core_arg - (buildEnvStack env_ids' (arg_id:stack_ids)) + (mkCorePairExpr (mkBigCoreVarTup env_ids') stack') + -- match the environment and stack against the input - core_map <- matchEnvStack env_ids stack_ids core_body + core_map <- matchEnvStack env_ids stack_id core_body return (do_premap ids - (envStackType env_ids stack) - (envStackType env_ids' stack') + (envStackType env_ids stack_ty) + (envStackType env_ids' stack_ty') res_ty core_map core_cmd, free_vars `unionVarSet` (exprFreeIds core_arg `intersectVarSet` local_vars)) --- A | ys |- c :: [ts] t' --- ----------------------------------------------- --- A | xs |- \ p1 ... pk -> c :: [t1:...:tk:ts] t' +-- D; ys |-a cmd : stk t' +-- ----------------------------------------------- +-- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t' -- --- ---> premap (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) c +-- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd -dsCmd ids local_vars stack res_ty +dsCmd ids local_vars stack_ty res_ty (HsCmdLam (MG { mg_alts = [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] })) env_ids = do let pat_vars = mkVarSet (collectPatsBinders pats) local_vars' = pat_vars `unionVarSet` local_vars - stack' = drop (length pats) stack - (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack' res_ty body - stack_ids <- mapM newSysLocalDs stack + (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty + (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty' res_ty body + param_ids <- mapM newSysLocalDs pat_tys + stack_id' <- newSysLocalDs stack_ty' -- the expression is built from the inside out, so the actions -- are presented in reverse order let - (actual_ids, stack_ids') = splitAt (length pats) stack_ids -- build a new environment, plus what's left of the stack - core_expr = buildEnvStack env_ids' stack_ids' - in_ty = envStackType env_ids stack - in_ty' = envStackType env_ids' stack' + core_expr = buildEnvStack env_ids' stack_id' + in_ty = envStackType env_ids stack_ty + in_ty' = envStackType env_ids' stack_ty' fail_expr <- mkFailExpr LambdaExpr in_ty' - -- match the patterns against the top of the old stack - match_code <- matchSimplys (map Var actual_ids) LambdaExpr pats core_expr fail_expr + -- match the patterns against the parameters + match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr fail_expr + -- match the parameters against the top of the old stack + (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code -- match the old environment and stack against the input - select_code <- matchEnvStack env_ids stack_ids match_code + select_code <- matchEnvStack env_ids stack_id param_code return (do_premap ids in_ty in_ty' res_ty select_code core_body, free_vars `minusVarSet` pat_vars) -dsCmd ids local_vars stack res_ty (HsCmdPar cmd) env_ids - = dsLCmd ids local_vars stack res_ty cmd env_ids +dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids + = dsLCmd ids local_vars stack_ty res_ty cmd env_ids --- A, xs |- e :: Bool --- A | xs1 |- c1 :: [ts] t --- A | xs2 |- c2 :: [ts] t --- ---------------------------------------- --- A | xs |- if e then c1 else c2 :: [ts] t +-- D, xs |- e :: Bool +-- D; xs1 |-a c1 : stk --> t +-- D; xs2 |-a c2 : stk --> t +-- ---------------------------------------- +-- D; xs |-a if e then c1 else c2 : stk --> t -- --- ---> premap (\ ((xs)*ts) -> --- if e then Left ((xs1)*ts) else Right ((xs2)*ts)) +-- ---> premap (\ ((xs),stk) -> +-- if e then Left ((xs1),stk) else Right ((xs2),stk)) -- (c1 ||| c2) -dsCmd ids local_vars stack res_ty (HsCmdIf mb_fun cond then_cmd else_cmd) +dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd) env_ids = do core_cond <- dsLExpr cond - (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack res_ty then_cmd - (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack res_ty else_cmd - stack_ids <- mapM newSysLocalDs stack + (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack_ty res_ty then_cmd + (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack_ty res_ty else_cmd + stack_id <- newSysLocalDs stack_ty either_con <- dsLookupTyCon eitherTyConName left_con <- dsLookupDataCon leftDataConName right_con <- dsLookupDataCon rightDataConName @@ -434,20 +468,20 @@ dsCmd ids local_vars stack res_ty (HsCmdIf mb_fun cond then_cmd else_cmd) let mk_left_expr ty1 ty2 e = mkConApp left_con [Type ty1, Type ty2, e] mk_right_expr ty1 ty2 e = mkConApp right_con [Type ty1, Type ty2, e] - in_ty = envStackType env_ids stack - then_ty = envStackType then_ids stack - else_ty = envStackType else_ids stack + in_ty = envStackType env_ids stack_ty + then_ty = envStackType then_ids stack_ty + else_ty = envStackType else_ids stack_ty sum_ty = mkTyConApp either_con [then_ty, else_ty] fvs_cond = exprFreeIds core_cond `intersectVarSet` local_vars - core_left = mk_left_expr then_ty else_ty (buildEnvStack then_ids stack_ids) - core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_ids) + core_left = mk_left_expr then_ty else_ty (buildEnvStack then_ids stack_id) + core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_id) core_if <- case mb_fun of Just fun -> do { core_fun <- dsExpr fun - ; matchEnvStack env_ids stack_ids $ + ; matchEnvStack env_ids stack_id $ mkCoreApps core_fun [core_cond, core_left, core_right] } - Nothing -> matchEnvStack env_ids stack_ids $ + Nothing -> matchEnvStack env_ids stack_id $ mkIfThenElse core_cond core_left core_right return (do_premap ids in_ty sum_ty res_ty @@ -482,10 +516,10 @@ case bodies, containing the following fields: bodies with |||. \begin{code} -dsCmd ids local_vars stack res_ty +dsCmd ids local_vars stack_ty res_ty (HsCmdCase exp (MG { mg_alts = matches, mg_arg_tys = arg_tys })) env_ids = do - stack_ids <- mapM newSysLocalDs stack + stack_id <- newSysLocalDs stack_ty -- Extract and desugar the leaf commands in the case, building tuple -- expressions that will (after tagging) replace these leaves @@ -494,9 +528,9 @@ dsCmd ids local_vars stack res_ty leaves = concatMap leavesMatch matches make_branch (leaf, bound_vars) = do (core_leaf, _fvs, leaf_ids) <- - dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack res_ty leaf - return ([mkHsEnvStackExpr leaf_ids stack_ids], - envStackType leaf_ids stack, + dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty res_ty leaf + return ([mkHsEnvStackExpr leaf_ids stack_id], + envStackType leaf_ids stack_ty, core_leaf) branches <- mapM make_branch leaves @@ -524,66 +558,82 @@ dsCmd ids local_vars stack res_ty -- yielding a HsExpr Id we can feed to dsExpr. (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches - in_ty = envStackType env_ids stack + in_ty = envStackType env_ids stack_ty core_body <- dsExpr (HsCase exp (MG { mg_alts = matches', mg_arg_tys = arg_tys , mg_res_ty = sum_ty })) -- Note that we replace the HsCase result type by sum_ty, -- which is the type of matches' - core_matches <- matchEnvStack env_ids stack_ids core_body + core_matches <- matchEnvStack env_ids stack_id core_body return (do_premap ids in_ty sum_ty res_ty core_matches core_choices, exprFreeIds core_body `intersectVarSet` local_vars) --- A | ys |- c :: [ts] t --- ---------------------------------- --- A | xs |- let binds in c :: [ts] t +-- D; ys |-a cmd : stk --> t +-- ---------------------------------- +-- D; xs |-a let binds in cmd : stk --> t -- --- ---> premap (\ ((xs)*ts) -> let binds in ((ys)*ts)) c +-- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c -dsCmd ids local_vars stack res_ty (HsCmdLet binds body) env_ids = do +dsCmd ids local_vars stack_ty res_ty (HsCmdLet binds body) env_ids = do let defined_vars = mkVarSet (collectLocalBinders binds) local_vars' = defined_vars `unionVarSet` local_vars - (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack res_ty body - stack_ids <- mapM newSysLocalDs stack + (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty res_ty body + stack_id <- newSysLocalDs stack_ty -- build a new environment, plus the stack, using the let bindings - core_binds <- dsLocalBinds binds (buildEnvStack env_ids' stack_ids) + core_binds <- dsLocalBinds binds (buildEnvStack env_ids' stack_id) -- match the old environment and stack against the input - core_map <- matchEnvStack env_ids stack_ids core_binds + core_map <- matchEnvStack env_ids stack_id core_binds return (do_premap ids - (envStackType env_ids stack) - (envStackType env_ids' stack) + (envStackType env_ids stack_ty) + (envStackType env_ids' stack_ty) res_ty core_map core_body, exprFreeIds core_binds `intersectVarSet` local_vars) -dsCmd ids local_vars [] res_ty (HsCmdDo stmts _) env_ids - = dsCmdDo ids local_vars res_ty stmts env_ids - --- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t --- A | xs |- ci :: [tsi] ti --- ----------------------------------- --- A | xs |- (|e c1 ... cn|) :: [ts] t ---> e [t_xs] c1 ... cn +-- D; xs |-a ss : t +-- ---------------------------------- +-- D; xs |-a do { ss } : () --> t +-- +-- ---> premap (\ (env,stk) -> env) c -dsCmd _ids local_vars _stack _res_ty (HsCmdArrForm op _ args) env_ids = do +dsCmd ids local_vars stack_ty res_ty (HsCmdDo stmts _) env_ids = do + (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids + let env_ty = mkBigCoreVarTupTy env_ids + core_fst <- mkFstExpr env_ty stack_ty + return (do_premap ids + (mkCorePairTy env_ty stack_ty) + env_ty + res_ty + core_fst + core_stmts, + env_ids') + +-- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t +-- D; xs |-a ci :: stki --> ti +-- ----------------------------------- +-- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn + +dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ args) env_ids = do let env_ty = mkBigCoreVarTupTy env_ids core_op <- dsLExpr op (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args return (mkApps (App core_op (Type env_ty)) core_args, unionVarSets fv_sets) ---dsCmd ids local_vars stack res_ty (HsTick tickish expr) env_ids = do --- (expr1,id_set) <- dsLCmd ids local_vars stack res_ty expr env_ids --- return (Tick tickish expr1, id_set) +dsCmd ids local_vars stack_ty res_ty (HsCmdCast coercion cmd) env_ids = do + (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids + wrapped_cmd <- dsHsWrapper (WpCast coercion) core_cmd + return (wrapped_cmd, env_ids') dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) --- A | ys |- c :: [ts] t (ys <= xs) --- --------------------- --- A | xs |- c :: [ts] t ---> premap_ts (\ (xs) -> (ys)) c +-- D; ys |-a c : stk --> t (ys <= xs) +-- --------------------- +-- D; xs |-a c : stk --> t ---> premap (\ ((xs),stk) -> ((ys),stk)) c dsTrimCmdArg :: IdSet -- set of local vars available to this command @@ -591,32 +641,32 @@ dsTrimCmdArg -> LHsCmdTop Id -- command argument to desugar -> DsM (CoreExpr, -- desugared expression IdSet) -- subset of local vars that occur free -dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack cmd_ty ids)) = do +dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do (meth_binds, meth_ids) <- mkCmdEnv ids - (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack cmd_ty cmd - stack_ids <- mapM newSysLocalDs stack - trim_code <- matchEnvStack env_ids stack_ids (buildEnvStack env_ids' stack_ids) + (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd + stack_id <- newSysLocalDs stack_ty + trim_code <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id) let - in_ty = envStackType env_ids stack - in_ty' = envStackType env_ids' stack + in_ty = envStackType env_ids stack_ty + in_ty' = envStackType env_ids' stack_ty arg_code = if env_ids' == env_ids then core_cmd else do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd return (mkLets meth_binds arg_code, free_vars) --- Given A | xs |- c :: [ts] t, builds c with xs fed back. --- Typically needs to be prefixed with arr (\p -> ((xs)*ts)) +-- Given D; xs |-a c : stk --> t, builds c with xs fed back. +-- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk)) dsfixCmd :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this command - -> [Type] -- type of the stack + -> Type -- type of the stack (right-nested tuple) -> Type -- return type of the command -> LHsCmd Id -- command to desugar -> DsM (CoreExpr, -- desugared expression IdSet, -- subset of local vars that occur free [Id]) -- the same local vars as a list, fed back -dsfixCmd ids local_vars stack cmd_ty cmd - = trimInput (dsLCmd ids local_vars stack cmd_ty cmd) +dsfixCmd ids local_vars stk_ty cmd_ty cmd + = trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) -- Feed back the list of local variables actually used a command, -- for use as the input tuple of the generated arrow. @@ -637,7 +687,7 @@ trimInput build_arrow Translation of command judgements of the form - A | xs |- do { ss } :: [] t + D |-a do { ss } : t \begin{code} @@ -651,14 +701,26 @@ dsCmdDo :: DsCmdEnv -- arrow combinators -> DsM (CoreExpr, -- desugared expression IdSet) -- subset of local vars that occur free --- A | xs |- c :: [] t --- -------------------------- --- A | xs |- do { c } :: [] t - dsCmdDo _ _ _ [] _ = panic "dsCmdDo" -dsCmdDo ids local_vars res_ty [L _ (LastStmt body _)] env_ids - = dsLCmd ids local_vars [] res_ty body env_ids +-- D; xs |-a c : () --> t +-- -------------------------- +-- D; xs |-a do { c } : t +-- +-- ---> premap (\ (xs) -> ((xs), ())) c + +dsCmdDo ids local_vars res_ty [L _ (LastStmt body _)] env_ids = do + (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids + let env_ty = mkBigCoreVarTupTy env_ids + env_var <- newSysLocalDs env_ty + let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr) + return (do_premap ids + env_ty + (mkCorePairTy env_ty unitTy) + res_ty + core_map + core_body, + env_ids') dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do let @@ -695,21 +757,23 @@ dsCmdStmt -> DsM (CoreExpr, -- desugared expression IdSet) -- subset of local vars that occur free --- A | xs1 |- c :: [] t --- A | xs' |- do { ss } :: [] t' --- ------------------------------ --- A | xs |- do { c; ss } :: [] t' +-- D; xs1 |-a c : () --> t +-- D; xs' |-a do { ss } : t' +-- ------------------------------ +-- D; xs |-a do { c; ss } : t' -- --- ---> premap (\ (xs) -> ((xs1),(xs'))) +-- ---> premap (\ ((xs)) -> (((xs1),()),(xs'))) -- (first c >>> arr snd) >>> ss dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do - (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] c_ty cmd - core_mux <- matchEnvStack env_ids [] - (mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup out_ids)) + (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd + core_mux <- matchEnv env_ids + (mkCorePairExpr + (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr) + (mkBigCoreVarTup out_ids)) let in_ty = mkBigCoreVarTupTy env_ids - in_ty1 = mkBigCoreVarTupTy env_ids1 + in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy out_ty = mkBigCoreVarTupTy out_ids before_c_ty = mkCorePairTy in_ty1 out_ty after_c_ty = mkCorePairTy c_ty out_ty @@ -719,21 +783,20 @@ dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do (do_first ids in_ty1 c_ty out_ty core_cmd) $ do_arr ids after_c_ty out_ty snd_fn, extendVarSetList fv_cmd out_ids) - where --- A | xs1 |- c :: [] t --- A | xs' |- do { ss } :: [] t' xs2 = xs' - defs(p) --- ----------------------------------- --- A | xs |- do { p <- c; ss } :: [] t' +-- D; xs1 |-a c : () --> t +-- D; xs' |-a do { ss } : t' xs2 = xs' - defs(p) +-- ----------------------------------- +-- D; xs |-a do { p <- c; ss } : t' -- --- ---> premap (\ (xs) -> ((xs1),(xs2))) +-- ---> premap (\ (xs) -> (((xs1),()),(xs2))) -- (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss -- -- It would be simpler and more consistent to do this using second, -- but that's likely to be defined in terms of first. dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do - (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] (hsLPatType pat) cmd + (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy (hsLPatType pat) cmd let pat_ty = hsLPatType pat pat_vars = mkVarSet (collectPatBinders pat) @@ -741,10 +804,12 @@ dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do env_ty2 = mkBigCoreVarTupTy env_ids2 -- multiplexing function - -- \ (xs) -> ((xs1),(xs2)) + -- \ (xs) -> (((xs1),()),(xs2)) - core_mux <- matchEnvStack env_ids [] - (mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup env_ids2)) + core_mux <- matchEnv env_ids + (mkCorePairExpr + (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr) + (mkBigCoreVarTup env_ids2)) -- projection function -- \ (p, (xs2)) -> (zs) @@ -766,7 +831,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do -- put it all together let in_ty = mkBigCoreVarTupTy env_ids - in_ty1 = mkBigCoreVarTupTy env_ids1 + in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy in_ty2 = mkBigCoreVarTupTy env_ids2 before_c_ty = mkCorePairTy in_ty1 in_ty2 return (do_premap ids in_ty before_c_ty out_ty core_mux $ @@ -775,9 +840,9 @@ dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do do_arr ids after_c_ty out_ty proj_expr, fv_cmd `unionVarSet` (mkVarSet out_ids `minusVarSet` pat_vars)) --- A | xs' |- do { ss } :: [] t --- -------------------------------------- --- A | xs |- do { let binds; ss } :: [] t +-- D; xs' |-a do { ss } : t +-- -------------------------------------- +-- D; xs |-a do { let binds; ss } : t -- -- ---> arr (\ (xs) -> let binds in (xs')) >>> ss @@ -785,17 +850,17 @@ dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do -- build a new environment using the let bindings core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids) -- match the old environment against the input - core_map <- matchEnvStack env_ids [] core_binds + core_map <- matchEnv env_ids core_binds return (do_arr ids (mkBigCoreVarTupTy env_ids) (mkBigCoreVarTupTy out_ids) core_map, exprFreeIds core_binds `intersectVarSet` local_vars) --- A | ys |- do { ss; returnA -< ((xs1), (ys2)) } :: [] ... --- A | xs' |- do { ss' } :: [] t --- ------------------------------------ --- A | xs |- do { rec ss; ss' } :: [] t +-- D; ys |-a do { ss; returnA -< ((xs1), (ys2)) } : ... +-- D; xs' |-a do { ss' } : t +-- ------------------------------------ +-- D; xs |-a do { rec ss; ss' } : t -- -- xs1 = xs' /\ defs(ss) -- xs2 = xs' - defs(ss) @@ -825,7 +890,7 @@ dsCmdStmt ids local_vars out_ids post_pair_ty = mkCorePairTy later_ty env2_ty post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids) - post_loop_fn <- matchEnvStack later_ids [env2_id] post_loop_body + post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body --- loop (...) @@ -840,7 +905,7 @@ dsCmdStmt ids local_vars out_ids pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids) (mkBigCoreVarTup env2_ids) - pre_loop_fn <- matchEnvStack env_ids [] pre_loop_body + pre_loop_fn <- matchEnv env_ids pre_loop_body -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn @@ -898,7 +963,7 @@ dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do out_pair = mkCorePairExpr later_tuple rec_tuple out_pair_ty = mkCorePairTy later_ty rec_ty - mk_pair_fn <- matchEnvStack out_ids [] out_pair + mk_pair_fn <- matchEnv out_ids out_pair -- ss @@ -919,7 +984,7 @@ dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do = mkTupleSelector rec_ids v rec_id (Var rec_id) | otherwise = Var v - squash_pair_fn <- matchEnvStack env1_ids [rec_id] core_body + squash_pair_fn <- matchEnvStack env1_ids rec_id core_body -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn)) @@ -936,7 +1001,7 @@ dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do \end{code} A sequence of statements (as in a rec) is desugared to an arrow between -two environments +two environments (no stack) \begin{code} dsfixCmdStmts @@ -978,7 +1043,6 @@ dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do fv_stmt) dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []" - \end{code} Match a list of expressions against a list of patterns, left-to-right. diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index b4de840e47..d59c193ae8 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -689,6 +689,12 @@ data HsCmd id | HsCmdDo [CmdLStmt id] PostTcType -- Type of the whole expression + + | HsCmdCast TcCoercion -- A simpler version of HsWrap in HsExpr + (HsCmd id) -- If cmd :: arg1 --> res + -- co :: arg1 ~ arg2 + -- Then (HsCmdCast co cmd) :: arg2 --> res + deriving (Data, Typeable) data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp @@ -705,7 +711,7 @@ type LHsCmdTop id = Located (HsCmdTop id) data HsCmdTop id = HsCmdTop (LHsCmd id) - [PostTcType] -- types of inputs on the command's stack + PostTcType -- Nested tuple of inputs on the command's stack PostTcType -- return type of the command (CmdSyntaxTable id) -- See Note [CmdSyntaxTable] deriving (Data, Typeable) @@ -772,8 +778,9 @@ ppr_cmd (HsCmdLet binds cmd) = sep [hang (ptext (sLit "let")) 2 (pprBinds binds), hang (ptext (sLit "in")) 2 (ppr cmd)] -ppr_cmd (HsCmdDo stmts _) = pprDo ArrowExpr stmts - +ppr_cmd (HsCmdDo stmts _) = pprDo ArrowExpr stmts +ppr_cmd (HsCmdCast co cmd) = sep [ ppr_cmd cmd + , ptext (sLit "|>") <+> ppr co ] ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp True) = hsep [ppr_lexpr arrow, ptext (sLit "-<"), ppr_lexpr arg] diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 325bd2e37c..1fa949653e 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -1,4 +1,3 @@ - % % (c) The University of Glasgow, 1992-2006 % @@ -29,7 +28,7 @@ module HsUtils( mkHsWrap, mkLHsWrap, mkHsWrapCo, mkLHsWrapCo, coToHsWrapper, mkHsDictLet, mkHsLams, mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo, - mkLHsPar, + mkLHsPar, mkHsCmdCast, nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, @@ -394,6 +393,10 @@ mkLHsWrapCo :: TcCoercion -> LHsExpr id -> LHsExpr id mkLHsWrapCo co (L loc e) | isTcReflCo co = L loc e | otherwise = L loc (mkHsWrap (WpCast co) e) +mkHsCmdCast :: TcCoercion -> HsCmd id -> HsCmd id +mkHsCmdCast co cmd | isTcReflCo co = cmd + | otherwise = HsCmdCast co cmd + coToHsWrapper :: TcCoercion -> HsWrapper coToHsWrapper co | isTcReflCo co = idHsWrapper | otherwise = WpCast co diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 6d60f38dea..18651b97c2 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -1464,7 +1464,7 @@ exp10 :: { LHsExpr RdrName } | 'proc' aexp '->' exp {% checkPattern empty $2 >>= \ p -> checkCommand $4 >>= \ cmd -> - return (LL $ HsProc p (LL $ HsCmdTop cmd [] + return (LL $ HsProc p (LL $ HsCmdTop cmd placeHolderType placeHolderType undefined)) } -- TODO: is LL right here? @@ -1559,7 +1559,7 @@ cmdargs :: { [LHsCmdTop RdrName] } acmd :: { LHsCmdTop RdrName } : aexp2 {% checkCommand $1 >>= \ cmd -> - return (L1 $ HsCmdTop cmd [] placeHolderType undefined) } + return (L1 $ HsCmdTop cmd placeHolderType placeHolderType undefined) } cvtopbody :: { [LHsDecl RdrName] } : '{' cvtopdecls0 '}' { $2 } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index b077032809..3695daef58 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -872,8 +872,8 @@ checkCmd _ (OpApp eLeft op fixity eRight) = do -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it c1 <- checkCommand eLeft c2 <- checkCommand eRight - let arg1 = L (getLoc c1) $ HsCmdTop c1 [] placeHolderType [] - arg2 = L (getLoc c2) $ HsCmdTop c2 [] placeHolderType [] + let arg1 = L (getLoc c1) $ HsCmdTop c1 placeHolderType placeHolderType [] + arg2 = L (getLoc c2) $ HsCmdTop c2 placeHolderType placeHolderType [] return $ HsCmdArrForm op (Just fixity) [arg1, arg2] checkCmd l e = cmdFail l e diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 7e1df1c840..29674ca34c 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -433,7 +433,7 @@ rnCmdTop = wrapLocFstM rnCmdTop' -- Generate the rebindable syntax for the monad ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names - ; return (HsCmdTop cmd' [] placeHolderType (cmd_names `zip` cmd_names'), + ; return (HsCmdTop cmd' placeHolderType placeHolderType (cmd_names `zip` cmd_names'), fvCmd `plusFV` cmd_fvs) } rnLCmd :: LHsCmd RdrName -> RnM (LHsCmd Name, FreeVars) @@ -511,6 +511,7 @@ rnCmd (HsCmdDo stmts _) = do { ((stmts', _), fvs) <- rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs)) ; return ( HsCmdDo stmts' placeHolderType, fvs ) } +rnCmd cmd@(HsCmdCast {}) = pprPanic "rnCmd" (ppr cmd) --------------------------------------------------- type CmdNeeds = FreeVars -- Only inhabitants are @@ -527,6 +528,7 @@ methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl) methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl) = unitFV appAName methodNamesCmd (HsCmdArrForm {}) = emptyFVs +methodNamesCmd (HsCmdCast _ cmd) = methodNamesCmd cmd methodNamesCmd (HsCmdPar c) = methodNamesLCmd c diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index bc66eea923..95bdcb413f 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -679,7 +679,7 @@ mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ | associate_right = do new_c <- mkOpFormRn a12 op2 fix2 a2 return (HsCmdArrForm op1 (Just fix1) - [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])]) + [a11, L loc (HsCmdTop (L loc new_c) placeHolderType placeHolderType [])]) -- TODO: locs are wrong where (nofix_error, associate_right) = compareFixity fix1 fix2 diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index 9248fd6af6..6dca32abcc 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -14,7 +14,7 @@ Typecheck arrow notation module TcArrows ( tcProc ) where -import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId ) +import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr ) import HsSyn import TcMatches @@ -33,7 +33,7 @@ import Name import TysWiredIn import VarSet import TysPrim - +import BasicTypes( Arity ) import SrcLoc import Outputable import FastString @@ -42,6 +42,39 @@ import Util import Control.Monad \end{code} +Note [Arrow overivew] +~~~~~~~~~~~~~~~~~~~~~ +Here's a summary of arrows and how they typecheck. First, here's +a cut-down syntax: + + expr ::= .... + | proc pat cmd + + cmd ::= cmd exp -- Arrow application + | \pat -> cmd -- Arrow abstraction + | (| exp cmd1 ... cmdn |) -- Arrow form, n>=0 + | ... -- If, case in the usual way + + cmd_type ::= carg_type --> type + + carg_type ::= () + | (type, carg_type) + +Note that + * The 'exp' in an arrow form can mention only + "arrow-local" variables + + * An "arrow-local" variable is bound by an enclosing + cmd binding form (eg arrow abstraction) + + * A cmd_type is here written with a funny arrow "-->", + The bit on the left is a carg_type (command argument type) + which itself is a nested tuple, finishing with () + + * The arrow-tail operator (e1 -< e2) means + (| e1 <<< arr snd |) e2 + + %************************************************************************ %* * Proc @@ -59,7 +92,7 @@ tcProc pat cmd exp_ty ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 ; let cmd_env = CmdEnv { cmd_arr = arr_ty } ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $ - tcCmdTop cmd_env cmd [] res_ty + tcCmdTop cmd_env cmd (unitTy, res_ty) ; let res_co = mkTcTransCo co (mkTcAppCo co1 (mkTcReflCo res_ty)) ; return (pat', cmd', res_co) } \end{code} @@ -72,10 +105,13 @@ tcProc pat cmd exp_ty %************************************************************************ \begin{code} -type CmdStack = [TcTauType] +-- See Note [Arrow overview] +type CmdType = (CmdArgType, TcTauType) -- cmd_type +type CmdArgType = TcTauType -- carg_type, a nested tuple + data CmdEnv = CmdEnv { - cmd_arr :: TcType -- arrow type constructor, of kind *->*->* + cmd_arr :: TcType -- arrow type constructor, of kind *->*->* } mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType @@ -84,29 +120,23 @@ mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2] --------------------------------------- tcCmdTop :: CmdEnv -> LHsCmdTop Name - -> CmdStack - -> TcTauType -- Expected result type; always a monotype - -- We know exactly how many cmd args are expected, - -- albeit perhaps not their types; so we can pass - -- in a CmdStack - -> TcM (LHsCmdTop TcId) - -tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_stk res_ty + -> CmdType + -> TcM (LHsCmdTop TcId) + +tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_ty@(cmd_stk, res_ty) = setSrcSpan loc $ - do { cmd' <- tcCmd env cmd (cmd_stk, res_ty) + do { cmd' <- tcCmd env cmd cmd_ty ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') } - - ---------------------------------------- -tcCmd :: CmdEnv -> LHsCmd Name -> (CmdStack, TcTauType) -> TcM (LHsCmd TcId) +tcCmd :: CmdEnv -> LHsCmd Name -> CmdType -> TcM (LHsCmd TcId) -- The main recursive function tcCmd env (L loc cmd) res_ty = setSrcSpan loc $ do { cmd' <- tc_cmd env cmd res_ty ; return (L loc cmd') } -tc_cmd :: CmdEnv -> HsCmd Name -> (CmdStack, TcTauType) -> TcM (HsCmd TcId) +tc_cmd :: CmdEnv -> HsCmd Name -> CmdType -> TcM (HsCmd TcId) tc_cmd env (HsCmdPar cmd) res_ty = do { cmd' <- tcCmd env cmd res_ty ; return (HsCmdPar cmd') } @@ -154,12 +184,23 @@ tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if ------------------------------------------- -- Arrow application -- (f -< a) or (f -<< a) +-- +-- D |- fun :: a t1 t2 +-- D,G |- arg :: t1 +-- ------------------------ +-- D;G |-a fun -< arg :: stk --> t2 +-- +-- D,G |- fun :: a t1 t2 +-- D,G |- arg :: t1 +-- ------------------------ +-- D;G |-a fun -<< arg :: stk --> t2 +-- +-- (plus -<< requires ArrowApply) -tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (cmd_stk, res_ty) +tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { arg_ty <- newFlexiTyVarTy openTypeKind - ; let fun_ty = mkCmdArrTy env (foldl mkPairTy arg_ty cmd_stk) res_ty - + ; let fun_ty = mkCmdArrTy env arg_ty res_ty ; fun' <- select_arrow_scope (tcMonoExpr fun fun_ty) -- ToDo: There should be no need for the escapeArrowScope stuff -- See Note [Escaping the arrow scope] in TcRnTypes @@ -178,159 +219,98 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (cmd_stk, res_ty) ------------------------------------------- -- Command application +-- +-- D,G |- exp : t +-- D;G |-a cmd : (t,stk) --> res +-- ----------------------------- +-- D;G |-a cmd exp : stk --> res tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { arg_ty <- newFlexiTyVarTy openTypeKind - - ; fun' <- tcCmd env fun (arg_ty:cmd_stk, res_ty) - - ; arg' <- tcMonoExpr arg arg_ty - + ; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty) + ; arg' <- tcMonoExpr arg arg_ty ; return (HsCmdApp fun' arg') } ------------------------------------------- -- Lambda +-- +-- D;G,x:t |-a cmd : stk --> res +-- ------------------------------ +-- D;G |-a (\x.cmd) : (t,stk) --> res -tc_cmd env cmd@(HsCmdLam (MG { mg_alts = [L mtch_loc (match@(Match pats _maybe_rhs_sig grhss))] })) +tc_cmd env + (HsCmdLam (MG { mg_alts = [L mtch_loc (match@(Match pats _maybe_rhs_sig grhss))] })) (cmd_stk, res_ty) = addErrCtxt (pprMatchInCtxt match_ctxt match) $ - - do { -- Check the cmd stack is big enough - ; checkTc (lengthAtLeast cmd_stk n_pats) - (kappaUnderflow cmd) + do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk -- Check the patterns, and the GRHSs inside ; (pats', grhss') <- setSrcSpan mtch_loc $ - tcPats LambdaExpr pats cmd_stk $ - tc_grhss grhss res_ty + tcPats LambdaExpr pats arg_tys $ + tc_grhss grhss cmd_stk' res_ty ; let match' = L mtch_loc (Match pats' Nothing grhss') arg_tys = map hsLPatType pats' - ; return (HsCmdLam (MG { mg_alts = [match'], mg_arg_tys = arg_tys - , mg_res_ty = res_ty })) - -- Or should we decompose res_ty? - } - + cmd' = HsCmdLam (MG { mg_alts = [match'], mg_arg_tys = arg_tys + , mg_res_ty = res_ty }) + ; return (mkHsCmdCast co cmd') } where n_pats = length pats - stk' = drop n_pats cmd_stk match_ctxt = (LambdaExpr :: HsMatchContext Name) -- Maybe KappaExpr? pg_ctxt = PatGuard match_ctxt - tc_grhss (GRHSs grhss binds) res_ty + tc_grhss (GRHSs grhss binds) stk_ty res_ty = do { (binds', grhss') <- tcLocalBinds binds $ - mapM (wrapLocM (tc_grhs res_ty)) grhss + mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss ; return (GRHSs grhss' binds') } - tc_grhs res_ty (GRHS guards body) + tc_grhs stk_ty res_ty (GRHS guards body) = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ - \ res_ty -> tcCmd env body (stk', res_ty) + \ res_ty -> tcCmd env body (stk_ty, res_ty) ; return (GRHS guards' rhs') } ------------------------------------------- -- Do notation -tc_cmd env cmd@(HsCmdDo stmts _) (cmd_stk, res_ty) - = do { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd) +tc_cmd env (HsCmdDo stmts _) (cmd_stk, res_ty) + = do { co <- unifyType unitTy cmd_stk -- Expecting empty argument stack ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty - ; return (HsCmdDo stmts' res_ty) } - where + ; return (mkHsCmdCast co (HsCmdDo stmts' res_ty)) } ----------------------------------------------------------------- -- Arrow ``forms'' (| e c1 .. cn |) -- --- G |-b c : [s1 .. sm] s --- pop(G) |- e : forall w. b ((w,s1) .. sm) s --- -> a ((w,t1) .. tn) t --- e \not\in (s, s1..sm, t, t1..tn) +-- D; G |-a1 c1 : stk1 --> r1 +-- ... +-- D; G |-an cn : stkn --> rn +-- D |- e :: forall e. a1 (e, stk1) t1 +-- ... +-- -> an (e, stkn) tn +-- -> a (e, stk) t +-- e \not\in (stk, stk1, ..., stkm, t, t1, ..., tn) -- ---------------------------------------------- --- G |-a (| e c |) : [t1 .. tn] t +-- D; G |-a (| e c1 ... cn |) : stk --> t tc_cmd env cmd@(HsCmdArrForm 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 [alphaTyVar] - ; let w_ty = mkTyVarTy w_tv -- Just a convenient starting point - - -- a ((w,t1) .. tn) t - ; let e_res_ty = mkCmdArrTy env (foldl mkPairTy w_ty cmd_stk) res_ty - - -- b ((w,s1) .. sm) s - -- -> a ((w,t1) .. tn) t - ; let e_ty = mkFunTys [mkAppTys b [tup,s] | (_,_,b,tup,s) <- cmds_w_tys] - e_res_ty - - -- ToDo: SLPJ: something is badly wrong here. - -- The escapeArrowScope pops the Untouchables.. but that - -- risks screwing up the skolem-escape check - -- Moreover, arrowfail001 fails with an ASSERT failure - -- because a variable gets the wrong level - -- Check expr - ; (inner_binds, expr') - <- checkConstraints ArrowSkol [w_tv] [] $ - escapeArrowScope (tcMonoExpr expr e_ty) - -{- - ; ((inner_binds, expr'), lie) - <- captureConstraints $ - checkConstraints ArrowSkol [w_tv] [] $ - tcMonoExpr expr e_ty - -- No need for escapeArrowScope in the - -- type checker. - -- Note [Escaping the arrow scope] in TcRnTypes - ; (lie, outer_binds) <- solveWantedsTcM lie - ; emitConstraints lie --} - - -- 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 - - ; let wrap = WpTyLam w_tv <.> mkWpLet inner_binds - ; return (HsCmdArrForm (mkLHsWrap wrap expr') fixity cmds') } + do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args + ; let e_ty = mkForAllTy alphaTyVar $ -- We use alphaTyVar for 'w' + mkFunTys cmd_tys $ + mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty + ; expr' <- tcPolyExpr expr e_ty + ; return (HsCmdArrForm expr' fixity cmd_args') } + where - -- Make the types - -- b, ((e,s1) .. sm), s - new_cmd_ty :: LHsCmdTop Name -> Int - -> TcM (LHsCmdTop Name, Int, TcType, TcType, TcType) - new_cmd_ty cmd i - = do { b_ty <- newFlexiTyVarTy arrowTyConKind - ; tup_ty <- newFlexiTyVarTy liftedTypeKind - -- We actually make a type variable for the tuple - -- because we don't know how deeply nested it is yet - ; s_ty <- newFlexiTyVarTy liftedTypeKind - ; return (cmd, i, b_ty, tup_ty, s_ty) - } - - tc_cmd w_tv (cmd, i, b, tup_ty, s) - = do { tup_ty' <- zonkTcType tup_ty - ; let (corner_ty, arg_tys) = unscramble tup_ty' - - -- Check that it has the right shape: - -- ((w,s1) .. sn) - -- where the si do not mention w - ; _bogus <- unifyType corner_ty (mkTyVarTy w_tv) - ; checkTc (not (w_tv `elemVarSet` tyVarsOfTypes arg_tys)) - (badFormFun i tup_ty') - -- JPM: WARNING: this test is utterly bogus; see #5609 - -- We are not using the coercion returned by the unify; - -- and (even more seriously) the w not in arg_tys test is totally - -- bogus if there are suspended equality constraints. This code - -- needs to be re-architected. - - ; tcCmdTop (env { cmd_arr = b }) cmd arg_tys s } - - unscramble :: TcType -> (TcType, [TcType]) - -- unscramble ((w,s1) .. sn) = (w, [s1..sn]) - unscramble ty = unscramble' ty [] - - unscramble' ty ss - = case tcSplitTyConApp_maybe ty of - Just (tc, [t,s]) | tc == pairTyCon - -> unscramble' t (s:ss) - _ -> (ty, ss) + tc_cmd_arg :: LHsCmdTop Name -> TcM (LHsCmdTop TcId, TcType) + tc_cmd_arg cmd + = do { arr_ty <- newFlexiTyVarTy arrowTyConKind + ; stk_ty <- newFlexiTyVarTy liftedTypeKind + ; res_ty <- newFlexiTyVarTy liftedTypeKind + ; let env' = env { cmd_arr = arr_ty } + ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty) + ; return (cmd', mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) } ----------------------------------------------------------------- -- Base case for illegal commands @@ -339,6 +319,15 @@ tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty) tc_cmd _ cmd _ = failWithTc (vcat [ptext (sLit "The expression"), nest 2 (ppr cmd), ptext (sLit "was found where an arrow command was expected")]) + + +matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercion, [TcType], TcType) +matchExpectedCmdArgs 0 ty + = return (mkTcReflCo ty, [], ty) +matchExpectedCmdArgs n ty + = do { (co1, [ty1, ty2]) <- matchExpectedTyConApp pairTyCon ty + ; (co2, tys, res_ty) <- matchExpectedCmdArgs (n-1) ty2 + ; return (mkTcTyConAppCo pairTyCon [co1, co2], ty1:tys, res_ty) } \end{code} @@ -357,7 +346,7 @@ tc_cmd _ cmd _ tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker tcArrDoStmt env _ (LastStmt rhs _) res_ty thing_inside - = do { rhs' <- tcCmd env rhs ([], res_ty) + = do { rhs' <- tcCmd env rhs (unitTy, res_ty) ; thing <- thing_inside (panic "tcArrDoStmt") ; return (LastStmt rhs' noSyntaxExpr, thing) } @@ -407,7 +396,7 @@ tcArrDoStmt _ _ stmt _ _ tc_arr_rhs :: CmdEnv -> LHsCmd Name -> TcM (LHsCmd TcId, TcType) tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind - ; rhs' <- tcCmd env rhs ([], ty) + ; rhs' <- tcCmd env rhs (unitTy, ty) ; return (rhs', ty) } \end{code} @@ -437,19 +426,4 @@ arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind \begin{code} cmdCtxt :: HsCmd Name -> SDoc cmdCtxt cmd = ptext (sLit "In the command:") <+> ppr cmd - -nonEmptyCmdStkErr :: HsCmd Name -> SDoc -nonEmptyCmdStkErr cmd - = hang (ptext (sLit "Non-empty command stack at command:")) - 2 (ppr cmd) - -kappaUnderflow :: HsCmd Name -> SDoc -kappaUnderflow 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")) - 2 (ptext (sLit "Argument type:") <+> ppr tup_ty') \end{code} diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 22ce21a184..1e2961258d 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -730,6 +730,10 @@ zonkCmd :: ZonkEnv -> HsCmd TcId -> TcM (HsCmd Id) zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd +zonkCmd env (HsCmdCast co cmd) + = do { co' <- zonkTcLCoToLCo env co + ; cmd' <- zonkCmd env cmd + ; return (HsCmdCast co' cmd') } zonkCmd env (HsCmdArrApp e1 e2 ty ho rl) = zonkLExpr env e1 `thenM` \ new_e1 -> zonkLExpr env e2 `thenM` \ new_e2 -> @@ -786,7 +790,7 @@ zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id) zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) = zonkLCmd env cmd `thenM` \ new_cmd -> - zonkTcTypeToTypes env stack_tys `thenM` \ new_stack_tys -> + zonkTcTypeToType 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) diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 1357395eff..03682bf848 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -8226,7 +8226,7 @@ Thus combinators that produce arrows from arrows may also be used to build commands from commands. For example, the <literal>ArrowPlus</literal> class includes a combinator <programlisting> -ArrowPlus a => (<+>) :: a e c -> a e c -> a e c +ArrowPlus a => (<+>) :: a b c -> a b c -> a b c </programlisting> so we can use it to build commands: <programlisting> @@ -8256,18 +8256,24 @@ expr' = (proc x -> returnA -< x) y <- term -< () expr' -< x - y) </programlisting> +We are actually using <literal><+></literal> here with the more specific type +<programlisting> +ArrowPlus a => (<+>) :: a (e,()) c -> a (e,()) c -> a (e,()) c +</programlisting> It is essential that this operator be polymorphic in <literal>e</literal> (representing the environment input to the command and thence to its subcommands) and satisfy the corresponding naturality property <screen> -arr k >>> (f <+> g) = (arr k >>> f) <+> (arr k >>> g) +arr (first k) >>> (f <+> g) = (arr (first k) >>> f) <+> (arr (first k) >>> g) </screen> at least for strict <literal>k</literal>. (This should be automatic if you're not using <function>seq</function>.) This ensures that environments seen by the subcommands are environments of the whole command, and also allows the translation to safely trim these environments. +(The second component of the input pairs can contain unnamed input values, +as described in the next section.) The operator must also not use any variable defined within the current arrow abstraction. </para> @@ -8275,7 +8281,7 @@ arrow abstraction. <para> We could define our own operator <programlisting> -untilA :: ArrowChoice a => a e () -> a e Bool -> a e () +untilA :: ArrowChoice a => a (e,s) () -> a (e,s) Bool -> a (e,s) () untilA body cond = proc x -> b <- cond -< x if b then returnA -< () @@ -8305,7 +8311,7 @@ the operator that attaches an exception handler will wish to pass the exception that occurred to the handler. Such an operator might have a type <screen> -handleA :: ... => a e c -> a (e,Ex) c -> a e c +handleA :: ... => a (e,s) c -> a (e,(Ex,s)) c -> a (e,s) c </screen> where <literal>Ex</literal> is the type of exceptions handled. You could then use this with arrow notation by writing a command @@ -8320,22 +8326,24 @@ Though the syntax here looks like a functional lambda, we are talking about commands, and something different is going on. The input to the arrow represented by a command consists of values for the free local variables in the command, plus a stack of anonymous values. -In all the prior examples, this stack was empty. +In all the prior examples, we made no assumptions about this stack. In the second argument to <function>handleA</function>, -this stack consists of one value, the value of the exception. +the value of the exception has been added to the stack input to the handler. The command form of lambda merely gives this value a name. </para> <para> More concretely, -the values on the stack are paired to the right of the environment. +the input to a command consists of a pair of an environment and a stack. +Each value on the stack is paired with the remainder of the stack, +with an empty stack being <literal>()</literal>. So operators like <function>handleA</function> that pass extra inputs to their subcommands can be designed for use with the notation -by pairing the values with the environment in this way. +by placing the values on the stack paired with the environment in this way. More precisely, the type of each argument of the operator (and its result) should have the form <screen> -a (...(e,t1), ... tn) t +a (e, (t1, ... (tn, ())...)) t </screen> where <replaceable>e</replaceable> is a polymorphic variable (representing the environment) @@ -8347,9 +8355,9 @@ The polymorphic variable <replaceable>e</replaceable> must not occur in However the arrows involved need not be the same. Here are some more examples of suitable operators: <screen> -bracketA :: ... => a e b -> a (e,b) c -> a (e,c) d -> a e d -runReader :: ... => a e c -> a' (e,State) c -runState :: ... => a e c -> a' (e,State) (c,State) +bracketA :: ... => a (e,s) b -> a (e,(b,s)) c -> a (e,(c,s)) d -> a (e,s) d +runReader :: ... => a (e,s) c -> a' (e,(State,s)) c +runState :: ... => a (e,s) c -> a' (e,(State,s)) (c,State) </screen> We can supply the extra input required by commands built with the last two by applying them to ordinary expressions, as in @@ -8371,16 +8379,16 @@ are the core of the notation; everything else can be built using them, though the results would be somewhat clumsy. For example, we could simulate <literal>do</literal>-notation by defining <programlisting> -bind :: Arrow a => a e b -> a (e,b) c -> a e c +bind :: Arrow a => a (e,s) b -> a (e,(b,s)) c -> a (e,s) c u `bind` f = returnA &&& u >>> f -bind_ :: Arrow a => a e b -> a e c -> a e c +bind_ :: Arrow a => a (e,s) b -> a (e,s) c -> a (e,s) c u `bind_` f = u `bind` (arr fst >>> f) </programlisting> We could simulate <literal>if</literal> by defining <programlisting> -cond :: ArrowChoice a => a e b -> a e b -> a (e,Bool) b -cond f g = arr (\ (e,b) -> if b then Left e else Right e) >>> f ||| g +cond :: ArrowChoice a => a (e,s) b -> a (e,s) b -> a (e,(Bool,s)) b +cond f g = arr (\ (e,(b,s)) -> if b then Left (e,s) else Right (e,s)) >>> f ||| g </programlisting> </para> @@ -8405,6 +8413,14 @@ a new <literal>form</literal> keyword. </para> </listitem> +<listitem> +<para>In the paper and the previous implementation, +values on the stack were paired to the right of the environment +in a single argument, +but now the environment and stack are separate arguments. +</para> +</listitem> + </itemizedlist> </sect2> |