falgebra.ml

(* General functor signature. *)
module type FUNCTOR = sig
  type 'a t
  val map : ('a -> 'b) -> 'a t -> 'b t
end

(* General def of catamorphism module, parameterized by a functor *)
module Cata (F : FUNCTOR) = struct

  type 'a t = 'a F.t

  type fix = Fix of fix t

  let fix x = Fix x

  let unfix (Fix x) = x

  let rec cata alg x = alg @@ F.map (cata alg) @@ unfix x

end

(* Example usage - we want to implement the following interface *)
module type EXP  = sig
  type exp
  val eval    : (string -> int) -> exp -> int
  val const   : int -> exp
  val var     : string -> exp
  val ( <+> ) : exp -> exp -> exp
  val ( <*> ) : exp -> exp -> exp
end

(* Realization of EXP leveraging Cata *)
module Exp : EXP = struct

  (* Non recursive definition *)
  type 'a expf =
    | Const of int
    | Var of string
    | Add of ('a * 'a)
    | Mul of ('a * 'a)

  (* Functor instance for expression - note that map is also non-recursive *)
  module ExpFunctor : FUNCTOR with type 'a t = 'a expf = struct
    type 'a t = 'a expf
    let map f = function
      | Const x   -> Const x
      | Var s     -> Var s
      | Add (l,r) -> Add (f l, f r)
      | Mul (l,r) -> Mul (f l, f r)
  end

  (* Evaluation strategy *)
  let alg env = function
    | Const x   -> x
    | Var s     -> env s
    | Add (x,y) -> x + y
    | Mul (x,y) -> x * y

  (* Define the expression type via  a catamorphism *)
  module C = Cata (ExpFunctor)
  type exp = C.fix

  (* Combinators *)
  let const x     = C.fix (Const x)
  let var v       = C.fix (Var v)
  let ( <+> ) x y = C.fix @@ Add (x,y)
  let ( <*> ) x y = C.fix @@ Mul (x,y)
  let eval env e  = C.cata (alg env) e

end

(* Example *)
module Test = struct
  open Exp

  let env = function
    | "x" -> 1
    | "y" -> 2
    | _   -> failwith "unknown"

  let e = (const 5 <+> var "x") <*> (const 2 <+> var "y")

  let res = eval env e
end