From: ross Date: Wed, 16 Jul 2003 08:49:05 +0000 (+0000) Subject: [project @ 2003-07-16 08:49:01 by ross] X-Git-Tag: Approx_11550_changesets_converted~690 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=98232a6130f0661486899530fa3461e32499366f [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|) --- diff --git a/ghc/compiler/deSugar/DsArrows.lhs b/ghc/compiler/deSugar/DsArrows.lhs index c25dfda..402c1ca 100644 --- a/ghc/compiler/deSugar/DsArrows.lhs +++ b/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 diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index d34d4b9..6969de2 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/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 diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 9e4c660..1802117 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-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 diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index a00cfae..23e41c0 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/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) diff --git a/ghc/compiler/typecheck/TcArrows.lhs b/ghc/compiler/typecheck/TcArrows.lhs index 026c006..b31c03a 100644 --- a/ghc/compiler/typecheck/TcArrows.lhs +++ b/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 diff --git a/ghc/docs/users_guide/glasgow_exts.sgml b/ghc/docs/users_guide/glasgow_exts.sgml index 6ac320e..8f1a41f 100644 --- a/ghc/docs/users_guide/glasgow_exts.sgml +++ b/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: proc x -> do y <- f -< x+1 - (|untilA|) (increment -< x+y) (within 0.5 -< x) + (|untilA (increment -< x+y) (within 0.5 -< x)|) + + + +Primitive constructs + 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 a (...(e,t1), ... tn) t -where e is the polymorphic variable +where e is a polymorphic variable (representing the environment) and ti are the types of the values on the stack, with t1 being the top. @@ -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) -How can we supply the extra input required by the last two? -We can define yet another operator, a counterpart of the monadic ->>= operator: +We can supply the extra input required by commands built with the last two +by applying them to ordinary expressions, as in + +proc x -> do + s <- ... + (|runReader (do { ... })|) s + +which adds s to the stack of inputs to the command +built using runReader. + + + +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 do-notation by defining 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) + +We could simulate do by defining + +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 -and then build commands like - -proc x -> - (mkState -< x) `bind` (|runReader|) (do { ... }) - -which uses the arrow mkState to create a state, -and then provides this as an extra input to the command built using -runReader.