unimo.ml

(* Paper: https://pdfs.semanticscholar.org/6485/84a9a714adc95a103c26d18b54c4aad1c812.pdf *)




module type EFFECT = sig
  type 'unimo t
end

module Unimo (Effect : EFFECT) = struct
  type ('a, 'effect) t =
    | Unit of 'a
    | Bind : (('b, 'effect) t) * ('b -> ('a, 'effect) t) -> ('a, 'effect) t
    | Effect of (('a, 'effect) t) Effect.t

  let return a = Unit a
  let (>>=) t callback = Bind (t, callback)
end








module StateEffect = struct
  type state = int

  type 'unimo t =
    | Get
    | Put of state
end

module State = struct
  include Unimo (StateEffect)
  open StateEffect

  let get = Effect Get
  let put state = Effect (Put state)

  module Test = struct
    get >>= fun state ->
    put (state + 1) >>= fun () ->
    get >>= fun state ->
    return state
  end
end








module PlusEffect = struct
  type 'unimo t =
    | Zero
    | Plus of 'unimo * 'unimo
end

module Plus = struct
  include Unimo (PlusEffect)
  open PlusEffect

  let mzero = Effect Zero
  let mplus x y = Effect (Plus (x, y))

  module Test = struct
    mplus (return 1) (return 2) >>= fun x ->
    return x
  end
end