Commit 98232a61 authored by ross's avatar ross

[project @ 2003-07-16 08:49:01 by ross]

Arrow notation: add a new (more primitive) form of command:

	cmd ::= ... | cmd aexp

analogous to ordinary application, and also represented using HsApp.
To avoid an overlap, the syntax for combining forms is changed to

	(|aexp cmd1 ... cmdn|)
parent 5ac88b39
......@@ -42,7 +42,7 @@ import TcType ( Type, tcSplitAppTy )
import Type ( mkTyConApp )
import CoreSyn
import CoreFVs ( exprFreeVars )
import CoreUtils ( mkIfThenElse, bindNonRec )
import CoreUtils ( mkIfThenElse, bindNonRec, exprType )
import Id ( Id, idType )
import PrelInfo ( pAT_ERROR_ID )
......@@ -343,6 +343,40 @@ dsCmd ids local_vars env_ids [] res_ty
(exprFreeVars core_arrow `unionVarSet` exprFreeVars core_arg)
`intersectVarSet` local_vars)
-- A | ys |- c :: [t:ts] t'
-- A, xs |- e :: t
-- ------------------------
-- A | xs |- c e :: [ts] t'
--
-- ---> arr (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) >>> c
dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg)
= dsExpr arg `thenDs` \ core_arg ->
let
arg_ty = exprType core_arg
stack' = arg_ty:stack
in
dsfixCmd ids local_vars stack' res_ty cmd
`thenDs` \ (core_cmd, free_vars, env_ids') ->
mapDs newSysLocalDs stack `thenDs` \ stack_ids ->
newSysLocalDs arg_ty `thenDs` \ arg_id ->
-- push the argument expression onto the stack
let
core_body = bindNonRec arg_id core_arg
(buildEnvStack env_ids' (arg_id:stack_ids))
in
-- match the environment and stack against the input
matchEnvStack env_ids stack_ids core_body
`thenDs` \ core_map ->
returnDs (do_map_arrow ids
(envStackType env_ids stack)
(envStackType env_ids' stack')
res_ty
core_map
core_cmd,
(exprFreeVars core_arg `intersectVarSet` local_vars)
`unionVarSet` free_vars)
-- A | ys |- c :: [ts] t'
-- -----------------------------------------------
-- A | xs |- \ p1 ... pk -> c :: [t1:...:tk:ts] t'
......@@ -505,7 +539,7 @@ dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _ _ _loc)
-- 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
-- A | xs |- (|e c1 ... cn|) :: [ts] t ---> e [t_xs] c1 ... cn
dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args _)
= let
......
......@@ -195,7 +195,7 @@ data HsExpr id
-- False => left-to-right (arg >- f)
SrcLoc
| HsArrForm -- Command formation, (| e |) cmd1 .. cmdn
| HsArrForm -- Command formation, (| e cmd1 .. cmdn |)
(HsExpr id) -- the operator
-- after type-checking, a type abstraction to be
-- applied to the type of the local environment tuple
......@@ -447,8 +447,8 @@ ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False _)
ppr_expr (HsArrForm (HsVar v) (Just _) [arg1, arg2] _)
= sep [pprCmdArg arg1, hsep [pprInfix v, pprCmdArg arg2]]
ppr_expr (HsArrForm op _ args _)
= hang (ptext SLIT("(|") <> pprExpr op <> ptext SLIT("|)"))
4 (sep (map pprCmdArg args))
= hang (ptext SLIT("(|") <> pprExpr op)
4 (sep (map pprCmdArg args) <> ptext SLIT("|)"))
pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc
pprCmdArg (HsCmdTop cmd@(HsArrForm _ Nothing [] _) _ _ _) = pprExpr cmd
......@@ -509,6 +509,9 @@ The legal constructors for commands are:
| HsArrForm ... -- as above
| HsApp (HsCmd id)
(HsExpr id)
| HsLam (Match id) -- kappa
-- the renamer turns this one into HsArrForm
......
{- -*-haskell-*-
-----------------------------------------------------------------------------
$Id: Parser.y,v 1.120 2003/06/24 07:58:22 simonpj Exp $
$Id: Parser.y,v 1.121 2003/07/16 08:49:05 ross Exp $
Haskell grammar.
......@@ -974,8 +974,6 @@ exp10 :: { RdrNameHsExpr }
{% checkPattern $2 $3 `thenP` \ p ->
returnP (HsProc p (HsCmdTop $6 [] placeHolderType undefined) $5) }
| srcloc operator cmdargs { HsArrForm $2 Nothing (reverse $3) $1 }
| '{-# CORE' STRING '#-}' exp { HsCoreAnn $2 $4 } -- hdaume: core annotation
| reifyexp { HsReify $1 }
......@@ -1044,16 +1042,16 @@ aexp2 :: { RdrNameHsExpr }
returnP (HsBracket (PatBr p) $1) }
| srcloc '[d|' cvtopbody '|]' { HsBracket (DecBr (mkGroup $3)) $1 }
-- arrow notation extension
| srcloc '(|' aexp2 cmdargs '|)'
{ HsArrForm $3 Nothing (reverse $4) $1 }
cmdargs :: { [RdrNameHsCmdTop] }
: cmdargs acmd { HsCmdTop $2 [] placeHolderType undefined : $1 }
: cmdargs acmd { $2 : $1 }
| {- empty -} { [] }
acmd :: { RdrNameHsExpr }
: '(' exp ')' { HsPar $2 }
| srcloc operator { HsArrForm $2 Nothing [] $1 }
operator :: { RdrNameHsExpr }
: '(|' exp '|)' { $2 }
acmd :: { RdrNameHsCmdTop }
: aexp2 { HsCmdTop $1 [] placeHolderType undefined }
cvtopbody :: { [RdrNameHsDecl] }
: '{' cvtopdecls '}' { $2 }
......@@ -1103,8 +1101,8 @@ pquals1 :: { [[RdrNameStmt]] }
| '|' quals { [$2] }
quals :: { [RdrNameStmt] }
: quals ',' stmt { $3 : $1 }
| stmt { [$1] }
: quals ',' qual { $3 : $1 }
| qual { [$1] }
-----------------------------------------------------------------------------
-- Parallel array expressions
......@@ -1189,11 +1187,16 @@ maybe_stmt :: { Maybe RdrNameStmt }
| {- nothing -} { Nothing }
stmt :: { RdrNameStmt }
: qual { $1 }
| srcloc infixexp '->' exp {% checkPattern $1 $4 `thenP` \p ->
returnP (BindStmt p $2 $1) }
| srcloc 'rec' stmtlist { RecStmt $3 undefined undefined undefined }
qual :: { RdrNameStmt }
: srcloc infixexp '<-' exp {% checkPattern $1 $2 `thenP` \p ->
returnP (BindStmt p $4 $1) }
| srcloc exp { ExprStmt $2 placeHolderType $1 }
| srcloc 'let' binds { LetStmt $3 }
| srcloc 'rec' stmtlist { RecStmt $3 undefined undefined undefined }
-----------------------------------------------------------------------------
-- Record Field Update/Construction
......
......@@ -485,6 +485,8 @@ rnCmdTop (HsCmdTop cmd _ _ _)
convertOpFormsCmd :: HsCmd id -> HsCmd id
convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsCmd c) e
convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
convertOpFormsCmd (OpApp c1 op fixity c2)
......@@ -557,6 +559,8 @@ methodNamesCmd (HsLet b c) = methodNamesCmd c
methodNamesCmd (HsDo sc stmts rbs ty loc) = methodNamesStmts stmts
methodNamesCmd (HsApp c e) = methodNamesCmd c
methodNamesCmd (HsLam match) = methodNamesMatch match
methodNamesCmd (HsCase scrut matches loc)
......
......@@ -133,6 +133,18 @@ tcCmd env cmd@(HsArrApp fun arg _ ho_app lr src_loc) (cmd_stk, res_ty)
HsHigherOrderApp -> tc
HsFirstOrderApp -> popArrowBinders tc
-------------------------------------------
-- Command application
tcCmd env cmd@(HsApp fun arg) (cmd_stk, res_ty)
= addErrCtxt (cmdCtxt cmd) $
do { arg_ty <- newTyVarTy openTypeKind
; fun' <- tcCmd env fun (arg_ty:cmd_stk, res_ty)
; arg' <- tcCheckRho arg arg_ty
; return (HsApp fun' arg') }
-------------------------------------------
-- Lambda
......
......@@ -3409,8 +3409,9 @@ cmd ::= exp1 -&lt; exp2
| if exp then cmd1 else cmd2
| case exp of { calts }
| cmd1 qop cmd2
| (| exp |) cmd1 .. cmdn
| (| aexp cmd1 .. cmdn |)
| \ pat1 .. patn -> cmd
| cmd aexp
| ( cmd )
cstmt ::= let decls
......@@ -3657,10 +3658,15 @@ there is also a more general syntax involving special brackets:
<screen>
proc x -> do
y &lt;- f -&lt; x+1
(|untilA|) (increment -&lt; x+y) (within 0.5 -&lt; x)
(|untilA (increment -&lt; x+y) (within 0.5 -&lt; x)|)
</screen>
</para>
</sect2>
<sect2>
<title>Primitive constructs</title>
<para>
Some operators will need to pass additional inputs to their subcommands.
For example, in an arrow type supporting exceptions,
......@@ -3699,7 +3705,7 @@ should have the form
<screen>
a (...(e,t1), ... tn) t
</screen>
where <replaceable>e</replaceable> is the polymorphic variable
where <replaceable>e</replaceable> is a polymorphic variable
(representing the environment)
and <replaceable>ti</replaceable> are the types of the values on the stack,
with <replaceable>t1</replaceable> being the <quote>top</quote>.
......@@ -3713,21 +3719,37 @@ 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)
</screen>
How can we supply the extra input required by the last two?
We can define yet another operator, a counterpart of the monadic
<literal>>>=</literal> operator:
We can supply the extra input required by commands built with the last two
by applying them to ordinary expressions, as in
<screen>
proc x -> do
s &lt;- ...
(|runReader (do { ... })|) s
</screen>
which adds <literal>s</literal> to the stack of inputs to the command
built using <literal>runReader</literal>.
</para>
<para>
The command versions of lambda abstraction and application are analogous to
the expression versions.
In particular, the beta and eta rules describe equivalences of commands.
These three features (operators, lambda abstraction and application)
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
u `bind` f = returnA &&& u >>> f
bind_ :: Arrow a => a e b -> a e c -> a e c
u `bind_` f = u `bind` (arr fst >>> f)
</programlisting>
We could simulate <literal>do</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
</programlisting>
and then build commands like
<screen>
proc x ->
(mkState -< x) `bind` (|runReader|) (do { ... })
</screen>
which uses the arrow <literal>mkState</literal> to create a state,
and then provides this as an extra input to the command built using
<literal>runReader</literal>.
</para>
</sect2>
......
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