Monads and exception handling in OCaml

monad_try.ml

(* Tested with OCaml 3.12.1/4.00.1 *)

(* A standard state monad with an integer state *)
module IntStateMonad =
struct
  type 'a t = int -> 'a * int

  (* val return : 'a -> 'a t *)
  let return (x : 'a) : 'a t =
    (fun s -> (x, s))

  (* val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t *)
  let (>>=) (m : 'a t) (f : 'a -> 'b t) : 'b t =
    (fun s ->
       let (x, s') = m s in
       let m' = f x in
       m' s')

  (* val get : int t *)
  let get : int t = (fun s -> (s, s))

  (* val put : int -> unit t *)
  let put new_state : unit t = (fun _ -> ((), new_state))
end

open IntStateMonad

(* A function that never throws exceptions *)
(* val double_and_incr_state : int -> int IntStateMonad.t = <fun> *)
let double_and_incr_state x =
  get >>= fun s ->
  put (succ s) >>= fun _ ->
  return (x + x)

(* Using the safe function *)
(* val sm1 : int IntStateMonad.t = <fun> *)
let sm1 =
  put 0 >>= fun () ->
  return 1 >>= fun x ->
  double_and_incr_state x >>= fun x ->
  double_and_incr_state x

let (result1, last_state1) = sm1 0
(* val result1 : int = 4
 * val last_state1 : int = 2 *) 

(* A function that throws an exception *)
let unsafe_f x =
  if x = 1 then raise Not_found
  else return 2

(* Directly catching the exception works as expected *)
(* val sm2 : int IntStateMonad.t = <fun> *)
let sm2 =
  put 0 >>= fun () ->
  return 1 >>= fun x ->
  try unsafe_f x with Not_found -> return 10 >>= fun x ->
  double_and_incr_state x

let (result2, last_state2) = sm2 0
(* val result2 : int = 20
 * val last_state2 : int = 1 *) 

(* Embedding the unsafe function in another monadic value *)
(* val use_unsafe_f : int IntStateMonad.t = <fun> *)
let use_unsafe_f =
  return 1 >>= fun x ->
  unsafe_f x

(* This time, catching the exception does not work *)
let sm3 =
  put 0 >>= fun () ->
  try use_unsafe_f with Not_found -> return 10 >>= fun x ->
  double_and_incr_state x

(* This line throws Exception: Not_found. *)
(* let (result3, last_state3) = sm3 0 *)

(* Wrapping try/with and raise to make them work inside the monad *)
(* val with_try : ('a -> 'b) -> (exn -> 'a -> 'b) -> 'a -> 'b = <fun> *)
let with_try f handle_exception s =
  try
    f s
  with e ->
    handle_exception e s

(* val throw : exn -> 'a -> 'b = <fun> *)
let throw e _ =
  raise e

(* val unsafe_f' : int -> int IntStateMonad.t = <fun> *)
let unsafe_f' x =
  if x = 1 then throw Not_found
  else return 2

(* val use_unsafe_f' : int IntStateMonad.t = <fun> *)
let use_unsafe_f' =
  return 1 >>= fun x ->
  unsafe_f' x

(* This time, catching the exception works *)
(* val sm4 : int IntStateMonad.t = <fun> *)
let sm4 =
  put 0 >>= fun () ->
  with_try
    use_unsafe_f'
    (function Not_found -> return 10 | e -> raise e) >>= fun x ->
  double_and_incr_state x

let (result4, last_state4) = sm4 0
(* val result4 : int = 20
 * val last_state4 : int = 1 *)