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