OCaml 杂记

utop # Printf.printf "%s %F\n %!" "hello" 3.14 

hello 3.14
 - : unit = ()

 let head lst =
   match lst with
   | h::_ -> h
(* | [] -> faliwith  "empty list"  *)
 ;;

let head lst =
match lst with
  | h::t -> h
  | [x] -> x
  | [] -> 0
;;

let head lst =
match lst with
  | [x] -> x
  | h::t -> h
  | [] -> 0
;;

let first_zero = function 
| [] -> true 
| h::t when h = 0 -> true 
| _ -> false 
;;

let number_or_letter = function 
  |'A' .. 'Z' | 'a' .. 'z' -> "letter" 
  | '0' .. '9' -> "number"
  | _ -> "??" 
;;

c.name ;; 

match c with
  | { name=n; hp=h; ptype=t } -> n
;;

raise ( MyException (233,"error") ) ;;

 raise ;;

- : exn -> 'a = <fun>

failwith "xxx" ;;

raise (Failure "xxx") ;;

type 'tp tree = 
|Leaf 
|Node of 'tp * 'tp tree * 'tp tree
;;

let a_tree =  Node(2,
  Node(1,Leaf,Leaf),
  Node(3,Leaf,Leaf)
) ;;

let rec size_of_tree t = 
match t with 
|Leaf -> 0
|Node(_,l,r) -> 1 + size_of_tree l + size_of_tree r
;;

type 'a tree = 
|Leaf
|Node of { v : 'a ; 
           l : 'a tree ; 
           r : 'a tree }
;;

let a_tree = Node {v=2;
                   l= Node{v=1;l=Leaf;r=Leaf};
                   r= Node{v=3;l=Leaf;r=Leaf}
                  } 
;;

let rec  size_of_tree tr = match tr with 
  | Leaf ->  0
  | Node{v=_;l=a;r=b} -> 1+ size_of_tree a + size_of_tree b 
;;

let rec is_member va t = match t with 
|Leaf -> false 
|Node {v=v;l=l;r=r} -> v=va || is_member va l || is_member va r 
;;

let rec preorder (t :'a tree) :  'a list = 
  match t with 
  |Leaf -> []
  |Node{v=v;l=l;r=r} -> [v] @ preorder l @ preorder r 
;;

let rec preorder (res :'a list)  (t :'a tree) : 'a list = 
  match t with 
  |Leaf -> res  (* 不添加元素到res 即原样返回 *)
  |Node{v=v;l=l;r=r} -> v::(preorder (preorder res r) l)
;;

let is_zero  = function
  | Zero -> true
  | Nextnum _ -> false
;;

  let pred = function
    | Zero -> None
    | Nextnum rest -> Some rest
  ;;
(* ======================= *)
  let pred_e = function
    | Zero -> failwith "pred zero is undefined"
    | Nextnum rest -> rest
  ;;

let nat_add n1 n2 = match n1 with
  |Zero -> n2
  |Nextnum x -> nat_add x  (Nextnum n2)
;;

let int_of_nat n = 
  let rec int_of_nat_tr acc  = function
    | Zero -> acc
    | Nextnum x -> int_of_nat_tr (1+acc) x
  in
  int_of_nat_tr 0 n
;;

let  nat_of_int i =
  let rec nat_of_int_tr acc =  function
      |n when n = 0  -> acc 
      |n when n > 0 -> nat_of_int_tr (Nextnum acc)  (n-1) 
      |_  -> failwith "n cannot be postived"
  in
  nat_of_int_tr Zero i
;;

.... = function
  |n when n = 0  -> acc 
  |n when n > 0 -> nat_of_int_tr (Nextnum acc)  (n-1) 
  |n when n < 0  -> failwith "n cannot be postived"
;;

let apply f x = f x ;;

let pipeline x f = f x 
let (|>) = pipeline ;;

let compose f g x = f (g x) ;;

let square_then_double = compose double square ;;

let both f g x = (f x,g x)

let cond p f g x =
  if p then f x else g x ;;

let rec addone = function
  |[] -> []
  |h::t -> (h+1) :: (addone t)
;;

let rec concat_3110 = function
  |[] -> []
  |h::t -> (h^ "3110" ) :: (concat_3110 t)
;;

let rec map(*transform*) func = function
  |[] -> []
  |h::t -> (func h) :: (map func t)
;;

let addone' = map (fun x -> x+1)
let concat_3110' = map (fun s -> s ^ "3110" )
;;

let strlist_of_intlist = map string_of_int ;;

let rec sum = function
  |[] -> 0
  |h::t -> h + (sum t)

let rec concat = function
  |[] -> ""
  |h::t -> h ^ (concat t)
;;

let rec fold_right op init = function
  |[] -> init
  |h::t -> op  h (fold_right op init t)
;;

let sum' = fold_right 0 ( + )

let concat' = fold_right "" ( ^ )
;;

let rec evens = function
  |[] -> []
  |h::t -> if (h mod 2) == 0 then h::(evens t) else  t
;;

let rec odds = function
  |[] -> []
  | h::t -> if (h mod 2) != 0 then h::(odds t) else t
;;

let rec filter p = function
  |[] -> []
  |h::t -> if (p h) then h::(filter p t) else filter p t
;;

let evens = filter (fun i -> (i mod 2) = 0 )
let odds = filter (fun i -> (i mod 2) != 0 )
;;

let filter p lst = 
  let rec impl acc p = function
    |[] -> List.rev acc 
    |h::t -> impl (if (p h) then h::acc else acc) p t 
  in
  impl [] p lst 
;;

type 'a tree =
    Leaf
  | Node of 'a * 'a tree * 'a tree
;;

let rec tree_map func = function
  |Leaf -> Leaf
  |Node (v,l,r) -> Node( (func v),(tree_map func l),(tree_map func r) )
;;

let rec tree_fold init op = function
  | Leaf -> init
  | Node (v,l,r) -> op v (tree_fold init op l) (tree_fold init op r) 
;;

let size t =
  tree_fold 0 (fun _ l r -> 1+l+r)  t
;;

let depth t =
  tree_fold 0 (fun _ l r -> 1+ (max l r)) t
;;

let preorder t =
  tree_fold [] (fun e l r -> [e] @ l @ r ) t
;;

let sum_square n =
  let rec loop acc i  =
    if i>n then acc
    else loop acc+(i*i) (i+1)
  in
  loop 0 1
;;

let ( -- ) i j =
  let rec loop acc i j =
    if i>j then acc
    else loop (j::acc) i (j-1)
  in
  loop [] i j
;;

let sum_square n =
  (1 -- n) |> (fold_left (fun acc e -> acc+e*e) 0) 
;;

let sum = fold_left (fun acc e -> acc+e) 0 ;;

let sum_square n =
   (1 -- n) |> map (fun e -> e*e) |> sum
;;

let sum_square n =
  let lst = (1 -- n) in
  lst |> (fold_left (fun acc e -> acc+e*e) 0) 
 ;;

let sum_square n =
  let l = (1 -- n) in 
   l |> map (fun e -> e*e) |> sum
;;

let f (x,y) = x+y

let g t = fst t + snd t 

int * int -> int = <fun>

let curried f x y = f (x,y) ;;

let uncurried f (x,y) = f x y ;;

module Myspace = struct
  let inc x = x+1
  type color = Red|Green|Blue
  exception Oops

  module NestedSpace = struct
    exception DivideByZero 
    type frac = ( :: ) of int * int

    let ( + ) (a::b) (x::y) =
      if b=0 || y==0 then raise DivideByZero
      else (a*y + x*b)::(b*y)
    let ( * ) (a::b)  (x::y) =
      if b=0 || y==0 then raise DivideByZero
      else (a*x) :: (b*y)
    let ( - ) (a::b) (x::y) =  (a::b) + ((0-x)::y) 
    let ( / ) (a::b) (x::y) = (a::b) * (y::x) 

  end

end

module M = struct
  let y = 1
  let x = y
end

module M = struct

  let rec even = function |0 -> true |n-> odd(n-1)
  and odd = function |1 -> true |n -> even(n-1)

end

Myspace.myfunc ....

let retval =
  let open MyStack in
  Empty |> push 3 |> top
;;

module MyStruct = struct
  open List
  open String (* 也定义了map *)

  let to_upper = List.map uppercase_ascii 
end

open MyStack (* 到文件末尾 *)
let val = Empty |> push 3 |> push 4 |> top 

open String
let length = String.length
let get = String.get
        ...    ...

let t = MyTree. Node(2,Leaf,Leaf) ;;

let t : int MyTree.tree = Node(2,Leaf,Leaf) ;;

module ListStackImpl = struct

  type 'a stack =
    |Empty 
    |Entry of 'a * 'a stack

  let empty = Empty

  let push e stk = Entry(e,stk)

  let pop = function
    |Empty -> Empty
    |Entry(_,rest) ->  rest

  let peek = function
    |Empty -> None
    |Entry(top, _ )-> Some top

  let peek_exn = function
    |Empty -> failwith "Empty Stack"
    |Entry(top,_) -> top

end
;;

# let open MyStack in 
      empty |> push 2 |> push 3 |> push 4 |> peek ;;

  - : int option = Some 4

# MyStack. (empty |> push 2 |> push 3 |> push 4 |> peek) ;;

- : int option = Some 4

 module ListQueue = struct

   type 'a queue = 'a list

   let enqueue v  que =
     que @ [v]  (*线性时间*)

   let dequeue = function
     |[] -> None
     |_::t -> Some t 

   let dequeue_exn = function
     |[] -> failwith "empty queue"
     |_::t -> t

   let first = function
     |[] -> None
     |h::_ -> Some h

   let first_exn = function
     |[] -> failwith "empty queue"
     |h::_ -> h

 end
;;

module TwoListQueue = struct

  type 'a queue = {
    front: 'a list ;
    back: 'a list 
  }

  let empty = {
    front= [];
    back = []
  }

  let peek = function
    |{front=[] } -> None
    |{front=x::_ ;} -> Some x
  ;;

  let enqueue x = function
    |{front=[] } -> {front=[x] ; back=[] }
    |q -> {q with back=x::q.back}  (* 即：当front不为空list时*)

  let dequeue = function
    |{front=[]} -> None
    |{front= _::[] ;back=b} -> Some {front = List.rev b ;back=[] } 
    |{front=_::t;back=b} -> Some {front = t ;back=b}

end

 module MyModule = struct
  let inc x = x+1
  type primary_color = Red | Green | Blue 
  exception Oops
end
 ;;

module MyModule :

  sig
    val inc : int -> int
    type primary_color = Red | Green | Blue
    exception Oops
  end

# let foo = 100 ;;
val foo : int = 100

# let inc y = y+1 ;;
val inc : int -> int = <fun>

sig
  val inc : int -> int
  type primary_color = Red | Green | Blue
  exception Oops
end

module type Fact =
sig 
  val fact : int -> int 
end

module type LIST_STACK =
sig
  exception EmptyStack
  val empty : 'a list
  val is_empty : 'a list -> bool
  val push : 'a -> 'a list -> 'a list
  val pop : 'a list -> 'a list
  val peek : 'a list -> 'a 
end

module 模块名 : 模块类型sig =  struct ....  end  ;; 

  module RescursiveFact : Fact = struct
    let rec fact n =
      if n=0 then 1 else n * fact (n-1)
  end
(*****************************************) 
  module TailRescursiveFact : Fact =struct
    let rec fact_iteration acc = function
      |0 -> acc
      |n -> fact_iteration (acc*n) (n-1)
    let fact n = fact_iteration 1 n
  end
  ;;

module ListStack :LIST_STACK = struct 
  exception EmptyStack
  let empty = [] 

  let is_empty = function 
    |[] -> true 
    |_ -> false 

  let push e stk= e::stk

  let pop = function 
    |[] -> raise EmptyStack 
    |_::t -> t 

  let peek = function 
    |[] -> raise EmptyStack
    |h::_ -> h 
end
;;

module type Addone = sig
  val addone: int list -> int list
end

module MyAddone: Addone  = struct
  let incr x  = x+1
  let rec addone = function
    |[] -> []
    |h::t -> (1+ h ) :: (addone t)
end
;;

(* 这是不允许的：
 MyAddone.incr 4;; *)

MyAddone.addone [1;3;5] ;;(*合法操作*)

module type X  =
sig
  val x : int 
end

module type T =
sig
  module Inner: X 
end

module T_impl  = struct

  module Inner : X = struct
    let x = 100 
  end
end

  module type IntFunc = sig 
    val foo : int -> int 
  end
  ;;
(* 下面实现中的foo其实是 'a -> 'a 类型的, 但只要能符合接口中的规定即可 *)
  module IntFuncImpl: IntFunc =  struct 
    let foo x = x 
  end
  ;;

module M = struct
  let x = 0
  let z =1
end

module type X = sig
  val x : int
end

module Mx : X = M ;;

module type Z = sig
  val z : int
end

module Mz : Z = M ;;

module type XZ = sig
  val x : int
  val z : int
end

module Mxz : XZ = M ;;

module Mxz' = ((M:X):Z) ;; 

module type NumType = sig
  type t
  val n : t
end

module NumInt : NumType = struct
  type t = int
  let n = 100
end
;;

# NumInt.n ;;
- : NumInt.t = <abstr>

module N = struct 
  type t = int
  let (n:t) = 100 
end 
;;

# N.n ;;
  - : N.t = 100

(library
 (name xxx))

(* 实现阶乘fact*) 
module Math = struct
  let rec fact_impl acc n =
    if n=0 then acc 
    else fact_impl (n*acc) (n-1)
  let fact = fact_impl 1

end

(* 实现阶乘fact*) 
module Math = struct
  let fact n = 
    let rec fact_impl acc n =
      if n=0 then acc 
      else fact_impl (n*acc) (n-1)
    in fact_impl 1 n 
end

module type Math = sig
  val fact : int -> int
end

module MathImpl : Math = struct
  let rec fact_impl acc n =
    if n=0 then acc 
    else fact_impl (n*acc) (n-1)
  let fact = fact_impl 1
end

module type ListStack = sig
  exception StackIsEmpty

  val empty : 'a list

  val is_empty : 'a list -> bool
  val push : 'a -> 'a list -> 'a list
  val peek : 'a list -> 'a
  val pop : 'a list -> 'a list

end

module ListStackImpl : ListStack = struct
  exception StackIsEmpty
  let empty = []
  let is_empty = function
    | [] -> true
    | _ -> false
  let push e s = e::s
  let peek = function
     | [] -> raise StackIsEmpty
     | h::_ -> h
  let pop = function
    | [] -> raise StackIsEmpty
    | _::t -> t
end

  module type ListStack = sig
    val size : 'a list -> int
      ....
  end

module ListStackImpl = struct
  let size  = List.length 
      .... 
end

module ListStackCachedSizeImpl = struct
  exception StackIsEmpty

  let empty = ([],0) 
  let is_empty = function
    | ([],_) -> true
    | _ -> false
  let size (s,n) = n 
  let push e (s,n) = (e::s, (1+n) ) 
  let peek = function
     | ([],_) -> raise StackIsEmpty
     | (h::_,_ ) -> h 
  let pop = function
    | ([],_) -> raise StackIsEmpty
    | (_::t,n) -> (t,(n-1))

end

ListStackCachedSize. (empty |> push 1 |> push 2 |> size )  ;;
(* --> 2 *)

module type ListStack = sig

  type 'a stack
  exception StackIsEmpty
  val empty : 'a stack
  val is_empty : 'a stack -> bool
  val push : 'a -> 'a stack -> 'a stack
  val peek : 'a stack -> 'a
  val pop : 'a stack -> 'a stack
  val size : 'a stack -> int

end

  module ListStackCachedSizeImpl = struct
      type 'a stack = 'a list * int 
      exception StackIsEmpty

      let empty = ([],0) 
      let is_empty = function
        | ([],_) -> true
        | _ -> false
      let size (s,n) = n 
      let push e (s,n) = (e::s, (1+n) ) 
      let peek = function
         | ([],_) -> raise StackIsEmpty
         | (h::_,_ ) -> h 
      let pop = function
        | ([],_) -> raise StackIsEmpty
        | (_::t,n) -> (t,(n-1))
    end
(*************************)
  module ListStackCachedSize : ListStack =  ListStackCachedSizeImpl ;;

module type IntType = sig
  type inttype
  val element : inttype 
end

module MyInt : IntType = struct
  type inttype = int
  let element = 0 
end

# let a = MyInt.element ;;
val a : MyInt.inttype = <abstr>

 module type IntType = sig
  type inttype
  val element : inttype 
  val pp : Format.formatter -> inttype -> unit 
end

module MyInt : IntType = struct
  type inttype = int
  let element = 0 
  let pp fmt (i: inttype) =
    Format.fprintf fmt ">%d<" i 

end ;;

#install_printer MyInt.pp ;;  

# MyInt.element ;;
- : MyInt.inttype = >0<

# let a = MyInt.element ;;
val a : MyInt.inttype = >0<

let lst = [1;3;4;5;7]
let lst' = List.tl lst ;;

lst;;
(* lst并未因tl操作而被修改 *)
- : int list = [3; 4; 5; 7]

module type Stack = sig
  type 'a t
  exception EmptyStack
  val empty : 'a t 
  val is_empty : 'a t -> bool
  val size : 'a t -> int
  val push : 'a -> 'a t -> 'a t
  val peek : 'a t -> 'a
  val peek_opt : 'a t -> 'a option
  val pop : 'a t -> 'a t
  val pop_opt : 'a t -> 'a t option 
end

module StackImpl : Stack = struct
  type 'a t = 'a list
  exception EmptyStack
  let empty = [] 
  let is_empty = function
    | [] -> true 
    | _ -> false
  let size = List.length
  let push e s = e::s

  let peek = function
    |[] -> raise StackEmpty
    |h::_ -> h
  let peek_opt = function
    |[] -> None
    |h::_ -> Some h

  let pop = function
    |[] -> raise StackEmpty
    |_::t -> t
  let pop_opt = function
    |[] -> None
    |_::t -> Some t


end

let ( >>| ) opt f =
  match opt with
  | None -> None
  | Some x -> Some (f x) 

let ( >>= ) opt f =
  match opt with
  |None -> None
  |Some x -> f x 

StackImpl. (empty |> push 1 |> push 2 |> pop_opt >>| push 4 >>= peek_opt )

module type Queue = sig
  type 'a t
  exception EmptyQueue
  val empty : 'a t
  val is_empty : 'a t -> bool
  val size : 'a t -> int
  val enqueue : 'a -> 'a t -> 'a t
  val front : 'a t -> 'a
  val dequeue : 'a t -> 'a t
  val to_list : 'a t -> 'a list 
end

module ListQueue : Queue = struct
  type 'a t = 'a list
  exception EmptyQueue
  let empty = []
  let is_empty = function
    | [] -> true
    | _ -> false
  let size = List.length

  let enqueue e q = q @ [e]  (* !! *)
  let front = function
    | [] -> raise EmptyQueue
    | h::_ -> h
  let dequeue = function
    | [] -> raise EmptyQueue
    | _::t -> t 
  let to_list = Fun.id (* 恒等映射 *)

module type Map = sig
  type ('k,'v) t
  exception EmptyMap
  val empty : ('k,'v) t
  val insert : 'k -> 'v -> ('k,'v) t -> ('k,'v) t
  val lookup : 'k -> ('k,'v) t -> 'v
  val bindings : ('k,'v) t -> ('k * 'v) list 
end 

module AssocListMap : Map = struct
  type ('k,'v) t = ('k*'v) list
  exception EmptyMap
  let empty = []
  let insert k v m = (k,v)::m

  let rec lookup k = function
    | [] -> raise EmptyMap
    | (key,value) :: t -> if k = key then value else (lookup k t)

  let bindings_aux m = List. (m |> map fst |>sort_uniq Stdlib.compare )  
  let bindings m =  m |> bindings_aux |> List.map (fun k -> ( k,(lookup k m)))

end

module UniqAssocListMap : Map = struct
   type ('k,'v) t = ('k*'v) list
   exception EmptyMap

   let empty = []

   let rec insert k v = function
     | [] -> [(k,v)]
     | (key,value)::t ->  if k=key then (key,v)::t else (insert k v t )

   let rec lookup k = function
     | [] -> raise EmptyMap
     | (key,value) :: t -> if k = key then value else (lookup k t)

   let bindings = Fun.id 
 end

module type Set = sig
  type 'a t
  val empty : 'a t 
  val add : 'a -> 'a t -> 'a t
  val mem : 'a -> 'a t -> bool
  val elements : 'a t -> 'a list 
end

module ListSet : Set = struct
  type 'a t = 'a list
  let empty = []
  let add e s = e::s
  let rec mem e  = function
    | [] -> false
    | h::t -> if h = e then true else (mem e t)

  let elements s = s |> ( List.sort_uniq Stdlib.compare ) 
end

module UniqListSet = struct
  type 'a t = 'a list
  let empty = []
  let rec add e s =
    match s with
    | [] -> [e]
    | h::t -> if h = e then h::t else h::(add e t)

  let rec mem e  = function
    | [] -> false
    | h::t -> if h = e then true else mem e t

  let elements = Fun.id 
end

  module ListSetExtended : SetExtended = struct
    include ListSet
    let of_list = Fun.id 
  end
(* 这样实现是错误的 : *) 
    Values do not match:
  val of_list : 'a -> 'a
      is not included in
  val of_list : 'a t -> 'a list

module type T = sig
  type 'a t 
  val foo : 'a list -> 'a t 
end 

module M : T = struct 
  type 'a t = 'a list 
  let foo lst = lst  (* 'a -> 'a *)
end ;;

module ListSetExtended : SetExtended = struct
  include ListSet
  let of_list lst = List.fold_right add lst empty 
end  ;;

let of_list lst =  List.fold_right add lst empty

let set_of_list add empty lst = List.fold_right add lst empty 

module SetOfList = struct
  let set_of_list add empty lst = List.fold_right add lst empty  
end

module ListSetExtended : SetExtended = struct
  include ListSet
  include SetOfList
  let of_list lst = set_of_list add empty lst 
end

module UniqListSetExtended : SetExtended = struct
  include UniqListSet
  include SetOfList
  let of_list lst = set_of_list add empty lst 
end

module F (M1:T1)  (M2:T2) ...  : S  = struct 

end

module F =
  functor (M1:T1) ->
  functor (M2:T2) ->
    ...
  functor (M : T) -> 
struct
  ...
end

module type Add = sig
  val add : int -> int
end

module AddX (M : T) = struct
  let add y = M.x + y
end

module CheckAddX : T -> Add =  AddX 

module type T = sig
  type t
  val x : t
end

module PairX (M : T) = struct
  let p = (M.x , 1)
end

module type T = sig type t val x : t end

module PairX : functor (M : T) -> sig val p : M.t * int end

module F (M : sig val x :int end) = struct
  let x = M.x +1
end

module A = struct
  let x = 1
end
module B = struct
  let x = 2
  let y = 100
end

module _ = F(A)
module _ = F(B) 

module Make :
  functor (Order: OrderType ) -> S with type key = Order.t 

module type OrderType = sig
  type t  (* key的类型 *)
  val compare : t -> t -> int (* 定义了key1 - key2 = ? *)
end

module type S = sig
  type key
  ..... (* 各种Map的操作 *)
end

type day = Mon | Tue | Wed | Thu | Fri | Sat | Sun

let int_of_day = function
  | Mon -> 1
  | Tue -> 2
  | Wed-> 3
  | Thu -> 4
  | Fri -> 5
  | Sat -> 6
  | Sun -> 7

module DayKey = struct
  type t = day
  let compare d1 d2 =
    (int_of_day d1) - (int_of_day d2)
end

module DayMap = Map.Make(DayKey)

DayMap. (empty |> add Mon "monday" |> add Tue "tuesday" ) 

S with type key = Order.t 

exception Empty

module type Stack = sig
  type 'a t
  val empty : 'a t
  val push : 'a -> 'a t -> 'a t
  val peek : 'a t -> 'a
  val pop : 'a t -> 'a t
end

module ListStack = struct
  type 'a t = 'a list
  let empty = []
  let push = List.cons
  let peek = function [] -> raise Empty | x :: _ -> x
  let pop = function [] -> raise Empty | _ :: s -> s
end

module VariantStack = struct
  type 'a t = E | S of 'a * 'a t
  let empty = E
  let push x s = S (x, s)
  let peek = function E -> raise Empty | S (x, _) -> x
  let pop = function E -> raise Empty | S (_, s) -> s
end

module StackTester (S:Stack) = struct
  let tests = [
    "peek (push x empty) = x" >:: (fun _ -> assert_equal 3 S. (empty |> push 3 |> peek) )
  ]
end

module LTest = StackTester(ListStack)
module VTest = StackTester(VariantStack)

let alltests = List.flatten [ LTest.tests; VTest.tests ]

List.flatten [ [2;3;4] ;[0] ; [5;7] ]
(* - : int list = [2; 3; 4; 0; 5; 7] *)

let stackimpls = [ (module ListStack: Stack) ; (module VariantStack : Stack); ..... ]

let get_tests m =
  let module StackImpl = (val m : Stack)
  in
    let module StackTests = StackTester(StackImpl)
    in StackTests.tests

let all_tests = stackimpls |> List.map get_tests |> List.flatten