1(* Author: Michael Norrish *)
2
3structure optmonad :> optmonad =
4struct
5
6type ('a, 'b) optmonad = 'a -> ('a * 'b) option
7
8fun fail env = NONE
9
10fun return x env = SOME (env, x)
11
12fun ok env = return () env
13
14infix >- ++ >> >-> +++
15
16fun (m1 >- f) env0 =
17  case m1 env0 of
18      NONE => NONE
19    | SOME(env1, res1) => f res1 env1
20fun (m1 >> m2) = (m1 >- (fn _ => m2))
21
22fun (m1 ++ m2) env0 =
23  case m1 env0 of
24      NONE => m2 env0
25    | x => x
26
27val op+++ = op++
28
29fun (m1 >-> m2) = m1 >- (fn x => m2 >> return x)
30fun optional p = (p >- return o SOME) ++ (return NONE)
31fun mmap f [] =  return []
32  | mmap f (x::xs) = let
33    in
34      f x >-            (fn x' =>
35      mmap f xs >-      (fn xs' =>
36      return (x'::xs')))
37    end
38
39fun tryall f [] = fail
40  | tryall f (x::xs) = f x ++ tryall f xs
41
42local
43  fun repeatn' 0 f = ok
44    | repeatn' n f = f >> repeatn' (n - 1) f
45in
46  fun repeatn n f = if n < 0 then fail else repeatn' n f
47end
48
49fun repeat p env = ((p >> repeat p) ++ ok) env
50
51fun many p =
52  (p >- (fn i => many p >- (fn rest => return (i::rest)))) +++
53  (return [])
54
55fun many1 p =
56  p >- (fn i => many p >- (fn rest => return (i::rest)))
57
58fun lift f m = m >- (fn a => return (f a))
59fun lift2 f m1 m2 = m1 >- (fn a => m2 >- (fn b => return (f a b)))
60
61fun addState s m s0 =
62  case m (s0,s) of
63      NONE => NONE
64    | SOME((s0',s'), x) => SOME(s0',(s',x))
65
66end
67