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