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 )
(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'
-- 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
-- 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
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
| 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.
{% 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 }
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 }
| '|' quals { [$2] }
quals :: { [RdrNameStmt] }
- : quals ',' stmt { $3 : $1 }
- | stmt { [$1] }
+ : quals ',' qual { $3 : $1 }
+ | qual { [$1] }
-----------------------------------------------------------------------------
-- Parallel array expressions
| {- 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
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)
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)
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
| 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
<screen>
proc x -> do
y <- f -< x+1
- (|untilA|) (increment -< x+y) (within 0.5 -< x)
+ (|untilA (increment -< x+y) (within 0.5 -< 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,
<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>.
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 <- ...
+ (|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>
projects / ghc-hetmet.git / commitdiff