diff --git a/generics.opam b/generics.opam index d80247c..8bc7e47 100644 --- a/generics.opam +++ b/generics.opam @@ -17,6 +17,6 @@ build: [ depends: [ "dune" {build} "ocaml-variants" - { = "4.02.1+modular-implicits" | = "4.02.1+modular-implicits-ber" } + { = "4.02.1+modular-implicits" | = "4.02.1+modular-implicits-ber" | = "4.02.1+modular-implicits+let_syntax" } "imp" -] \ No newline at end of file +] diff --git a/lib/dune b/lib/dune index 070c735..0cb7e79 100644 --- a/lib/dune +++ b/lib/dune @@ -1,5 +1,5 @@ (library (public_name generics) - (modules Generic GenShow GenEq Memo GenOrd) + (modules Generic Show Eq Memo Ord) (libraries imp) - (synopsis "Experimental library using modular implicits")) \ No newline at end of file + (synopsis "Experimental library using modular implicits")) diff --git a/lib/genEq.ml b/lib/eq.ml similarity index 50% rename from lib/genEq.ml rename to lib/eq.ml index ffe1f17..8043253 100644 --- a/lib/genEq.ml +++ b/lib/eq.ml @@ -1,30 +1,25 @@ -open Generic;; -open Imp.Data;; - - - -implicit module EqGenBasic {X : Eq} : Eq with type t = X.t genBasic = struct - type t = X.t genBasic - let ( = ) (GenBasic (_, a)) (GenBasic (_, b)) = X.( = ) a b -end;; +open Generic +open Imp.Data +implicit module EqGenBasic {X : Eq} : Eq with type t = X.t basic = struct + type t = X.t basic + let ( = ) (Basic (_, a)) (Basic (_, b)) = X.( = ) a b +end -implicit module EqGenProd {X : Eq} {Y : Eq} : Eq with type t = (X.t, Y.t) genProd = struct - type t = (X.t, Y.t) genProd - let ( = ) (GenProd (a1, a2)) (GenProd (b1, b2)) = X.( = ) a1 b1 && Y.( = ) a2 b2 -end;; +implicit module EqGenProd {X : Eq} {Y : Eq} : Eq with type t = (X.t, Y.t) prod = struct + type t = (X.t, Y.t) prod + let ( = ) (Prod (a1, a2)) (Prod (b1, b2)) = X.( = ) a1 b1 && Y.( = ) a2 b2 +end -implicit module EqGenSum {X : Eq} {Y : Eq} : Eq with type t = (X.t, Y.t) genSum = struct - type t = (X.t, Y.t) genSum +implicit module EqGenSum {X : Eq} {Y : Eq} : Eq with type t = (X.t, Y.t) sum = struct + type t = (X.t, Y.t) sum let ( = ) a b = match a, b with | Left a, Left b -> X.( = ) a b | Right a, Right b -> Y.( = ) a b | _ -> false -end;; - +end implicit module EqGeneric {X : Generic} {XRep : Eq with type t = X.rep} : Eq with type t = X.t = struct type t = X.t let ( = ) a b = XRep.(=) (toRep a) (toRep b) end - diff --git a/lib/genShow.ml b/lib/genShow.ml deleted file mode 100644 index 343d978..0000000 --- a/lib/genShow.ml +++ /dev/null @@ -1,32 +0,0 @@ -open Imp.Show;; -open Generic;; - - -module type Showable = sig - type t - val showable : t -> string -end;; - -let showable {S : Showable} x = S.showable x;; - -implicit module ShowableGenBasic {X : Show} : Showable with type t = X.t genBasic = struct - type t = X.t genBasic - let showable (GenBasic (s, x)) = s ^ " " ^ X.show x -end;; - -implicit module ShowableGenProd {X : Showable} {Y : Showable} : Showable with type t = (X.t, Y.t) genProd = struct - type t = (X.t, Y.t) genProd - let showable (GenProd (x, y)) = X.showable x ^ ", " ^ Y.showable y -end;; - -implicit module ShowableGenSum {X : Showable} {Y : Showable} : Showable with type t = (X.t, Y.t) genSum = struct - type t = (X.t, Y.t) genSum - let showable = function - | (Left a) -> X.showable a - | (Right b) -> Y.showable b -end;; - -implicit module ShowableGeneric {X : Generic} {XRep : Showable with type t = X.rep} : Show with type t = X.t = struct - type t = X.t - let show x = XRep.showable (X.toRep x) -end \ No newline at end of file diff --git a/lib/generic.ml b/lib/generic.ml index b271301..8f4809a 100644 --- a/lib/generic.ml +++ b/lib/generic.ml @@ -1,24 +1,16 @@ - - module type Generic = sig type t type rep val toRep : t -> rep val fromRep : rep -> t -end;; - -let toRep {G : Generic} = G.toRep;; - -let fromRep {G : Generic} = G.fromRep;; - -type 'a genBasic = GenBasic of (string * 'a);; - -type ('a, 'b) genProd = GenProd of ('a * 'b );; - -type ('a, 'b) genSum = Left of 'a | Right of 'b;; - +end +let toRep {G : Generic} = G.toRep +let fromRep {G : Generic} = G.fromRep +type 'a basic = Basic of (string * 'a) +type ('a, 'b) prod = Prod of ('a * 'b ) +type ('a, 'b) sum = Left of 'a | Right of 'b diff --git a/lib/memo.ml b/lib/memo.ml index a004d95..a7997cd 100644 --- a/lib/memo.ml +++ b/lib/memo.ml @@ -1,49 +1,46 @@ -open Generic;; - +open Generic module type Memo = sig type t val memo : (t -> 'a) -> t -> 'a -end;; +end -let memo {M : Memo} = M.memo;; +let memo {M : Memo} = M.memo -implicit module MemoBasic {X : Memo} : Memo with type t = X.t genBasic = struct - type t = X.t genBasic +implicit module MemoBasic {X : Memo} : Memo with type t = X.t basic = struct + type t = X.t basic let memo f = - let memoX = X.memo (fun x -> f (GenBasic ("", x))) in - (fun (GenBasic (_, x)) -> memoX x) -end;; + let memoX = X.memo (fun x -> f (Basic ("", x))) in + (fun (Basic (_, x)) -> memoX x) +end -implicit module MemoisableProd {X : Memo} {Y : Memo} : Memo with type t = (X.t, Y.t) genProd = struct - type t = (X.t, Y.t) genProd +implicit module MemoisableProd {X : Memo} {Y : Memo} : Memo with type t = (X.t, Y.t) prod = struct + type t = (X.t, Y.t) prod let memo f = - let memoX = X.memo (fun x -> Y.memo (fun y -> f (GenProd (x, y)))) in - fun (GenProd (x, y)) -> memoX x y -end;; - + let memoX = X.memo (fun x -> Y.memo (fun y -> f (Prod (x, y)))) in + fun (Prod (x, y)) -> memoX x y +end -implicit module MemoisableSum {X : Memo} {Y : Memo} : Memo with type t = (X.t, Y.t) genSum = struct - type t = (X.t, Y.t) genSum +implicit module MemoisableSum {X : Memo} {Y : Memo} : Memo with type t = (X.t, Y.t) sum = struct + type t = (X.t, Y.t) sum let memo f = let memoX = X.memo (fun x -> f (Left x)) in let memoY = Y.memo (fun y -> f (Right y)) in fun s -> match s with | (Left x) -> memoX x | (Right y) -> memoY y -end;; - +end implicit module MemoisableGeneric {X : Generic} {XRep : Memo with type t = X.rep} : Memo with type t = X.t = struct type t = X.t let memo (f : X.t -> 'a) : X.t -> 'a = let memoXRep = XRep.memo (fun x -> f (X.fromRep x)) in fun x -> memoXRep (X.toRep x) -end;; +end module IntMap = Map.Make(struct type t = int let compare = compare -end);; +end) implicit module MemoInt : Memo with type t = int = struct type t = int @@ -56,14 +53,12 @@ implicit module MemoInt : Memo with type t = int = struct let y = f x in memoMap := IntMap.add x y !memoMap; y -end;; - - +end module StrMap = Map.Make(struct type t = string let compare = compare -end);; +end) implicit module MemoStr : Memo with type t = string = struct type t = string @@ -76,4 +71,4 @@ implicit module MemoStr : Memo with type t = string = struct let y = f x in memoMap := StrMap.add x y !memoMap; y -end;; +end diff --git a/lib/genOrd.ml b/lib/ord.ml similarity index 53% rename from lib/genOrd.ml rename to lib/ord.ml index 641ad69..d76b9be 100644 --- a/lib/genOrd.ml +++ b/lib/ord.ml @@ -1,20 +1,20 @@ open Generic open Imp.Data -implicit module OrdGenBasic {X : Ord} : Ord with type t = X.t genBasic = struct - type t = X.t genBasic - let compare (GenBasic (_, a)) (GenBasic (_, b)) = X.compare a b +implicit module OrdGenBasic {X : Ord} : Ord with type t = X.t basic = struct + type t = X.t basic + let compare (Basic (_, a)) (Basic (_, b)) = X.compare a b end -implicit module OrdGenProd {X : Ord} {Y : Ord} : Ord with type t = (X.t, Y.t) genProd = struct - type t = (X.t, Y.t) genProd - let compare (GenProd (a1, a2)) (GenProd (b1, b2)) = - let comp = X.compare a1 b1 in - if comp = EQ then Y.compare a2 b2 else comp +implicit module OrdGenProd {X : Ord} {Y : Ord} : Ord with type t = (X.t, Y.t) prod = struct + type t = (X.t, Y.t) prod + let compare (Prod (a1, a2)) (Prod (b1, b2)) = + let comp = X.compare a1 b1 in + if comp = EQ then Y.compare a2 b2 else comp end -implicit module OrdGenSum {X : Ord} {Y : Ord} : Ord with type t = (X.t, Y.t) genSum = struct - type t = (X.t, Y.t) genSum +implicit module OrdGenSum {X : Ord} {Y : Ord} : Ord with type t = (X.t, Y.t) sum = struct + type t = (X.t, Y.t) sum let compare a b = match a, b with | Left _, Right _ -> LT | Right _, Left _ -> GT diff --git a/lib/show.ml b/lib/show.ml new file mode 100644 index 0000000..5db16ed --- /dev/null +++ b/lib/show.ml @@ -0,0 +1,24 @@ +open Imp.Show +open Generic + +implicit module ShowGenBasic {X : Show} : Show with type t = X.t basic = struct + type t = X.t basic + let show (Basic (s, x)) = s ^ " " ^ X.show x +end + +implicit module ShowGenProd {X : Show} {Y : Show} : Show with type t = (X.t, Y.t) prod = struct + type t = (X.t, Y.t) prod + let show (Prod (x, y)) = X.show x ^ ", " ^ Y.show y +end + +implicit module ShowGenSum {X : Show} {Y : Show} : Show with type t = (X.t, Y.t) sum = struct + type t = (X.t, Y.t) sum + let show = function + | (Left a) -> X.show a + | (Right b) -> Y.show b +end + +implicit module ShowGeneric {X : Generic} {XRep : Show with type t = X.rep} : Show with type t = X.t = struct + type t = X.t + let show x = XRep.show (X.toRep x) +end diff --git a/tests/test.ml b/tests/test.ml index a6835a0..7e92833 100644 --- a/tests/test.ml +++ b/tests/test.ml @@ -6,20 +6,18 @@ type basicSum = L of int | R of string implicit module GenBasicSum = struct type t = basicSum - type rep = (int genBasic, string genBasic) genSum + type rep = (int basic, string basic) sum let toRep = function - | L x -> Left (GenBasic ("L", x)) - | R x -> Right (GenBasic ("R", x)) + | L x -> Left (Basic ("L", x)) + | R x -> Right (Basic ("R", x)) let fromRep = function - | Left (GenBasic (_, x)) -> L x - | Right (GenBasic (_, x)) -> R x + | Left (Basic (_, x)) -> L x + | Right (Basic (_, x)) -> R x end -type basicProd = P of int * string - let () = begin - let open [@warning "-33"] Generics.GenShow in + let open [@warning "-33"] Generics.Show in assert (show (L 1) = "L 1"); end @@ -29,13 +27,13 @@ type ints = L1 of int | R1 of int implicit module IntsGeneric = struct type t = ints - type rep = (int genBasic, int genBasic) genSum - let (toRep : ints -> (int genBasic, int genBasic) genSum) = function - | L1 a -> Left (GenBasic ("L1", a)) - | R1 b -> Right (GenBasic ("R1", b)) - let (fromRep : (int genBasic, int genBasic) genSum -> ints) = function - | Left (GenBasic (_, a)) -> L1 a - | Right (GenBasic (_,b)) -> R1 b + type rep = (int basic, int basic) sum + let (toRep : ints -> (int basic, int basic) sum) = function + | L1 a -> Left (Basic ("L1", a)) + | R1 b -> Right (Basic ("R1", b)) + let (fromRep : (int basic, int basic) sum -> ints) = function + | Left (Basic (_, a)) -> L1 a + | Right (Basic (_,b)) -> R1 b end let rec fib : int -> int = function @@ -50,6 +48,10 @@ let weirdFib : ints -> int = function let () = begin let m = memo weirdFib in + (* Dune doesn't show live output when running tests, it just prints it all at the end. + So, to test how fast they run, compare the times with different numbers of copies of this line. + (If memoisation is working, then 2 should be barely slower than 1) + *) print (m (R1 46)); print (m (R1 46)); print (m (R1 46));