vlan

module type FunctorType =
sig
  type 'a t
  val map : ('a -> 'b) -> 'a t -> 'b t
  (** Laws:

      map id x = x
      map (f . g) = map f . map g *)
end

module type PointedType =
sig
  include FunctorType
  val pure : 'a -> 'a t
  (** Law:

      map f . pure = pure . f *)
end

module type ApplicativeType =
sig
  include PointedType
  val (<*>) : ('a -> 'b) t -> 'a t -> 'b t
  (** Law:

      map f x = pure f <*> x *)
end

module type MonadType =
sig
  include ApplicativeType
  val join : 'a t t -> 'a t
  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
  val (>>) : 'a t -> 'b t -> 'b t
  (** Laws:

      pure a >>= f = f a
      x >>= pure = x
      map f x = x >>= pure . f *)
end

module OptionMonad =
struct
  type 'a t = 'a option

  let map f x =
    match x with
      | Some x' -> Some (f x')
      | None -> None

  let pure x = Some x

  let (<*>) f x =
    match (f, x) with
      | (Some f', Some x') -> Some (f' x')
      | _ -> None

  let join x =
    match x with
      | Some x' -> x'
      | None -> None

  let (>>=) x f = join (pure f <*> x)
  let (>>) x y = x >>= fun _ -> y
end

module MakeDummy (Functor : FunctorType) =
struct
  let id x = x
  let ($.) f g x = f (g x)

  let test_id x =
    (x = Functor.map id x)

  let test_compose f g x =
    let left = Functor.map (f $. g) x in
    let right = (Functor.map f $. Functor.map g) x in
    (left = right)
end

module MakeSumInMonad (Monad : MonadType) =
struct
  let (>>=) = Monad.(>>=)
  let return = Monad.pure

  let maybe_div a b =
    match (a, b) with
      | (Some a', Some b') ->
        if b' = 0 then
          None
        else
          Some (a' / b')
      | _ -> None

  let (+) a b =
    a >>= fun a' ->
    b >>= fun b' ->
    return (Pervasives.(+) a' b')
end

module Dummy = MakeDummy (OptionMonad)
module SumInMaybe = MakeSumInMonad (OptionMonad)

let main () =
  let id x = x in
  let app x y = y ^ x in
  let bar = app "bar" in
  let (/?) = SumInMaybe.maybe_div in
  let (+?) = SumInMaybe.(+) in
  begin
    assert (Dummy.test_id (Some "foo"));
    assert (Dummy.test_id None);
    assert (Dummy.test_compose bar bar (Some "foo"));
    assert (Dummy.test_compose bar bar None);
    assert (Dummy.test_compose id id (Some "foo"));
    assert ((Some 4) /? (Some 2) +? (Some 3) /? (Some 1) = (Some 5));
    assert ((Some 4) /? (Some 0) +? (Some 3) /? (Some 1) = None);
  end
;;

main ()