Res -- так я называю аналог "error monad".
Лицензия -- "делайте что хотите", public domain.
res.mli:
type res 'a 'e =
[= `Ok of 'a
| `Error of 'e
]
;
value return : 'a -> res 'a 'e
;
value fail : 'e -> res 'a 'e
;
value bind : ('a -> res 'b 'e) -> res 'a 'e -> res 'b 'e
;
value ( >>= ) : res 'a 'e -> ('a -> res 'b 'e) -> res 'b 'e
;
value catch : (unit -> res 'a 'e1) -> ('e1 -> res 'a 'e2) -> res 'a 'e2
;
value wrap1 : ('a -> 'z)
-> ('a -> res 'z exn)
;
value wrap2 : ('a -> 'b -> 'z)
-> ('a -> 'b -> res 'z exn)
;
value wrap3 : ('a -> 'b -> 'c -> 'z)
-> ('a -> 'b -> 'c -> res 'z exn)
;
value wrap4 : ('a -> 'b -> 'c -> 'd -> 'z)
-> ('a -> 'b -> 'c -> 'd -> res 'z exn)
;
value wrap5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'z)
-> ('a -> 'b -> 'c -> 'd -> 'e -> res 'z exn)
;
value res_exn : (unit -> 'a) -> res 'a exn
;
value res_opterr : option 'e -> res unit 'e
;
value res_optval : option 'r -> res 'r unit
;
(* Ловит реальные исключения, доводя их "fail exn".
Отличие от res_exn в том, что тут функция возвращает уже res.
"res_exn f" = "catch_exn (return % f)"
= "catch_exn (fun () -> return (f ()))"
*)
value catch_exn : (unit -> res 'a exn) -> res 'a exn
;
(* Ловит как реальные исключения, так и res-ошибки (обязанные иметь
тип exn), обрабатывает. *)
value catch_all : (unit -> res 'a exn) -> (exn -> res 'a exn) -> res 'a exn
;
value exn_res : res 'a exn -> 'a
;
value map_err : ('e1 -> 'e2) -> res 'a 'e1 -> res 'a 'e2
;
value foldres_of_fold :
( ('a -> 'i -> 'a ) -> 'a -> 'v -> 'a ) ->
( ('a -> 'i -> res 'a 'e) -> 'a -> 'v -> res 'a 'e )
;
(*
value rprintf : Pervasives.format 'a Pervasives.out_channel unit -> res 'a exn
;
*)
value rprintf :
Pervasives.format4
'a unit string (res unit exn) -> 'a
;
value reprintf :
Pervasives.format4
'a unit string (res unit exn) -> 'a
;
value wrap_with1 :
( 'a -> ('r -> 'z ) -> 'z ) ->
( 'a -> ('r -> res 'z exn) -> res 'z exn )
;
value wrap_with3 :
( 'a -> 'b -> 'c -> ('r -> 'z ) -> 'z ) ->
( 'a -> 'b -> 'c -> ('r -> res 'z exn) -> res 'z exn )
;
(* sequential. *)
value list_map_all :
( 'a -> res 'b 'e ) -> list 'a -> res (list 'b) ('a * 'e)
;
value array_map_all :
( 'a -> res 'b 'e ) -> array 'a -> res (array 'b) ('a * 'e)
;
value list_fold_left_all :
( 'a -> 'i -> res 'a 'e ) -> 'a -> list 'i
-> res 'a ('i * list 'i * 'a * 'e)
;
value list_iter_all :
( 'a -> res unit 'e ) -> list 'a -> res unit ('a * list 'a * 'e)
;
(* error contains: (the_occured_error, count_of_repeats_made) *)
value repeat : int -> ( 'a -> res 'a 'e ) -> 'a -> res 'a ('e * int)
;
res.ml:
type res 'a 'e =
[= `Ok of 'a
| `Error of 'e
]
;
value return r = `Ok r
;
value fail e = `Error e
;
value bind f m =
match m with
[ `Ok a -> f a
| (`Error _) as e -> e
]
;
value ( >>= ) m f = bind f m
;
value catch func handler =
match func () with
[ (`Ok _) as r -> r
| `Error e -> handler e
]
;
value wrap1 f = fun a ->
try `Ok (f a)
with [ e -> `Error e ]
;
value wrap2 f = fun a b ->
try `Ok (f a b)
with [ e -> `Error e ]
;
value wrap3 f = fun a b c ->
try `Ok (f a b c)
with [ e -> `Error e ]
;
value wrap4 f = fun a b c d ->
try `Ok (f a b c d)
with [ e -> `Error e ]
;
value wrap5 f = fun a b c d e ->
try `Ok (f a b c d e)
with [ e' -> `Error e' ]
;
value catch_exn func =
try
func ()
with
[ e -> fail e ]
;
value catch_all f handler =
catch (fun () -> catch_exn f) handler
;
value exn_res r =
match r with
[ `Ok x -> x
| `Error e -> raise e
]
;
value map_err f r =
match r with
[ (`Ok _) as r -> r
| `Error e -> `Error (f e)
]
;
value res_opterr oe =
match oe with
[ None -> `Ok ()
| Some e -> `Error e
]
;
value res_optval ov =
match ov with
[ None -> `Error ()
| Some v -> `Ok v
]
;
value ( & ) f x = f x
;
value ( % ) f g = fun x -> f (g x)
;
value res_exn func =
catch_exn (return % func)
;
exception Foldres_exit
;
value (foldres_of_fold :
( ('a -> 'i -> 'a ) -> 'a -> 'v -> 'a ) ->
( ('a -> 'i -> res 'a 'e) -> 'a -> 'v -> res 'a 'e )
)
fold =
fun f init v ->
let opt_err = ref None in
let new_f a v =
match f a v with
[ `Ok new_a -> new_a
| `Error e -> (opt_err.val := Some e; raise Foldres_exit)
]
in
try
`Ok (fold new_f init v)
with
[ Foldres_exit ->
match opt_err.val with
[ None -> assert False
| Some e -> `Error e
]
]
;
value rprintf fmt =
Printf.ksprintf
(fun str ->
try
return & output_string stdout str
with
[ e -> `Error e ]
)
fmt
;
value reprintf fmt =
Printf.ksprintf
(fun str ->
try
return & (output_string stderr str; flush stderr)
with
[ e -> `Error e ]
)
fmt
;
value wrap_with1 =
fun with1 ->
fun a f ->
res_exn & fun () ->
with1 a (exn_res % f)
;
value wrap_with3 =
fun with3 ->
fun a b c f ->
res_exn & fun () ->
with3 a b c (exn_res % f)
;
value list_map_all func lst =
inner [] lst
where rec inner rev_acc lst =
match lst with
[ [] -> return & List.rev rev_acc
| [h :: t] ->
match func h with
[ `Ok x -> inner [x :: rev_acc] t
| `Error e -> `Error (h, e)
]
]
;
value array_map_all func arr =
let lst = Array.to_list arr in
list_map_all func lst >>= fun res_lst ->
return & Array.of_list res_lst
;
value list_fold_left_all func init lst =
inner init lst
where rec inner init lst =
match lst with
[ [] -> return init
| [h :: t] ->
match func init h with
[ `Ok x -> inner x t
| `Error e -> `Error (h, t, init, e)
]
]
;
value list_iter_all func lst =
catch
(fun () ->
list_fold_left_all
(fun () x -> ((func x) : res unit _))
()
lst
)
(fun (h, t, (), e) -> fail (h, t, e))
;
value repeat n f a =
inner 0 a
where rec inner made a =
if made >= n
then
`Ok a
else
match f a with
[ `Ok a -> inner (made + 1) a
| `Error e -> `Error (e, made)
]
;
2011-03-26 13:08