(* This version from 1 April 2015 *)
module Monad = struct
module type MAPPABLE = sig
type 'a t
val map : ('a -> 'b) -> 'a t -> 'b t
(* mapconst is definable as map % const. For example mapconst 4 [1,2,3] == [4,4,4]. Haskell calls mapconst <$ in Data.Functor and Control.Applicative. They also use $> for flip mapconst, and Control.Monad.void for mapconst (). *)
end
module type APPLICATIVE = sig
include MAPPABLE
val mid : 'a -> 'a t
val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
val mapply : ('a -> 'b) t -> 'a t -> 'b t
val (>>) : 'a t -> 'b t -> 'b t
val (<<) : 'a t -> 'b t -> 'a t
end
module type MONAD = sig
include APPLICATIVE
type 'a result
val run : 'a t -> 'a result
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
val (>=>) : ('a -> 'b t) -> ('b -> 'c t) -> ('a -> 'c t)
val (<=<) : ('b -> 'c t) -> ('a -> 'b t) -> ('a -> 'c t)
val join : 'a t t -> 'a t
val ignore : 'a t -> unit t
val seq : 'a t list -> 'a list t
val seq_ignore : unit t list -> unit t
val do_when : bool -> unit t -> unit t
val do_unless : bool -> unit t -> unit t
end
module type MONADT = sig
type 'a ut
include MONAD
val hoist : 'a ut -> 'a t
end
module type ZERO = sig
type 'a t
(* mzero is a value of type α that is exemplified by Nothing for the box type Maybe α and by [] for the box type List α. It has the behavior that anything ¢ mzero == mzero == mzero ¢ anything == mzero >>= anything. In Haskell, this notion is called Control.Applicative.empty or Control.Monad.mzero. *)
val mzero : 'a t
val guard : bool -> unit t
end
module type MONADZERO = sig
include MONAD
include ZERO with type 'a t := 'a t
end
module type MONADZEROT = sig
include MONADT
include ZERO with type 'a t := 'a t
end
module type MAPPABLE2 = sig
type ('a,'d) t
val map : ('a -> 'b) -> ('a,'d) t -> ('b,'d) t
end
module type APPLICATIVE2 = sig
include MAPPABLE2
val mid : 'a -> ('a,'d) t
val map2 : ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t
val mapply : ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t
val (>>) : ('a,'d) t -> ('b,'d) t -> ('b,'d) t
val (<<) : ('a,'d) t -> ('b,'d) t -> ('a,'d) t
end
module type MONAD2 = sig
include APPLICATIVE2
type ('a,'d) result
val run : ('a,'d) t -> ('a,'d) result
val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
val (>=>) : ('a -> ('b,'d) t) -> ('b -> ('c,'d) t) -> ('a -> ('c,'d) t)
val (<=<) : ('b -> ('c,'d) t) -> ('a -> ('b,'d) t) -> ('a -> ('c,'d) t)
val join : (('a,'d) t,'d) t -> ('a,'d) t
val ignore : ('a,'d) t -> (unit,'d) t
val seq : ('a,'d) t list -> ('a list,'d) t
val seq_ignore : (unit,'d) t list -> (unit,'d) t
val do_when : bool -> (unit,'d) t -> (unit,'d) t
val do_unless : bool -> (unit,'d) t -> (unit,'d) t
end
module type MONAD2T = sig
include MONAD2
type ('a,'d) ut
val hoist : ('a,'d) ut -> ('a,'d) t
end
module type MONADZERO2 = sig
include MONAD2
val mzero : ('a,'d) t
val guard : bool -> (unit,'d) t
end
module type MONADZERO2T = sig
include MONADZERO2
type ('a,'d) ut
val hoist : ('a,'d) ut -> ('a,'d) t
end
module Make = struct
module type MAP2 = sig
type 'a t
val mid : 'a -> 'a t
val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t]
val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t]
end
module type MAPPLY = sig
type 'a t
val mid : 'a -> 'a t
val mapply : ('a -> 'b) t -> 'a t -> 'b t
val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t]
val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t]
end
module type BIND = sig
type 'a t
type 'a result
val run : 'a t -> 'a result
val mid : 'a -> 'a t
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t]
val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t]
val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t]
end
module type COMP = sig
type 'a t
type 'a result
val run : 'a t -> 'a result
val mid : 'a -> 'a t
val (>=>) : ('a -> 'b t) -> ('b -> 'c t) -> ('a -> 'c t)
val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t]
val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t]
val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t]
end
module type JOIN = sig
type 'a t
type 'a result
val run : 'a t -> 'a result
val mid : 'a -> 'a t
val join : 'a t t -> 'a t
val map : ('a -> 'b) -> 'a t -> 'b t
val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t]
val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t]
end
module type TRANS = sig
module U : MONAD
type 'a t
type 'a result
val run : 'a t -> 'a result
(* Provide hoist, >>=; LAWS: 1. hoist U.(mid x) == mid x; 2. hoist U.(uu >>= k) == hoist uu >>= fun u -> hoist (k u) *)
val hoist : 'a U.t -> 'a t
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
end
module type TRANSUZ = sig
module U : MONADZERO
type 'a t
type 'a result
val run : 'a t -> 'a result
val hoist : 'a U.t -> 'a t
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
end
module type TRANSZ = sig
module U : MONAD
type 'a t
type 'a result
val run : 'a t -> 'a result
val hoist : 'a U.t -> 'a t
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
val mzero : 'a t
end
module ApplicativeFromBind(B : BIND) : APPLICATIVE with type 'a t = 'a B.t = struct
type 'a t = 'a B.t
let mid = B.mid
let (>>=) = B.(>>=)
let map = match B.map with
| `Custom map -> map
| `Generate -> fun f xx -> xx >>= fun x -> mid (f x)
let map2 = match B.map2 with
| `Custom map2 -> map2
| `Generate -> fun f xx yy -> xx >>= fun x -> yy >>= fun y -> mid (f x y)
let mapply = match B.map2 with
| `Custom map2 -> fun eta -> map2 ident eta
| `Generate -> fun ff xx -> ff >>= fun f -> map f xx
let (>>) xx yy = xx >>= fun _ -> yy
let (<<) xx yy = mapply (map const xx) yy
end
module ApplicativeFromMap2(B : MAP2) : APPLICATIVE with type 'a t = 'a B.t = struct
type 'a t = 'a B.t
let mid = B.mid
let map2 = B.map2
let mapply = match B.mapply with
| `Custom mapply -> mapply
| `Generate -> fun eta -> map2 ident eta
let map = match B.map with
| `Custom map -> map
| `Generate -> fun f xx -> mapply (mid f) xx
let (>>) xx yy = mapply (map (const ident) xx) yy
let (<<) xx yy = mapply (map const xx) yy
end
module ApplicativeFromApply(B : MAPPLY) : APPLICATIVE with type 'a t = 'a B.t = struct
type 'a t = 'a B.t
let mid = B.mid
let mapply = B.mapply
let map = match B.map with
| `Custom map -> map
| `Generate -> fun f xx -> mapply (mid f) xx
let map2 = match B.map2 with
| `Custom map2 -> map2
| `Generate -> fun f xx yy -> mapply (map f xx) yy
let (>>) xx yy = mapply (map (const ident) xx) yy
let (<<) xx yy = mapply (map const xx) yy
end
module MonadFromBind(B : BIND) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct
let (>>=) = B.(>>=)
include ApplicativeFromBind(B)
type 'a result = 'a B.result
let run = B.run
let (>=>) j k = fun a -> j a >>= k
let (<=<) k j = fun a -> j a >>= k
let join xxx = xxx >>= ident
let ignore xx = map (fun _ -> ()) xx
(* seq xxs = let f xx zzf = (xx >>=) . flip ((zzf.).(:)) in foldr f (return $) xxs [] *)
(*
foldr' f z xs = foldl (\g x z -> g (f x z)) id xs z -- foldr but evaluating from left?
foldl'' f z xs = foldr (\x g z -> g (f z x)) id xs z -- foldl but evaluating from right? these don't work
-- with foldr, evaluates left->right; with foldl the reverse
seq xxs =
let f c xx ret xs = xx >>= ret . c xs in -- careful! isn't fmap (c xs) xx because ret isn't (always) return
reverse <$> foldr (f $ flip (:)) return xxs []
-- or simply: foldr (f snoc) return xxs []
*)
let seq =
let rec aux xs = function
| [] -> mid (List.rev xs)
| xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
fun xxs -> aux [] xxs
let rec seq_ignore = function
| [] -> mid ()
| xx::xxs -> xx >>= fun () -> seq_ignore xxs
let do_when res xx = if res then xx else mid ()
let do_unless res xx = if res then mid () else xx
end
module MonadFromComp(B : COMP) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct
let (>=>) = B.(>=>)
let (<=<) k j = j >=> k
let (>>=) xx k = (ident >=> k) xx
include ApplicativeFromBind(struct include B let (>>=) = (>>=) end)
type 'a result = 'a B.result
let run = B.run
let join xxx = xxx >>= ident
let ignore xx = map (fun _ -> ()) xx
let seq =
let rec aux xs = function
| [] -> mid (List.rev xs)
| xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
fun xxs -> aux [] xxs
let rec seq_ignore = function
| [] -> mid ()
| xx::xxs -> xx >>= fun () -> seq_ignore xxs
let do_when res xx = if res then xx else mid ()
let do_unless res xx = if res then mid () else xx
end
module MonadFromJoin(B : JOIN) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct
let join = B.join
let (>>=) xx k = join (B.map k xx)
include ApplicativeFromBind(struct include B let (>>=) = (>>=) let map = `Custom B.map end)
type 'a result = 'a B.result
let run = B.run
let (>=>) j k = fun a -> j a >>= k
let (<=<) k j = fun a -> j a >>= k
let ignore xx = map (fun _ -> ()) xx
let seq =
let rec aux xs = function
| [] -> mid (List.rev xs)
| xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
fun xxs -> aux [] xxs
let rec seq_ignore = function
| [] -> mid ()
| xx::xxs -> xx >>= fun () -> seq_ignore xxs
let do_when res xx = if res then xx else mid ()
let do_unless res xx = if res then mid () else xx
end
module MonadFromT(B : TRANS) : MONADT with type 'a t = 'a B.t and type 'a result = 'a B.result and type 'a ut := 'a B.U.t = struct
include MonadFromBind(struct
include B
let mid x = hoist U.(mid x)
let map = `Generate let map2 = `Generate let mapply = `Generate
end)
let hoist = B.hoist
end
module MonadFromTUZ(B : TRANSUZ) : MONADZEROT with type 'a t = 'a B.t and type 'a result = 'a B.result and type 'a ut := 'a B.U.t = struct
let mzero = Obj.magic (B.hoist (B.U.mzero)) (* Obj.magic hack to generate enough polymorphism without having to thunk mzero *)
include MonadFromBind(struct
include B
let (>>=) xx k = xx >>= fun x -> try k x with Match_failure _ -> mzero
let mid x = hoist U.(mid x)
let map = `Generate let map2 = `Generate let mapply = `Generate
end)
let hoist = B.hoist
let guard res = if res then mid () else mzero
end
module MonadFromTZ(B : TRANSZ) : MONADZEROT with type 'a t = 'a B.t and type 'a result = 'a B.result and type 'a ut := 'a B.U.t = struct
include MonadFromBind(struct
include B
let (>>=) xx k = xx >>= fun x -> try k x with Match_failure _ -> mzero
let mid x = hoist U.(mid x)
let map = `Generate let map2 = `Generate let mapply = `Generate
end)
let hoist = B.hoist
let mzero = B.mzero
let guard res = if res then mid () else mzero
end
module type BIND2 = sig
type ('a,'d) t
type ('a,'d) result
val run : ('a,'d) t -> ('a,'d) result
val mid : 'a -> ('a,'d) t
val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t]
val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t]
val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t]
end
module type COMP2 = sig
type ('a,'d) t
type ('a,'d) result
val run : ('a,'d) t -> ('a,'d) result
val mid : 'a -> ('a,'d) t
val (>=>) : ('a -> ('b,'d) t) -> ('b -> ('c,'d) t) -> ('a -> ('c,'d) t)
val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t]
val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t]
val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t]
end
module type JOIN2 = sig
type ('a,'d) t
type ('a,'d) result
val run : ('a,'d) t -> ('a,'d) result
val mid : 'a -> ('a,'d) t
val join : (('a,'d) t,'d) t -> ('a,'d) t
val map : ('a -> 'b) -> ('a,'d) t -> ('b,'d) t
val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t]
val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t]
end
module type TRANS2 = sig
module U : MONAD2
type ('a,'d) t
type ('a,'d) result
val run : ('a,'d) t -> ('a,'d) result
val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
val hoist : ('a,'d) U.t -> ('a,'d) t
end
module type TRANSUZ2 = sig
module U : MONADZERO2
type ('a,'d) t
type ('a,'d) result
val run : ('a,'d) t -> ('a,'d) result
val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
val hoist : ('a,'d) U.t -> ('a,'d) t
end
module type TRANSZ2 = sig
module U : MONAD2
type ('a,'d) t
type ('a,'d) result
val run : ('a,'d) t -> ('a,'d) result
val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
val hoist : ('a,'d) U.t -> ('a,'d) t
val mzero : ('a,'d) t
end
module type MAP22 = sig
type ('a,'d) t
val mid : 'a -> ('a,'d) t
val map2 : ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t
val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t]
val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t]
end
module type MAPPLY2 = sig
type ('a,'d) t
val mid : 'a -> ('a,'d) t
val mapply : ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t
val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t]
val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t]
end
module Applicative2FromBind(B : BIND2) : APPLICATIVE2 with type ('a,'d) t = ('a,'d) B.t = struct
type ('a,'d) t = ('a,'d) B.t
let mid = B.mid
let (>>=) = B.(>>=)
let map = match B.map with
| `Custom map -> map
| `Generate -> fun f xx -> xx >>= fun x -> mid (f x)
let map2 = match B.map2 with
| `Custom map2 -> map2
| `Generate -> fun f xx yy -> xx >>= fun x -> yy >>= fun y -> mid (f x y)
let mapply = match B.map2 with
| `Custom map2 -> fun eta -> map2 ident eta
| `Generate -> fun ff xx -> ff >>= fun f -> map f xx
let (>>) xx yy = xx >>= fun _ -> yy
let (<<) xx yy = mapply (map const xx) yy
end
module Applicative2FromMap2(B : MAP22) : APPLICATIVE2 with type ('a,'d) t = ('a,'d) B.t = struct
type ('a,'d) t = ('a,'d) B.t
let mid = B.mid
let map2 = B.map2
let mapply = match B.mapply with
| `Custom mapply -> mapply
| `Generate -> fun eta -> map2 ident eta
let map = match B.map with
| `Custom map -> map
| `Generate -> fun f xx -> mapply (mid f) xx
let (>>) xx yy = mapply (map (const ident) xx) yy
let (<<) xx yy = mapply (map const xx) yy
end
module Applicative2FromApply(B : MAPPLY2) : APPLICATIVE2 with type ('a,'d) t = ('a,'d) B.t = struct
type ('a,'d) t = ('a,'d) B.t
let mid = B.mid
let mapply = B.mapply
let map = match B.map with
| `Custom map -> map
| `Generate -> fun f xx -> mapply (mid f) xx
let map2 = match B.map2 with
| `Custom map2 -> map2
| `Generate -> fun f xx yy -> mapply (map f xx) yy
let (>>) xx yy = mapply (map (const ident) xx) yy
let (<<) xx yy = mapply (map const xx) yy
end
module Monad2FromBind(B : BIND2) : MONAD2 with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) result = ('a,'d) B.result = struct
let (>>=) = B.(>>=)
include Applicative2FromBind(B)
type ('a,'d) result = ('a,'d) B.result
let run = B.run
let (>=>) j k = fun a -> j a >>= k
let (<=<) k j = fun a -> j a >>= k
let join xxx = xxx >>= ident
let ignore xx = map (fun _ -> ()) xx
let seq =
let rec aux xs = function
| [] -> mid (List.rev xs)
| xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
fun xxs -> aux [] xxs
let rec seq_ignore = function
| [] -> mid ()
| xx::xxs -> xx >>= fun () -> seq_ignore xxs
let do_when res xx = if res then xx else mid ()
let do_unless res xx = if res then mid () else xx
end
module Monad2FromComp(B : COMP2) : MONAD2 with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) result = ('a,'d) B.result = struct
let (>=>) = B.(>=>)
let (<=<) k j = j >=> k
let (>>=) xx k = (ident >=> k) xx
include Applicative2FromBind(struct include B let (>>=) = (>>=) end)
type ('a,'d) result = ('a,'d) B.result
let run = B.run
let join xxx = xxx >>= ident
let ignore xx = map (fun _ -> ()) xx
let seq =
let rec aux xs = function
| [] -> mid (List.rev xs)
| xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
fun xxs -> aux [] xxs
let rec seq_ignore = function
| [] -> mid ()
| xx::xxs -> xx >>= fun () -> seq_ignore xxs
let do_when res xx = if res then xx else mid ()
let do_unless res xx = if res then mid () else xx
end
module Monad2FromJoin(B : JOIN2) : MONAD2 with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) result = ('a,'d) B.result = struct
let join = B.join
let (>>=) xx k = join (B.map k xx)
include Applicative2FromBind(struct include B let (>>=) = (>>=) let map = `Custom B.map end)
type ('a,'d) result = ('a,'d) B.result
let run = B.run
let (>=>) j k = fun a -> j a >>= k
let (<=<) k j = fun a -> j a >>= k
let ignore xx = map (fun _ -> ()) xx
let seq =
let rec aux xs = function
| [] -> mid (List.rev xs)
| xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
fun xxs -> aux [] xxs
let rec seq_ignore = function
| [] -> mid ()
| xx::xxs -> xx >>= fun () -> seq_ignore xxs
let do_when res xx = if res then xx else mid ()
let do_unless res xx = if res then mid () else xx
end
module Monad2FromT(B : TRANS2) : MONAD2T with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) ut := ('a,'d) B.U.t and type ('a,'d) result = ('a,'d) B.result = struct
include Monad2FromBind(struct
include B
let mid x = hoist U.(mid x)
let map = `Generate let map2 = `Generate let mapply = `Generate
end)
let hoist = B.hoist
end
module Monad2FromTUZ(B : TRANSUZ2) : MONADZERO2T with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) ut := ('a,'d) B.U.t and type ('a,'d) result = ('a,'d) B.result = struct
include Monad2FromBind(struct
include B
let mid x = hoist U.(mid x)
let map = `Generate let map2 = `Generate let mapply = `Generate
end)
let hoist = B.hoist
let mzero = Obj.magic (B.hoist (B.U.mzero)) (* Obj.magic hack to generate enough polymorphism without having to thunk mzero *)
let guard res = if res then mid () else mzero
end
module Monad2FromTZ(B : TRANSZ2) : MONADZERO2T with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) ut := ('a,'d) B.U.t and type ('a,'d) result = ('a,'d) B.result = struct
include Monad2FromBind(struct
include B
let mid x = hoist U.(mid x)
let map = `Generate let map2 = `Generate let mapply = `Generate
end)
let hoist = B.hoist
let mzero = B.mzero
let guard res = if res then mid () else mzero
end
end (* Make *)
module type OPTION = sig
include MONADZERO with type 'a result = 'a option
val test : ('a option -> bool) -> 'a t -> 'a t
end
module type OPTIONT = sig
type 'a uresult
include MONADT with type 'a result = 'a option uresult
val test : ('a option ut -> bool) -> 'a t -> 'a t
end
module Option = struct
include Juli8.Option
module type EXTRA = sig
type 'a t
val test : ('a option (* U.t *) -> bool) -> 'a t -> 'a t
end
module type EXTRA2 = sig
type ('a,'d) t
val test : ('a option -> bool) -> ('a,'d) t -> ('a,'d) t
end
module M : OPTION = struct
include Make.MonadFromBind(struct
type 'a t = 'a option
type 'a result = 'a t let run xx = xx
let map = `Custom map let map2 = `Custom map2 let mapply = `Generate
let mid = some
(* val (>>=) : 'a option -> ('a -> 'b option) -> 'b option *)
let (>>=) xx k = match xx with Some x -> (try k x with Match_failure _ -> None) | None -> None
end)
let mzero = None
let guard res : unit t = if res then Some () else None
let test p xx = if p xx then xx else None
end (* Option.M *)
module M2 : sig
include MONADZERO2 with type ('a,'d) result = 'a option
include EXTRA2 with type ('a,'d) t := ('a,'d) t
end = struct
include Make.Monad2FromBind(struct
type ('a,'d) t = 'a option
type ('a,'d) result = ('a,'d) t let run xx = xx
let map = `Custom map let map2 = `Custom map2 let mapply = `Generate
let mid = some
let (>>=) xx k = match xx with Some x -> (try k x with Match_failure _ -> None) | None -> None
end)
let mzero = None
let guard res : (unit,'d) t = if res then Some () else None
let test p xx = if p xx then xx else None
end (* Option.M2 *)
module T(U : MONAD) : OPTIONT with type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
include Make.MonadFromTZ(struct
module U = U
type 'a t = 'a option U.t
type 'a result = 'a option U.result let run xx = U.run xx
let hoist uu = U.(uu >>= fun u -> mid (Some u))
let (>>=) xx k = U.(xx >>= function Some x -> k x | None -> mid None)
let mzero = Obj.magic U.(mid None)
end)
let test p xx = if p xx then xx else U.mid None
end (* Option.T *)
module T2(U : MONAD2) : sig
include MONADZERO2T with type ('a,'d) result = ('a option, 'd) U.result and type ('a,'d) ut := ('a,'d) U.t
include EXTRA2 with type ('a,'d) t := ('a,'d) t
val test : (('a option,'d) U.t -> bool) -> ('a,'d) t -> ('a,'d) t
end = struct
include Make.Monad2FromTZ(struct
module U = U
type ('a,'d) t = ('a option,'d) U.t
type ('a,'d) result = ('a option,'d) U.result let run xx = U.run xx
let hoist uu = U.(uu >>= fun u -> mid (Some u))
let (>>=) xx k = U.(xx >>= function Some x -> k x | None -> mid None)
let mzero = Obj.magic U.(mid None)
end)
let test p xx = if p xx then xx else U.mid None
end (* Option.T2 *)
end (* Option *)
module type LIST = sig
include MONADZERO with type 'a result = 'a list
val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
val pick : 'a t -> ('a * 'a t) t (* monadically pick each element *)
val test : ('a list -> bool) -> 'a t -> 'a t
end
module type LISTT = sig
type 'a uresult
include MONADZEROT with type 'a result = 'a list uresult
val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
val pick : 'a t -> ('a * 'a t) t (* monadically pick each element *)
val test : ('a list ut -> bool) -> 'a t -> 'a t
(*
Monadically seq k over box.
OptionM.seq (List.map (\a -> OptionM.mid $ a+1) int_list) == (after running)
ListOption.distribute (\a -> OptionM.mid $ a+1) int_list == Some [x+1,x+1,...]
TreeOption.distribute (\a -> OptionM.mid $ a+1) int_tree: works similarly
*)
val distribute : ('a -> 'b ut) -> 'a list -> 'b t
end
module List = struct
include Juli8.List
module type EXTRA2 = sig
type ('a,'d) t
val (++) : ('a,'d) t -> ('a,'d) t -> ('a,'d) t
val pick : ('a,'d) t -> ('a * ('a,'d) t,'d) t
val test : ('a list -> bool) -> ('a,'d) t -> ('a,'d) t
end
module M : LIST = struct
include Make.MonadFromBind(struct
type 'a t = 'a list
type 'a result = 'a t let run xx = xx
let map = `Custom (fun f xs -> map f xs) let map2 = `Custom (fun f xs -> map2 f xs) let mapply = `Generate
let mid = singleton
let (>>=) xx k = catmap (fun x -> try k x with Match_failure _ -> []) xx
end)
let mzero = []
let guard res : unit t = if res then [()] else []
(* (++) has tighter precedence than (>>=) *)
let (++) = append
let rec pick = function [] -> mzero | x::xs -> mid (x,xs) ++ (pick xs >>= fun (y,ys) -> mid (y, x::ys))
let test p xx = if p xx then xx else []
end (* List.M *)
module M2 : sig
include MONADZERO2 with type ('a,'d) result = 'a list
include EXTRA2 with type ('a,'d) t := ('a,'d) t
end = struct
include Make.Monad2FromBind(struct
type ('a,'d) t = 'a list
type ('a,'d) result = ('a,'d) t let run xx = xx
let map = `Custom (fun f xs -> map f xs) let map2 = `Custom (fun f xs -> map2 f xs) let mapply = `Generate
let mid = singleton
let (>>=) xx k = catmap (fun x -> try k x with Match_failure _ -> []) xx
end)
let mzero = []
let guard res : (unit,'d) t = if res then [()] else []
let (++) = append
let rec pick = function [] -> mzero | x::xs -> mid (x,xs) ++ (pick xs >>= fun (y,ys) -> mid (y, x::ys))
let test p xx = if p xx then xx else []
end (* List.M2 *)
module T(U : MONAD) : LISTT with type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
let distribute k xs = U.seq (List.map k xs)
include Make.MonadFromTZ(struct
module U = U
type 'a t = 'a list U.t
type 'a result = 'a list U.result let run xx = U.run xx
let hoist uu = U.(uu >>= fun u -> mid [u])
let (>>=) xx k = U.(xx >>= fun xs -> distribute k xs >>= fun xss -> mid (concat xss))
let mzero = Obj.magic U.(mid [])
end)
let (++) xx yy = U.(xx >>= fun xs -> yy >>= fun ys -> mid (append xs ys))
let rec pick xx = U.(>>=) xx (function [] -> mzero | x::xs -> mid (x, U.(mid xs)) ++ (pick U.(mid xs) >>= fun (y,yy) -> mid (y, U.(yy >>= fun ys -> mid (x::ys)))))
let test p xx = if p xx then xx else U.mid []
end (* List.T *)
module T2(U : MONAD2) : sig
include MONADZERO2T with type ('a,'d) result = ('a list,'d) U.result and type ('a,'d) ut := ('a,'d) U.t
include EXTRA2 with type ('a,'d) t := ('a,'d) t
val test : (('a list,'d) U.t -> bool) -> ('a,'d) t -> ('a,'d) t
val distribute : ('a -> ('b,'d) U.t) -> 'a list -> ('b,'d) t
end = struct
let distribute k xs = U.seq (List.map k xs)
include Make.Monad2FromTZ(struct
module U = U
type ('a,'d) t = ('a list,'d) U.t
type ('a,'d) result = ('a list,'d) U.result let run xx = U.run xx
let hoist uu = U.(uu >>= fun u -> mid [u])
let (>>=) xx k = U.(xx >>= fun xs -> distribute k xs >>= fun xss -> mid (concat xss))
let mzero = Obj.magic U.(mid [])
end)
let (++) xx yy = U.(xx >>= fun xs -> yy >>= fun ys -> mid (append xs ys))
let rec pick xx = U.(>>=) xx (function [] -> mzero | x::xs -> mid (x, U.(mid xs)) ++ (pick U.(mid xs) >>= fun (y,yy) -> mid (y, U.(yy >>= fun ys -> mid (x::ys)))))
let test p xx = if p xx then xx else U.mid []
end (* List.T2 *)
end (* List *)
(* LTree, unit centers, has natural ++ *)
(* ITree, unit leaves, has natural mzero *)
module type TREE = sig
type 'a tree
include MONAD with type 'a result = 'a tree
val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
end
module type TREET = sig
type 'a tree
type 'a uresult
include MONADT with type 'a result = 'a tree uresult
val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
(*
Monadically seq k over box.
OptionM.seq (List.map (\a -> OptionM.mid $ a+1) int_list) == (after running)
ListOption.distribute (\a -> OptionM.mid $ a+1) int_list == Some [x+1,x+1,...]
TreeOption.distribute (\a -> OptionM.mid $ a+1) int_tree: works similarly
*)
val distribute : ('a -> 'b ut) -> 'a tree -> 'b t
end
module LTree = struct
type 'a tree = Leaf of 'a | Branch of 'a tree * 'a tree
let branch x y = Branch(x,y)
let leaf x = Leaf x
let traverse ((++) : 'b -> 'b -> 'b) (k : 'a -> 'b) (xt : 'a tree) : 'b =
let rec aux = function
| Leaf x -> k x
| Branch(l, r) -> (* recursive application of k may delete a branch? *) aux l ++ aux r in
aux xt
let map (f : 'a -> 'b) (xt : 'a tree) =
let rec aux = function
| Leaf x -> Leaf (f x)
| Branch(l, r) -> Branch(aux l, aux r) in
aux xt
module M : TREE with type 'a tree := 'a tree = struct
include Make.MonadFromBind(struct
type 'a t = 'a tree
type 'a result = 'a t let run xx = xx
let map = `Custom map let map2 = `Generate let mapply = `Generate
let mid = leaf
let (>>=) xx k = traverse branch k xx
end)
let (++) xx yy = Branch(xx, yy)
end (* Tree.M *)
module T(U : MONAD) : TREET with type 'a tree := 'a tree and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
let hoist uu = U.(uu >>= fun u -> mid (Leaf u))
let distribute k xt = traverse (U.map2 branch) (fun x -> hoist (k x)) xt
include Make.MonadFromT(struct
module U = U
type 'a t = 'a tree U.t
type 'a result = 'a tree U.result let run xx = U.run xx
let hoist = hoist
let join xtt = traverse branch ident xtt
let (>>=) xx k = U.(>>=) xx (fun xt -> U.(>>=) (distribute k xt) (fun xtt -> U.mid (join xtt)))
end)
let (++) xx yy = U.(xx >>= fun xt -> yy >>= fun yt -> mid (Branch(xt,yt)))
end (* Tree.T *)
module Z(U : MONADZERO) : sig
include TREET with type 'a tree := 'a tree and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
include ZERO with type 'a t := 'a t
end = struct
let hoist uu = U.(uu >>= fun u -> mid (Leaf u))
let distribute k xt = traverse (U.map2 branch) (fun x -> hoist (k x)) xt
include Make.MonadFromTUZ(struct
module U = U
type 'a t = 'a tree U.t
type 'a result = 'a tree U.result let run xx = U.run xx
let hoist = hoist
let join xtt = traverse branch ident xtt
let (>>=) xx k = U.(>>=) xx (fun xt -> U.(>>=) (distribute k xt) (fun xtt -> U.mid (join xtt)))
end)
let (++) xx yy = U.(xx >>= fun xt -> yy >>= fun yt -> mid (Branch(xt,yt)))
end (* Tree.Z *)
end (* Tree *)
module Identity = struct
module M : sig
include MONAD with type 'a result = 'a
end = struct
include Make.MonadFromComp(struct
type 'a t = 'a
type 'a result = 'a t let run xx = xx
let map = `Custom (fun f x -> f x) let map2 = `Custom (fun f x y -> f x y) let mapply = `Custom (fun f x -> f x)
let mid = ident
let (>=>) j k = fun x -> k (j x)
end)
end
end
module type READER = sig
type env
include MONAD with type 'a result = env -> 'a
val ask : env t
val asks : (env -> 'a) -> 'a t
val shift : (env -> env) -> 'a t -> 'a t
end
module type READERT = sig
type env
type 'a uresult
include MONADT with type 'a result = env -> 'a uresult
val ask : env t
val asks : (env -> 'a) -> 'a t
val shift : (env -> env) -> 'a t -> 'a t
end
(* must be parameterized on `struct type env = ... end` *)
module Reader(E : sig type env end) = struct
type env = E.env
module M : READER with type env := env = struct
include Make.MonadFromBind(struct
type 'a t = env -> 'a
type 'a result = 'a t let run xx = fun e -> xx e
let map = `Generate let map2 = `Generate let mapply = `Generate
let mid x = fun e -> x
let (>>=) xx k = fun e -> let x = xx e in let xx' = k x in xx' e
end)
let ask = fun e -> e
let asks selector = ask >>= (fun e -> mid (selector e)) (* may fail with Not_found *)
let shift modifier xx = fun e -> xx (modifier e)
end (* Reader.M *)
module T(U : MONAD) : READERT with type env := env and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
include Make.MonadFromT(struct
module U = U
type 'a t = env -> 'a U.t
type 'a result = env -> 'a U.result let run xx = fun e -> U.run (xx e)
let hoist uu = fun e -> uu
let (>>=) xx k = fun e -> U.(xx e >>= fun x -> k x e)
end)
let ask = U.mid
let asks selector = ask >>= (fun e -> mid (selector e)) (* may fail with Not_found *)
let shift modifier xx = fun e -> xx (modifier e)
end (* Reader.T *)
module Z(U : MONADZERO) : sig
include READERT with type env := env and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
include ZERO with type 'a t := 'a t
end = struct
include Make.MonadFromTUZ(struct
module U = U
type 'a t = env -> 'a U.t
type 'a result = env -> 'a U.result let run xx = fun e -> U.run (xx e)
let hoist uu = fun e -> uu
let (>>=) xx k = fun e -> U.(xx e >>= fun x -> k x e)
end)
let ask = U.mid
let asks selector = ask >>= (fun e -> try mid (selector e) with Not_found -> mzero)
let shift modifier xx = fun e -> xx (modifier e)
end (* Reader.Z *)
end (* Reader *)
module type STATE = sig
type store
include MONAD with type 'a result = store -> 'a * store
val get : store t
val gets : (store -> 'a) -> 'a t
val put : store -> unit t
val modify : (store -> store) -> unit t
end
module type STATET = sig
type store
type 'a uresult
include MONADT with type 'a result = store -> ('a * store) uresult
val get : store t
val gets : (store -> 'a) -> 'a t
val put : store -> unit t
val modify : (store -> store) -> unit t
end
(* must be parameterized on `struct type store = ... end` *)
module State(S : sig type store end) = struct
type store = S.store
module M : STATE with type store := store = struct
include Make.MonadFromBind(struct
type 'a t = store -> 'a * store
type 'a result = 'a t let run xx = fun s -> xx s
let map = `Generate let map2 = `Generate let mapply = `Generate
let mid x = fun s -> x, s
let (>>=) xx k = fun s -> let (x,s') = xx s in let xx' = k x in xx' s'
end)
let get = fun s -> s,s
(* `gets viewer` is `map viewer get` *)
let gets viewer = fun s -> viewer s, s (* may fail with Not_found *)
let put s = fun _ -> (), s
let modify modifier = fun s -> (), modifier s
end (* State.M *)
module T(U : MONAD) : STATET with type store := store and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
include Make.MonadFromT(struct
module U = U
type 'a t = store -> ('a * store) U.t
type 'a result = store -> ('a * store) U.result let run xx = fun s -> U.run (xx s)
let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s))
let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s')
end)
let get = fun s -> U.mid (s,s)
let gets viewer = fun s -> U.mid (viewer s, s) (* may fail with Not_found *)
let put s = fun _ -> U.mid ((), s)
let modify modifier = fun s -> U.mid ((), modifier s)
end (* State.T *)
module Z(U : MONADZERO) : sig
include STATET with type store := store and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
include ZERO with type 'a t := 'a t
end = struct
include Make.MonadFromTUZ(struct
module U = U
type 'a t = store -> ('a * store) U.t
type 'a result = store -> ('a * store) U.result let run xx = fun s -> U.run (xx s)
let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s))
let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s')
end)
let get = fun s -> U.mid (s,s)
let gets viewer = fun s -> try U.mid (viewer s, s) with Not_found -> mzero s
let put s = fun _ -> U.mid ((), s)
let modify modifier = fun s -> U.mid ((), modifier s)
end (* State.Z *)
end (* State *)
module type REF = sig
type ref
type value
include MONAD with type 'a result = 'a
val newref : value -> ref t
val deref : ref -> value t
val change : ref -> value -> unit t
end
module type REFT = sig
type ref
type value
type 'a uresult
include MONADT with type 'a result = 'a uresult
val newref : value -> ref t
val deref : ref -> value t
val change : ref -> value -> unit t
end
(* State with a different interface; must be parameterized on `struct type value = ... end` *)
module Ref(V : sig type value end) = struct
type ref = int
type value = V.value
module D = Map.Make(struct type t = ref let compare = compare end)
type dict = { next : ref; tree : value D.t }
let empty = { next = 0; tree = D.empty }
let alloc v d = d.next, { next = succ d.next; tree = D.add d.next v d.tree}
let read (k : ref) d = D.find k d.tree
let write (k : ref) v d = { next = d.next; tree = D.add k v d.tree }
module M : REF with type value := value and type ref := ref = struct
include Make.MonadFromBind(struct
type 'a t = dict -> 'a * dict
type 'a result = 'a let run xx = fst (xx empty)
let map = `Generate let map2 = `Generate let mapply = `Generate
let mid x = fun s -> x, s
let (>>=) xx k = fun s -> let (x,s') = xx s in let xx' = k x in xx' s'
end)
let newref v = fun s -> alloc v s
let deref k = fun s -> read k s, s (* shouldn't fail because k will have an abstract type? and we never GC *)
let change k v = fun s -> (), write k v s (* shouldn't allocate because k will have an abstract type *)
end (* Ref.M *)
module T(U : MONAD) : REFT with type value := value and type ref := ref and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
include Make.MonadFromT(struct
module U = U
type 'a t = dict -> ('a * dict) U.t
type 'a result = 'a U.result let run xx = let uu = U.(xx empty >>= fun (x,s) -> mid x) in U.run uu
let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s))
let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s')
end)
let newref v = fun s -> U.mid (alloc v s)
let deref k = fun s -> U.mid (read k s, s)
let change k v = fun s -> U.mid ((), write k v s)
end (* Ref.T *)
module Z(U : MONADZERO) : sig
include REFT with type value := value and type ref := ref and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
include ZERO with type 'a t := 'a t
end = struct
include Make.MonadFromTUZ(struct
module U = U
type 'a t = dict -> ('a * dict) U.t
type 'a result = 'a U.result let run xx = let uu = U.(xx empty >>= fun (x,s) -> mid x) in U.run uu
let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s))
let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s')
end)
let newref v = fun s -> U.mid (alloc v s)
let deref k = fun s -> U.mid (read k s, s)
let change k v = fun s -> U.mid ((), write k v s)
end (* Ref.Z *)
end (* Ref *)
module type WRITER = sig
type log
include MONAD with type 'a result = 'a * log
val listen : 'a t -> ('a * log) t
val listens : (log -> 'b) -> 'a t -> ('a * 'b) t
val tell : log -> unit t
(* val pass : ('a * (log -> log)) t -> 'a t *)
val censor : (log -> log) -> 'a t -> 'a t
end
module type WRITERT = sig
type log
type 'a uresult
include MONADT with type 'a result = ('a * log) uresult
val listen : 'a t -> ('a * log) t
val listens : (log -> 'b) -> 'a t -> ('a * 'b) t
val tell : log -> unit t
(* val pass : ('a * (log -> log)) t -> 'a t *)
val censor : (log -> log) -> 'a t -> 'a t
end
(* must be parameterized on `struct type log = ... end` *)
module Writer(W : sig type log val empty : log val append : log -> log -> log end) = struct
type log = W.log
module M : WRITER with type log := log = struct
include Make.MonadFromBind(struct
type 'a t = 'a * log
type 'a result = 'a t let run xx = xx
let map = `Generate let map2 = `Generate let mapply = `Generate
let mid x = x, W.empty
let (>>=) (x,w) k = let (y,w') = k x in (y, W.append w w')
end)
let listen (x,w) = (x,w), w
let listens selector xx = listen xx >>= fun (x,w) -> mid (x,selector w) (* filter listen through selector *)
let tell entries = (), entries (* add to log *)
let pass ((x,c),w) = (x, c w) (* usually use censor *)
let censor c xx = pass (xx >>= fun x -> mid (x,c)) (* ==> (x, c w) *)
end (* Writer.M *)
module T(U : MONAD) : WRITERT with type log := log and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
include Make.MonadFromT(struct
module U = U
type 'a t = ('a * log) U.t
type 'a result = ('a * log) U.result let run xx = U.run xx
let hoist uu = U.(uu >>= fun u -> mid (u, W.empty))
let (>>=) xx k = U.(xx >>= fun (x,w) -> k x >>= fun (y,w') -> mid (y, W.append w w'))
end)
let listen xx = U.(xx >>= fun (x,w) -> mid ((x,w),w))
let listens selector xx = listen xx >>= fun (x,w) -> mid (x,selector w)
let tell entries = U.mid ((), entries)
let pass xx = U.(xx >>= fun ((x,c),w) -> mid (x, c w))
let censor c xx = pass (xx >>= fun x -> mid (x,c))
end (* Writer.T *)
module Z(U : MONADZERO) : sig
include WRITERT with type log := log and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
include ZERO with type 'a t := 'a t
end = struct
include Make.MonadFromTUZ(struct
module U = U
type 'a t = ('a * log) U.t
type 'a result = ('a * log) U.result let run xx = U.run xx
let hoist uu = U.(uu >>= fun u -> mid (u, W.empty))
let (>>=) xx k = U.(xx >>= fun (x,w) -> k x >>= fun (y,w') -> mid (y, W.append w w'))
end)
let listen xx = U.(xx >>= fun (x,w) -> mid ((x,w),w))
let listens selector xx = listen xx >>= fun (x,w) -> mid (x,selector w)
let tell entries = U.mid ((), entries)
let pass xx = U.(xx >>= fun ((x,c),w) -> mid (x, c w))
let censor c xx = pass (xx >>= fun x -> mid (x,c))
end (* Writer.Z *)
end (* Writer *)
module type ERROR = sig
type msg
type 'a error
include MONAD with type 'a result = 'a error
val throw : msg -> 'a t
val catch : 'a t -> (msg -> 'a t) -> 'a t
end
module type ERRORT = sig
type msg
type 'a error
type 'a uresult
include MONADT with type 'a result = 'a uresult (* note the difference from ERROR *)
val throw : msg -> 'a t
val catch : 'a t -> (msg -> 'a t) -> 'a t
end
(* must be parameterized on `struct type msg = ... end` *)
module Error(E : sig type msg exception Exc of msg (* Exc used only by T *) end) = struct
type msg = E.msg
type 'a error = Error of msg | OK of 'a
module M : ERROR with type msg := msg and type 'a error := 'a error = struct
include Make.MonadFromBind(struct
type 'a t = 'a error
type 'a result = 'a t
(* note that M.run doesn't raise *)
let run xx = xx
let map = `Generate let map2 = `Generate let mapply = `Generate
let mid x = OK x
let (>>=) xx k = match xx with OK x -> k x | Error e -> Error e
end)
let throw e = Error e
let catch xx handler = match xx with OK _ -> xx | Error e -> handler e
end (* Error.M *)
module T(U : MONAD) : ERRORT with type msg := msg and type 'a error := 'a error and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
include Make.MonadFromT(struct
module U = U
type 'a t = 'a error U.t
type 'a result = 'a U.result
(* note that T.run does raise *)
let run xx = let uu = U.(xx >>= function OK x -> mid x | Error e -> raise (E.Exc e)) in U.run uu
let hoist uu = U.(uu >>= fun u -> mid (OK u))
let (>>=) xx k = U.(xx >>= function OK x -> k x | Error e -> mid (Error e))
end)
let throw e = U.mid (Error e)
let catch xx handler = U.(xx >>= function OK _ as x -> mid x | Error e -> handler e)
end (* Error.T *)
module Z(U : MONADZERO) : sig
include ERRORT with type msg := msg and type 'a error := 'a error and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
include ZERO with type 'a t := 'a t
end = struct
include Make.MonadFromTUZ(struct
module U = U
type 'a t = 'a error U.t
type 'a result = 'a U.result
(* we recover from error by using U's mzero; but this discards the error msg *)
let run xx = let uu = U.(xx >>= function OK x -> mid x | Error e -> mzero) in U.run uu
let hoist uu = U.(uu >>= fun u -> mid (OK u))
let (>>=) xx k = U.(xx >>= function OK x -> k x | Error e -> mid (Error e))
end)
let throw e = U.mid (Error e)
let catch xx handler = U.(xx >>= function OK _ as x -> mid x | Error e -> handler e)
end (* Error.Z *)
end (* Error *)
(* predefine some common instances *)
module Writer1 = Writer(struct type log = string let empty = "" let append s1 s2 = if s2 = "" then s1 else if s1 = "" then s2 else s1 ^ "\n" ^ s2 end)
module Writer2 = struct
include Writer(struct
type log = string list
let empty = []
let append s1 s2 = List.append s2 s1
end)
(* FIXME these aren't inside M *)
let tell_string s = M.tell [s]
let tell entries = M.tell (List.rev entries)
let run xx = let (x,w) = M.run xx in (x, List.rev w)
end
module Failure = Error(struct type msg = string exception Exc = Failure end)
end (* Monad *)
module Option = Monad.Option
module List = Monad.List