hs.ml

module type FUNCTOR = sig
  type 'a t
  val map : ('a -> 'b) -> 'a t -> 'b t
end

module type APPLY = sig
  include FUNCTOR
  val ap : ('a -> 'b) t -> 'a t -> 'b t
end

module type POINTED = sig
  include FUNCTOR
  val pure : 'a -> 'a t
end

module type MONAD = sig
  include POINTED
  include APPLY with type 'a t := 'a t
  val bind : 'a t -> ('a -> 'b t) -> 'b t
end

module FunctorFromApp
  (Ap : sig
          include APPLY
          include POINTED with type 'a t := 'a t
        end
  )
      : FUNCTOR with type 'a t = 'a Ap.t
= struct
  type 'a t = 'a Ap.t

  let map f = Ap.ap @@ Ap.pure f
end

module AppFromMonad
  (M : MONAD)
     : APPLY with type 'a t = 'a M.t
= struct
  include FunctorFromApp(M)

  let ap mf mx =
    M.bind mf @@ fun f ->
    M.bind mx @@ fun x ->
    M.pure (f x)
end

module type SHOW = sig
  type t
  val show : t -> string
end

module type SHOW1 = sig
  type 'a t
  val show : string t -> string
end

module ShowFromShow1
  (S1 : sig
          include SHOW1
          include FUNCTOR with type 'a t := 'a t
        end
  )
  (S  : SHOW)
      : SHOW with type t = S.t S1.t
= struct
  type t = S.t S1.t

  let show xs = S1.show (S1.map S.show xs)
end

module rec ListM :
  sig
    include MONAD with type 'a t  = 'a list
    include SHOW1 with type 'a t := 'a list
  end
= struct
  type 'a t = 'a list

  let bind xs f = List.flatten @@ List.map f xs

  let pure x = [x]

  include (AppFromMonad(ListM) : APPLY with type 'a t := 'a t)

  let show xs = String.concat "," xs
end

module Int : SHOW with type t = int
= struct
  type t = int
  let show = string_of_int
end

module IntList = ShowFromShow1(ListM)(Int)

let show
  (type   t)
  (module S : SHOW with type t = t)
  (       x : S.t)
            : string
  = S.show x

(*
let show1
  (type   t)
  (module F  : FUNCTOR)
  (module S  : SHOW  with type t = t)
  (module S1 : SHOW1 with type 'a t = 'a F.t)
  (       x  : S.t S1.t)
             : string
  = S.show x
*)

module type FREE_MONAD
  = functor (F : FUNCTOR) ->
    sig
      type 'a t
      val wrap :  'a F.t -> 'a t
      val fold : ('a F.t -> 'a) -> 'a t -> 'a
      include MONAD with type 'a t := 'a t
    end

module Free : FREE_MONAD
  = functor (F : FUNCTOR) ->
struct
  type 'a t =
    | Pure of 'a
    | Free of 'a t F.t

  let wrap (fx : 'a F.t) : 'a t = Free (F.map (fun x -> Pure x) fx)

  let fold f =
    let rec aux = function
      | Pure x  -> x
      | Free fx -> f @@ F.map aux fx
    in aux

  let pure a = Pure a

  let rec bind free f =
    match free with
    | Pure a  -> f a
    | Free fx -> Free (F.map (fun tree -> bind tree f) fx)

  let ap mf mx =
    bind mf @@ fun f ->
    bind mx @@ fun x ->
    pure (f x)

  let map f xs =
    bind xs @@ fun x ->
    pure (f x)
end

module type Transform =
  functor (F : FUNCTOR) ->
  functor (G : FUNCTOR) ->
  sig
    module F = F
    module G = G
    val nat : 'a F.t -> 'a G.t
  end

let hoist
  (module T   : Transform)
  (       src : 'a (Free(T.F)).t)
              : 'a (Free(T.G)).t
  = 1

let () =
  print_string
    @@ IntList.show
    @@ (ListM.bind [1;2;3] (fun x -> [x; x * 2]));

  print_newline ()