Commit daf67985 authored by ross's avatar ross

[project @ 2004-09-15 17:48:08 by ross]

arrow notation: allow arrow applications (f -< a) to take a non-empty
command stack, as suggested by Sebastian Boldt <Sebastian.Boldt@arcor.de>.
parent 346166a4
......@@ -289,12 +289,14 @@ dsCmd :: DsCmdEnv -- arrow combinators
-> DsM (CoreExpr, -- desugared expression
IdSet) -- set of local vars that occur free
-- A |- f :: a t t'
-- A |- f :: a (t*ts) t'
-- A, xs |- arg :: t
-- ---------------------------
-- A | xs |- f -< arg :: [] t' ---> arr (\ (xs) -> arg) >>> f
-- -----------------------------
-- A | xs |- f -< arg :: [ts] t'
--
-- ---> arr (\ ((xs)*ts) -> (arg*ts)) >>> f
dsCmd ids local_vars env_ids [] res_ty
dsCmd ids local_vars env_ids stack res_ty
(HsArrApp arrow arg arrow_ty HsFirstOrderApp _)
= let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
......@@ -303,18 +305,26 @@ dsCmd ids local_vars env_ids [] res_ty
in
dsLExpr arrow `thenDs` \ core_arrow ->
dsLExpr arg `thenDs` \ core_arg ->
matchEnvStack env_ids [] core_arg `thenDs` \ core_make_arg ->
returnDs (do_map_arrow ids env_ty arg_ty res_ty
mappM newSysLocalDs stack `thenDs` \ stack_ids ->
matchEnvStack env_ids stack_ids
(foldl mkCorePairExpr core_arg (map Var stack_ids))
`thenDs` \ core_make_arg ->
returnDs (do_map_arrow ids
(envStackType env_ids stack)
arg_ty
res_ty
core_make_arg
core_arrow,
exprFreeVars core_arg `intersectVarSet` local_vars)
-- A, xs |- f :: a t t'
-- A, xs |- f :: a (t*ts) t'
-- A, xs |- arg :: t
-- ---------------------------
-- A | xs |- f -<< arg :: [] t' ---> arr (\ (xs) -> (f,arg)) >>> app
-- ------------------------------
-- A | xs |- f -<< arg :: [ts] t'
--
-- ---> arr (\ ((xs)*ts) -> (f,(arg*ts))) >>> app
dsCmd ids local_vars env_ids [] res_ty
dsCmd ids local_vars env_ids stack res_ty
(HsArrApp arrow arg arrow_ty HsHigherOrderApp _)
= let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
......@@ -323,9 +333,15 @@ dsCmd ids local_vars env_ids [] res_ty
in
dsLExpr arrow `thenDs` \ core_arrow ->
dsLExpr arg `thenDs` \ core_arg ->
matchEnvStack env_ids [] (mkCorePairExpr core_arrow core_arg)
mappM newSysLocalDs stack `thenDs` \ stack_ids ->
matchEnvStack env_ids stack_ids
(mkCorePairExpr core_arrow
(foldl mkCorePairExpr core_arg (map Var stack_ids)))
`thenDs` \ core_make_pair ->
returnDs (do_map_arrow ids env_ty (mkCorePairTy arrow_ty arg_ty) res_ty
returnDs (do_map_arrow ids
(envStackType env_ids stack)
(mkCorePairTy arrow_ty arg_ty)
res_ty
core_make_pair
(do_app ids arg_ty res_ty),
(exprFreeVars core_arrow `unionVarSet` exprFreeVars core_arg)
......
......@@ -130,14 +130,12 @@ tc_cmd env (HsIf pred b1 b2) res_ty
-------------------------------------------
-- Arrow application
-- (f -< a) or (f =< a)
-- (f -< a) or (f -<< a)
tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty)
= addErrCtxt (cmdCtxt cmd) $
do { arg_ty <- newTyVarTy openTypeKind
; let fun_ty = mkCmdArrTy env arg_ty res_ty
; checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd)
; let fun_ty = mkCmdArrTy env (foldl mkPairTy arg_ty cmd_stk) res_ty
; fun' <- pop_arrow_binders (tcCheckRho fun fun_ty)
......@@ -148,7 +146,7 @@ tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty)
-- Before type-checking f, remove the "arrow binders" from the
-- environment in the (-<) case.
-- Local bindings, inside the enclosing proc, are not in scope
-- inside f. In the higher-order case (--<), they are.
-- inside f. In the higher-order case (-<<), they are.
pop_arrow_binders tc = case ho_app of
HsHigherOrderApp -> tc
HsFirstOrderApp -> popArrowBinders tc
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment