1structure errormonad :> errormonad =
2struct
3
4datatype ('a,'b) fs = Some of 'a | Error of 'b
5type ('s, 'a, 'error) t = 's -> ('s * 'a,'error) fs
6
7fun error (e:'error) : ('s,'a,'error) t = fn env => Error e
8fun fail s = error s
9
10fun return x env = Some (env, x)
11
12fun ok e = return () e (* eta-expanded b/c of value restriction *)
13
14infix >- ++ >> >-> +++ ++?
15
16fun (m1 >- f) env0 =
17  case m1 env0 of
18      Some (env1, res1) => f res1 env1
19    | Error e => Error e (* pat and rhs have different types *)
20fun (m1 >> m2) = (m1 >- (fn _ => m2))
21
22fun (m1 ++ m2) env =
23  case m1 env of
24      Error _ => m2 env
25    | Some x => Some x
26
27fun (m1 ++? fm2) env =
28  case m1 env of
29      Error e => fm2 e env
30    | Some x => Some x
31
32fun mmap f [] =  return []
33  | mmap (f:'a -> ('s,'b,'error) t) ((x:'a)::xs) = let
34    in
35      f x >-            (fn (x':'b) =>
36      mmap f xs >-      (fn xs' =>
37      return (x'::xs')))
38    end
39
40local
41  fun repeatn' 0 f = ok
42    | repeatn' n f = f >> repeatn' (n - 1) f
43in
44  fun repeatn n f = if n < 0 then raise Fail "repeatn: n < 0"
45                    else repeatn' n f
46end
47
48fun repeat p env = ((p >> repeat p) ++ ok) env
49
50fun lift f m = m >- (fn a => return (f a))
51fun lift2 f m1 m2 =
52  m1 >- (fn x => m2 >- (fn y => return (f x y)))
53
54fun fromOpt optm errv s0 =
55  case optm s0 of
56      NONE => Error errv
57    | SOME (s, r) => Some (s, r)
58
59fun toOpt errm s0 =
60  case errm s0 of
61      Error _ => NONE
62    | Some res => SOME res
63
64fun addState s m s0 =
65  case m (s0,s) of
66      Error e => Error e
67    | Some((s0',s'), result) => Some(s0',(s',result))
68
69fun foldlM f a list =
70  case list of
71      [] => return a
72    | h::t => f (h,a) >- (fn a' => foldlM f a' t)
73
74fun with_flagM (r,v) (m : ('a,'b,'c)t) : ('a,'b,'c)t = fn (s:'a) =>
75  Portable.with_flag (r,v) m s
76
77
78
79end
80