[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|)

ghc/compiler/deSugar/DsArrows.lhs

@@ -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

ghc/compiler/hsSyn/HsExpr.lhs

@@ -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

ghc/compiler/parser/Parser.y

 {-								-*-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

ghc/compiler/rename/RnExpr.lhs

@@ -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)

ghc/compiler/typecheck/TcArrows.lhs

@@ -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

ghc/docs/users_guide/glasgow_exts.sgml

@@ -3409,8 +3409,9 @@ cmd   ::= exp1 -<  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>