Monad Comprehension Sugar
Geoffrey Alan Washburn <[email protected]>
| Newsgroups | gmane.comp.lang.sml.smlnj |
|---|---|
| Message-ID | <[email protected]> |
Somewhat related to my other e-mail, I've just finished putting
together a patch to SML/NJ to allow monad comprehensions. Here is an
example of using it to implement the list monad.
type 'a monad = 'a list
infix 5 >>=;
fun (x : 'a monad) >>= (f : 'a -> 'b monad) =
List.concat (List.map f x)
fun return x : 'a monad = [x]
val test = [| (x, y) | x <~ [1,2],
y <~ ["a","b"] |]
(* The sugar is implemented entirely within the parser. The above
declaration becomes
val test = [1,2] >>= (fn x => ["a","b"] >>= (fn y => return (x, y)))
for the rest of the compilation pipeline. *)
Obviously this isn't quite as useful as having the monad type class, but
it is still extremely useful for the interperter/compile I'm working on
at the moment. Is there any possibility of getting this into the
default tree? I'm certainly open to suggestions of adjusting the
syntax. I only wound up using <~ rather than <- because the latter is
used for an internally defined infix operator somewhere in the basis.
Rather than change it, I just switched symbols.
I've attached my diff against the current Subversion tree to this e-mail.
-------------------------------------------------------------------------
Take Surveys. Earn Cash. Influence the Future of IT
Join SourceForge.net's Techsay panel and you'll get the chance to share your
opinions on IT & business topics through brief surveys - and earn cash
http://www.techsay.com/default.php?page=join.php&p=sourceforge&CID=DEVDEV
_______________________________________________
Smlnj-list mailing list
[email protected]
https://lists.sourceforge.net/lists/listinfo/smlnj-list
monad-comp.patch
(text/x-patch, 5.4 KB)
Index: system/pathconfig
===================================================================
--- system/pathconfig (revision 2262)
+++ system/pathconfig (working copy)
@@ -1,6 +1,7 @@
!standard
root.cm ../system
+cml ../../cml/src
smlnj ../system/smlnj
SMLNJ-MLRISC ../../MLRISC/cm
Index: compiler/Parse/lex/ml.lex
===================================================================
--- compiler/Parse/lex/ml.lex (revision 2262)
+++ compiler/Parse/lex/ml.lex (working copy)
@@ -102,8 +102,10 @@
<INITIAL>"{" => (Tokens.LBRACE(yypos,yypos+1));
<INITIAL>"}" => (Tokens.RBRACE(yypos,yypos+1));
<INITIAL>"[" => (Tokens.LBRACKET(yypos,yypos+1));
+<INITIAL>"[|" => (Tokens.LBRACKETBAR(yypos,yypos+1));
<INITIAL>"#[" => (Tokens.VECTORSTART(yypos,yypos+1));
<INITIAL>"]" => (Tokens.RBRACKET(yypos,yypos+1));
+<INITIAL>"|]" => (Tokens.RBARBRACKET(yypos,yypos+1));
<INITIAL>";" => (Tokens.SEMICOLON(yypos,yypos+1));
<INITIAL>"(" => (if (null(!brack_stack))
then ()
Index: compiler/Parse/lex/tokentable.sml
===================================================================
--- compiler/Parse/lex/tokentable.sml (revision 2262)
+++ compiler/Parse/lex/tokentable.sml (working copy)
@@ -41,6 +41,7 @@
("=" , fn yypos => Tokens.EQUALOP(yypos,yypos+1)),
("#" , fn yypos => Tokens.HASH(yypos,yypos+1)),
("->" , fn yypos => Tokens.ARROW(yypos,yypos+2)),
+ ("<~" , fn yypos => Tokens.LEFTARROW(yypos,yypos+2)),
("=>" , fn yypos => Tokens.DARROW(yypos,yypos+2))
])
Index: compiler/Parse/parse/ml.grm
===================================================================
--- compiler/Parse/parse/ml.grm (revision 2262)
+++ compiler/Parse/parse/ml.grm (working copy)
@@ -26,6 +26,60 @@
val quotedBogusHash = HashString.hashString "'BOGUS"
val quotedBogusString = "'BOGUS"
+(* GAW 2006.12.23 Additions for monad sugar *)
+val bindHash = HashString.hashString ">>="
+val bindString = ">>="
+val seqHash = HashString.hashString ">>"
+val seqString = ">>"
+val returnHash = HashString.hashString "return"
+val returnString = "return"
+
+fun returnHelper rexp compfn (left, right) =
+ let
+ val ident = (rawSymbol (returnHash,returnString))
+ val (v,f) = var'n'fix ident
+ in
+ compfn (FlatAppExp [{item=(VarExp [varSymbol ident]),
+ region=(left,right),
+ fixity=SOME f},
+ {item=rexp,
+ region=(left,right),
+ fixity=NONE}])
+ end
+
+fun seqHelper sexp (left, right) x =
+ let
+ val ident = (rawSymbol (seqHash,seqString))
+ val (v,f) = var'n'fix ident
+ in
+ FlatAppExp([{item=markexp(sexp,left,right),
+ region=(left,right),
+ fixity=NONE},
+ {item=(VarExp [varSymbol ident]),
+ region=(left,right),
+ fixity=SOME f},
+ {item=markexp(x,left,right),
+ region=(left,right),
+ fixity=NONE}])
+ end
+
+fun bindHelper pat bexp (left, right) x =
+ let
+ val ident = (rawSymbol (bindHash,bindString))
+ val (v,f) = var'n'fix ident
+ in
+ FlatAppExp([{item=markexp(bexp,left,right),
+ region=(left,right),
+ fixity=NONE},
+ {item=(VarExp [varSymbol ident]),
+ region=(left,right),
+ fixity=SOME f},
+ {item=markexp(FnExp ([Rule{pat=pat,
+ exp=x}]), left,right),
+ region=(left,right),
+ fixity=NONE}])
+ end
+
%%
%term
EOF | SEMICOLON
@@ -43,6 +97,8 @@
| STRUCTURE | THEN | TYPE | VAL | WHERE | WHILE | WILD | WITH | WITHTYPE
| ASTERISK | COLON | COLONGT | COMMA | LBRACE | LBRACKET | LPAREN | RBRACE
| RBRACKET | RPAREN | ORELSE | ANDALSO | FUNSIG | VECTORSTART | BEGINQ
+(* GAW 2006.12.23 Added for comprehension sugar *)
+ | LBRACKETBAR | RBARBRACKET | LEFTARROW
| ENDQ of string | OBJL of string | AQID of FastSymbol.raw_symbol
%nonterm ident of FastSymbol.raw_symbol
@@ -63,9 +119,11 @@
| elabel of (symbol * exp)
| elabels of (symbol * exp) list
| exp_ps of exp list
+ | compexp of exp -> exp
| exp of exp
| app_exp of exp fixitem list
| aexp of exp
+ | comp_list of exp -> exp
| exp_list of exp list
| exp_2c of exp list
| quote of exp list
@@ -294,6 +352,8 @@
| LPAREN exp_ps RPAREN (SeqExp exp_ps)
| LPAREN exp_2c RPAREN (TupleExp exp_2c)
| LBRACKET exp_list RBRACKET (ListExp exp_list)
+ | LBRACKETBAR exp BAR comp_list RBARBRACKET (returnHelper exp comp_list (expleft, expright))
+
| LBRACKET RBRACKET (ListExp nil)
| VECTORSTART exp_list RBRACKET (VectorExp exp_list)
| VECTORSTART RBRACKET (VectorExp nil)
@@ -315,6 +375,14 @@
exp_2c : exp COMMA exp_2c (exp :: exp_2c)
| exp COMMA exp ([exp1, exp2])
+(* GAW 2006.12.23 comprehension expressions *)
+compexp : DO exp (seqHelper exp (DOleft,expright))
+ | pat LEFTARROW exp (bindHelper pat exp (patleft,expright))
+
+(* GAW 2006.12.23 comprehension lists *)
+comp_list : compexp (compexp)
+ | compexp COMMA comp_list (fn (x : exp) => compexp (comp_list x))
+
exp_list : exp ([exp])
| exp COMMA exp_list (exp :: exp_list)