Created
June 24, 2018 18:17
-
-
Save texastoland/c84aef81344cc8765c7bf67ba81d30f2 to your computer and use it in GitHub Desktop.
HKT in OCaml/Reason with functors
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(** `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 ] |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
/** `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], | |
) | |
); |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment