Skip to content

Instantly share code, notes, and snippets.

@NicolasT
Created August 25, 2014 14:51
Show Gist options
  • Save NicolasT/65dad40b203da7c65b4c to your computer and use it in GitHub Desktop.
Save NicolasT/65dad40b203da7c65b4c to your computer and use it in GitHub Desktop.
An `Either` module for OCaml
(** Either *)
module Either : sig
type ('a, 'b) t = Left of 'a | Right of 'b
val left : 'a -> ('a, 'b) t
val right : 'b -> ('a, 'b) t
val either : ('a -> 'c) -> ('b -> 'c) -> ('a, 'b) t -> 'c
val map : ('b -> 'c) -> ('a, 'b) t -> ('a, 'c) t
val (<$>) : ('b -> 'c) -> ('a, 'b) t -> ('a, 'c) t
val map_left : ('a -> 'c) -> ('a, 'b) t -> ('c, 'b) t
val bimap : ('a -> 'c) -> ('b -> 'd) -> ('a, 'b) t -> ('c, 'd) t
val pure : 'b -> ('a, 'b) t
val apply : ('a, ('b -> 'c)) t -> ('a, 'b) t -> ('a, 'c) t
val (<*>) : ('a, ('b -> 'c)) t -> ('a, 'b) t -> ('a, 'c) t
val return : 'b -> ('a, 'b) t
val bind : ('a, 'b) t -> ('b -> ('a, 'c) t) -> ('a, 'c) t
val (>>=) : ('a, 'b) t -> ('b -> ('a, 'c) t) -> ('a, 'c) t
val throw : 'a -> ('a, 'b) t
val is_left : ('a, 'b) t -> bool
val is_right : ('a, 'b) t -> bool
val to_string : ('a -> string) -> ('b -> string) -> ('a, 'b) t -> string
val error : (exn, 'a) t -> 'a
val try_ : (unit -> 'b) -> (exn, 'b) t
val hush : ('a, 'b) t -> 'b option
val note : 'a -> 'b option -> ('a, 'b) t
val fold : ('b -> 'c -> 'c) -> 'c -> ('a, 'b) t -> 'c
module Lwt : sig
val try_ : (unit -> 'b Lwt.t) -> (exn, 'b) t Lwt.t
val error : (exn, 'b) t -> 'b Lwt.t
end
end = struct
type ('a, 'b) t = Left of 'a | Right of 'b
(** Constructor functions *)
let left a = Left a
let right b = Right b
let either l r = function
| Left v -> l v
| Right v -> r v
(** Bifunctor interface *)
let bimap l r = either (fun v -> left (l v)) (fun v -> right (r v))
external id : 'a -> 'a = "%identity"
let const v = fun _ -> v
(** Functor interface *)
let map f = bimap id f
let (<$>) = map
let map_left f = bimap f id
(** Monadic interface *)
let bind m k = either left k m
let return = right
let (>>=) = bind
let throw = left
(** Applicative interface *)
let pure = return
let apply f v = f >>= fun f' -> v >>= fun v' -> pure (f' v')
let (<*>) = apply
(** Turn a function result in a value or an error *)
let try_ f = try pure (f ()) with exn -> throw exn
(** Predicates *)
let is_left v = either (const true) (const false) v
let is_right v = either (const false) (const true) v
let to_string l r = either
(fun v -> Printf.sprintf "Left (%s)" (l v))
(fun v -> Printf.sprintf "Right (%s)" (r v))
(** Extract a value of raise an exception *)
let error v = either (fun e -> raise e) id v
(** Silence into an option *)
let hush v = either (const None) (fun v' -> Some v') v
(** Expand from an option *)
let note e = function
| None -> Left e
| Some v -> Right v
(** Catamorphism *)
let fold f z = either (const z) (fun v -> f v z)
module Lwt = struct
let try_ f = Lwt.catch
(fun () -> Lwt.map pure (f ()))
(fun exn -> Lwt.return (throw exn))
let error v = either Lwt.fail Lwt.return v
end
end
include Either
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment