Commit daf67985 authored by ross's avatar ross
Browse files

[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 ...@@ -289,12 +289,14 @@ dsCmd :: DsCmdEnv -- arrow combinators
-> DsM (CoreExpr, -- desugared expression -> DsM (CoreExpr, -- desugared expression
IdSet) -- set of local vars that occur free 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 |- 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 _) (HsArrApp arrow arg arrow_ty HsFirstOrderApp _)
= let = let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
...@@ -303,18 +305,26 @@ dsCmd ids local_vars env_ids [] res_ty ...@@ -303,18 +305,26 @@ dsCmd ids local_vars env_ids [] res_ty
in in
dsLExpr arrow `thenDs` \ core_arrow -> dsLExpr arrow `thenDs` \ core_arrow ->
dsLExpr arg `thenDs` \ core_arg -> dsLExpr arg `thenDs` \ core_arg ->
matchEnvStack env_ids [] core_arg `thenDs` \ core_make_arg -> mappM newSysLocalDs stack `thenDs` \ stack_ids ->
returnDs (do_map_arrow ids env_ty arg_ty res_ty 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_make_arg
core_arrow, core_arrow,
exprFreeVars core_arg `intersectVarSet` local_vars) 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 |- 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 _) (HsArrApp arrow arg arrow_ty HsHigherOrderApp _)
= let = let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
...@@ -323,9 +333,15 @@ dsCmd ids local_vars env_ids [] res_ty ...@@ -323,9 +333,15 @@ dsCmd ids local_vars env_ids [] res_ty
in in
dsLExpr arrow `thenDs` \ core_arrow -> dsLExpr arrow `thenDs` \ core_arrow ->
dsLExpr arg `thenDs` \ core_arg -> 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 -> `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 core_make_pair
(do_app ids arg_ty res_ty), (do_app ids arg_ty res_ty),
(exprFreeVars core_arrow `unionVarSet` exprFreeVars core_arg) (exprFreeVars core_arrow `unionVarSet` exprFreeVars core_arg)
......
...@@ -130,14 +130,12 @@ tc_cmd env (HsIf pred b1 b2) res_ty ...@@ -130,14 +130,12 @@ tc_cmd env (HsIf pred b1 b2) res_ty
------------------------------------------- -------------------------------------------
-- Arrow application -- 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) tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty)
= addErrCtxt (cmdCtxt cmd) $ = addErrCtxt (cmdCtxt cmd) $
do { arg_ty <- newTyVarTy openTypeKind do { arg_ty <- newTyVarTy openTypeKind
; let fun_ty = mkCmdArrTy env arg_ty res_ty ; let fun_ty = mkCmdArrTy env (foldl mkPairTy arg_ty cmd_stk) res_ty
; checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd)
; fun' <- pop_arrow_binders (tcCheckRho fun fun_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) ...@@ -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 -- Before type-checking f, remove the "arrow binders" from the
-- environment in the (-<) case. -- environment in the (-<) case.
-- Local bindings, inside the enclosing proc, are not in scope -- 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 pop_arrow_binders tc = case ho_app of
HsHigherOrderApp -> tc HsHigherOrderApp -> tc
HsFirstOrderApp -> popArrowBinders 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