higher_monadic.ml

#require "higher";;

open Higher

type 'f functr = {
  fmap : 'a 'b. ('a -> 'b) -> ('a, 'f) app -> ('b, 'f) app
}

type 'f applicative = {
  app : 'a 'b. ('a -> 'b, 'f) app -> ('a, 'f) app -> ('b, 'f) app;
  pure : 'a. 'a -> ('a, 'f) app;
}

type 'm monad = {
  bind : 'a 'b. ('a, 'm) app -> ('a -> ('b, 'm) app) -> ('b, 'm) app;
  return : 'a. 'a -> ('a, 'm) app
}

module type MHI = sig
  type 'a s
  type t
  val inj : 'a s -> ('a, t) app
  val prj : ('a, t) app -> 'a s
end

module MHigher(M : MHI) = struct
  include M
  let (let+) x k = prj x |> k

  let (let*) x k = k x
  let (and*) x y = (prj x, prj y)
let return = inj
end

module type MCONSTRUCT = sig
  type 'a s
  type t
  val inj : 'a s -> ('a, t) app
  val prj : ('a, t) app -> 'a s
  val functr : t functr
  val applicative : t applicative
  val monad : t monad
end

module Monad(M : MCONSTRUCT) = struct
  open M

  let {fmap} = functr
  let (<$>) = fmap

  let {app; pure} = applicative
  let (<*>) = app

  let {bind; return} = monad

  let (>>=) x k = bind (inj x) k
  let (let+) = (>>=)
end

module Id : MCONSTRUCT with type 'a s = 'a = struct
  include MHigher(Newtype1(struct type 'a t = 'a end))

  let functr = {
    fmap = fun f fa ->
      let+ fa = fa in
      return @@ f fa
  }

  let applicative = {
    pure = inj;
    app = fun fab fa ->
      let* fa = fa
      and* fab = fab in
      return @@ fab fa
  }

  let monad = {
    return = inj;
    bind = fun x k -> k @@ prj x
  }
end

module Maybe : MCONSTRUCT with type 'a s = 'a option = struct
  include MHigher(Newtype1(struct type 'a t = 'a option end))

  let functr = {
    fmap = fun f fa ->
      let+ fa = fa in
      return @@ match fa with
      | Some a -> Some(f a)
      | _ -> None
  }

  let applicative = {
    pure = (fun x -> inj @@ Some x);
    app = fun fab fa ->
      let+ fab = fab in
      match fab with
      | Some f -> functr.fmap f fa
      | None   -> return None;
  }

  let monad = {
    return = (fun x -> inj @@ Some x);
    bind = fun m a ->
      let+ m = m in
      match m with
      | Some x -> a x
      | None -> return None
  }
end

let main () =
  let open Monad(Maybe) in
  let+ x = Some 5 in
  return @@ x + 3