+++ /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
- 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<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 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<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 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
-