70 lines
1.7 KiB
Text
70 lines
1.7 KiB
Text
module type Functor = sig
|
|
type 'a t
|
|
val map : ('a -> 'b) -> 'a t -> 'b t
|
|
end
|
|
|
|
module type Applicative = sig
|
|
type 'a t
|
|
val pure : 'a -> 'a t
|
|
val apply : ('a -> 'b) t -> 'a t -> 'b t
|
|
end
|
|
|
|
module type Monad = sig
|
|
type 'a t
|
|
val return : 'a -> 'a t
|
|
val bind : ('a -> 'b t) -> 'a t -> 'b t
|
|
end
|
|
|
|
module ApplicativeOfMonad (M : Monad) : Applicative with type 'a t = 'a M.t = struct
|
|
type 'a t = 'a M.t
|
|
let pure = M.return
|
|
let apply f x = M.(bind (fun y -> bind (fun g -> return (g y)) f) x)
|
|
end
|
|
|
|
module FunctorOfApplicative (A : Applicative) : Functor with type 'a t = 'a A.t = struct
|
|
type 'a t = 'a A.t
|
|
let map f x = A.(apply (pure f) x)
|
|
end
|
|
|
|
module FunctorOfMonad (M : Monad) : Functor with type 'a t = 'a M.t = struct
|
|
include FunctorOfApplicative(ApplicativeOfMonad(M))
|
|
end
|
|
|
|
module MonadDerive (M : Monad) = struct
|
|
include M
|
|
include ApplicativeOfMonad(M)
|
|
include FunctorOfMonad(M)
|
|
let (>>=) x f = bind f x
|
|
let (<$>) x f = map x f
|
|
let (<*>) x f = apply x f
|
|
end
|
|
|
|
module ListMonad = struct
|
|
type 'a t = 'a list
|
|
let return x = [x]
|
|
let rec bind (f : 'a -> 'b list) : 'a list -> 'b list = function
|
|
| [] -> []
|
|
| x :: xs -> f x @ bind f xs
|
|
end
|
|
|
|
module Dlm = MonadDerive(ListMonad)
|
|
|
|
let pair x y = x, y
|
|
let cart_prod xs ys = Dlm.(pair <$> xs <*> ys)
|
|
|
|
let () = cart_prod [1;2;3;4] ["7"; "hello there"; "forthwith!"]
|
|
|> List.iter (fun (x, y) -> print_endline @@ "(" ^ string_of_int x ^ ", " ^ y ^ ")")
|
|
|
|
|
|
|
|
(* ============================================================================================= *)
|
|
|
|
module StateMonad (S : sig type t end) = struct
|
|
type 'a t = S.t -> S.t * 'a
|
|
let return x s = (s, x)
|
|
let bind f x s = let s', a = x s in f a s'
|
|
end
|
|
|
|
module IntStateMonad = StateMonad(struct type t = int end)
|
|
|
|
|