--- /dev/null
+(* 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
+ include MONAD
+ type 'a ut
+ val hoist : 'a ut -> 'a t
+ end
+
+ module type MONADZERO = sig
+ include MONAD
+ (* 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 MONADZEROT = sig
+ include MONADZERO
+ type 'a ut
+ val hoist : 'a ut -> '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 ut := 'a B.U.t and type 'a result = 'a B.result = 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 ut := 'a B.U.t and type 'a result = 'a B.result = 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 ut := 'a B.U.t and type 'a result = 'a B.result = 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 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 : sig
+ include MONADZERO with type 'a result = 'a option
+ include EXTRA with type 'a t := 'a t
+ end = 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) : sig
+ include MONADZEROT with type 'a result = 'a option U.result and type 'a ut := 'a U.t
+ include EXTRA with type 'a t := 'a t
+ val test : ('a option U.t -> bool) -> 'a t -> 'a t
+ end = 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 List = struct
+ include Juli8.List
+ module type EXTRA = sig
+ type 'a t
+ 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 (* U.t *) -> bool) -> 'a t -> 'a t
+ end
+ 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 : sig
+ include MONADZERO with type 'a result = 'a list
+ include EXTRA with type 'a t := 'a t
+ end = 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) : sig
+ include MONADZEROT with type 'a result = 'a list U.result and type 'a ut := 'a U.t
+ include EXTRA with type 'a t := 'a t
+ val test : ('a list U.t -> bool) -> 'a t -> 'a t
+ (*
+ Monadically seq k over box<a>.
+ 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 U.t) -> 'a list -> 'b t
+ end = 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 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 type EXTRA = sig
+ type 'a t
+ val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
+ end
+ module M : sig
+ include MONAD with type 'a result = 'a tree
+ include EXTRA with type 'a t := 'a t
+ end = 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) : sig
+ include MONADT with type 'a result = 'a tree U.result and type 'a ut := 'a U.t
+ include EXTRA with type 'a t := 'a t
+ (*
+ Monadically seq k over box<a>.
+ 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 U.t) -> 'a tree -> 'b 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.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 MONADZEROT with type 'a result = 'a tree U.result and type 'a ut := 'a U.t
+ include EXTRA with type 'a t := 'a t
+ val distribute : ('a -> 'b U.t) -> 'a tree -> 'b 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
+
+ (* must be parameterized on `struct type env = ... end` *)
+ module Reader(E : sig type env end) = struct
+ type env = E.env
+ module type EXTRA = sig
+ type 'a t
+ val ask : env t
+ val asks : (env -> 'a) -> 'a t
+ val shift : (env -> env) -> 'a t -> 'a t
+ end
+ module M : sig
+ include MONAD with type 'a result = env -> 'a
+ include EXTRA with type 'a t := 'a t
+ end = 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) : sig
+ include MONADT with type 'a result = env -> 'a U.result and type 'a ut := 'a U.t
+ include EXTRA with type 'a t := 'a t
+ end = 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 MONADZEROT with type 'a result = env -> 'a U.result and type 'a ut := 'a U.t
+ include EXTRA 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 *)
+
+ (* must be parameterized on `struct type store = ... end` *)
+ module State(S : sig type store end) = struct
+ type store = S.store
+ module type EXTRA = sig
+ type 'a t
+ val get : store t
+ val gets : (store -> 'a) -> 'a t
+ val put : store -> unit t
+ val modify : (store -> store) -> unit t
+ end
+ module M : sig
+ include MONAD with type 'a result = store -> 'a * store
+ include EXTRA with type 'a t := 'a t
+ end = 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) : sig
+ include MONADT with type 'a result = store -> ('a * store) U.result and type 'a ut := 'a U.t
+ include EXTRA with type 'a t := 'a t
+ end = 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 MONADZEROT with type 'a result = store -> ('a * store) U.result and type 'a ut := 'a U.t
+ include EXTRA 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 *)
+
+ (* 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 type EXTRA = sig
+ type 'a t
+ val newref : value -> ref t
+ val deref : ref -> value t
+ val change : ref -> value -> unit t
+ end
+ module M : sig
+ include MONAD with type 'a result = 'a
+ include EXTRA with type 'a t := 'a t
+ end = 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) : sig
+ include MONADT with type 'a result = 'a U.result and type 'a ut := 'a U.t
+ include EXTRA with type 'a t := 'a t
+ end = 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 MONADZEROT with type 'a result = 'a U.result and type 'a ut := 'a U.t
+ include EXTRA 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 *)
+
+ (* 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 type EXTRA = sig
+ type 'a t
+ 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 M : sig
+ include MONAD with type 'a result = 'a * log
+ include EXTRA with type 'a t := 'a t
+ end = 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) : sig
+ include MONADT with type 'a result = ('a * log) U.result and type 'a ut := 'a U.t
+ include EXTRA with type 'a t := 'a t
+ end = 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 MONADZEROT with type 'a result = ('a * log) U.result and type 'a ut := 'a U.t
+ include EXTRA 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 *)
+
+ (* must be parameterized on `struct type err = ... end` *)
+ module Error(E : sig type err exception Exc of err end) = struct
+ type err = E.err
+ type 'a error = Error of err | OK of 'a
+ module type EXTRA = sig
+ type 'a t
+ val throw : err -> 'a t
+ val catch : 'a t -> (err -> 'a t) -> 'a t
+ end
+ module M : sig
+ include MONAD with type 'a result = 'a error
+ include EXTRA with type 'a t := 'a t
+ end = struct
+ include Make.MonadFromBind(struct
+ type 'a t = 'a error
+ type 'a result = 'a t 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) : sig
+ include MONADT with type 'a result = 'a U.result and type 'a ut := 'a U.t
+ include EXTRA with type 'a t := 'a t
+ end = struct
+ include Make.MonadFromT(struct
+ module U = U
+ type 'a t = 'a error U.t
+ type 'a result = 'a U.result
+ 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 MONADZEROT with type 'a result = 'a U.result and type 'a ut := 'a U.t
+ include EXTRA 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 = 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 err = string exception Exc = Failure end)
+
+end (* Monad *)
+
+module Option = Monad.Option
+module List = Monad.List
+