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