Monads, monadic notation and OCaml

["Jacques Carette" <carette@mcmaster.ca>]

[-- Attachment #1: Type: text/plain, Size: 2582 bytes --]

Attached is a camlp4 syntax extension for a 'monadic do notation' for OCaml, much like Haskell's.  The syntax 
extension is joint work with Oleg Kiselyov, and is loosely based on previous work of Lydia van Dijk on a similar 
syntax extension.

Naturally, in OCaml certain monads (like State and IO) are unnecessary.  But other monads (List, option, etc) can be 
quite convenient.

But monads can be much more than convenient.  Below is some code written in a non-deterministic monad of streams.
This example is particularly interesting in that it cannot be (naively) done in either Prolog or in Haskell's
MonadPlus monad, both of which would go into an infinite loop on this example.

(* test non-determinism monad, the simplest possible implementation *)
type 'a stream = Nil | Cons of 'a * (unit -> 'a stream) 
                      | InC of (unit -> 'a stream)
let test_nondet () =
   let mfail = fun () -> Nil in
   let ret a = fun () -> Cons (a,mfail) in
   (* actually, interleave: a fair disjunction with breadth-first search*)
   let rec mplus a b = fun () -> match a () with
                   | Nil -> InC b
		  | InC a -> (match b () with
		    | Nil -> InC a
		    | InC b -> InC (mplus a b)
		    | Cons (b1,b2) -> Cons (b1, (mplus a b2)))
                   | Cons (a1,a2) -> Cons (a1,(mplus b a2)) in
   (* a fair conjunction *)
   let rec bind m f = fun () -> match m () with
                   | Nil -> mfail ()
		  | InC a -> InC (bind a f)
                   | Cons (a,b) -> mplus (f a) (bind b f) () in
   let guard be = if be then ret () else mfail in
   let rec run n m = if n = 0 then [] else
                 match m () with
		| Nil -> []
		| InC a -> run n a
		| Cons (a,b) -> (a::run (n-1) b)
   in
   let rec numb () = InC (mplus (ret 0) (mdo { n <-- numb; ret (n+1) })) in
   (* Don't try this in Prolog or in Haskell's MonadPlus! *)
   let tst = mdo {
                   i <-- numb;
                   guard (i>0);
                   j <-- numb;
                   guard (j>0);
                   k <-- numb;
                   guard (k>0);
                   (* Just to illustrate the `let' form within mdo *)
                   let test x = x*x = j*j + k*k in;
                   guard (test i);
		  ret (i,j,k)
                 } 
   in run 7 tst
;;

We ourselves have been experimenting with a combined state-passing, continuation-passing monad, where the values 
returned and manipulated are code fragments (in MetaOCaml).  This allows for considerably simpler, typed code 
combinators.  Details of this work will be reported elsewhere.  

Jacques

[-- Attachment #2: pa_monad.ml --]
[-- Type: application/octet-stream, Size: 4477 bytes --]

(* name:          pa_monad.ml
 * synopsis:      Haskell-like "do" for monads
 * authors:       Jacques Carette and Oleg Kiselyov, 
 *                based in part of work of Lydia E. Van Dijk
 * last revision: Sun Mar 27 2005
 * ocaml version: 3.08.0 *)


(** Conversion Rules

Grammar informally:
                 mdo { exp }
                 mdo { exp1; exp2 }
                 mdo { x <-- exp; exp }
                 mdo { let x = foo in; exp }
which is almost literally the grammar of Haskell `do' notation,
modulo `do'/`mdo' and `<-'/`<--'.

Grammar formally:

        mdo { <do-body> }
        <do-body> :: =
                "let" var = EXP ("and" var = EXP)* "in" ";" <do-body>
                EXP
                (pat <--)? EXP ";" <do-body>

Semantics (as re-writing into the core language)

        mdo { exp } ===> exp
        mdo { pat <-- exp; rest } ===> bind exp (fun pat -> mdo { rest })
        mdo { exp; rest } ===> bind exp (fun _ -> mdo { rest })
        mdo { let pat = exp in; rest } ===> let pat = exp in mdo { rest }

Actually, in `let pat = exp' one can use anything that is allowed
in a `let' expression, e.g., `let pat1 = exp1 and pat2 = exp2 ...'.
The reason we can't terminate the `let' expression with just a semi-colon
is because semi-colon can be a part of an expression that is bound to
the pattern.

It is possible to use `<-' instead of `<--'. In that case,
the similarity to the `do' notation of Haskell will be complete. However,
due to the parsing rules of Camlp4, we would have to accept `:=' as
an alias for `<-'. So, mdo { pat := exp1; exp2 } would be allowed too.
Perhaps that is too much.

The major difficulty with the `do' notation is that it can't truly be
parsed by an LR-grammar. Indeed, to figure out if we should start
parsing <do-body> as an expression or a pattern, we have to parse it
as a pattern and check the "<--" delimiter. If it isn't there, we should
_backtrack_ and parse it again as an expression. Furthermore, "a <-- b"
(or "a <- b") can also be parsed as an expression. However, for some patterns,
e.g. (`_ <-- exp'), that cannot be parsed as an expression. 

    *)

type monbind = BindL of (MLast.patt * MLast.expr) list
             | BindM of MLast.patt * MLast.expr
             | ExpM  of MLast.expr
(* Convert MLast.expr into MLast.patt, if we `accidentally'
   parsed a pattern as an expression.
  The code is based on pattern_eq_expression in 
  /camlp4/etc/pa_fstream.ml *)

let rec exp_to_patt loc e =
  match e with
    <:expr< $lid:b$ >> -> <:patt< $lid:b$ >>
  | <:expr< $uid:b$ >> -> <:patt< $uid:b$ >>
  | <:expr< $e1$ $e2$ >> -> 
      let p1 = exp_to_patt loc e1 and p2 = exp_to_patt loc e2 in
      <:patt< $p1$ $p2$ >>
  | <:expr< ($list:el$) >> ->
      let pl = List.map (exp_to_patt loc) el in
      <:patt< ($list:pl$) >>
  | _ -> failwith "This pattern isn't yet supported"

(* The main semantic function *)
let process loc b = 
    let globbind2 x p acc =
        <:expr< bind $x$ (fun $p$ -> $acc$) >>
    and globbind1 x acc =
        <:expr< bind $x$ (fun _ -> $acc$) >>
    and ret n = <:expr< $n$ >> in
    let folder = let (a,b) = (globbind2, globbind1) in
        (fun accumulator y -> 
        match y with
        | BindM(p,x) -> a x p accumulator
        | ExpM(x) -> b x accumulator
        | BindL(l) -> <:expr< let $list:l$ in $accumulator$ >>
        )
    in
    match List.rev b with 
    | [] -> failwith "somehow got an empty list from a LIST1!"
    | (ExpM(n)::t) -> List.fold_left folder (ret n) t  
    | _ -> failwith "Does not end with an expression"

EXTEND
    GLOBAL: Pcaml.expr; 

    Pcaml.expr: LEVEL "expr1"
    [
      [ "mdo"; "{";
        bindings = LIST1 monadic_binding SEP ";"; "}" ->
            process loc bindings
      ] 
    ] ;

    Pcaml.expr: BEFORE "apply"
    [ NONA
	  [ e1 = SELF; "<--"; e2 = Pcaml.expr LEVEL "expr1" ->
          <:expr< $e1$ $lid:"<--"$ $e2$ >>
	  ] 
    ] ;

    monadic_binding:
    [ 
      [ "let"; l = LIST1 Pcaml.let_binding SEP "and"; "in" ->
	      BindL(l) ]
    | 
      [ x = Pcaml.expr LEVEL "expr1" ->
	(* For some patterns, "patt <-- exp" can parse
	   as an expression too. So we have to figure out which is which. *)
        match x with
              <:expr< $e1$  $lid:op$  $e3$  >> when op = "<--" 
                  -> BindM((exp_to_patt loc e1),e3)
            | _ -> ExpM(x) ]
    | 
      [ p = Pcaml.patt LEVEL "simple"; "<--"; x = Pcaml.expr LEVEL "expr1" ->
        BindM(p,x) ]
    ] ;
END;