HKT in OCaml/Reason with functors

tree.ml

(** `Tree` abstracts over differnet kinds of trees *)
module Tree = struct
  (** `BasicType` is what tree implementations provide *)
  module type BasicType = sig
    type _ children
    (* polymorphic variant easier to use in implementations *)
    type 'a tree = [ `Leaf of 'a | `Branch of 'a children ]
    val flatten : 'a tree -> 'a list
  end

  (** `BasicTree` is what tree users see *)
  module type BasicTree = sig
    include BasicType
    val lf : 'a -> 'a tree
    val br : 'a children -> 'a tree
  end

  (** `MakeTree` exposes `children` type as concrete *)
  module MakeTree (Type : BasicType) : (BasicTree
    with type 'a children = 'a Type.children
    ) = struct
    include Type
    (* default implementations of tree primatives *)
    let lf data = `Leaf data
    let br children = `Branch children
  end

  (** `GeneralType` implements `flatten` for general trees *)
  module GeneralType = struct
  	(* NOT `GeneralType : BasicType` or
    `children` type would be opaque and
    `br` wouldn't know what to receive *)
    type 'a tree = [ `Leaf of 'a | `Branch of 'a children ]
    and 'a children = 'a tree list
    let flatten tree =
      let rec aux list = function
      | `Leaf leaf -> leaf :: list
      | `Branch [] -> list
      | `Branch (tree :: rest) ->
        aux [] tree @ aux list (`Branch rest) in
      Belt.List.reduce [ tree ] [] aux
  end

  (** `BinaryType` implements `flatten` for binary trees *)
  module BinaryType = struct
    (* `tree` and `children` types are mutually recursive *)
    type 'a tree = [ `Leaf of 'a | `Branch of 'a children ]
    and 'a children = ('a tree * 'a * 'a tree)
    let flatten tree =
      let rec aux list = function
      | `Leaf leaf -> leaf :: list
      | `Branch (left, data, right) ->
        aux [] left @ data :: aux list right in
      aux [] tree
  end

  (* `open` these *)
  module GeneralTree = MakeTree (GeneralType)
  module BinaryTree = MakeTree (BinaryType)
end

let testFunction apply ~(describe : string) ~given ~expect =
  let actual = apply given in
  Js.log begin
    if actual = expect then {j|$describe PASSED|j}
    else {j|$describe FAILED: expected $expect but got $actual|j}
  end

(* [[1,2,[3]],4] -> [1,2,3,4] *)
let () = let open Tree.GeneralTree in
  testFunction flatten
    ~describe:"GeneralTree.flatten"
    ~given:(br [ br [ lf 1; lf 2; br [ lf 3 ] ]; lf 4 ])
    ~expect:[ 1; 2; 3; 4 ]

(* [[[1],2,[3]],4,[5]] -> [1,2,3,4,5] *)
let () = let open Tree.BinaryTree in
  testFunction flatten
    ~describe:"BinaryTree.flatten"
    ~given:(br (br (lf 1, 2, lf 3), 4, lf 5))
    ~expect:[ 1; 2; 3; 4; 5 ]

tree.re

/** `Tree` abstracts over differnet kinds of trees */
module Tree = {
  /** `BasicType` is what tree implementations provide */
  module type BasicType = {
    type children(_);
    /* polymorphic variant easier to use in implementations */
    type tree('a) = [ | `Leaf('a) | `Branch(children('a))];
    let flatten: tree('a) => list('a);
  };
  /** `BasicTree` is what tree users see */
  module type BasicTree = {
    include BasicType;
    let lf: 'a => tree('a);
    let br: children('a) => tree('a);
  };
  /** `MakeTree` exposes `children` type as concrete */
  module MakeTree =
         (Type: BasicType)
         : (BasicTree with type children('a) = Type.children('a)) => {
    include Type;
    /* default implementations of tree primatives */
    let lf = data => `Leaf(data);
    let br = children => `Branch(children);
  };
  /** `GeneralType` implements `flatten` for general trees */
  module GeneralType = {
    /* NOT `GeneralType : BasicType` or
       `children` type would be opaque and
       `br` wouldn't know what to receive */
    type tree('a) = [ | `Leaf('a) | `Branch(children('a))]
    and children('a) = list(tree('a));
    let flatten = tree => {
      let rec aux = list =>
        fun
        | `Leaf(leaf) => [leaf, ...list]
        | `Branch([]) => list
        | `Branch([tree, ...rest]) =>
          aux([], tree) @ aux(list, `Branch(rest));
      Belt.List.reduce([tree], [], aux);
    };
  };
  /** `BinaryType` implements `flatten` for binary trees */
  module BinaryType = {
    /* `tree` and `children` types are mutually recursive */
    type tree('a) = [ | `Leaf('a) | `Branch(children('a))]
    and children('a) = (tree('a), 'a, tree('a));
    let flatten = tree => {
      let rec aux = list =>
        fun
        | `Leaf(leaf) => [leaf, ...list]
        | `Branch(left, data, right) =>
          aux([], left) @ [data, ...aux(list, right)];
      aux([], tree);
    };
  };
  /* `open` these */
  module GeneralTree = MakeTree(GeneralType);
  module BinaryTree = MakeTree(BinaryType);
};

let testFunction = (apply, ~describe: string, ~given, ~expect) => {
  let actual = apply(given);
  Js.log(
    if (actual == expect) {
      {j|$describe PASSED|j};
    } else {
      {j|$describe FAILED: expected $expect but got $actual|j};
    },
  );
};

/* [[1,2,[3]],4] -> [1,2,3,4] */
let () =
  Tree.GeneralTree.(
    testFunction(
      flatten,
      ~describe="GeneralTree.flatten",
      ~given=br([br([lf(1), lf(2), br([lf(3)])]), lf(4)]),
      ~expect=[1, 2, 3, 4],
    )
  );

/* [[[1],2,[3]],4,[5]] -> [1,2,3,4,5] */
let () =
  Tree.BinaryTree.(
    testFunction(
      flatten,
      ~describe="BinaryTree.flatten",
      ~given=br((br((lf(1), 2, lf(3))), 4, lf(5))),
      ~expect=[1, 2, 3, 4, 5],
    )
  );