1structure seqmonad :> seqmonad = struct
2type ('a,'b) seqmonad = 'a -> ('a * 'b) seq.seq
3fun fail env = seq.empty
4fun return x env = seq.result (env, x)
5fun ok env = seq.result (env, ())
6
7infix >- ++ >> >-> +++
8fun (m1 >- f) env =
9    seq.delay (fn () => let val res0 = m1 env
10                        in
11                          seq.flatten (seq.map (fn (e, v) => f v e) res0)
12                        end)
13fun (m1 >> m2) = (m1 >- (fn _ => m2))
14fun (m1 ++ m2) env =
15  seq.append (seq.delay (fn () => m1 env)) (seq.delay (fn () => m2 env))
16fun (m1 >-> m2) = m1 >- (fn x => m2 >> return x)
17
18fun (m1 +++ m2) env =
19    seq.delay (fn () => let val batch1 = m1 env
20                        in
21                          case (seq.cases batch1) of
22                            NONE => m2 env
23                          | SOME _ => batch1
24                        end)
25
26fun pair1 pm (a, b) = seq.map (fn (a',res) => ((a',b), res)) (pm a)
27fun pair2 pm (a, b) = seq.map (fn (b',res) => ((a,b'), res)) (pm b)
28
29fun optional p = (p >- return o SOME) ++ (return NONE)
30fun mmap f [] =  return []
31  | mmap f (x::xs) = let
32    in
33      f x >-            (fn x' =>
34      mmap f xs >-      (fn xs' =>
35      return (x'::xs')))
36    end
37
38fun tryall f [] = fail
39  | tryall f (x::xs) = f x ++ tryall f xs
40
41fun tryall_seq f s = let
42  open seq
43in
44  case (cases s) of
45    NONE => fail
46  | SOME (x, xs) => f x ++ tryall_seq f xs
47end
48
49local
50  fun repeatn' 0 f = ok
51    | repeatn' n f = f >> repeatn' (n - 1) f
52in
53  fun repeatn n f = if n < 0 then fail else repeatn' n f
54end
55
56fun repeat p env = ((p >> repeat p) ++ ok) env
57
58fun lift f m = m >- (fn v => return (f v))
59fun lift2 f m1 m2 = m1 >- (fn x => m2 >- (fn y => return (f x y)))
60
61fun fromOpt optm s0 =
62  case optm s0 of
63      NONE => fail s0
64    | SOME (s, x) => return x s
65
66fun toError e seqm s0 =
67  case seq.cases (seqm s0) of
68      NONE => errormonad.Error e
69    | SOME ((s,v), rest) =>
70        errormonad.Some(s, (v, not (Option.isSome (seq.cases rest))))
71
72fun fromErr em s0 =
73  case em s0 of
74      errormonad.Error e => fail s0
75    | errormonad.Some(s,x) => return x s
76
77end (* struct *)
78