├── tests ├── show_tests.ml ├── rejected │ ├── labels.ml │ ├── eq1.ml │ ├── eq3.ml │ ├── enum1.ml │ ├── infsup.ml │ ├── privaterows1.ml │ ├── enum2.ml │ ├── eq2.ml │ ├── polyrec.ml │ ├── enum3.ml │ ├── privaterows2.ml │ ├── alias.ml │ ├── functorf.ml │ ├── a.ml │ ├── enum4.ml │ ├── eqparams.ml │ ├── dump1.ml │ ├── dump2.ml │ ├── polyrecord.ml │ └── README ├── bounded_tests.ml ├── bimap.ml ├── inline.ml ├── Makefile ├── typeable_tests.ml ├── enum_tests.ml ├── functor_tests.ml ├── exp.ml ├── dump_tests.ml ├── defs.ml ├── eq_tests.ml ├── sigs.ml └── pickle_tests.ml ├── syntax ├── id.ml ├── Makefile ├── enum_class.ml ├── typeable_class.ml ├── bounded_class.ml ├── extend.ml ├── show_class.ml ├── eq_class.ml ├── dump_class.ml ├── functor_class.ml ├── utils.ml ├── pickle_class.ml └── base.ml ├── lib ├── util.mli ├── interned.mli ├── functor.mli ├── dynmap.mli ├── bounded.mli ├── interned.ml ├── Makefile ├── enum.mli ├── eq.mli ├── dump.mli ├── functor.ml ├── show.mli ├── typeable.mli ├── eq.ml ├── dynmap.ml ├── bounded.ml ├── pickle.mli ├── monad.mli ├── enum.ml ├── show.ml ├── monad.ml ├── dump.ml ├── typeable.ml └── pickle.ml ├── Makefile ├── README ├── CHANGES └── COPYING /tests/show_tests.ml: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /syntax/id.ml: -------------------------------------------------------------------------------- 1 | let name = "deriving" 2 | let version = "0.1" 3 | -------------------------------------------------------------------------------- /tests/rejected/labels.ml: -------------------------------------------------------------------------------- 1 | type label = x:int -> int 2 | deriving (Eq) 3 | -------------------------------------------------------------------------------- /lib/util.mli: -------------------------------------------------------------------------------- 1 | val last : 'a list -> 'a 2 | val rassoc : 'a -> ('b * 'a) list -> 'b 3 | -------------------------------------------------------------------------------- /tests/rejected/eq1.ml: -------------------------------------------------------------------------------- 1 | (* Eq for functions *) 2 | type t = int -> int deriving (Eq) 3 | -------------------------------------------------------------------------------- /tests/rejected/eq3.ml: -------------------------------------------------------------------------------- 1 | (* Eq for classes *) 2 | class c = object end deriving (Eq) 3 | -------------------------------------------------------------------------------- /tests/rejected/enum1.ml: -------------------------------------------------------------------------------- 1 | (* enum for records *) 2 | type r = { x : int } deriving (Enum) 3 | -------------------------------------------------------------------------------- /tests/rejected/infsup.ml: -------------------------------------------------------------------------------- 1 | (* < > variant types *) 2 | type poly6 = [< `A > `B] 3 | deriving (Eq) 4 | -------------------------------------------------------------------------------- /tests/rejected/privaterows1.ml: -------------------------------------------------------------------------------- 1 | (* Private rows are currently not supported *) 2 | type poly4 = private [< `A] 3 | -------------------------------------------------------------------------------- /tests/rejected/enum2.ml: -------------------------------------------------------------------------------- 1 | (* Enum for sum types with arguments *) 2 | type t = X of int | Y 3 | deriving (Enum) 4 | -------------------------------------------------------------------------------- /tests/rejected/eq2.ml: -------------------------------------------------------------------------------- 1 | (* Eq for records with polymorphic fields *) 2 | type r4 = { 3 | l1 : 'a . 'a list 4 | } deriving (Eq) 5 | -------------------------------------------------------------------------------- /tests/rejected/polyrec.ml: -------------------------------------------------------------------------------- 1 | (* non-regular datatype *) 2 | 3 | type 'a seq = Nil | Cons of 'a * ('a * 'a) seq 4 | deriving (Eq) 5 | -------------------------------------------------------------------------------- /tests/rejected/enum3.ml: -------------------------------------------------------------------------------- 1 | (* Enum for polymorphic variant types with arguments *) 2 | 3 | type t = [`A of int | `B] deriving (Enum) 4 | -------------------------------------------------------------------------------- /tests/rejected/privaterows2.ml: -------------------------------------------------------------------------------- 1 | (* Private rows are currently not supported *) 2 | type poly4 = private [> `A] 3 | deriving (Eq) 4 | -------------------------------------------------------------------------------- /tests/rejected/alias.ml: -------------------------------------------------------------------------------- 1 | (* Alias variable names must be distinct from parameter names *) 2 | type 'a x = [`Foo] as 'a 3 | deriving (Eq) 4 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | built: 2 | cd syntax && make 3 | cd lib && make ncl bcl 4 | 5 | clean: 6 | cd syntax && make clean 7 | cd lib && make clean 8 | 9 | -------------------------------------------------------------------------------- /tests/rejected/functorf.ml: -------------------------------------------------------------------------------- 1 | (* Reject types called 'f' to avoid confusion with the overloaded type parameter *) 2 | type f = F deriving (Functor) 3 | -------------------------------------------------------------------------------- /tests/rejected/a.ml: -------------------------------------------------------------------------------- 1 | (* Reject types called 'a' to avoid confusion with the overloaded type parameter *) 2 | 3 | type a = A 4 | deriving (Eq) 5 | -------------------------------------------------------------------------------- /tests/rejected/enum4.ml: -------------------------------------------------------------------------------- 1 | (* Enum for extending polymorphic variant types *) 2 | type t1 = [`A] deriving (Enum) 3 | 4 | type t2 = [`B|t1] deriving (Enum) 5 | -------------------------------------------------------------------------------- /tests/rejected/eqparams.ml: -------------------------------------------------------------------------------- 1 | (* All types in a group must have the same parameters *) 2 | 3 | type 'a t1 = int 4 | and ('a,'b) t2 = int 5 | and t3 = int 6 | deriving (Eq) 7 | -------------------------------------------------------------------------------- /tests/rejected/dump1.ml: -------------------------------------------------------------------------------- 1 | (* private datatypes cannot be instances of dump (because Dump.from_string 2 | constructs values *) 3 | 4 | type p = private F 5 | deriving (Dump) 6 | -------------------------------------------------------------------------------- /lib/interned.mli: -------------------------------------------------------------------------------- 1 | (* Interned strings *) 2 | 3 | type t 4 | val compare : t -> t -> int 5 | val eq : t -> t -> bool 6 | val intern : string -> t 7 | val to_string : t -> string 8 | val name : t -> string 9 | -------------------------------------------------------------------------------- /tests/rejected/dump2.ml: -------------------------------------------------------------------------------- 1 | (* records with mutable fields cannot be instances of Dump 2 | (because it doesn't preserve sharing *) 3 | 4 | type t = { x : int; mutable y : int ; z : int } 5 | deriving (Dump) 6 | -------------------------------------------------------------------------------- /tests/rejected/polyrecord.ml: -------------------------------------------------------------------------------- 1 | (* Polymorphic variant definitions within polymorphic record field 2 | types *) 3 | type r = { 4 | (* I think this could be supported without too much difficulty, but 5 | it doesn't have much benefit *) 6 | x : 'a. [`Foo of 'a] 7 | 8 | } deriving (Eq) 9 | -------------------------------------------------------------------------------- /tests/rejected/README: -------------------------------------------------------------------------------- 1 | This directory contains programs that are syntactically correct but 2 | that are rejected by deriving because the types invovled don't meet 3 | the requirements for the classses in the deriving list. They're here 4 | so that it's easy to check the quality of the error messages produced. 5 | -------------------------------------------------------------------------------- /lib/functor.mli: -------------------------------------------------------------------------------- 1 | module type Functor = 2 | sig 3 | type 'a f 4 | val map : ('a -> 'b) -> 'a f -> 'b f 5 | end 6 | module MonadFunctor (M : Monad.Monad) : Functor with type 'a f = 'a M.m 7 | module Functor_option : Functor with type 'a f = 'a option 8 | module Functor_list : Functor with type 'a f = 'a list 9 | module Functor_map (O : Map.OrderedType) : Functor with type 'a f = 'a Map.Make(O).t 10 | -------------------------------------------------------------------------------- /lib/dynmap.mli: -------------------------------------------------------------------------------- 1 | (* Finite map : dynamic |-> t *) 2 | 3 | open Typeable 4 | 5 | module Comp (T : Typeable) (E : Eq.Eq with type a = T.a) : 6 | sig 7 | type a = T.a 8 | val eq : dynamic -> dynamic -> bool 9 | end 10 | 11 | module DynMap : 12 | sig 13 | type comparator = dynamic -> dynamic -> bool 14 | type 'a t 15 | val empty : 'a t 16 | val add : dynamic -> 'a -> comparator -> 'a t -> 'a t 17 | val mem : dynamic -> 'a t -> bool 18 | val find : dynamic -> 'a t -> 'a option 19 | val iter : (dynamic -> 'a -> unit) -> 'a t -> unit 20 | end 21 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Typing `make' in this directory should build both the preprocessor 2 | (syntax/deriving) and the libraries (lib/deriving.cma, 3 | lib/deriving.cmxa). 4 | 5 | You can run the tests by changing to the test directory and building 6 | and running the `tests' executable 7 | 8 | $ cd tests 9 | $ make 10 | ... 11 | $ ./tests 12 | Tests succeeded! 13 | 14 | There's very limited documentation at present, but you should be able 15 | to get started by looking at the test files. 16 | 17 | Any comments are very welcome. 18 | 19 | Jeremy Yallop 20 | jeremy.yallop@ed.ac.uk 21 | -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | 0.1.1 3 | 4 | Changes from 0.1: 5 | 6 | * Renamed serialisation classes: 7 | 8 | Pickle -> Dump 9 | Shelve -> Pickle 10 | 11 | * Made Dump and Pickle interface compatible with each other and more 12 | compatible with Marshal. 13 | 14 | * Bugfix in the tag hash function on 64-bit platforms. 15 | 16 | * Fixed a bug with a functor application quotation that used revised 17 | syntax. 18 | 19 | ------------------------------------------------------------------------------ 20 | 0.1 21 | 22 | Initial release 23 | -------------------------------------------------------------------------------- /tests/bounded_tests.ml: -------------------------------------------------------------------------------- 1 | open Defs 2 | 3 | let nullsum = 4 | begin 5 | assert (Bounded_nullsum.min_bound = N0); 6 | assert (Bounded_nullsum.max_bound = N3); 7 | end 8 | 9 | let poly0 = 10 | begin 11 | assert (Bounded_poly0.min_bound = `T0); 12 | assert (Bounded_poly0.max_bound = `T3); 13 | end 14 | 15 | let tup4 = 16 | begin 17 | assert (Bounded_tup4.min_bound = (min_int, min_int, false, ())); 18 | assert (Bounded_tup4.max_bound = (max_int, max_int, true, ())); 19 | end 20 | 21 | let t = 22 | begin 23 | assert (Bounded_t.min_bound = min_int); 24 | assert (Bounded_t.max_bound = max_int); 25 | end 26 | -------------------------------------------------------------------------------- /tests/bimap.ml: -------------------------------------------------------------------------------- 1 | (* Bidirectional map {t -> t} *) 2 | 3 | module type S = 4 | sig 5 | type item 6 | type t 7 | val empty : t 8 | val add : item -> item -> t -> t 9 | val find : item -> t -> item 10 | val mem : item -> t -> bool 11 | val rmem : item -> t -> bool 12 | end 13 | 14 | module type OrderedType = sig type t val compare : t -> t -> int end 15 | module Make (Ord : OrderedType) = 16 | struct 17 | type item = Ord.t 18 | type t = (item * item) list 19 | let empty = [] 20 | let add l r list = (l,r)::list 21 | let find = List.assoc 22 | let mem = List.mem_assoc 23 | let rmem item = List.exists (fun (_,i) -> i = item) 24 | end 25 | 26 | -------------------------------------------------------------------------------- /lib/bounded.mli: -------------------------------------------------------------------------------- 1 | module type Bounded = 2 | sig 3 | type a 4 | val min_bound : a 5 | val max_bound : a 6 | end 7 | 8 | module Bounded_bool : Bounded with type a = bool 9 | module Bounded_char : Bounded with type a = char 10 | module Bounded_int : Bounded with type a = int 11 | module Bounded_int32 : Bounded with type a = int32 12 | module Bounded_int64 : Bounded with type a = int64 13 | module Bounded_nativeint : Bounded with type a = nativeint 14 | module Bounded_unit : Bounded with type a = unit 15 | module Bounded_open_flag : Bounded with type a = Pervasives.open_flag 16 | module Bounded_fpclass : Bounded with type a = Pervasives.fpclass 17 | -------------------------------------------------------------------------------- /lib/interned.ml: -------------------------------------------------------------------------------- 1 | (*pp deriving *) 2 | 3 | (* Copyright Jeremy Yallop 2007. 4 | This file is free software, distributed under the MIT license. 5 | See the file COPYING for details. 6 | *) 7 | 8 | (* Interned strings *) 9 | module StringMap = Map.Make(String) 10 | 11 | (* global state *) 12 | let map = ref StringMap.empty 13 | let counter = ref 0 14 | 15 | type t = int * string 16 | deriving (Show) 17 | 18 | let intern s = 19 | try StringMap.find s !map 20 | with Not_found -> 21 | let fresh = (!counter, String.copy s) in begin 22 | map := StringMap.add s fresh !map; 23 | incr counter; 24 | fresh 25 | end 26 | 27 | let to_string (_,s) = String.copy s 28 | let name = snd 29 | let compare (l,_) (r,_) = compare l r 30 | let eq (l,_) (r,_) = l = r 31 | -------------------------------------------------------------------------------- /lib/Makefile: -------------------------------------------------------------------------------- 1 | OCAMLMAKEFILE = ../OCamlMakefile 2 | 3 | PATH := $(PATH):../syntax 4 | 5 | OCAMLOPT = ocamlopt.opt 6 | OCAMLC = ocamlc.opt 7 | OCAMLDEP = ocamldep.opt 8 | OCAMLFLAGS =-w ae 9 | LIBS = nums str unix 10 | 11 | SOURCES = show.ml show.mli \ 12 | interned.mli interned.ml \ 13 | eq.ml eq.mli \ 14 | bounded.ml bounded.mli \ 15 | enum.ml enum.mli \ 16 | monad.ml monad.mli \ 17 | dump.ml dump.mli \ 18 | typeable.ml typeable.mli \ 19 | dynmap.ml dynmap.mli \ 20 | pickle.ml pickle.mli \ 21 | functor.ml functor.mli \ 22 | 23 | 24 | RESULT = deriving 25 | 26 | include $(OCAMLMAKEFILE) 27 | -------------------------------------------------------------------------------- /tests/inline.ml: -------------------------------------------------------------------------------- 1 | (*pp deriving *) 2 | 3 | let _ = 4 | Eq.eq true false 5 | 6 | 7 | let _ = 8 | Show.show<(bool * string) list option> 9 | (Some ([true, "yes"; 10 | false, "no"])) 11 | 12 | 13 | let _ = 14 | [Typeable.mk 3; 15 | Typeable.mk 3.0; 16 | Typeable.mk [1;2;3]] 17 | 18 | type 'a seq = [`Nil | `Cons of 'a * 'a seq] 19 | deriving (Typeable) 20 | 21 | type nil = [`Nil] 22 | deriving (Typeable) 23 | type intlist = ([nil| `Cons of int * 'a ] as 'a) 24 | deriving (Typeable) 25 | 26 | let _ = 27 | Typeable.throwing_cast 28 | (Typeable.mk (`Cons (1, `Cons (2, `Cons (3, `Nil))))) 29 | 30 | let _ = 31 | Eq.eq true (Eq.eq 3 4) 32 | 33 | let _ = 34 | print_endline "Tests succeeded!" 35 | -------------------------------------------------------------------------------- /lib/enum.mli: -------------------------------------------------------------------------------- 1 | module type Enum = 2 | sig 3 | type a 4 | val succ : a -> a 5 | val pred : a -> a 6 | val to_enum : int -> a 7 | val from_enum : a -> int 8 | val enum_from : a -> a list 9 | val enum_from_then : a -> a -> a list 10 | val enum_from_to : a -> a -> a list 11 | val enum_from_then_to : a -> a -> a -> a list 12 | end 13 | 14 | module Defaults 15 | (E : sig type a val numbering : (a * int) list end) 16 | : Enum with type a = E.a 17 | 18 | module Defaults' 19 | (E : sig type a val from_enum : a -> int val to_enum : int -> a end) 20 | (B : Bounded.Bounded with type a = E.a) 21 | : Enum with type a = B.a 22 | 23 | module Enum_bool : Enum with type a = bool 24 | module Enum_char : Enum with type a = char 25 | module Enum_int : Enum with type a = int 26 | module Enum_unit : Enum with type a = unit 27 | -------------------------------------------------------------------------------- /tests/Makefile: -------------------------------------------------------------------------------- 1 | OCAMLMAKEFILE = ../OCamlMakefile 2 | 3 | AUXLIB_DIRS = ../lib/ 4 | OCAMLOPT = ocamlopt.opt 5 | OCAMLC = ocamlc.opt 6 | OCAMLDEP = ocamldep 7 | PATH := $(PATH):../syntax 8 | OCAMLFLAGS = -w Aef 9 | 10 | SOURCES = defs.ml \ 11 | bimap.ml bimap.mli \ 12 | sigs.ml \ 13 | pickle_tests.ml \ 14 | typeable_tests.ml \ 15 | bounded_tests.ml \ 16 | eq_tests.ml \ 17 | dump_tests.ml \ 18 | enum_tests.ml \ 19 | functor_tests.ml \ 20 | show_tests.ml \ 21 | exp.ml \ 22 | inline.ml \ 23 | 24 | LIBS = nums deriving 25 | RESULT = tests 26 | CLIBS = 27 | 28 | INCDIRS = $(AUXLIB_DIRS) 29 | LIBDIRS = $(AUXLIB_DIRS) 30 | 31 | include $(OCAMLMAKEFILE) 32 | -------------------------------------------------------------------------------- /lib/eq.mli: -------------------------------------------------------------------------------- 1 | (* A module for SML-style equality, i.e. where equality of mutables is 2 | physical equality and equality of immutables is structural equality. 3 | *) 4 | 5 | module type Eq = 6 | sig 7 | type a 8 | val eq : a -> a -> bool 9 | end 10 | 11 | module Defaults (E : Eq) : Eq with type a = E.a 12 | 13 | module Eq_immutable (S : sig type a end) : Eq with type a = S.a 14 | module Eq_mutable (S : sig type a end) : Eq with type a = S.a 15 | 16 | module Eq_int : Eq with type a = int 17 | module Eq_num : Eq with type a = Num.num 18 | module Eq_bool : Eq with type a = bool 19 | module Eq_float : Eq with type a = float 20 | module Eq_unit : Eq with type a = unit 21 | module Eq_char : Eq with type a = char 22 | module Eq_string : Eq with type a = string 23 | module Eq_ref (E : Eq) : Eq with type a = E.a ref 24 | module Eq_array (E : Eq) : Eq with type a = E.a array 25 | module Eq_list (E : Eq) : Eq with type a = E.a list 26 | module Eq_option (E : Eq): Eq with type a = E.a option 27 | module Eq_map_s_t (E : Eq) (M : Map.S) : Eq with type a = E.a M.t 28 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2007 Jeremy Yallop 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | THE SOFTWARE. 22 | -------------------------------------------------------------------------------- /syntax/Makefile: -------------------------------------------------------------------------------- 1 | OCAMLMAKEFILE = ../OCamlMakefile 2 | 3 | OCAMLC = ocamlc.opt 4 | OCAMLOPT = ocamlopt.opt 5 | OCAMLDEP = ocamldep.opt 6 | ANNOTATE = yes 7 | PPFLAGS = -loc loc 8 | USE_CAMLP4 = yes 9 | LIBS = dynlink camlp4lib unix 10 | 11 | CAMLP4_PRE_NOPRINTER = 12 | 13 | CAMLP4_PREFILES = Camlp4Parsers/Camlp4OCamlRevisedParser.cmo \ 14 | Camlp4Parsers/Camlp4OCamlParser.cmo \ 15 | Camlp4Printers/Camlp4AutoPrinter.cmo 16 | CAMLP4_POSTFILES = Camlp4Bin.cmo 17 | CAMLP4_NATIVE_PREFILES=$(CAMLP4_PREFILES:.cmo=.cmx) 18 | CAMLP4_NATIVE_POSTFILES=$(CAMLP4_POSTFILES:.cmo=.cmx) 19 | 20 | SOURCES = id.ml \ 21 | utils.ml \ 22 | type.ml \ 23 | base.ml \ 24 | extend.ml \ 25 | show_class.ml \ 26 | dump_class.ml \ 27 | enum_class.ml \ 28 | bounded_class.ml \ 29 | eq_class.ml \ 30 | typeable_class.ml \ 31 | functor_class.ml \ 32 | pickle_class.ml \ 33 | 34 | RESULT = deriving 35 | 36 | all: exe 37 | 38 | include $(OCAMLMAKEFILE) 39 | 40 | exe: $(IMPL_CMO) 41 | $(OCAMLC) -linkall $(ALL_LDFLAGS) $(CAMLP4_PREFILES) $(IMPL_CMO) -o deriving $(CAMLP4_POSTFILES) 42 | -------------------------------------------------------------------------------- /lib/dump.mli: -------------------------------------------------------------------------------- 1 | module type Dump = 2 | sig 3 | type a 4 | val to_buffer : Buffer.t -> a -> unit 5 | val to_string : a -> string 6 | val to_channel : out_channel -> a -> unit 7 | val from_stream : char Stream.t -> a 8 | val from_string : string -> a 9 | val from_channel : in_channel -> a 10 | end 11 | 12 | module Defaults 13 | (P : sig 14 | type a 15 | val to_buffer : Buffer.t -> a -> unit 16 | val from_stream : char Stream.t -> a 17 | end) : Dump with type a = P.a 18 | 19 | exception Dump_error of string 20 | 21 | module Dump_int32 : Dump with type a = Int32.t 22 | module Dump_int64 : Dump with type a = Int64.t 23 | module Dump_nativeint : Dump with type a = Nativeint.t 24 | module Dump_int : Dump with type a = int 25 | module Dump_char : Dump with type a = char 26 | module Dump_string : Dump with type a = string 27 | module Dump_float : Dump with type a = float 28 | module Dump_num : Dump with type a = Num.num 29 | module Dump_bool : Dump with type a = bool 30 | module Dump_unit : Dump with type a = unit 31 | module Dump_list (P : Dump) : Dump with type a = P.a list 32 | module Dump_option (P : Dump) : Dump with type a = P.a option 33 | 34 | module Dump_undumpable (P : sig type a val tname : string end) 35 | : Dump with type a = P.a 36 | module Dump_via_marshal (P : sig type a end) 37 | : Dump with type a = P.a 38 | -------------------------------------------------------------------------------- /lib/functor.ml: -------------------------------------------------------------------------------- 1 | open Monad 2 | 3 | (* Copyright Jeremy Yallop 2007. 4 | This file is free software, distributed under the MIT license. 5 | See the file COPYING for details. 6 | *) 7 | 8 | module type Functor = 9 | sig 10 | type 'a f 11 | val map : ('a -> 'b) -> 'a f -> 'b f 12 | end 13 | 14 | module MonadFunctor (M : Monad) 15 | : Functor with type 'a f = 'a M.m 16 | = 17 | struct 18 | open M 19 | type 'a f = 'a M.m 20 | let map f x = x >>= (fun x -> return (f x)) 21 | end 22 | 23 | 24 | module Functor_option = MonadFunctor(Monad.Monad_option) 25 | module Functor_list = MonadFunctor(Monad.Monad_list) 26 | 27 | module Functor_map (O : Map.OrderedType) 28 | : Functor with type 'a f = 'a Map.Make(O).t = 29 | struct 30 | include Map.Make(O) 31 | type 'a f = 'a t 32 | end 33 | 34 | (* 35 | NB: Instances for mutable types (including 36 | 37 | ref 38 | queue 39 | stack 40 | array 41 | stream 42 | buffer) 43 | 44 | are deliberately omitted. Since sharing is detectable for values of 45 | these types we have two distinct design choices: 46 | 47 | 1. Always create a new copy that shares no structure with the 48 | original. 49 | 50 | 2. Always mutate the original copy 51 | 52 | Neither of these seems like the right thing to do, so instead we 53 | simply don't handle mustable types at all. 54 | 55 | (Lazy.t is another example: we'd like map to be total and side-effect 56 | free, which is impossible to guarantee if we handle lazy. 57 | *) 58 | -------------------------------------------------------------------------------- /lib/show.mli: -------------------------------------------------------------------------------- 1 | module type Show = 2 | sig 3 | type a 4 | val format : Format.formatter -> a -> unit 5 | val format_list : Format.formatter -> a list -> unit 6 | val show : a -> string 7 | val show_list : a list -> string 8 | end 9 | 10 | module Defaults (S : 11 | sig 12 | type a 13 | val format : Format.formatter -> a -> unit 14 | end) : Show with type a = S.a 15 | 16 | module Show_unprintable (S : sig type a end) : Show with type a = S.a 17 | 18 | module Show_char : Show with type a = char 19 | module Show_bool : Show with type a = bool 20 | module Show_unit : Show with type a = unit 21 | module Show_int : Show with type a = int 22 | module Show_int32 : Show with type a = int32 23 | module Show_int64 : Show with type a = int64 24 | module Show_nativeint : Show with type a = nativeint 25 | module Show_num : Show with type a = Num.num 26 | module Show_float : Show with type a = float 27 | module Show_string : Show with type a = string 28 | 29 | module Show_list (S : Show) : Show with type a = S.a list 30 | module Show_ref (S : Show) : Show with type a = S.a ref 31 | module Show_option (S : Show) : Show with type a = S.a option 32 | module Show_array (S : Show) : Show with type a = S.a array 33 | 34 | module Show_map 35 | (O : Map.OrderedType) 36 | (K : Show with type a = O.t) 37 | (V : Show) 38 | : Show with type a = V.a Map.Make(O).t 39 | 40 | module Show_set 41 | (O : Set.OrderedType) 42 | (K : Show with type a = O.t) 43 | : Show with type a = Set.Make(O).t 44 | -------------------------------------------------------------------------------- /lib/typeable.mli: -------------------------------------------------------------------------------- 1 | module TypeRep : 2 | sig 3 | type t 4 | type delayed = unit -> t 5 | val compare : t -> t -> int 6 | val eq : t -> t -> bool 7 | val mkFresh : string -> delayed list -> delayed 8 | val mkTuple : delayed list -> delayed 9 | val mkPolyv : (string * delayed option) list -> delayed list -> delayed 10 | end 11 | 12 | exception CastFailure of string 13 | 14 | type dynamic 15 | val tagOf : dynamic -> TypeRep.t 16 | 17 | module type Typeable = 18 | sig 19 | type a 20 | val type_rep : unit -> TypeRep.t 21 | val has_type : dynamic -> bool 22 | val cast : dynamic -> a option 23 | val throwing_cast : dynamic -> a 24 | val make_dynamic : a -> dynamic 25 | val mk : a -> dynamic 26 | end 27 | 28 | module Defaults (T : (sig 29 | type a 30 | val type_rep : unit -> TypeRep.t 31 | end)) 32 | : Typeable with type a = T.a 33 | 34 | module Typeable_list (A : Typeable) : Typeable with type a = A.a list 35 | module Typeable_option (A : Typeable) : Typeable with type a = A.a option 36 | module Typeable_ref (A : Typeable) : Typeable with type a = A.a ref 37 | 38 | (*module Primitive_typeable (T : sig type t end): Typeable with type a = T.t *) 39 | 40 | module Typeable_unit : Typeable with type a = unit 41 | module Typeable_int : Typeable with type a = int 42 | module Typeable_num : Typeable with type a = Num.num 43 | module Typeable_float : Typeable with type a = float 44 | module Typeable_bool : Typeable with type a = bool 45 | module Typeable_string : Typeable with type a = string 46 | module Typeable_char : Typeable with type a = char 47 | 48 | -------------------------------------------------------------------------------- /lib/eq.ml: -------------------------------------------------------------------------------- 1 | (*pp deriving *) 2 | 3 | (* Copyright Jeremy Yallop 2007. 4 | This file is free software, distributed under the MIT license. 5 | See the file COPYING for details. 6 | *) 7 | 8 | module type Eq = 9 | sig 10 | type a 11 | val eq : a -> a -> bool 12 | end 13 | 14 | module Defaults (E : Eq) = E 15 | 16 | module Eq_immutable(S : sig type a end) : 17 | Eq with type a = S.a = 18 | struct 19 | type a = S.a 20 | let eq = (=) 21 | end 22 | 23 | module Eq_mutable(S : sig type a end) : 24 | Eq with type a = S.a = 25 | struct 26 | type a = S.a 27 | let eq = (==) 28 | end 29 | 30 | module Eq_int = Eq_immutable(struct type a = int end) 31 | module Eq_bool = Eq_immutable(struct type a = bool end) 32 | module Eq_float = Eq_immutable(struct type a = float end) 33 | module Eq_unit = Eq_immutable(struct type a = unit end) 34 | module Eq_char = Eq_immutable(struct type a = char end) 35 | 36 | module Eq_string = Eq_mutable(struct type a = string end) 37 | module Eq_ref (E : Eq) = Eq_mutable(struct type a = E.a ref end) 38 | module Eq_array (E : Eq) = Eq_mutable(struct type a = E.a array end) 39 | 40 | module Eq_option (E : Eq) 41 | : Eq with type a = E.a option = 42 | struct 43 | type a = E.a option 44 | let eq l r = match l, r with 45 | | None, None -> true 46 | | Some l, Some r -> E.eq l r 47 | | _ -> false 48 | end 49 | 50 | module Eq_map_s_t (E : Eq) (M : Map.S) 51 | : Eq with type a = E.a M.t = 52 | struct 53 | type a = E.a M.t 54 | let eq = M.equal (E.eq) 55 | end 56 | 57 | module Eq_list (E : Eq) : 58 | Eq with type a = E.a list = 59 | struct 60 | type a = E.a list 61 | let rec eq l r = match l, r with 62 | | [], [] -> true 63 | | (lfst::lrst), (rfst::rrst) when E.eq lfst rfst -> eq lrst rrst 64 | | _ -> false 65 | end 66 | 67 | module Eq_num 68 | : Eq with type a = Num.num = 69 | struct 70 | type a = Num.num 71 | let eq = Num.eq_num 72 | end 73 | -------------------------------------------------------------------------------- /lib/dynmap.ml: -------------------------------------------------------------------------------- 1 | (* Finite maps : t -> dynamic *) 2 | 3 | (* Copyright Jeremy Yallop 2007. 4 | This file is free software, distributed under the MIT license. 5 | See the file COPYING for details. 6 | *) 7 | open Typeable 8 | 9 | module Comp (T : Typeable) (E : Eq.Eq with type a = T.a) = 10 | struct 11 | type a = T.a 12 | let adjust_comparator : (T.a -> T.a -> bool) -> dynamic -> dynamic -> bool 13 | = fun comparator d1 d2 -> 14 | match T.cast d1, T.cast d2 with 15 | | Some l, Some r -> comparator l r 16 | | _ -> assert false 17 | let eq = adjust_comparator E.eq 18 | end 19 | 20 | 21 | module DynMap = 22 | struct 23 | module TypeMap = Map.Make(TypeRep) 24 | type comparator = dynamic -> dynamic -> bool 25 | type 'value t = (((dynamic * 'value) list * comparator) TypeMap.t) 26 | 27 | let empty = TypeMap.empty 28 | 29 | let add dynamic value comparator map = 30 | let typeRep = tagOf dynamic in 31 | let monomap = 32 | try (List.filter 33 | (fun (k,_) -> not (comparator k dynamic)) 34 | (fst (TypeMap.find typeRep map))) 35 | with Not_found -> [] 36 | in 37 | TypeMap.add 38 | typeRep 39 | (((dynamic,value)::monomap), comparator) 40 | map 41 | 42 | let mem dynamic map = 43 | try let monomap, comparator = TypeMap.find (tagOf dynamic) map in 44 | (List.exists 45 | (fun (k,_) -> (comparator dynamic k)) 46 | monomap) 47 | with Not_found -> false 48 | 49 | let find dynamic map = 50 | try 51 | let monomap, comparator = TypeMap.find (tagOf dynamic) map in 52 | Some (snd (List.find 53 | (fun (k,_) -> comparator dynamic k) 54 | monomap)) 55 | with Not_found -> None 56 | 57 | let iter : (dynamic -> 'a -> unit) -> 'a t -> unit 58 | = fun f -> 59 | TypeMap.iter 60 | (fun _ (monomap,_) -> List.iter (fun (k, v) -> f k v) monomap) 61 | end 62 | -------------------------------------------------------------------------------- /lib/bounded.ml: -------------------------------------------------------------------------------- 1 | (*pp deriving *) 2 | (* Copyright Jeremy Yallop 2007. 3 | This file is free software, distributed under the MIT license. 4 | See the file COPYING for details. 5 | *) 6 | 7 | (** Primitive instanecs for bounded **) 8 | module Bounded = struct 9 | module type Bounded = sig 10 | type a 11 | val min_bound : a 12 | val max_bound : a 13 | end 14 | 15 | module Bounded_integer(B : sig type t 16 | val max_int : t 17 | val min_int : t 18 | end) : Bounded with type a = B.t = 19 | struct 20 | type a = B.t 21 | let min_bound = B.min_int 22 | let max_bound = B.max_int 23 | end 24 | module Bounded_int32 = Bounded_integer(Int32) 25 | module Bounded_int64 = Bounded_integer(Int64) 26 | module Bounded_nativeint = Bounded_integer(Nativeint) 27 | module Bounded_int = struct 28 | type a = int 29 | let min_bound = Pervasives.min_int 30 | let max_bound = Pervasives.max_int 31 | end 32 | module Bounded_bool = struct 33 | type a = bool 34 | let min_bound = false 35 | let max_bound = true 36 | end 37 | module Bounded_char = struct 38 | type a = char 39 | let min_bound = Char.chr 0 40 | let max_bound = Char.chr 0xff (* Is this guaranteed? *) 41 | end 42 | module Bounded_unit = struct 43 | type a = unit 44 | let min_bound = () 45 | let max_bound = () 46 | end 47 | end 48 | include Bounded 49 | type open_flag = Pervasives.open_flag = 50 | | Open_rdonly 51 | | Open_wronly 52 | | Open_append 53 | | Open_creat 54 | | Open_trunc 55 | | Open_excl 56 | | Open_binary 57 | | Open_text 58 | | Open_nonblock 59 | deriving (Bounded) 60 | 61 | type fpclass = Pervasives.fpclass = 62 | | FP_normal 63 | | FP_subnormal 64 | | FP_zero 65 | | FP_infinite 66 | | FP_nan 67 | deriving (Bounded) 68 | -------------------------------------------------------------------------------- /lib/pickle.mli: -------------------------------------------------------------------------------- 1 | type id 2 | 3 | (* representation of values of user-defined types *) 4 | module Repr : sig 5 | type t 6 | val make : ?constructor:int -> id list -> t 7 | end 8 | 9 | (* Utilities for serialization *) 10 | module Write : sig 11 | type s 12 | include Monad.Monad_state_type with type state = s 13 | module Utils (T : Typeable.Typeable) (E : Eq.Eq with type a = T.a) : sig 14 | val allocate : T.a -> (id -> unit m) -> id m 15 | val store_repr : id -> Repr.t -> unit m 16 | end 17 | end 18 | 19 | (* Utilities for deserialization *) 20 | module Read : sig 21 | type s 22 | include Monad.Monad_state_type with type state = s 23 | module Utils (T : Typeable.Typeable) : sig 24 | val sum : (int * id list -> T.a m) -> (id -> T.a m) 25 | val tuple : (id list -> T.a m) -> (id -> T.a m) 26 | val record : (T.a -> id list -> T.a m) -> int -> (id -> T.a m) 27 | end 28 | end 29 | 30 | exception UnpicklingError of string 31 | exception UnknownTag of int * string 32 | 33 | module type Pickle = 34 | sig 35 | type a 36 | module T : Typeable.Typeable with type a = a 37 | module E : Eq.Eq with type a = a 38 | val pickle : a -> id Write.m 39 | val unpickle : id -> a Read.m 40 | val to_buffer : Buffer.t -> a -> unit 41 | val to_string : a -> string 42 | val to_channel : out_channel -> a -> unit 43 | val from_stream : char Stream.t -> a 44 | val from_string : string -> a 45 | val from_channel : in_channel -> a 46 | end 47 | 48 | module Defaults 49 | (S : sig 50 | type a 51 | module T : Typeable.Typeable with type a = a 52 | module E : Eq.Eq with type a = a 53 | val pickle : a -> id Write.m 54 | val unpickle : id -> a Read.m 55 | end) : Pickle with type a = S.a 56 | 57 | module Pickle_unit : Pickle with type a = unit 58 | module Pickle_bool : Pickle with type a = bool 59 | module Pickle_int : Pickle with type a = int 60 | module Pickle_char : Pickle with type a = char 61 | module Pickle_float : Pickle with type a = float 62 | module Pickle_num : Pickle with type a = Num.num 63 | module Pickle_string : Pickle with type a = string 64 | module Pickle_option (V0 : Pickle) : Pickle with type a = V0.a option 65 | module Pickle_list (V0 : Pickle) : Pickle with type a = V0.a list 66 | module Pickle_ref (S : Pickle) : Pickle with type a = S.a ref 67 | 68 | module Pickle_from_dump 69 | (P : Dump.Dump) 70 | (E : Eq.Eq with type a = P.a) 71 | (T : Typeable.Typeable with type a = P.a) 72 | : Pickle with type a = P.a 73 | -------------------------------------------------------------------------------- /tests/typeable_tests.ml: -------------------------------------------------------------------------------- 1 | (*pp deriving *) 2 | 3 | type t1 = F deriving (Typeable) 4 | type t2 = F deriving (Typeable) 5 | 6 | let eq_types = Typeable.TypeRep.eq 7 | 8 | let _ = 9 | begin 10 | assert (eq_types 11 | (Typeable_t1.type_rep ()) 12 | (Typeable_t1.type_rep ())); 13 | assert (eq_types 14 | (Typeable_t2.type_rep ()) 15 | (Typeable_t2.type_rep ())); 16 | assert (not (eq_types 17 | (Typeable_t1.type_rep ()) 18 | (Typeable_t2.type_rep ()))); 19 | assert (not (eq_types 20 | (Typeable_t2.type_rep ()) 21 | (Typeable_t1.type_rep ()))); 22 | end 23 | 24 | type t3 = int deriving (Typeable) 25 | 26 | let _ = 27 | begin 28 | assert (eq_types 29 | (Typeable.Typeable_int.type_rep ()) 30 | (Typeable_t3.type_rep ())); 31 | end 32 | 33 | 34 | type t4 = [`T of int] deriving (Typeable) 35 | type t5 = [`T of t3] deriving (Typeable) 36 | 37 | let _ = 38 | begin 39 | assert (eq_types 40 | (Typeable_t4.type_rep ()) 41 | (Typeable_t5.type_rep ())); 42 | end 43 | 44 | type t6 = [`T of t5] 45 | deriving (Typeable) 46 | 47 | let _ = 48 | begin 49 | assert (not (eq_types 50 | (Typeable_t5.type_rep ()) 51 | (Typeable_t6.type_rep ()))); 52 | 53 | end 54 | 55 | type t7 = [`T of t6] 56 | deriving (Typeable) 57 | 58 | let _ = 59 | begin 60 | assert (not (eq_types 61 | (Typeable_t6.type_rep ()) 62 | (Typeable_t7.type_rep ()))); 63 | end 64 | 65 | 66 | type t8 = [`A | `B] deriving (Typeable) 67 | type t9 = [`B | `A] deriving (Typeable) 68 | 69 | let _ = 70 | begin 71 | assert (eq_types 72 | (Typeable_t8.type_rep ()) 73 | (Typeable_t9.type_rep ())); 74 | end 75 | 76 | 77 | type ('a,'r) openr = [`Nil | `Cons of 'a * 'r] 78 | deriving (Typeable) 79 | type 'a closedr = [`Nil | `Cons of 'a * 'a closedr] 80 | deriving (Typeable) 81 | type l1 = (int, l1) openr 82 | and l2 = int closedr deriving (Typeable) 83 | 84 | let _ = 85 | begin 86 | assert (eq_types 87 | (Typeable_l1.type_rep ()) 88 | (Typeable_l1.type_rep ())); 89 | end 90 | 91 | type nil = [`Nil] deriving (Typeable) 92 | type t10 = ([nil| `Cons of int * 'a ] as 'a) list 93 | deriving (Typeable) 94 | type t11 = l2 list deriving (Typeable) 95 | 96 | let _ = 97 | begin 98 | assert 99 | (eq_types 100 | (Typeable_t10.type_rep ()) 101 | (Typeable_t11.type_rep ())); 102 | end 103 | -------------------------------------------------------------------------------- /syntax/enum_class.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4of *) 2 | 3 | (* Copyright Jeremy Yallop 2007. 4 | This file is free software, distributed under the MIT license. 5 | See the file COPYING for details. 6 | *) 7 | 8 | module InContext (L : Base.Loc) = 9 | struct 10 | open Base 11 | open Utils 12 | open Type 13 | open Camlp4.PreCast 14 | include Base.InContext(L) 15 | 16 | let classname = "Enum" 17 | 18 | let instance = object(self) 19 | inherit make_module_expr ~classname ~allow_private:false 20 | 21 | method sum ?eq ctxt ((tname,_,_,_,_) as decl) summands = 22 | let numbering = 23 | List.fold_right2 24 | (fun n ctor rest -> 25 | match ctor with 26 | | (name, []) -> <:expr< ($uid:name$, $`int:n$) :: $rest$ >> 27 | | (name,_) -> raise (Underivable ("Enum cannot be derived for the type "^ 28 | tname ^" because the constructor "^ 29 | name^" is not nullary"))) 30 | (List.range 0 (List.length summands)) 31 | summands 32 | <:expr< [] >> in 33 | <:module_expr< Enum.Defaults(struct type $Ast.TyDcl (loc, "a", [], atype ctxt decl, [])$ 34 | let numbering = $numbering$ end) >> 35 | 36 | method variant ctxt decl (_, tags) = 37 | let numbering = 38 | List.fold_right2 39 | (fun n tagspec rest -> 40 | match tagspec with 41 | | Tag (name, None) -> <:expr< (`$name$, $`int:n$) :: $rest$ >> 42 | | Tag (name, _) -> raise (Underivable ("Enum cannot be derived because the tag "^ 43 | name^" is not nullary")) 44 | | _ -> raise (Underivable ("Enum cannot be derived for this " 45 | ^"polymorphic variant type"))) 46 | (List.range 0 (List.length tags)) 47 | tags 48 | <:expr< [] >> in 49 | <:module_expr< Enum.Defaults(struct type $Ast.TyDcl (loc, "a", [], atype ctxt decl, [])$ let numbering = $numbering$ end) >> 50 | 51 | method tuple context _ = raise (Underivable "Enum cannot be derived for tuple types") 52 | method record ?eq _ (tname,_,_,_,_) = raise (Underivable 53 | ("Enum cannot be derived for record types (i.e. "^ 54 | tname^")")) 55 | end 56 | end 57 | 58 | let _ = Base.register "Enum" 59 | ((fun (loc, context, decls) -> 60 | let module M = InContext(struct let loc = loc end) in 61 | M.generate ~context ~decls ~make_module_expr:M.instance#rhs ~classname:M.classname ()), 62 | (fun (loc, context, decls) -> 63 | let module M = InContext(struct let loc = loc end) in 64 | M.gen_sigs ~context ~decls ~classname:M.classname)) 65 | -------------------------------------------------------------------------------- /syntax/typeable_class.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4of *) 2 | 3 | (* Copyright Jeremy Yallop 2007. 4 | This file is free software, distributed under the MIT license. 5 | See the file COPYING for details. 6 | *) 7 | 8 | module InContext (L : Base.Loc) = 9 | struct 10 | open Type 11 | open Base 12 | open Camlp4.PreCast 13 | include Base.InContext(L) 14 | 15 | let classname = "Typeable" 16 | 17 | let mkName : name -> string = 18 | let file_name, sl, _, _, _, _, _, _ = Loc.to_tuple loc in 19 | Printf.sprintf "%s_%d_%f_%s" 20 | file_name sl (Unix.gettimeofday ()) 21 | 22 | let gen ?eq ctxt ((tname,_,_,_,_) as decl : Type.decl) _ = 23 | let paramList = 24 | List.fold_right 25 | (fun (p,_) cdr -> 26 | <:expr< $uid:NameMap.find p ctxt.argmap$.type_rep::$cdr$ >>) 27 | ctxt.params 28 | <:expr< [] >> 29 | in <:module_expr< struct type $Ast.TyDcl (loc, "a", [], atype ctxt decl, [])$ 30 | let type_rep = TypeRep.mkFresh $str:mkName tname$ $paramList$ end >> 31 | 32 | let tup ctxt ts mexpr expr = 33 | let params = 34 | expr_list 35 | (List.map (fun t -> <:expr< let module M = $expr ctxt t$ 36 | in $mexpr$ >>) ts) in 37 | <:module_expr< Defaults(struct type $Ast.TyDcl (loc, "a", [], atype_expr ctxt (`Tuple ts), [])$ 38 | let type_rep = Typeable.TypeRep.mkTuple $params$ end) >> 39 | 40 | let instance = object(self) 41 | inherit make_module_expr ~classname ~allow_private:true 42 | 43 | method tuple ctxt ts = tup ctxt ts <:expr< M.type_rep >> (self#expr) 44 | method sum = gen 45 | method record = gen 46 | method variant ctxt decl (_,tags) = 47 | let tags, extends = 48 | List.fold_left 49 | (fun (tags, extends) -> function 50 | | Tag (l, None) -> <:expr< ($str:l$, None) :: $tags$ >>, extends 51 | | Tag (l,Some t) -> 52 | <:expr< ($str:l$, Some $mproject (self#expr ctxt t) "type_rep"$) ::$tags$ >>, 53 | extends 54 | | Extends t -> 55 | tags, 56 | <:expr< $mproject (self#expr ctxt t) "type_rep"$::$extends$ >>) 57 | (<:expr< [] >>, <:expr< [] >>) tags in 58 | <:module_expr< Defaults( 59 | struct type $Ast.TyDcl (loc, "a", [], atype ctxt decl, [])$ 60 | let type_rep = Typeable.TypeRep.mkPolyv $tags$ $extends$ 61 | end) >> 62 | end 63 | end 64 | 65 | let _ = Base.register "Typeable" 66 | ((fun (loc, context, decls) -> 67 | let module M = InContext(struct let loc = loc end) in 68 | M.generate ~context ~decls ~make_module_expr:M.instance#rhs ~classname:M.classname 69 | ~default_module:"Defaults" ()), 70 | (fun (loc, context, decls) -> 71 | let module M = InContext(struct let loc = loc end) in 72 | M.gen_sigs ~context ~decls ~classname:M.classname)) 73 | -------------------------------------------------------------------------------- /tests/enum_tests.ml: -------------------------------------------------------------------------------- 1 | open Defs 2 | 3 | let nullsum = 4 | begin 5 | let module E = Enum_nullsum in 6 | 7 | assert (E.succ N0 = N1); 8 | assert (E.succ N1 = N2); 9 | assert (E.succ N2 = N3); 10 | assert (try ignore (E.succ N3); false 11 | with Invalid_argument "succ" -> true); 12 | 13 | assert (try ignore (E.pred N0); false 14 | with Invalid_argument "pred" -> true); 15 | assert (E.pred N1 = N0); 16 | assert (E.pred N2 = N1); 17 | assert (E.pred N3 = N2); 18 | 19 | assert (E.from_enum N0 = 0); 20 | assert (E.from_enum N1 = 1); 21 | assert (E.from_enum N2 = 2); 22 | assert (E.from_enum N3 = 3); 23 | 24 | assert (E.to_enum 0 = N0); 25 | assert (E.to_enum 1 = N1); 26 | assert (E.to_enum 2 = N2); 27 | assert (E.to_enum 3 = N3); 28 | assert (try ignore (E.to_enum 4); false 29 | with Invalid_argument "to_enum" -> true); 30 | 31 | assert (E.enum_from N0 = [N0;N1;N2;N3]); 32 | assert (E.enum_from N1 = [N1;N2;N3]); 33 | assert (E.enum_from N2 = [N2;N3]); 34 | assert (E.enum_from N3 = [N3]); 35 | 36 | assert (E.enum_from_then N0 N1 = [N0;N1;N2;N3]); 37 | assert (E.enum_from_then N0 N2 = [N0;N2]); 38 | assert (E.enum_from_then N1 N2 = [N1;N2;N3]); 39 | assert (E.enum_from_then N1 N3 = [N1;N3]); 40 | assert (try ignore (E.enum_from_then N3 N3); false 41 | with Invalid_argument _ -> true); 42 | assert (try ignore (E.enum_from_then N3 N1); false 43 | with Invalid_argument _ -> true); 44 | 45 | assert (E.enum_from_to N0 N1 = [N0;N1]); 46 | assert (E.enum_from_to N1 N3 = [N1;N2;N3]); 47 | assert (E.enum_from_to N1 N1 = [N1]); 48 | assert (E.enum_from_to N1 N0 = []); 49 | 50 | assert (E.enum_from_then_to N0 N1 N3 = [N0;N1;N2;N3]); 51 | assert (E.enum_from_then_to N0 N2 N3 = [N0;N2]); 52 | assert (E.enum_from_then_to N0 N3 N3 = [N0;N3]); 53 | assert (try ignore (E.enum_from_then_to N0 N0 N0); false 54 | with Invalid_argument _ -> true); 55 | end 56 | 57 | let poly0 = 58 | begin 59 | let module E = Enum_poly0 in 60 | 61 | assert (E.succ `T0 = `T1); 62 | assert (E.succ `T1 = `T2); 63 | assert (E.succ `T2 = `T3); 64 | assert (try ignore (E.succ `T3); false 65 | with Invalid_argument "succ" -> true); 66 | 67 | assert (try ignore (E.pred `T0); false 68 | with Invalid_argument "pred" -> true); 69 | assert (E.pred `T1 = `T0); 70 | assert (E.pred `T2 = `T1); 71 | assert (E.pred `T3 = `T2); 72 | 73 | end 74 | 75 | let t = 76 | begin 77 | ListLabels.iter (Enum.Enum_int.enum_from_to (-1000) 1000) 78 | ~f:(fun i -> 79 | assert (Enum_t.succ i = i+1); 80 | assert (Enum_t.pred i = i-1); 81 | assert (Enum_t.to_enum i = i); 82 | assert (Enum_t.from_enum i = i)); 83 | end 84 | -------------------------------------------------------------------------------- /syntax/bounded_class.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4of *) 2 | 3 | (* Copyright Jeremy Yallop 2007. 4 | This file is free software, distributed under the MIT license. 5 | See the file COPYING for details. 6 | *) 7 | 8 | module InContext (L : Base.Loc) = 9 | struct 10 | open Base 11 | open Utils 12 | open Type 13 | open Camlp4.PreCast 14 | include Base.InContext(L) 15 | 16 | let classname = "Bounded" 17 | 18 | let instance = object (self) 19 | inherit make_module_expr ~classname ~allow_private:false 20 | 21 | method tuple ctxt ts = 22 | let minBounds, maxBounds = 23 | List.split (List.map 24 | (fun t -> let e = self#expr ctxt t in 25 | <:expr< let module M = $e$ in M.min_bound >>, 26 | <:expr< let module M = $e$ in M.max_bound >>) ts) in 27 | <:module_expr< struct type $Ast.TyDcl (loc, "a", [], atype_expr ctxt (`Tuple ts), [])$ 28 | let min_bound = $tuple_expr minBounds$ 29 | let max_bound = $tuple_expr maxBounds$ end >> 30 | 31 | method sum ?eq ctxt ((tname,_,_,_,_) as decl) summands = 32 | let names = ListLabels.map summands 33 | ~f:(function 34 | | (name,[]) -> name 35 | | (name,_) -> raise (Underivable ("Bounded cannot be derived for the type "^ 36 | tname ^" because the constructor "^ 37 | name^" is not nullary"))) in 38 | <:module_expr< struct type $Ast.TyDcl (loc, "a", [], atype ctxt decl, [])$ 39 | let min_bound = $uid:List.hd names$ 40 | and max_bound = $uid:List.last names$ end >> 41 | 42 | method variant ctxt decl (_, tags) = 43 | let names = ListLabels.map tags 44 | ~f:(function 45 | | Tag (name, None) -> name 46 | | Tag (name, _) -> raise (Underivable ("Bounded cannot be derived because the tag "^ 47 | name^" is not nullary")) 48 | | _ -> raise (Underivable ("Bounded cannot be derived for this " 49 | ^"polymorphic variant type"))) in 50 | <:module_expr< struct type $Ast.TyDcl (loc, "a", [], atype ctxt decl, [])$ 51 | let min_bound = `$List.hd names$ 52 | and max_bound = `$List.last names$ end >> 53 | 54 | (* should perhaps implement this one *) 55 | method record ?eq _ (tname,_,_,_,_) = raise (Underivable ("Bounded cannot be derived for record types (i.e. "^ 56 | tname^")")) 57 | end 58 | end 59 | 60 | let _ = Base.register "Bounded" 61 | ((fun (loc, context, decls) -> 62 | let module M = InContext(struct let loc = loc end) in 63 | M.generate ~context ~decls ~make_module_expr:M.instance#rhs ~classname:M.classname ()), 64 | (fun (loc, context, decls) -> 65 | let module M = InContext(struct let loc = loc end) in 66 | M.gen_sigs ~context ~decls ~classname:M.classname)) 67 | -------------------------------------------------------------------------------- /lib/monad.mli: -------------------------------------------------------------------------------- 1 | module type Monad = 2 | sig 3 | type +'a m 4 | val return : 'a -> 'a m 5 | val fail : string -> 'a m 6 | val ( >>= ) : 'a m -> ('a -> 'b m) -> 'b m 7 | val ( >> ) : 'a m -> 'b m -> 'b m 8 | end 9 | 10 | module type MonadPlus = 11 | sig 12 | include Monad 13 | val mzero : 'a m 14 | val mplus : 'a m -> 'a m -> 'a m 15 | end 16 | 17 | module MonadDefault 18 | (M : sig 19 | type +'a m 20 | val return : 'a -> 'a m 21 | val fail : string -> 'a m 22 | val ( >>= ) : 'a m -> ('a -> 'b m) -> 'b m 23 | end) : Monad with type +'a m = 'a M.m 24 | 25 | module Monad_option : MonadPlus with type 'a m = 'a option 26 | module Monad_list : MonadPlus with type 'a m = 'a list 27 | module IO : 28 | sig 29 | include Monad 30 | val putStr : string -> unit m 31 | val runIO : 'a m -> 'a 32 | val mkIO : (unit -> 'b) -> 'b m 33 | end 34 | module type MonadUtilsSig = 35 | sig 36 | include Monad 37 | val liftM : ('a -> 'b) -> 'a m -> 'b m 38 | val liftM2 : ('a -> 'b -> 'c) -> 'a m -> 'b m -> 'c m 39 | val liftM3 : ('a -> 'b -> 'c -> 'd) -> 'a m -> 'b m -> 'c m -> 'd m 40 | val liftM4 : 41 | ('a -> 'b -> 'c -> 'd -> 'e) -> 'a m -> 'b m -> 'c m -> 'd m -> 'e m 42 | val liftM5 : 43 | ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 44 | 'a m -> 'b m -> 'c m -> 'd m -> 'e m -> 'f m 45 | val ap : ('a -> 'b) m -> 'a m -> 'b m 46 | val sequence : 'a m list -> 'a list m 47 | val sequence_ : 'a m list -> unit m 48 | val mapM : ('a -> 'b m) -> 'a list -> 'b list m 49 | val mapM_ : ('a -> 'b m) -> 'a list -> unit m 50 | val ( =<< ) : ('a -> 'b m) -> 'a m -> 'b m 51 | val join : 'a m m -> 'a m 52 | val filterM : ('a -> bool m) -> 'a list -> 'a list m 53 | val mapAndUnzipM : 54 | ('a -> ('b * 'c) m) -> 'a list -> ('b list * 'c list) m 55 | val zipWithM : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> 'c list m 56 | val zipWithM_ : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> unit m 57 | val foldM : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m 58 | val foldM_ : ('a -> 'b -> 'a m) -> 'a -> 'b list -> unit m 59 | val replicateM : int -> 'a m -> 'a list m 60 | val replicateM_ : int -> 'a m -> unit m 61 | val quand : bool -> unit m -> unit m 62 | val unless : bool -> unit m -> unit m 63 | end 64 | 65 | module MonadUtils (M : Monad) : MonadUtilsSig with type 'a m = 'a M.m 66 | module type MonadPlusUtilsSig = 67 | sig 68 | include MonadUtilsSig 69 | val mzero : 'a m 70 | val mplus : 'a m -> 'a m -> 'a m 71 | val guard : bool -> unit m 72 | val msum : 'a m list -> 'a m 73 | end 74 | 75 | module MonadPlusUtils (M : MonadPlus) : MonadPlusUtilsSig with type 'a m = 'a M.m 76 | 77 | module MonadPlusUtils_option : MonadPlusUtilsSig with type 'a m = 'a Monad_option.m 78 | module MonadPlusUtils_list : MonadPlusUtilsSig with type 'a m = 'a Monad_list.m 79 | module Monad_IO : MonadUtilsSig with type 'a m = 'a IO.m 80 | 81 | module type Monad_state_type = 82 | sig 83 | include MonadUtilsSig 84 | type state 85 | val get : state m 86 | val put : state -> unit m 87 | val runState : 'a m -> state -> 'a * state 88 | end 89 | 90 | module Monad_state (S : sig type state end) : 91 | Monad_state_type with type state = S.state 92 | -------------------------------------------------------------------------------- /tests/functor_tests.ml: -------------------------------------------------------------------------------- 1 | open Defs 2 | 3 | let r1 = 4 | begin 5 | let map : r1 -> r1 = Functor_r1.map in 6 | let x = {r1_l1 = 2; r1_l2 = 12} in 7 | 8 | assert (map x = x); 9 | end 10 | 11 | let intseq = 12 | begin 13 | let map : intseq -> intseq = Functor_intseq.map in 14 | let i = ICons (0, ICons (1, ICons (2, INil))) in 15 | assert (map i = i); 16 | end 17 | 18 | let seq = 19 | begin 20 | let map = 21 | let module M : sig val map : ('a -> 'b) -> 'a seq -> 'b seq end 22 | = struct let map = Functor_seq.map end in M.map in 23 | assert (map ((+)1) (Cons (1, Cons (2, Cons (3, Cons (4, Nil))))) 24 | = Cons (2, Cons (3, Cons (4, Cons (5, Nil))))); 25 | end 26 | 27 | let poly7 = 28 | begin 29 | let map = 30 | let module M : sig val map : ('a -> 'b) -> 'a poly7 -> 'b poly7 end 31 | = struct let map = Functor_poly7.map end in M.map in 32 | assert (map ((+)1) (Foo (`F 0)) = Foo (`F 1)); 33 | end 34 | 35 | let poly8 = 36 | begin 37 | let map = 38 | let module M : sig val map : ('a -> 'b) -> 'a poly8 -> 'b poly8 end 39 | = struct let map = Functor_poly8.map end in M.map in 40 | assert (map ((+)1) 41 | { x = `G (`H (`I (Foo (`F 0))))} 42 | = { x = `G (`H (`I (Foo (`F 1))))}); 43 | end 44 | 45 | let poly10 = 46 | begin 47 | let map : poly10 -> poly10 = Functor_poly10.map in 48 | assert (map `F = `F); 49 | assert (map (`Cons (1,`Cons (2, `Nil))) = (`Cons (1,`Cons (2, `Nil)))); 50 | end 51 | 52 | let pmutrec = 53 | begin 54 | let _ = 55 | let module M : sig val map : ('a -> 'b) -> ('c -> 'd) -> ('a,'c) pmutrec_a -> ('b,'d) pmutrec_a end 56 | = struct let map = Functor_pmutrec_a.map end in M.map in 57 | let _ = 58 | let module M : sig val map : ('a -> 'b) -> ('c -> 'd) -> ('a,'c) pmutrec_b -> ('b,'d) pmutrec_b end 59 | = struct let map = Functor_pmutrec_b.map end in M.map in 60 | let _ = 61 | let module M : sig val map : ('a -> 'b) -> ('c -> 'd) -> ('a,'c) pmutrec_c -> ('b,'d) pmutrec_c end 62 | = struct let map = Functor_pmutrec_c.map end in M.map in 63 | let _ = 64 | let module M : sig val map : ('a -> 'b) -> ('c -> 'd) -> ('a,'c) pmutrec_d -> ('b,'d) pmutrec_d end 65 | = struct let map = Functor_pmutrec_d.map end in M.map in 66 | () 67 | end 68 | 69 | let ff1 = 70 | begin 71 | let map = 72 | let module M : sig val map : ('a -> 'b) -> 'a ff1 -> 'b ff1 end 73 | = struct let map = Functor_ff1.map end in M.map in 74 | assert (map ((+)1) (F (1,2)) = F (2,3)); 75 | assert (map ((+)1) (G 3) = G 3); 76 | end 77 | 78 | let ff2 = 79 | begin 80 | let map f = 81 | let module M : sig val map : ('a -> 'b) -> ('c -> 'd) -> ('a,'c) ff2 -> ('b,'d) ff2 end 82 | = struct let map = Functor_ff2.map end in M.map f in 83 | assert (map ((+)1) not (F1 (F2 (Cons (1,Cons (2, Nil)), 3, Some true))) 84 | = (F1 (F2 (Cons (2,Cons (3, Nil)), 3, Some false)))); 85 | 86 | assert (map not ((+)1) (F1 (F2 (Cons (true,Nil), 3, Some 0))) 87 | = (F1 (F2 (Cons (false,Nil), 3, Some 1)))); 88 | end 89 | 90 | (* 91 | type 'a constrained = [`F of 'a] constraint 'a = int 92 | *) 93 | 94 | let t = 95 | begin 96 | let map : int -> int = Functor_t.map in 97 | assert (map 12 = 12); 98 | end 99 | -------------------------------------------------------------------------------- /tests/exp.ml: -------------------------------------------------------------------------------- 1 | (*pp deriving *) 2 | 3 | module Env = Bimap.Make(String) 4 | 5 | type name = string deriving (Show, Dump, Typeable) 6 | module Eq_string : Eq.Eq with type a = name = 7 | struct 8 | type a = name 9 | let eq = (=) 10 | end 11 | module Pickle_name 12 | = Pickle.Pickle_from_dump(Dump_string)(Eq_string)(Typeable_string) 13 | 14 | module rec Exp : 15 | sig 16 | type exp = Var of name 17 | | App of exp * exp 18 | | Abs of name * exp 19 | deriving (Eq,Show,Pickle,Typeable,Dump) 20 | end = 21 | struct 22 | module Eq_exp = struct 23 | open Exp 24 | type a = exp 25 | let eq : exp -> exp -> bool 26 | = let rec alpha_eq env l r = match l, r with 27 | | Var l, Var r when Env.mem l env -> 28 | Env.find l env = r 29 | | Var l, Var r -> 30 | not (Env.rmem r env) && l = r 31 | | App (fl,pl), App (fr,pr) -> 32 | alpha_eq env fl fr && alpha_eq env pl pr 33 | | Abs (vl,bl), Abs (vr,br) -> 34 | alpha_eq (Env.add vl vr env) bl br 35 | | _ -> false 36 | in alpha_eq Env.empty 37 | end 38 | type exp = Var of name 39 | | App of exp * exp 40 | | Abs of name * exp 41 | deriving (Show, Typeable, Pickle,Dump) 42 | end 43 | 44 | open Exp 45 | (* 46 | let args = ref [] 47 | *) 48 | let discover_sharing : exp -> 'a = 49 | let find (next,dynmap) obj = 50 | let repr = Obj.repr obj in 51 | try List.assq repr dynmap, next, dynmap 52 | with Not_found -> next,next+1,(repr,next)::dynmap in 53 | let rec discover (next,dynmap) = function 54 | | Var s as v -> 55 | let (id,next,dynmap) = find (next,dynmap) v in 56 | Printf.printf "Var %d\n" id; 57 | let (id,next,dynmap) = find (next,dynmap) s in 58 | Printf.printf "string: %s %d\n" s id; 59 | (next, dynmap) 60 | 61 | | App (e1,e2) as a -> 62 | let (id,next,dynmap) = find (next,dynmap) a in 63 | Printf.printf "App %d\n" id; 64 | let (next,dynmap) = discover (next,dynmap) e1 in 65 | let (next,dynmap) = discover (next,dynmap) e2 in 66 | (next,dynmap) 67 | 68 | | Abs (s,e) as l -> 69 | let (id,next,dynmap) = find (next,dynmap) l in 70 | Printf.printf "Abs %d\n" id; 71 | let (id,next,dynmap) = find (next,dynmap) s in 72 | Printf.printf "string: %s %d\n" s id; 73 | let (next,dynmap) = discover (next,dynmap) e in 74 | (next,dynmap) 75 | in fun e -> (discover (1,[]) e) 76 | 77 | 78 | 79 | let y = 80 | Abs ("a", 81 | App (Abs ("b", 82 | App (Var "a", 83 | Abs ("c", 84 | App (App (Var "b", 85 | Var "b"), 86 | Var "c")))), 87 | Abs ("d", 88 | App (Var "a", 89 | Abs ("e", 90 | App (App (Var "d", 91 | Var "d"), 92 | Var "e")))))) 93 | let app e1 e2 = App (e1, e2) 94 | 95 | let abs (v,e) = Abs (v,e) 96 | 97 | let freevar x = Var x 98 | 99 | let rec term_size = function 100 | | Var _ -> 1 101 | | App (e1,e2) -> term_size e1 + term_size e2 102 | | Abs (_, body) -> 1 + term_size body 103 | -------------------------------------------------------------------------------- /syntax/extend.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4of *) 2 | 3 | (* Copyright Jeremy Yallop 2007. 4 | This file is free software, distributed under the MIT license. 5 | See the file COPYING for details. 6 | *) 7 | 8 | (* Extend the OCaml grammar to include the `deriving' clause after 9 | type declarations in structure and signatures. *) 10 | 11 | open Utils 12 | 13 | module Deriving (Syntax : Camlp4.Sig.Camlp4Syntax) = 14 | struct 15 | open Camlp4.PreCast 16 | 17 | include Syntax 18 | 19 | let fatal_error loc msg = 20 | Syntax.print_warning loc msg; 21 | exit 1 22 | 23 | let display_errors loc f p = 24 | try 25 | f p 26 | with 27 | Base.Underivable msg | Failure msg -> 28 | fatal_error loc msg 29 | 30 | let derive proj (loc : Loc.t) tdecls classname = 31 | let context = display_errors loc (Base.setup_context loc) tdecls in 32 | display_errors loc 33 | (proj (Base.find classname)) (loc, context, tdecls) 34 | 35 | let derive_str loc (tdecls : Type.decl list) classname : Ast.str_item = 36 | derive fst loc tdecls classname 37 | 38 | let derive_sig loc tdecls classname : Ast.sig_item = 39 | derive snd loc tdecls classname 40 | 41 | 42 | DELETE_RULE Gram str_item: "type"; type_declaration END 43 | DELETE_RULE Gram sig_item: "type"; type_declaration END 44 | 45 | open Ast 46 | 47 | EXTEND Gram 48 | str_item: 49 | [[ "type"; types = type_declaration -> <:str_item< type $types$ >> 50 | | "type"; types = type_declaration; "deriving"; "("; cl = LIST0 [x = UIDENT -> x] SEP ","; ")" -> 51 | let decls = display_errors loc Type.Translate.decls types in 52 | let module U = Type.Untranslate(struct let loc = loc end) in 53 | let tdecls = List.map U.decl decls in 54 | <:str_item< type $list:tdecls$ $list:List.map (derive_str loc decls) cl$ >> 55 | ]] 56 | ; 57 | sig_item: 58 | [[ "type"; types = type_declaration -> <:sig_item< type $types$ >> 59 | | "type"; types = type_declaration; "deriving"; "("; cl = LIST0 [x = UIDENT -> x] SEP "," ; ")" -> 60 | let decls = display_errors loc Type.Translate.decls types in 61 | let module U = Type.Untranslate(struct let loc = loc end) in 62 | let tdecls = List.concat_map U.sigdecl decls in 63 | let ms = List.map (derive_sig loc decls) cl in 64 | <:sig_item< type $list:tdecls$ $list:ms$ >> ]] 65 | ; 66 | END 67 | 68 | EXTEND Gram 69 | expr: LEVEL "simple" 70 | [ 71 | [e1 = TRY val_longident ; "<" ; t = ctyp; ">" -> 72 | match e1 with 73 | | <:ident< $uid:classname$ . $lid:methodname$ >> -> 74 | if not (Base.is_registered classname) then 75 | fatal_error loc ("deriving: "^ classname ^" is not a known `class'") 76 | else 77 | let module U = Type.Untranslate(struct let loc = loc end) in 78 | let binding = Ast.TyDcl (loc, "inline", [], t, []) in 79 | let decls = display_errors loc Type.Translate.decls binding in 80 | if List.exists Base.contains_tvars_decl decls then 81 | fatal_error loc ("deriving: type variables cannot be used in `method' instantiations") 82 | else 83 | let tdecls = List.map U.decl decls in 84 | let m = derive_str loc decls classname in 85 | <:expr< let module $uid:classname$ = 86 | struct 87 | type $list:tdecls$ 88 | $m$ 89 | include $uid:classname ^ "_inline"$ 90 | end 91 | in $uid:classname$.$lid:methodname$ >> 92 | | _ -> 93 | fatal_error loc ("deriving: this looks a bit like a method application, but " 94 | ^"the syntax is not valid"); 95 | ]]; 96 | END 97 | 98 | end 99 | 100 | module M = Camlp4.Register.OCamlSyntaxExtension(Id)(Deriving) 101 | -------------------------------------------------------------------------------- /tests/dump_tests.ml: -------------------------------------------------------------------------------- 1 | (*pp deriving *) 2 | 3 | open Defs 4 | 5 | module Test (D : Dump.Dump) = 6 | struct 7 | let test v = D.from_string (D.to_string v) = v 8 | end 9 | 10 | let sum = begin 11 | let module T = Test (Dump_sum) in 12 | assert (T.test S0); 13 | assert (T.test (S1 max_int)); 14 | assert (T.test (S2 (min_int, 1243.2))); 15 | assert (T.test (S2 (min_int, 1243.2))); 16 | assert (T.test (S3 (12, 0.0, true))); 17 | assert (T.test (Sunit ())); 18 | assert (T.test (Stup (1001, 10.01))); 19 | end 20 | 21 | let r1 = begin 22 | let module T = Test (Dump_r1) in 23 | assert (T.test {r1_l1 = max_int - 10; r1_l2 = min_int + 10}); 24 | end 25 | 26 | let intseq = begin 27 | let module T = Test (Dump_intseq) in 28 | assert (T.test INil); 29 | assert (T.test (ICons (10, ICons (20, ICons (30, INil))))); 30 | end 31 | 32 | let seq = begin 33 | let module T = Test (Dump_seq (Dump.Dump_bool)) in 34 | assert (T.test Nil); 35 | assert (T.test (Cons (true, Cons (false, Cons (true, Nil))))); 36 | end 37 | 38 | let uses_seqs = begin 39 | let module T = Test (Dump_uses_seqs) in 40 | assert (T.test (INil, Nil)); 41 | assert (T.test (INil, Cons (0.0, Cons(10.0, Nil)))); 42 | assert (T.test (ICons (10, ICons(20, INil)), Nil)); 43 | assert (T.test (ICons (10, ICons(20, INil)), 44 | Cons (0.0, Cons(10.0, Nil)))); 45 | end 46 | 47 | let poly1 = begin 48 | let module T = Test (Dump_poly1) in 49 | assert (T.test `T0); 50 | assert (T.test (`T1 (-1231))); 51 | end 52 | 53 | let poly2 = begin 54 | let module T = Test (Dump_poly2) in 55 | assert (T.test (P (10, `T1 11, 12.0))); 56 | end 57 | 58 | let poly3 = begin 59 | let module T = Test (Dump_poly3) in 60 | assert (T.test `Nil); 61 | assert (T.test (`Cons (1, `Cons (2, `Cons (3, `Nil))))); 62 | end 63 | 64 | let poly3b = begin 65 | let module T = Test (Dump_poly3b) in 66 | assert (T.test (10, `Nil, `F)); 67 | assert (T.test (0, `Cons (10, `Cons (11, `Cons (12, `Nil))), `F)); 68 | end 69 | 70 | let poly7 = begin 71 | let module T = Test(Dump_poly7(Dump.Dump_bool)) in 72 | let module T' = Test(Dump_poly8(Dump.Dump_int)) in 73 | assert (T.test (Foo (`F true))); 74 | assert (T.test (Foo (`F false))); 75 | assert (T'.test {x = `G (`H (`I (Foo (`F (max_int - 1)))))}); 76 | assert (T'.test {x = `G (`H (`I (Foo (`F (min_int + 1)))))}); 77 | end 78 | 79 | let poly10 = begin 80 | let module T = Test (Dump_poly10) in 81 | assert (T.test `F); 82 | assert (T.test `Nil); 83 | assert (T.test (`Cons (12, `Cons (14, `Nil)))); 84 | end 85 | 86 | let mutrec = begin 87 | let module A = Test (Dump_mutrec_a) in 88 | let module B = Test (Dump_mutrec_b) in 89 | let module C = Test (Dump_mutrec_c) in 90 | let module D = Test (Dump_mutrec_d) in 91 | let a = N in 92 | let b = { l1 = S (3, a); l2 = a } in 93 | let c = S (3, S (4, S (5, N))) in 94 | let d = `T b in 95 | assert (A.test a); 96 | assert (B.test b); 97 | assert (C.test c); 98 | assert (D.test d); 99 | end 100 | 101 | let pmutrec = begin 102 | (* 103 | type ('a,'b) pmutrec_a = ('a,'b) pmutrec_c 104 | and ('a,'b) pmutrec_b = { pl1 : ('a,'b) pmutrec_c ; pl2 : ('a,'b) pmutrec_a } 105 | and ('a,'b) pmutrec_c = SS of 'a * ('a,'b) pmutrec_a * 'b 106 | and ('a,'b) pmutrec_d = [`T of ('a,'b) pmutrec_b] 107 | *) 108 | end 109 | 110 | let ff1 = begin 111 | let module T = Test(Dump_ff1(Dump.Dump_bool)) in 112 | assert (T.test (F (true,false))); 113 | assert (T.test (G 435)); 114 | end 115 | 116 | let ff2 = begin 117 | let module T = Test(Dump_ff2(Dump.Dump_bool)(Dump.Dump_int)) in 118 | assert (T.test (F1 (F2 (Nil, 10, None)))); 119 | assert (T.test (F1 (F2 (Cons (true, Cons (false, Nil)), 10, Some 14)))); 120 | end 121 | 122 | let tup0 = begin 123 | let module T = Test (Dump_tup0) in 124 | assert (T.test ()); 125 | end 126 | 127 | let tup2 = begin 128 | let module T = Test (Dump_tup2) in 129 | assert (T.test (10, 10.0)); 130 | assert (T.test (max_int, -10.0)); 131 | end 132 | 133 | let tup3 = begin 134 | let module T = Test (Dump_tup3) in 135 | assert (T.test (0,12.3,true)); 136 | assert (T.test (min_int,-12.3,false)); 137 | end 138 | 139 | let tup4 = begin 140 | let module T = Test (Dump_tup4) in 141 | assert (T.test (0,0,true,())); 142 | assert (T.test (min_int,max_int,false,())); 143 | end 144 | 145 | let t = begin 146 | let module T = Test (Dump_t) in 147 | assert (T.test min_int); 148 | assert (T.test max_int); 149 | assert (T.test 10); 150 | end 151 | -------------------------------------------------------------------------------- /syntax/show_class.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4of *) 2 | 3 | (* Copyright Jeremy Yallop 2007. 4 | This file is free software, distributed under the MIT license. 5 | See the file COPYING for details. 6 | *) 7 | module InContext (L : Base.Loc) = 8 | struct 9 | open Base 10 | open Utils 11 | open Type 12 | open Camlp4.PreCast 13 | include Base.InContext(L) 14 | 15 | let classname = "Show" 16 | 17 | let wrap (ctxt:Base.context) (decl : Type.decl) matches = <:module_expr< 18 | struct type $Ast.TyDcl (loc, "a", [], atype ctxt decl, [])$ 19 | let format formatter = function $list:matches$ end >> 20 | 21 | let in_a_box box e = 22 | <:expr< 23 | Format.$lid:box$ formatter 0; 24 | $e$; 25 | Format.pp_close_box formatter () >> 26 | 27 | let in_hovbox = in_a_box "pp_open_hovbox" and in_box = in_a_box "pp_open_box" 28 | 29 | 30 | let instance = object (self) 31 | inherit make_module_expr ~classname ~allow_private:true 32 | 33 | method polycase ctxt : Type.tagspec -> Ast.match_case = function 34 | | Tag (name, None) -> 35 | <:match_case< `$uid:name$ -> 36 | Format.pp_print_string formatter $str:"`" ^ name ^" "$ >> 37 | | Tag (name, Some e) -> 38 | <:match_case< `$uid:name$ x -> 39 | $in_hovbox <:expr< 40 | Format.pp_print_string formatter $str:"`" ^ name ^" "$; 41 | $mproject (self#expr ctxt e) "format"$ formatter x >>$ >> 42 | | Extends t -> 43 | let patt, guard, cast = cast_pattern ctxt t in 44 | <:match_case< 45 | $patt$ when $guard$ -> 46 | $in_hovbox <:expr< $mproject (self#expr ctxt t) "format"$ formatter $cast$ >>$ >> 47 | 48 | method nargs ctxt (exprs : (name * Type.expr) list) : Ast.expr = 49 | match exprs with 50 | | [id,t] -> 51 | <:expr< $mproject (self#expr ctxt t) "format"$ formatter $lid:id$ >> 52 | | exprs -> 53 | let fmt = 54 | "@[("^ String.concat ",@;" (List.map (fun _ -> "%a") exprs) ^")@]" in 55 | List.fold_left 56 | (fun f (id, t) -> 57 | <:expr< $f$ $mproject (self#expr ctxt t) "format"$ $lid:id$ >>) 58 | <:expr< Format.fprintf formatter $str:fmt$ >> 59 | exprs 60 | 61 | method tuple ctxt args = 62 | let n = List.length args in 63 | let tpatt, _ = tuple n in 64 | <:module_expr< Defaults (struct type $Ast.TyDcl (loc, "a", [], atype_expr ctxt (`Tuple args), [])$ 65 | let format formatter $tpatt$ = 66 | $self#nargs ctxt 67 | (List.mapn (fun t n -> Printf.sprintf "v%d" n, t) args)$ end) >> 68 | 69 | method case ctxt : Type.summand -> Ast.match_case = 70 | fun (name, args) -> 71 | match args with 72 | | [] -> <:match_case< $uid:name$ -> Format.pp_print_string formatter $str:name$ >> 73 | | _ -> 74 | let patt, exp = tuple (List.length args) in 75 | <:match_case< 76 | $uid:name$ $patt$ -> 77 | $in_hovbox <:expr< 78 | Format.pp_print_string formatter $str:name$; 79 | Format.pp_print_break formatter 1 2; 80 | $self#nargs ctxt (List.mapn (fun t n -> Printf.sprintf "v%d" n, t) args)$ >>$ >> 81 | 82 | method field ctxt : Type.field -> Ast.expr = function 83 | | (name, ([], t), _) -> <:expr< Format.pp_print_string formatter $str:name ^ " ="$; 84 | $mproject (self#expr ctxt t) "format"$ formatter $lid:name$ >> 85 | | f -> raise (Underivable ("Show cannot be derived for record types with polymorphic fields")) 86 | 87 | method sum ?eq ctxt decl summands = wrap ctxt decl (List.map (self#case ctxt) summands) 88 | 89 | method record ?eq ctxt decl fields = wrap ctxt decl [ <:match_case< 90 | $record_pattern fields$ -> $in_hovbox 91 | <:expr< 92 | Format.pp_print_char formatter '{'; 93 | $List.fold_left1 94 | (fun l r -> <:expr< $l$; Format.pp_print_string formatter "; "; $r$ >>) 95 | (List.map (self#field ctxt) fields)$; 96 | Format.pp_print_char formatter '}'; >>$ >>] 97 | 98 | method variant ctxt decl (_,tags) = wrap ctxt decl (List.map (self#polycase ctxt) tags 99 | @ [ <:match_case< _ -> assert false >> ]) 100 | end 101 | end 102 | 103 | let _ = Base.register "Show" 104 | ((fun (loc, context, decls) -> 105 | let module M = InContext(struct let loc = loc end) in 106 | M.generate ~context ~decls ~make_module_expr:M.instance#rhs ~classname:M.classname 107 | ~default_module:"Defaults" ()), 108 | (fun (loc, context, decls) -> 109 | let module M = InContext(struct let loc = loc end) in 110 | M.gen_sigs ~classname:M.classname ~context ~decls)) 111 | -------------------------------------------------------------------------------- /lib/enum.ml: -------------------------------------------------------------------------------- 1 | (*pp deriving *) 2 | 3 | (* Copyright Jeremy Yallop 2007. 4 | This file is free software, distributed under the MIT license. 5 | See the file COPYING for details. 6 | *) 7 | 8 | open Bounded 9 | 10 | let rec rassoc (rkey : 'b) : ('a * 'b) list -> 'a = function 11 | | [] -> raise Not_found 12 | | (a,b)::_ when b = rkey -> a 13 | | _::xs -> rassoc rkey xs 14 | 15 | let rec last : 'a list -> 'a = function 16 | | [] -> raise (Invalid_argument "last") 17 | | [x] -> x 18 | | _::xs -> last xs 19 | 20 | module Enum = 21 | struct 22 | (** Enum **) 23 | module type Enum = sig 24 | type a 25 | val succ : a -> a 26 | val pred : a -> a 27 | val to_enum : int -> a 28 | val from_enum : a -> int 29 | val enum_from : a -> a list 30 | val enum_from_then : a -> a -> a list 31 | val enum_from_to : a -> a -> a list 32 | val enum_from_then_to : a -> a -> a -> a list 33 | end 34 | 35 | let startThenTo (start : int) (next : int) (until : int) : int list = 36 | let step = next - start in 37 | if step <= 0 then invalid_arg "startThenTo" 38 | else 39 | let rec upFrom current = 40 | if current > until then [] 41 | else current :: upFrom (current+step) 42 | in 43 | upFrom start 44 | 45 | let range : int -> int -> int list 46 | = fun f t -> startThenTo f (f+1) t 47 | 48 | module Defaults 49 | (E : (sig 50 | type a 51 | val numbering : (a * int) list 52 | end)) : Enum with type a = E.a = 53 | struct 54 | let firstCon = fst (List.hd E.numbering) 55 | let lastCon = fst (last E.numbering) 56 | 57 | type a = E.a 58 | let from_enum a = List.assoc a E.numbering 59 | let to_enum i = try rassoc i E.numbering with Not_found -> raise (Invalid_argument "to_enum") 60 | let succ s = try to_enum ((from_enum s) + 1) with Invalid_argument "to_enum" -> raise (Invalid_argument "succ") 61 | let pred s = try to_enum ((from_enum s) - 1) with Invalid_argument "to_enum" -> raise (Invalid_argument "pred") 62 | let enum_from_to x y = List.map to_enum (range (from_enum x) (from_enum y)) 63 | let enum_from_then_to x y z = List.map to_enum (startThenTo (from_enum x) (from_enum y) (from_enum z)) 64 | let enum_from_then x y = (enum_from_then_to x y 65 | (if from_enum y >= from_enum x then lastCon 66 | else firstCon)) 67 | let enum_from x = enum_from_to x lastCon 68 | end 69 | 70 | 71 | module Defaults' 72 | (E : (sig 73 | type a 74 | val from_enum : a -> int 75 | val to_enum : int -> a 76 | end)) 77 | (B : Bounded with type a = E.a) : Enum with type a = E.a 78 | and type a = B.a = 79 | struct 80 | include E 81 | let firstCon = B.min_bound 82 | let lastCon = B.max_bound 83 | 84 | let succ s = try to_enum ((from_enum s) + 1) with Invalid_argument "to_enum" -> raise (Invalid_argument "succ") 85 | let pred s = try to_enum ((from_enum s) - 1) with Invalid_argument "to_enum" -> raise (Invalid_argument "pred") 86 | let enum_from_to x y = List.map to_enum (range (from_enum x) (from_enum y)) 87 | let enum_from_then_to x y z = List.map to_enum (startThenTo (from_enum x) (from_enum y) (from_enum z)) 88 | let enum_from_then x y = (enum_from_then_to x y 89 | (if from_enum y >= from_enum x then lastCon 90 | else firstCon)) 91 | let enum_from x = enum_from_to x lastCon 92 | end 93 | 94 | module Enum_bool = Defaults(struct 95 | type a = bool 96 | let numbering = [false, 0; true, 1] 97 | end) 98 | 99 | module Enum_char = Defaults'(struct 100 | type a = char 101 | let from_enum = Char.code 102 | let to_enum = Char.chr 103 | end) (Bounded_char) 104 | 105 | module Enum_int = Defaults' (struct 106 | type a = int 107 | let from_enum i = i 108 | let to_enum i = i 109 | end)(Bounded_int) 110 | 111 | (* Can `instance Enum Float' be justified? 112 | For some floats `f' we have `succ f == f'. 113 | Furthermore, float is wider than int, so from_enum will necessarily 114 | give nonsense on many inputs. *) 115 | 116 | module Enum_unit = Defaults' (struct 117 | type a = unit 118 | let from_enum () = 0 119 | let to_enum = function 120 | | 0 -> () 121 | | _ -> raise (Invalid_argument "to_enum") 122 | end) (Bounded_unit) 123 | end 124 | include Enum 125 | 126 | type open_flag = Pervasives.open_flag = 127 | | Open_rdonly 128 | | Open_wronly 129 | | Open_append 130 | | Open_creat 131 | | Open_trunc 132 | | Open_excl 133 | | Open_binary 134 | | Open_text 135 | | Open_nonblock 136 | deriving (Enum) 137 | 138 | type fpclass = Pervasives.fpclass = 139 | | FP_normal 140 | | FP_subnormal 141 | | FP_zero 142 | | FP_infinite 143 | | FP_nan 144 | deriving (Enum) 145 | -------------------------------------------------------------------------------- /syntax/eq_class.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4of *) 2 | 3 | (* Copyright Jeremy Yallop 2007. 4 | This file is free software, distributed under the MIT license. 5 | See the file COPYING for details. 6 | *) 7 | 8 | module InContext (L : Base.Loc) = 9 | struct 10 | open Base 11 | open Utils 12 | open Type 13 | open Camlp4.PreCast 14 | include Base.InContext(L) 15 | 16 | let classname = "Eq" 17 | 18 | let lprefix = "l" and rprefix = "r" 19 | 20 | let wildcard_failure = <:match_case< _ -> false >> 21 | 22 | let tup ctxt ts mexpr exp = 23 | match ts with 24 | | [t] -> 25 | <:module_expr< struct type $Ast.TyDcl (loc, "a", [], atype_expr ctxt (`Tuple ts), [])$ 26 | let eq l r = let module M = $exp ctxt t$ 27 | in $mexpr$ l r end >> 28 | | ts -> 29 | let _, (lpatt, rpatt), expr = 30 | List.fold_right 31 | (fun t (n, (lpatt, rpatt), expr) -> 32 | let lid = Printf.sprintf "l%d" n and rid = Printf.sprintf "r%d" n in 33 | (n+1, 34 | (Ast.PaCom (loc,<:patt< $lid:lid$ >>, lpatt), 35 | Ast.PaCom (loc,<:patt< $lid:rid$ >>, rpatt)), 36 | <:expr< let module M = $exp ctxt t$ 37 | in $mexpr$ $lid:lid$ $lid:rid$ && $expr$ >>)) 38 | ts 39 | (0, (<:patt< >>, <:patt< >>), <:expr< true >>) 40 | in 41 | <:module_expr< struct type $Ast.TyDcl (loc, "a", [], atype_expr ctxt (`Tuple ts), [])$ 42 | let eq $Ast.PaTup (loc, lpatt)$ $Ast.PaTup (loc, rpatt)$ = $expr$ end >> 43 | 44 | 45 | let instance = object (self) 46 | inherit make_module_expr ~classname ~allow_private:true 47 | 48 | method tuple ctxt ts = tup ctxt ts <:expr< M.eq >> (self#expr) 49 | 50 | method polycase ctxt : Type.tagspec -> Ast.match_case = function 51 | | Tag (name, None) -> <:match_case< `$name$, `$name$ -> true >> 52 | | Tag (name, Some e) -> <:match_case< 53 | `$name$ l, `$name$ r -> 54 | $mproject (self#expr ctxt e) "eq"$ l r >> 55 | | Extends t -> 56 | let lpatt, lguard, lcast = cast_pattern ctxt ~param:"l" t in 57 | let rpatt, rguard, rcast = cast_pattern ctxt ~param:"r" t in 58 | <:match_case< 59 | ($lpatt$, $rpatt$) when $lguard$ && $rguard$ -> 60 | $mproject (self#expr ctxt t) "eq"$ $lcast$ $rcast$ >> 61 | 62 | method case ctxt : Type.summand -> Ast.match_case = 63 | fun (name,args) -> 64 | match args with 65 | | [] -> <:match_case< ($uid:name$, $uid:name$) -> true >> 66 | | _ -> 67 | let nargs = List.length args in 68 | let lpatt, lexpr = tuple ~param:"l" nargs 69 | and rpatt, rexpr = tuple ~param:"r" nargs in 70 | <:match_case< 71 | ($uid:name$ $lpatt$, $uid:name$ $rpatt$) -> 72 | $mproject (self#expr ctxt (`Tuple args)) "eq"$ $lexpr$ $rexpr$ >> 73 | 74 | method field ctxt : Type.field -> Ast.expr = function 75 | | (name, ([], t), `Immutable) -> <:expr< 76 | $mproject (self#expr ctxt t) "eq"$ $lid:lprefix ^ name$ $lid:rprefix ^ name$ >> 77 | | (_, _, `Mutable) -> assert false 78 | | f -> raise (Underivable ("Eq cannot be derived for record types with polymorphic fields")) 79 | 80 | method sum ?eq ctxt decl summands = 81 | let wildcard = match summands with [_] -> [] | _ -> [ <:match_case< _ -> false >>] in 82 | <:module_expr< 83 | struct type $Ast.TyDcl (loc, "a", [], atype ctxt decl, [])$ 84 | let eq l r = match l, r with 85 | $list:List.map (self#case ctxt) summands @ wildcard$ 86 | end >> 87 | 88 | method record ?eq ctxt decl fields = 89 | if List.exists (function (_,_,`Mutable) -> true | _ -> false) fields then 90 | <:module_expr< struct type $Ast.TyDcl (loc, "a", [], atype ctxt decl, [])$ let eq = (==) end >> 91 | else 92 | let lpatt = record_pattern ~prefix:"l" fields 93 | and rpatt = record_pattern ~prefix:"r" fields 94 | and expr = 95 | List.fold_right 96 | (fun f e -> <:expr< $self#field ctxt f$ && $e$ >>) 97 | fields 98 | <:expr< true >> 99 | in <:module_expr< struct type $Ast.TyDcl (loc, "a", [], atype ctxt decl, [])$ 100 | let eq $lpatt$ $rpatt$ = $expr$ end >> 101 | 102 | method variant ctxt decl (spec, tags) = 103 | <:module_expr< struct type $Ast.TyDcl (loc, "a", [], atype ctxt decl, [])$ 104 | let eq l r = match l, r with 105 | $list:List.map (self#polycase ctxt) tags$ 106 | | _ -> false end >> 107 | end 108 | end 109 | 110 | let _ = Base.register "Eq" 111 | ((fun (loc, context, decls) -> 112 | let module M = InContext(struct let loc = loc end) in 113 | M.generate ~context ~decls ~make_module_expr:M.instance#rhs ~classname:M.classname 114 | ~default_module:"Defaults" ()), 115 | (fun (loc, context, decls) -> 116 | let module M = InContext(struct let loc = loc end) in 117 | M.gen_sigs ~context ~decls ~classname:M.classname)) 118 | 119 | -------------------------------------------------------------------------------- /tests/defs.ml: -------------------------------------------------------------------------------- 1 | (*pp deriving *) 2 | 3 | (* sums (nullary, unary, and n-ary) *) 4 | type sum = S0 | S1 of int | S2 of int * float | S3 of int * float * bool | Sunit of unit | Stup of (int * float) | Stup1 of (int) 5 | deriving (Dump, Eq, Show, Typeable, Pickle) 6 | 7 | type nullsum = N0 | N1 | N2 | N3 8 | deriving (Enum, Bounded, Eq, Typeable, Pickle) 9 | 10 | (* records with mutable and immutable fields (and various combinations) *) 11 | type r1 = { 12 | r1_l1 : int; 13 | r1_l2 : int; 14 | } deriving (Dump, Eq, Show, Typeable, Pickle, Functor) 15 | 16 | type r2 = { 17 | mutable r2_l1 : int; 18 | mutable r2_l2 : int; 19 | } deriving (Eq, Show, Typeable, Pickle) 20 | 21 | type r3 = { 22 | r3_l1 : int; 23 | mutable r3_l2 : int; 24 | } deriving (Eq, Show, Typeable, Pickle) 25 | 26 | (* polymorphic records *) 27 | type r4 = { 28 | r4_l1 : 'a . 'a list 29 | } (* deriving (Dump, Eq, Show, Typeable, Pickle) *) 30 | 31 | (* label types *) 32 | type label = x:int -> int 33 | (* deriving (Dump, Eq, Show) *) 34 | 35 | (* function types *) 36 | type funct = int -> int 37 | (* deriving (Dump, Eq, Show) *) 38 | 39 | (* recursive types *) 40 | type intseq = INil | ICons of int * intseq 41 | deriving (Dump, Eq, Show, Typeable, Pickle, Functor) 42 | 43 | type 'a seq = Nil | Cons of 'a * 'a seq 44 | deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 45 | 46 | (* applied type constructors (nullary, n-ary) *) 47 | type uses_seqs = (intseq * float seq) 48 | deriving (Dump, Eq, Show, Typeable, Pickle) 49 | 50 | (* object and class types *) 51 | type obj = < x : int > 52 | 53 | (* class types *) 54 | class c = object end 55 | 56 | (* polymorphic variants (nullary, unary tags, extending complex type expressions, defined inline) *) 57 | type poly0 = [`T0 | `T1 | `T2 | `T3] 58 | deriving (Enum, Bounded, Show, Eq, Typeable, Pickle) 59 | 60 | type poly1 = [`T0 | `T1 of int] 61 | deriving (Dump, Eq, Show) 62 | 63 | type poly2 = P of int * [`T0 | `T1 of int] * float 64 | deriving (Dump, Eq, Show) 65 | 66 | (* `as'-recursion *) 67 | type poly3 = [`Nil | `Cons of int * 'c] as 'c 68 | deriving (Dump, Eq, Show, Typeable, Pickle) 69 | 70 | type poly3b = int * ([`Nil | `Cons of int * 'c] as 'c) * [`F] 71 | deriving (Dump, Eq, Show, Typeable, Pickle) 72 | 73 | (* <, >, =, > < polymorphic variants *) 74 | type 'a poly7 = Foo of [`F of 'a] 75 | and 'a poly8 = { x : [`G of [`H of [`I of 'a poly7]]] } 76 | deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 77 | 78 | (* 79 | type poly9 = [`F | [`G]] 80 | deriving (Dump, Eq, Show, Typeable, Pickle) 81 | currently broken. 82 | *) 83 | type poly10 = [`F | poly3] 84 | deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 85 | 86 | (* mutually recursive types (monomorphic, polymorphic) *) 87 | type mutrec_a = mutrec_c 88 | and mutrec_b = { l1 : mutrec_c ; l2 : mutrec_a } 89 | and mutrec_c = S of int * mutrec_a | N 90 | and mutrec_d = [`T of mutrec_b] 91 | deriving (Dump, Eq, Show, Typeable, Pickle) 92 | 93 | type ('a,'b) pmutrec_a = ('a,'b) pmutrec_c 94 | and ('a,'b) pmutrec_b = { pl1 : ('a,'b) pmutrec_c ; pl2 : ('a,'b) pmutrec_a } 95 | and ('a,'b) pmutrec_c = SS of 'a * ('a,'b) pmutrec_a * 'b 96 | and ('a,'b) pmutrec_d = [`T of ('a,'b) pmutrec_b] 97 | deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 98 | 99 | (* polymorphic types *) 100 | type 'a ff1 = F of 'a * 'a | G of int deriving (Show, Eq, Dump, Functor, Typeable, Pickle) 101 | type ('a,'b) ff2 = F1 of ('a,'b) ff2 | F2 of 'a seq * int * 'b option 102 | deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 103 | 104 | (* tuples *) 105 | type tup0 = unit 106 | deriving (Dump, Eq, Show, Typeable, Pickle) 107 | type tup2 = int * float 108 | deriving (Dump, Eq, Show, Typeable, Pickle) 109 | type tup3 = int * float * bool 110 | deriving (Dump, Eq, Show, Typeable, Pickle) 111 | type tup4 = int * int * bool * unit 112 | deriving (Dump, Eq, Show, Typeable, Pickle, Bounded) 113 | 114 | (* type equations (replication) *) 115 | (* TODO *) 116 | 117 | (* references *) 118 | type withref = WR of int * (int ref) 119 | deriving (Eq, Show, Typeable, Pickle) 120 | 121 | (* through module boundaries *) 122 | module rec M : sig 123 | type t deriving (Show, Eq, Dump) 124 | end = 125 | struct 126 | type t = [`N|`C of M.t] deriving (Show, Eq, Dump) 127 | end 128 | 129 | (* parameterized types through module boundaries *) 130 | module rec P : sig 131 | type 'a t (* deriving (Show) *) 132 | end = 133 | struct 134 | type 'a t = [`N|`C of 'a P.t] 135 | (*Doesn't work: results in an unsafe module definition 136 | *)(* deriving (Show)*) 137 | end 138 | 139 | (* with constraints *) 140 | type 'a constrained = [`F of 'a] constraint 'a = int 141 | deriving (Functor) (* Show, etc. don't work here *) 142 | 143 | (* private datatypes *) 144 | type p1 = private P1 145 | deriving (Show, Eq) 146 | 147 | (* check that `private' in the interface is allowed for classes that 148 | disallow `private' (e.g. Dump) as long as we don't have `private' 149 | in the implementation *) 150 | module Private : sig 151 | type p2 = private Q deriving (Show, Eq, Dump) 152 | end = 153 | struct 154 | type p2 = Q deriving (Show, Eq, Dump) 155 | end 156 | 157 | (* Reusing existing instances *) 158 | type t = int 159 | deriving (Eq, Enum, Bounded, Dump, Show, Typeable, Pickle, Functor) 160 | -------------------------------------------------------------------------------- /syntax/dump_class.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4of *) 2 | 3 | (* Copyright Jeremy Yallop 2007. 4 | This file is free software, distributed under the MIT license. 5 | See the file COPYING for details. 6 | *) 7 | 8 | module InContext (L : Base.Loc) = 9 | struct 10 | open Base 11 | open Utils 12 | open Type 13 | open Camlp4.PreCast 14 | include Base.InContext(L) 15 | 16 | let classname = "Dump" 17 | 18 | let wrap ~atype ~dumpers ~undump = 19 | <:module_expr< struct type $Ast.TyDcl (loc, "a", [], atype, [])$ 20 | let to_buffer buffer = function $list:dumpers$ 21 | let from_stream stream = $undump$ end >> 22 | 23 | let instance = object (self) 24 | inherit make_module_expr ~classname ~allow_private:false 25 | 26 | method nargs ctxt (exprs : (name * Type.expr) list) : Ast.expr * Ast.expr = 27 | List.fold_right 28 | (fun (id,t) (p,u) -> 29 | <:expr< $mproject (self#expr ctxt t) "to_buffer"$ buffer $lid:id$; $p$ >>, 30 | <:expr< let $lid:id$ = $mproject (self#expr ctxt t) "from_stream"$ stream in $u$ >>) 31 | exprs (<:expr<>>, <:expr< $tuple_expr (List.map (fun (id,_) -> <:expr< $lid:id$ >>) exprs)$>>) 32 | 33 | method tuple ctxt ts = 34 | let atype = atype_expr ctxt (`Tuple ts) 35 | and dumpers, undump = 36 | let n = List.length ts in 37 | let pinner, undump = self#nargs ctxt (List.mapn (fun t n -> (Printf.sprintf "v%d" n, t)) ts) in 38 | let patt, expr = tuple n in 39 | [ <:match_case< $patt$ -> $pinner$ >> ], undump in 40 | <:module_expr< Defaults( $wrap ~atype ~dumpers ~undump$) >> 41 | 42 | method polycase ctxt tagspec n : Ast.match_case * Ast.match_case = 43 | let dumpn = <:expr< Dump_int.to_buffer buffer $`int:n$ >> in 44 | match tagspec with 45 | | Tag (name, args) -> (match args with 46 | | None -> <:match_case< `$name$ -> $dumpn$ >>, 47 | <:match_case< $`int:n$ -> `$name$ >> 48 | | Some e -> <:match_case< `$name$ x -> $dumpn$; 49 | $mproject (self#expr ctxt e) "to_buffer"$ buffer x >>, 50 | <:match_case< $`int:n$ -> 51 | `$name$ ($mproject (self#expr ctxt e) "from_stream"$ stream) >>) 52 | | Extends t -> 53 | let patt, guard, cast = cast_pattern ctxt t in 54 | <:match_case< $patt$ when $guard$ -> 55 | $dumpn$; $mproject (self#expr ctxt t) "to_buffer"$ buffer $cast$ >>, 56 | <:match_case< $`int:n$ -> ($mproject (self#expr ctxt t) "from_stream"$ stream :> a) >> 57 | 58 | method case ctxt (ctor,args) n = 59 | match args with 60 | | [] -> (<:match_case< $uid:ctor$ -> Dump_int.to_buffer buffer $`int:n$ >>, 61 | <:match_case< $`int:n$ -> $uid:ctor$ >>) 62 | | _ -> 63 | let nargs = List.length args in 64 | let patt, exp = tuple nargs in 65 | let dump, undump = self#nargs ctxt (List.mapn (fun t n -> (Printf.sprintf "v%d" n, t)) args) in 66 | <:match_case< $uid:ctor$ $patt$ -> 67 | Dump_int.to_buffer buffer $`int:n$; 68 | $dump$ >>, 69 | <:match_case< $`int:n$ -> let $patt$ = $undump$ in $uid:ctor$ $exp$ >> 70 | 71 | method field ctxt : Type.field -> Ast.expr * Ast.expr = function 72 | | (name, _, `Mutable) -> 73 | raise (Underivable ("Dump cannot be derived for record types with mutable fields ("^name^")")) 74 | | (name, ([], t), _) -> 75 | <:expr< $mproject (self#expr ctxt t) "to_buffer"$ buffer $lid:name$ >>, 76 | <:expr< $mproject (self#expr ctxt t) "from_stream"$ stream >> 77 | | f -> raise (Underivable ("Dump cannot be derived for record types with polymorphic fields")) 78 | 79 | method sum ?eq ctxt ((tname,_,_,_,_) as decl) summands = 80 | let msg = "Dump: unexpected tag %d at character %d when deserialising " ^ tname in 81 | let dumpers, undumpers = 82 | List.split (List.mapn (self#case ctxt) summands) in 83 | wrap ~atype:(atype ctxt decl) ~dumpers 84 | ~undump:<:expr< match Dump_int.from_stream stream with $list:undumpers$ 85 | | n -> raise (Dump_error 86 | (Printf.sprintf $str:msg$ n 87 | (Stream.count stream))) >> 88 | 89 | method record ?eq ctxt decl fields = 90 | let dumpers, undumpers = 91 | List.split (List.map (self#field ctxt) fields) in 92 | let undump = 93 | List.fold_right2 94 | (fun (field,_,_) undumper e -> 95 | <:expr< let $lid:field$ = $undumper$ in $e$ >>) 96 | fields 97 | undumpers 98 | (record_expression fields) in 99 | wrap ~atype:(atype ctxt decl) ~undump 100 | ~dumpers:[ <:match_case< $record_pattern fields$ -> $List.fold_left1 seq dumpers$ >>] 101 | 102 | method variant ctxt decl (_, tags) = 103 | let msg = "Dump: unexpected tag %d at character %d when deserialising polymorphic variant" in 104 | let dumpers, undumpers = 105 | List.split (List.mapn (self#polycase ctxt) tags) in 106 | wrap ~atype:(atype ctxt decl) ~dumpers:(dumpers @ [ <:match_case< _ -> assert false >>]) 107 | ~undump:<:expr< match Dump_int.from_stream stream with $list:undumpers$ 108 | | n -> raise (Dump_error 109 | (Printf.sprintf $str:msg$ n 110 | (Stream.count stream))) >> 111 | end 112 | end 113 | 114 | let _ = Base.register "Dump" 115 | ((fun (loc, context, decls) -> 116 | let module M = InContext(struct let loc = loc end) in 117 | M.generate ~context ~decls ~make_module_expr:M.instance#rhs ~classname:M.classname 118 | ~default_module:"Defaults" ()), 119 | (fun (loc, context, decls) -> 120 | let module M = InContext(struct let loc = loc end) in 121 | M.gen_sigs ~context ~decls ~classname:M.classname)) 122 | -------------------------------------------------------------------------------- /syntax/functor_class.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4of *) 2 | 3 | (* Copyright Jeremy Yallop 2007. 4 | This file is free software, distributed under the MIT license. 5 | See the file COPYING for details. 6 | *) 7 | 8 | open Camlp4.PreCast 9 | 10 | module InContext (C : sig val context : Base.context val loc : Camlp4.PreCast.Loc.t end) = 11 | struct 12 | open C 13 | open Type 14 | open Utils 15 | open Base 16 | include Base.InContext(C) 17 | 18 | let classname = "Functor" 19 | 20 | let param_map : string NameMap.t = 21 | List.fold_right 22 | (fun (name,_) map -> NameMap.add name ("f_" ^ name) map) 23 | context.params 24 | NameMap.empty 25 | 26 | let tdec, sigdec = 27 | let dec name = 28 | ("f", context.params, 29 | `Expr (`Constr ([name], List.map (fun p -> `Param p) context.params)), [], false) 30 | in 31 | (fun name -> Untranslate.decl (dec name)), 32 | (fun name -> Untranslate.sigdecl (dec name)) 33 | 34 | let wrapper name expr = 35 | let patts :Ast.patt list = 36 | List.map 37 | (fun (name,_) -> <:patt< $lid:NameMap.find name param_map$ >>) 38 | context.params in 39 | let rhs = 40 | List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) patts expr in 41 | <:module_expr< struct 42 | open Functor 43 | type $tdec name$ 44 | let map = $rhs$ 45 | end >> 46 | (* 47 | prototype: [[t]] : t -> t[b_i/a_i] 48 | 49 | 50 | [[a_i]] = f_i 51 | 52 | [[C1|...CN]] = function [[C1]] ... [[CN]] sum 53 | [[`C1|...`CN]] = function [[`C1]] ... [[`CN]] variant 54 | 55 | [[{t1,...tn}]] = fun (t1,tn) -> ([[t1]],[[tn]]) tuple 56 | [[{l1:t1; ... ln:tn}]] = 57 | fun {l1=t1;...ln=tn} -> {l1=[[t1]];...ln=[[tn]]} record 58 | 59 | [[(t1,...tn) c]] = c_map [[t1]]...[[tn]] constructor 60 | 61 | [[a -> b]] = f . [[a]] (where a_i \notin fv(b)) function 62 | 63 | [[C0]] = C0->C0 nullary constructors 64 | [[C1 (t1...tn)]] = C1 t -> C0 ([[t1]] t1...[[tn]] tn) unary constructor 65 | [[`C0]] = `C0->`C0 nullary tag 66 | [[`C1 t]] = `C1 t->`C0 [[t]] t unary tag 67 | *) 68 | let rec polycase = function 69 | | Tag (name, None) -> <:match_case< `$name$ -> `$name$ >> 70 | | Tag (name, Some e) -> <:match_case< `$name$ x -> `$name$ ($expr e$ x) >> 71 | | Extends t -> 72 | let patt, guard, exp = cast_pattern context t in 73 | <:match_case< $patt$ when $guard$ -> $expr t$ $exp$ >> 74 | 75 | and expr : Type.expr -> Ast.expr = function 76 | | t when not (contains_tvars t) -> <:expr< fun x -> x >> 77 | | `Param (p,_) -> <:expr< $lid:NameMap.find p param_map$ >> 78 | | `Function (f,t) when not (contains_tvars t) -> 79 | <:expr< fun f x -> f ($expr f$ x) >> 80 | | `Constr (qname, ts) -> 81 | List.fold_left 82 | (fun fn arg -> <:expr< $fn$ $expr arg$ >>) 83 | <:expr< $id:modname_from_qname ~qname ~classname$.map >> 84 | ts 85 | | `Tuple ts -> tup ts 86 | | _ -> raise (Underivable "Functor cannot be derived for this type") 87 | 88 | and tup = function 89 | | [t] -> expr t 90 | | ts -> 91 | let args, exps = 92 | (List.fold_right2 93 | (fun t n (p,e) -> 94 | let v = Printf.sprintf "t%d" n in 95 | Ast.PaCom (loc, <:patt< $lid:v$ >>, p), 96 | Ast.ExCom (loc, <:expr< $expr t$ $lid:v$ >>, e)) 97 | ts 98 | (List.range 0 (List.length ts)) 99 | (<:patt< >>, <:expr< >>)) in 100 | let pat, exp = Ast.PaTup (loc, args), Ast.ExTup (loc, exps) in 101 | <:expr< fun $pat$ -> $exp$ >> 102 | 103 | and case = function 104 | | (name, []) -> <:match_case< $uid:name$ -> $uid:name$ >> 105 | | (name, args) -> 106 | let f = tup args 107 | and tpatt, texp = tuple (List.length args) in 108 | <:match_case< $uid:name$ $tpatt$ -> let $tpatt$ = ($f$ $texp$) in $uid:name$ ($texp$) >> 109 | 110 | and field (name, (_,t), _) : Ast.expr = 111 | <:expr< $expr t$ $lid:name$ >> 112 | 113 | let rhs = function 114 | |`Fresh (_, _, `Private) -> raise (Underivable "Functor cannot be derived for private types") 115 | |`Fresh (_, Sum summands, _) -> 116 | <:expr< function $list:List.map case summands$ >> 117 | |`Fresh (_, Record fields, _) -> 118 | <:expr< fun $record_pattern fields$ -> 119 | $record_expr (List.map (fun ((l,_,_) as f) -> (l,field f)) fields)$ >> 120 | |`Expr e -> expr e 121 | |`Variant (_, tags) -> 122 | <:expr< function $list:List.map polycase tags$ | _ -> assert false >> 123 | | `Nothing -> raise (Underivable "Cannot generate functor instance for the empty type") 124 | 125 | 126 | let maptype name = 127 | let ctor_in = `Constr ([name], List.map (fun p -> `Param p) context.params) in 128 | let ctor_out = substitute param_map ctor_in (* c[f_i/a_i] *) in 129 | List.fold_right (* (a_i -> f_i) -> ... -> c[a_i] -> c[f_i/a_i] *) 130 | (fun (p,_) out -> 131 | (<:ctyp< ('$lid:p$ -> '$lid:NameMap.find p param_map$) -> $out$>>)) 132 | context.params 133 | (Untranslate.expr (`Function (ctor_in, ctor_out))) 134 | 135 | let signature name : Ast.sig_item list = 136 | [ <:sig_item< type $list:sigdec name$ >>; 137 | <:sig_item< val map : $maptype name$ >> ] 138 | 139 | let decl (name, _, r, _, _) : Camlp4.PreCast.Ast.module_binding = 140 | if name = "f" then 141 | raise (Underivable ("deriving: Functor cannot be derived for types called `f'.\n" 142 | ^"Please change the name of your type and try again.")) 143 | else 144 | <:module_binding< 145 | $uid:classname ^ "_" ^ name$ 146 | : sig $list:signature name$ end 147 | = $wrapper name (rhs r)$ >> 148 | 149 | let gen_sig (tname, params, _, _, generated) = 150 | if tname = "f" then 151 | raise (Underivable ("deriving: Functor cannot be derived for types called `f'.\n" 152 | ^"Please change the name of your type and try again.")) 153 | else 154 | if generated then 155 | <:sig_item< >> 156 | else 157 | <:sig_item< module $uid:classname ^ "_" ^ tname$ : 158 | sig type $tdec tname$ val map : $maptype tname$ end >> 159 | 160 | end 161 | 162 | let _ = Base.register "Functor" 163 | ((fun (loc, context, decls) -> 164 | let module F = InContext(struct let loc = loc and context = context end) in 165 | <:str_item< module rec $list:List.map F.decl decls$ >>), 166 | (fun (loc, context, decls) -> 167 | let module F = InContext(struct let loc = loc and context = context end) in 168 | <:sig_item< $list:List.map F.gen_sig decls$>>)) 169 | -------------------------------------------------------------------------------- /syntax/utils.ml: -------------------------------------------------------------------------------- 1 | (* Copyright Jeremy Yallop 2007. 2 | This file is free software, distributed under the MIT license. 3 | See the file COPYING for details. 4 | *) 5 | 6 | type ('a,'b) either = Left of 'a | Right of 'b 7 | 8 | let either_partition (f : 'a -> ('b, 'c) either) (l : 'a list) 9 | : 'b list * 'c list = 10 | let rec aux (lefts, rights) = function 11 | | [] -> (List.rev lefts, List.rev rights) 12 | | x::xs -> 13 | match f x with 14 | | Left l -> aux (l :: lefts, rights) xs 15 | | Right r -> aux (lefts, r :: rights) xs 16 | in aux ([], []) l 17 | 18 | 19 | module List = 20 | struct 21 | include List 22 | 23 | let fold_left1 : ('a -> 'a -> 'a) -> 'a list -> 'a 24 | = fun f l -> match l with 25 | | x::xs -> List.fold_left f x xs 26 | | [] -> invalid_arg "fold_left1" 27 | 28 | let rec fold_right1 : ('a -> 'a -> 'a) -> 'a list -> 'a 29 | = fun f l -> match l with 30 | | [x] -> x 31 | | x::xs -> f x (fold_right1 f xs) 32 | | [] -> invalid_arg "fold_right1" 33 | 34 | let rec range from upto = 35 | let rec aux f t result = 36 | if f = t then result 37 | else aux (f+1) t (f::result) 38 | in if upto < from then raise (Invalid_argument "range") 39 | else List.rev (aux from upto []) 40 | 41 | let rec last : 'a list -> 'a = function 42 | | [] -> invalid_arg "last" 43 | | [x] -> x 44 | | _::xs -> last xs 45 | 46 | let concat_map f l = 47 | let rec aux = function 48 | | _, [] -> [] 49 | | f, x :: xs -> f x @ aux (f, xs) 50 | in aux (f,l) 51 | 52 | let concat_map2 (f : 'a -> 'b -> 'c list) (l1 : 'a list) (l2 : 'b list) : 'c list = 53 | let rec aux = function 54 | | [], [] -> [] 55 | | x::xs, y :: ys -> f x y @ aux (xs, ys) 56 | | _ -> invalid_arg "concat_map2" 57 | in aux (l1, l2) 58 | 59 | let mapn ?(init=0) f = 60 | let rec aux n = function 61 | | [] -> [] 62 | | x::xs -> f x n :: aux (n+1) xs in 63 | aux init 64 | end 65 | 66 | module F = 67 | struct 68 | let id x = x 69 | let curry f x y = f (x,y) 70 | let uncurry f (x,y) = f x y 71 | end 72 | 73 | module Option = 74 | struct 75 | let map f = function 76 | | None -> None 77 | | Some x -> Some (f x) 78 | end 79 | 80 | module DumpAst = 81 | struct 82 | open Camlp4.PreCast.Ast 83 | 84 | let rec ident = function 85 | | IdAcc (_, i1, i2) -> "IdAcc ("^ident i1^","^ident i2^")" 86 | | IdApp (_, i1, i2) -> "IdApp ("^ident i1^","^ident i2^")" 87 | | IdLid (_, s) -> "IdLid("^s^")" 88 | | IdUid (_, s) -> "IdUid("^s^")" 89 | | IdAnt (_, s) -> "IdAnt("^s^")" 90 | 91 | let rec ctyp = function 92 | | TyLab (_, s, c) -> "TyLab ("^s ^ "," ^ ctyp c ^")" 93 | | TyDcl (_, s, cs, c2, ccs) -> "TyDcl ("^s ^", [" ^ String.concat ";" (List.map ctyp cs) ^"], "^ctyp c2 ^ ", ["^ 94 | String.concat "," (List.map (fun (c1,c2) -> "(" ^ ctyp c1 ^ ", " ^ ctyp c2 ^ ")") ccs) 95 | ^ "])" 96 | | TyObj (_, c, _) -> "TyObj ("^ ctyp c ^ ", ?)" 97 | | TyOlb (_, s, c) -> "TyOlb ("^s ^ "," ^ ctyp c ^")" 98 | | TyOf (_, c1, c2) -> "TyOf ("^ ctyp c1 ^ ", " ^ ctyp c2 ^ ")" 99 | | TyOr (_, c1, c2) -> "TyOr ("^ ctyp c1 ^ ", " ^ ctyp c2 ^ ")" 100 | | TyRec (_, c) -> "TyRec("^ctyp c^")" 101 | | TySum (_, c) -> "TySum("^ctyp c^")" 102 | | TyPrv (_, c) -> "TyPrv("^ctyp c^")" 103 | | TyMut (_, c) -> "TyMut("^ctyp c^")" 104 | | TyTup (_, c) -> "TyTup("^ctyp c^")" 105 | | TyVrnEq (_, c) -> "TyVrnEq("^ctyp c^")" 106 | | TyVrnSup (_, c) -> "TyVrnSup("^ctyp c^")" 107 | | TyVrnInf (_, c) -> "TyVrnInf("^ctyp c^")" 108 | | TyCls (_, i) -> "TyCls("^ident i^")" 109 | | TyId (_, i) -> "TyId("^ident i^")" 110 | | TyNil (_) -> "TyNil" 111 | | TyAli (_, c1, c2) -> "TyAli ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 112 | | TyAny (_) -> "TyAny" 113 | | TyApp (_, c1, c2) -> "TyApp ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 114 | | TyArr (_, c1, c2) -> "TyArr ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 115 | | TyMan (_, c1, c2) -> "TyMan ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 116 | | TyPol (_, c1, c2) -> "TyPol ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 117 | | TyQuo (_, s) -> "TyQuo("^s^")" 118 | | TyQuP (_, s) -> "TyQuP("^s^")" 119 | | TyQuM (_, s) -> "TyQuM("^s^")" 120 | | TyVrn (_, s) -> "TyVrn("^s^")" 121 | | TyCol (_, c1, c2) -> "TyCol ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 122 | | TySem (_, c1, c2) -> "TySem ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 123 | | TyCom (_, c1, c2) -> "TyCom ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 124 | | TyAnd (_, c1, c2) -> "TyAnd ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 125 | | TySta (_, c1, c2) -> "TySta ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 126 | | TyVrnInfSup (_, c1, c2) -> "TyVrnInfSup ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 127 | | TyAmp (_, c1, c2) -> "TyAmp ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 128 | | TyOfAmp (_, c1, c2) -> "TyOfAmp ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 129 | | TyPkg (_, mt) -> failwith "first-class modules not supported" 130 | | TyAnt (_, s) -> "TyAnt("^s^")" 131 | end 132 | 133 | module StringMap = 134 | struct 135 | include Map.Make(String) 136 | exception NotFound of string 137 | let find s m = 138 | try find s m 139 | with Not_found -> raise (NotFound s) 140 | let fromList : (key * 'a) list -> 'a t = fun elems -> 141 | List.fold_right (F.uncurry add) elems empty 142 | let union_disjoint2 l r = 143 | fold 144 | (fun k v r -> 145 | if mem k r then invalid_arg "union_disjoint" 146 | else add k v r) l r 147 | let union_disjoint maps = List.fold_right union_disjoint2 maps empty 148 | end 149 | 150 | module Set = 151 | struct 152 | module type OrderedType = Set.OrderedType 153 | module type S = sig 154 | include Set.S 155 | val fromList : elt list -> t 156 | end 157 | module Make (Ord : OrderedType) = 158 | struct 159 | include Set.Make(Ord) 160 | let fromList elems = List.fold_right add elems empty 161 | end 162 | end 163 | 164 | let random_id length = 165 | let idchars = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_'" in 166 | let nidchars = String.length idchars in 167 | let s = String.create length in 168 | for i = 0 to length - 1 do 169 | s.[i] <- idchars.[Random.int nidchars] 170 | done; 171 | s 172 | 173 | (* The function used in OCaml to convert variant labels to their 174 | integer representations. The formula is given in Jacques 175 | Garrigue's 1998 ML workshop paper. 176 | *) 177 | let tag_hash s = 178 | let wrap = 0x40000000 in 179 | let acc = ref 0 in 180 | let mul = ref 1 in 181 | let len = String.length s in 182 | for i = 0 to len - 1 do 183 | let c = String.unsafe_get s (len - i - 1) in 184 | let n = Char.code c in 185 | acc := (!acc + n * !mul) mod wrap; 186 | mul := (!mul * 223) mod wrap; 187 | done; 188 | !acc 189 | 190 | let _ = 191 | (* Sanity check to make sure the function doesn't change underneath 192 | us *) 193 | assert (tag_hash "premiums" = tag_hash "squigglier"); 194 | assert (tag_hash "deriving" = 398308260) 195 | 196 | -------------------------------------------------------------------------------- /lib/show.ml: -------------------------------------------------------------------------------- 1 | (*pp deriving *) 2 | 3 | (* Copyright Jeremy Yallop 2007. 4 | This file is free software, distributed under the MIT license. 5 | See the file COPYING for details. 6 | *) 7 | 8 | module Show = 9 | struct 10 | (** Show **) 11 | module type Show = sig 12 | type a 13 | val format : Format.formatter -> a -> unit 14 | val format_list : Format.formatter -> a list -> unit 15 | val show : a -> string 16 | val show_list : a list -> string 17 | end 18 | 19 | module type SimpleFormatter = 20 | sig 21 | type a 22 | val format : Format.formatter -> a -> unit 23 | end 24 | 25 | module ShowFormatterDefault (S : SimpleFormatter) = 26 | struct 27 | include S 28 | let format_list formatter items = 29 | let rec writeItems formatter = function 30 | | [] -> () 31 | | [x] -> S.format formatter x; 32 | | x :: xs -> Format.fprintf formatter "%a;@;%a" S.format x writeItems xs 33 | in 34 | Format.fprintf formatter "@[[%a]@]" writeItems items 35 | end 36 | 37 | module ShowDefaults' 38 | (S : (sig 39 | type a 40 | val format : Format.formatter -> a -> unit 41 | val format_list : Format.formatter -> a list -> unit 42 | end)) : Show with type a = S.a = 43 | struct 44 | include S 45 | let showFormatted f item = 46 | let b = Buffer.create 16 in 47 | let formatter = Format.formatter_of_buffer b in 48 | Format.fprintf formatter "@[%a@]@?" f item; 49 | Buffer.sub b 0 (Buffer.length b) 50 | 51 | (* Warning: do not eta-reduce either of the following *) 52 | let show item = showFormatted S.format item 53 | let show_list items = showFormatted S.format_list items 54 | end 55 | 56 | module Defaults (S : SimpleFormatter) : Show with type a = S.a = 57 | ShowDefaults' (ShowFormatterDefault (S)) 58 | 59 | module Show_unprintable (S : sig type a end) (*: Show with type a = S.a *) = 60 | Defaults (struct 61 | type a = S.a 62 | let format formatter _ = Format.pp_print_string formatter "..." 63 | end) 64 | 65 | (* instance Show a => Show [a] *) 66 | module Show_list (S : Show) : Show with type a = S.a list = 67 | Defaults (struct 68 | type a = S.a list 69 | let format = S.format_list 70 | end) 71 | 72 | (* instance Show a => Show (a option) *) 73 | module Show_option (S : Show) : Show with type a = S.a option = 74 | Defaults (struct 75 | type a = S.a option 76 | let format formatter = function 77 | | None -> Format.fprintf formatter "@[None@]" 78 | | Some s -> Format.fprintf formatter "@[Some@;<1 2>%a@]" S.format s 79 | end) 80 | 81 | (* instance Show a => Show (a array) *) 82 | module Show_array (S : Show) : Show with type a = S.a array = 83 | Defaults (struct 84 | type a = S.a array 85 | let format formatter obj = 86 | let writeItems formatter items = 87 | let length = Array.length items in 88 | for i = 0 to length - 2 do 89 | Format.fprintf formatter "@[%a;@;@]" S.format (Array.get items i) 90 | done; 91 | if length <> 0 then 92 | S.format formatter (Array.get items (length -1)); 93 | in 94 | Format.fprintf formatter "@[[|%a|]@]" writeItems obj 95 | end) 96 | 97 | module Show_map 98 | (O : Map.OrderedType) 99 | (K : Show with type a = O.t) 100 | (V : Show) 101 | : Show with type a = V.a Map.Make(O).t = 102 | Defaults( 103 | struct 104 | module M = Map.Make(O) 105 | type a = V.a M.t 106 | let format formatter map = 107 | Format.pp_open_box formatter 0; 108 | Format.pp_print_string formatter "{"; 109 | M.iter (fun key value -> 110 | Format.pp_open_box formatter 0; 111 | K.format formatter key; 112 | Format.pp_print_string formatter " => "; 113 | V.format formatter value; 114 | Format.pp_close_box formatter (); 115 | ) map; 116 | Format.pp_print_string formatter "}"; 117 | Format.pp_close_box formatter (); 118 | 119 | end) 120 | 121 | module Show_set 122 | (O : Set.OrderedType) 123 | (K : Show with type a = O.t) 124 | : Show with type a = Set.Make(O).t = 125 | Defaults( 126 | struct 127 | module S = Set.Make(O) 128 | type a = S.t 129 | let format formatter set = 130 | Format.pp_open_box formatter 0; 131 | Format.pp_print_string formatter "{"; 132 | S.iter (fun elt -> 133 | Format.pp_open_box formatter 0; 134 | K.format formatter elt; 135 | Format.pp_close_box formatter (); 136 | ) set; 137 | Format.pp_print_string formatter "}"; 138 | Format.pp_close_box formatter (); 139 | end) 140 | 141 | module Show_bool = Defaults (struct 142 | type a = bool 143 | let format formatter item = 144 | match item with 145 | | true -> Format.pp_print_string formatter "true" 146 | | false -> Format.pp_print_string formatter "false" 147 | end) 148 | 149 | module Show_integer (S : sig type t val to_string : t -> string end) = Defaults (struct 150 | type a = S.t 151 | let format formatter item = Format.pp_print_string formatter (S.to_string item) 152 | end) 153 | 154 | module Show_int32 = Show_integer(Int32) 155 | module Show_int64 = Show_integer(Int64) 156 | module Show_nativeint = Show_integer(Nativeint) 157 | 158 | module Show_char = Defaults (struct 159 | type a = char 160 | let format formatter item = Format.pp_print_string formatter ("'" ^ Char.escaped item ^ "'") 161 | end) 162 | 163 | module Show_int = Defaults (struct 164 | type a = int 165 | let format formatter item = Format.pp_print_string formatter (string_of_int item) 166 | end) 167 | 168 | module Show_num = Defaults (struct 169 | type a = Num.num 170 | let format formatter item = Format.pp_print_string formatter (Num.string_of_num item) 171 | end) 172 | 173 | module Show_float = Defaults(struct 174 | type a = float 175 | let format formatter item = Format.pp_print_string formatter (string_of_float item) 176 | end) 177 | 178 | module Show_string = Defaults (struct 179 | type a = string 180 | let format formatter item = 181 | Format.pp_print_char formatter '"'; 182 | Format.pp_print_string formatter (String.escaped item); 183 | Format.pp_print_char formatter '"' 184 | end) 185 | 186 | module Show_unit = Defaults(struct 187 | type a = unit 188 | let format formatter () = Format.pp_print_string formatter "()" 189 | end) 190 | 191 | end 192 | include Show 193 | 194 | type open_flag = Pervasives.open_flag = 195 | | Open_rdonly 196 | | Open_wronly 197 | | Open_append 198 | | Open_creat 199 | | Open_trunc 200 | | Open_excl 201 | | Open_binary 202 | | Open_text 203 | | Open_nonblock 204 | deriving (Show) 205 | 206 | type fpclass = Pervasives.fpclass = 207 | | FP_normal 208 | | FP_subnormal 209 | | FP_zero 210 | | FP_infinite 211 | | FP_nan 212 | deriving (Show) 213 | 214 | type 'a ref = 'a Pervasives.ref = { mutable contents : 'a; } 215 | deriving (Show) 216 | 217 | -------------------------------------------------------------------------------- /tests/eq_tests.ml: -------------------------------------------------------------------------------- 1 | open Defs 2 | 3 | let sum = 4 | begin 5 | assert (Eq_sum.eq S0 S0); 6 | assert (not (Eq_sum.eq S0 (S1 0))); 7 | assert (Eq_sum.eq (S1 0) (S1 0)); 8 | assert (Eq_sum.eq (Stup (3,0.0)) (Stup (3,0.0))); 9 | assert (not (Eq_sum.eq (Stup (0,0.0)) (Stup (1,0.0)))); 10 | end 11 | 12 | let nullsum = 13 | begin 14 | assert (Eq_nullsum.eq N2 N2) 15 | end 16 | 17 | let r1 = 18 | begin 19 | assert (Eq_r1.eq 20 | { r1_l1 = 10; r1_l2 = 20 } 21 | { r1_l1 = 10; r1_l2 = 20 }); 22 | assert (not (Eq_r1.eq 23 | { r1_l1 = 20; r1_l2 = 10 } 24 | { r1_l1 = 10; r1_l2 = 20 })); 25 | end 26 | 27 | let r2 = 28 | begin 29 | let l, r = ({ r2_l1 = 10; r2_l2 = 20}, 30 | { r2_l1 = 10; r2_l2 = 20}) in 31 | assert (Eq_r2.eq l l); 32 | assert (not (Eq_r2.eq l r)); 33 | assert (not (Eq_r2.eq r l)); 34 | end 35 | 36 | let r3 = 37 | begin 38 | let l, r = ({ r3_l1 = 10; r3_l2 = 20}, 39 | { r3_l1 = 10; r3_l2 = 20}) in 40 | assert (Eq_r3.eq l l); 41 | assert (not (Eq_r3.eq l r)); 42 | assert (not (Eq_r3.eq r l)); 43 | end 44 | 45 | let intseq = 46 | begin 47 | assert (Eq_intseq.eq INil INil); 48 | assert (Eq_intseq.eq 49 | (ICons (1,INil)) 50 | (ICons (1,INil))); 51 | assert (not (Eq_intseq.eq 52 | (ICons (1,INil)) 53 | INil)); 54 | assert (not (Eq_intseq.eq 55 | INil 56 | (ICons (1,INil)))); 57 | assert (not (Eq_intseq.eq 58 | INil 59 | (let rec i = ICons(1,i) in i))); 60 | end 61 | 62 | let uses_seqs = 63 | begin 64 | let eq = Eq_uses_seqs.eq in 65 | assert (eq (INil,Cons(1.0,Nil)) (INil,Cons(1.0,Nil))); 66 | assert (not (eq (INil,Cons(1.0,Nil)) (INil,Cons(2.0,Nil)))); 67 | assert (not (eq (ICons (1,INil),Nil) (INil,Nil))); 68 | end 69 | 70 | let poly0 = 71 | begin 72 | let eq = Eq_poly0.eq in 73 | assert (eq `T0 `T0); 74 | assert (not (eq `T1 `T3)); 75 | end 76 | 77 | let poly1 = 78 | begin 79 | let eq = Eq_poly1.eq in 80 | assert (eq `T0 `T0); 81 | assert (eq (`T1 10) (`T1 10)); 82 | assert (not (eq (`T1 20) (`T1 10))); 83 | assert (not (eq (`T1 20) `T0)); 84 | end 85 | 86 | let poly2 = 87 | begin 88 | let eq = Eq_poly2.eq in 89 | assert (eq (P (3, `T0, 0.0)) (P (3, `T0, 0.0))); 90 | assert (eq (P (4, `T1 10, 2.0)) (P (4, `T1 10, 2.0))); 91 | assert (not (eq (P (5, `T1 10, 2.0)) (P (5, `T0, 2.0)))); 92 | assert (not (eq (P (6, `T0, 2.0)) (P (6, `T0, 10.0)))); 93 | assert (not (eq (P (0, `T0, 2.0)) (P (7, `T0, 2.0)))); 94 | end 95 | 96 | 97 | let poly3 = 98 | begin 99 | let eq = Eq_poly3.eq in 100 | assert (eq `Nil `Nil); 101 | assert (eq (`Cons (3,`Nil)) (`Cons (3,`Nil))); 102 | assert (eq (`Cons (3,`Cons (4,`Nil))) (`Cons (3,`Cons (4,`Nil)))); 103 | assert (not (eq (`Cons (3,`Cons (4,`Nil))) (`Cons (3,`Nil)))); 104 | end 105 | 106 | let poly3b = 107 | begin 108 | let eq = Eq_poly3b.eq in 109 | assert (eq (0,`Nil,`F) (0,`Nil,`F)); 110 | assert (not (eq (0,`Cons (1,`Nil),`F) (0,`Nil,`F))); 111 | assert (not (eq (1,`Nil,`F) (0,`Nil,`F))); 112 | end 113 | 114 | 115 | let poly7_8 = 116 | begin 117 | let module M7 = Eq_poly7(Eq.Eq_int) in 118 | let module M8 = Eq_poly8(Eq.Eq_int) in 119 | assert (M7.eq (Foo (`F 0)) (Foo (`F 0))); 120 | assert (not (M7.eq (Foo (`F 0)) (Foo (`F 1)))); 121 | assert (M8.eq 122 | {x = `G (`H (`I (Foo (`F 0))))} 123 | {x = `G (`H (`I (Foo (`F 0))))}); 124 | assert (not 125 | (M8.eq 126 | {x = `G (`H (`I (Foo (`F 0))))} 127 | {x = `G (`H (`I (Foo (`F 1))))})); 128 | end 129 | 130 | let poly10 = 131 | begin 132 | let eq = Eq_poly10.eq in 133 | assert (eq `F `F); 134 | assert (eq `Nil `Nil); 135 | assert (not (eq `Nil `F)); 136 | end 137 | 138 | let mutrec = 139 | begin 140 | let rec cyclic_1 = S (0, cyclic_2) 141 | and cyclic_2 = S (1, cyclic_1) in 142 | assert (not (Eq_mutrec_a.eq cyclic_1 cyclic_2)); 143 | assert (not 144 | (Eq_mutrec_d.eq 145 | (`T {l1 = cyclic_1; l2 = cyclic_2}) 146 | (`T {l1 = cyclic_2; l2 = cyclic_1}))); 147 | end 148 | 149 | let pmutrec = 150 | begin 151 | let module M_a = Eq_pmutrec_a(Eq.Eq_int)(Eq.Eq_bool) in 152 | let module M_b = Eq_pmutrec_b(Eq.Eq_int)(Eq.Eq_bool) in 153 | let module M_c = Eq_pmutrec_c(Eq.Eq_int)(Eq.Eq_bool) in 154 | let module M_d = Eq_pmutrec_d(Eq.Eq_int)(Eq.Eq_bool) in 155 | 156 | let rec cyclic_1 = SS (0, cyclic_2, true) 157 | and cyclic_2 = SS (1, cyclic_1, true) in 158 | assert (not (M_a.eq cyclic_1 cyclic_2)); 159 | assert (not 160 | (M_d.eq 161 | (`T {pl1 = cyclic_1; pl2 = cyclic_2}) 162 | (`T {pl1 = cyclic_2; pl2 = cyclic_1}))); 163 | end 164 | 165 | 166 | let ff1 = 167 | begin 168 | let module M = Eq_ff1(Eq.Eq_bool) in 169 | assert (M.eq (F (true,false)) (F (true,false))); 170 | assert (M.eq (G (-1)) (G (-1))); 171 | assert (not (M.eq (F (false,true)) (F (true,false)))); 172 | assert (not (M.eq (G (-1)) (G 0))); 173 | assert (not (M.eq (G (-1)) (F (true, true)))); 174 | end 175 | 176 | let ff2 = 177 | begin 178 | let module M = Eq_ff2(Eq.Eq_bool)(Eq.Eq_bool) in 179 | assert (M.eq 180 | (F1 (F2 (Cons (true,Nil), 0, None))) 181 | (F1 (F2 (Cons (true,Nil), 0, None)))); 182 | 183 | assert (not (M.eq 184 | (F2 (Nil, 0, None)) 185 | (F2 (Cons (true,Nil), 0, None)))); 186 | 187 | assert (not (M.eq 188 | (F2 (Cons (true,Nil), 0, Some true)) 189 | (F2 (Cons (true,Nil), 0, Some false)))); 190 | 191 | assert (not (M.eq 192 | (F2 (Cons (true,Nil), 0, None)) 193 | (F2 (Cons (true,Nil), 0, Some false)))); 194 | end 195 | 196 | let tup0 = 197 | begin 198 | assert (Eq_tup0.eq () ()); 199 | end 200 | 201 | let tup2 = 202 | begin 203 | assert (Eq_tup2.eq (10,5.0) (10,5.0)); 204 | assert (not (Eq_tup2.eq (10,5.0) (11,5.0))); 205 | assert (not (Eq_tup2.eq (10,5.0) (10,4.0))); 206 | end 207 | 208 | let tup3 = 209 | begin 210 | assert (Eq_tup3.eq (10,2.5,true) (10,2.5,true)); 211 | assert (not (Eq_tup3.eq (10,2.5,true) (11,2.5,true))); 212 | assert (not (Eq_tup3.eq (10,2.5,true) (10,2.4,true))); 213 | assert (not (Eq_tup3.eq (10,2.5,true) (10,2.5,false))); 214 | end 215 | 216 | let tup4 = 217 | begin 218 | assert (Eq_tup4.eq (1,2,true,()) (1,2,true,())); 219 | assert (not (Eq_tup4.eq (1,2,true,()) (0,2,true,()))); 220 | assert (not (Eq_tup4.eq (1,2,true,()) (1,3,true,()))); 221 | assert (not (Eq_tup4.eq (1,2,true,()) (1,2,false,()))); 222 | end 223 | 224 | let withref = 225 | begin 226 | let x = ref 0 in 227 | assert (Eq_withref.eq (WR (0,x)) (WR (0,x))); 228 | assert (not (Eq_withref.eq (WR (0,x)) (WR (0,ref 0)))); 229 | end 230 | 231 | let t = 232 | begin 233 | assert (Eq_t.eq 0 0); 234 | assert (Eq_t.eq (-10) (-10)); 235 | assert (Eq_t.eq 14 14); 236 | assert (not (Eq_t.eq 14 0)); 237 | assert (not (Eq_t.eq 0 14)); 238 | assert (not (Eq_t.eq (-1) 0)); 239 | end 240 | -------------------------------------------------------------------------------- /tests/sigs.ml: -------------------------------------------------------------------------------- 1 | (*pp deriving *) 2 | 3 | (* Deriving a signature with types exposed *) 4 | module T : 5 | sig 6 | type sum = S0 | S1 of int | S2 of int * float | S3 of int * float * bool | Sunit of unit | Stup of (int * float) | Stup1 of (int) 7 | deriving (Dump, Eq, Show, Typeable, Pickle) 8 | 9 | type nullsum = N0 | N1 | N2 | N3 10 | deriving (Enum, Bounded, Eq, Typeable, Pickle) 11 | 12 | type r1 = { 13 | r1_l1 : int; 14 | r1_l2 : int; 15 | } deriving (Dump, Eq, Show, Typeable, Pickle, Functor) 16 | 17 | type r2 = { 18 | mutable r2_l1 : int; 19 | mutable r2_l2 : int; 20 | } deriving (Eq, Show, Typeable, Pickle) 21 | 22 | type r3 = { 23 | r3_l1 : int; 24 | mutable r3_l2 : int; 25 | } deriving (Eq, Show, Typeable, Pickle) 26 | 27 | type r4 = { 28 | r4_l1 : 'a . 'a list 29 | } 30 | type label = x:int -> int 31 | 32 | type funct = int -> int 33 | 34 | type intseq = INil | ICons of int * intseq 35 | deriving (Dump, Eq, Show, Typeable, Pickle, Functor) 36 | 37 | type 'a seq = Nil | Cons of 'a * 'a seq 38 | deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 39 | 40 | type uses_seqs = (intseq * float seq) 41 | deriving (Dump, Eq, Show, Typeable, Pickle) 42 | 43 | type obj = < x : int > 44 | 45 | type poly0 = [`T0 | `T1 | `T2 | `T3] 46 | deriving (Enum, Bounded, Show, Eq, Typeable, Pickle) 47 | 48 | type poly1 = [`T0 | `T1 of int] 49 | deriving (Dump, Eq, Show) 50 | 51 | type poly2 = P of int * [`T0 | `T1 of int] * float 52 | deriving (Dump, Eq, Show) 53 | 54 | type poly3 = [`Nil | `Cons of int * 'c] as 'c 55 | deriving (Dump, Eq, Show, Typeable, Pickle) 56 | 57 | type poly3b = int * ([`Nil | `Cons of int * 'c] as 'c) * [`F] 58 | deriving (Dump, Eq, Show, Typeable, Pickle) 59 | 60 | type 'a poly7 = Foo of [`F of 'a] 61 | and 'a poly8 = { x : [`G of [`H of [`I of 'a poly7]]] } 62 | deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 63 | 64 | type poly10 = [`F | poly3] 65 | deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 66 | 67 | type mutrec_a = mutrec_c 68 | and mutrec_b = { l1 : mutrec_c ; l2 : mutrec_a } 69 | and mutrec_c = S of int * mutrec_a | N 70 | and mutrec_d = [`T of mutrec_b] 71 | deriving (Dump, Eq, Show, Typeable, Pickle) 72 | 73 | type ('a,'b) pmutrec_a = ('a,'b) pmutrec_c 74 | and ('a,'b) pmutrec_b = { pl1 : ('a,'b) pmutrec_c ; pl2 : ('a,'b) pmutrec_a } 75 | and ('a,'b) pmutrec_c = SS of 'a * ('a,'b) pmutrec_a * 'b 76 | and ('a,'b) pmutrec_d = [`T of ('a,'b) pmutrec_b] 77 | deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 78 | 79 | type 'a ff1 = F of 'a * 'a | G of int deriving (Show, Eq, Dump, Functor, Typeable, Pickle) 80 | type ('a,'b) ff2 = F1 of ('a,'b) ff2 | F2 of 'a seq * int * 'b option 81 | deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 82 | 83 | type tup0 = unit 84 | deriving (Dump, Eq, Show, Typeable, Pickle) 85 | type tup2 = int * float 86 | deriving (Dump, Eq, Show, Typeable, Pickle) 87 | type tup3 = int * float * bool 88 | deriving (Dump, Eq, Show, Typeable, Pickle) 89 | type tup4 = int * int * bool * unit 90 | deriving (Dump, Eq, Show, Typeable, Pickle, Bounded) 91 | 92 | type withref = WR of int * (int ref) 93 | deriving (Eq, Show, Typeable, Pickle) 94 | 95 | module M : sig 96 | type t deriving (Show, Eq, Dump) 97 | end 98 | 99 | module P : sig 100 | type 'a t (* deriving (Show) *) 101 | end 102 | 103 | type 'a constrained = [`F of 'a] constraint 'a = int 104 | deriving (Functor) 105 | 106 | type p1 = private P1 107 | deriving (Show, Eq) 108 | 109 | module Private : sig 110 | type p2 = private Q deriving (Show, Eq, Dump) 111 | end 112 | 113 | type t = int 114 | deriving (Eq, Enum, Bounded, Dump, Show, Typeable, Pickle, Functor) 115 | end 116 | = Defs 117 | 118 | (* Deriving a signature with types made abstract *) 119 | module T_opaque : 120 | sig 121 | type sum deriving (Dump, Eq, Show, Typeable, Pickle) 122 | type nullsum deriving (Enum, Bounded, Eq, Typeable, Pickle) 123 | type r1 deriving (Dump, Eq, Show, Typeable, Pickle, Functor) 124 | type r2 deriving (Eq, Show, Typeable, Pickle) 125 | type r3 deriving (Eq, Show, Typeable, Pickle) 126 | type r4 127 | type label 128 | type funct 129 | type intseq deriving (Dump, Eq, Show, Typeable, Pickle, Functor) 130 | type 'a seq deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 131 | type uses_seqs deriving (Dump, Eq, Show, Typeable, Pickle) 132 | type obj 133 | type poly0 deriving (Enum, Bounded, Show, Eq, Typeable, Pickle) 134 | type poly1 deriving (Dump, Eq, Show) 135 | type poly2 deriving (Dump, Eq, Show) 136 | type poly3 deriving (Dump, Eq, Show, Typeable, Pickle) 137 | type poly3b deriving (Dump, Eq, Show, Typeable, Pickle) 138 | type 'a poly7 139 | and 'a poly8 deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 140 | type poly10 deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 141 | type mutrec_a 142 | and mutrec_b 143 | and mutrec_c 144 | and mutrec_d deriving (Dump, Eq, Show, Typeable, Pickle) 145 | type ('a,'b) pmutrec_a 146 | and ('a,'b) pmutrec_b 147 | and ('a,'b) pmutrec_c 148 | and ('a,'b) pmutrec_d deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 149 | type 'a ff1 deriving (Show, Eq, Dump, Functor, Typeable, Pickle) 150 | type ('a,'b) ff2 deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 151 | type tup0 deriving (Dump, Eq, Show, Typeable, Pickle) 152 | type tup2 deriving (Dump, Eq, Show, Typeable, Pickle) 153 | type tup3 deriving (Dump, Eq, Show, Typeable, Pickle) 154 | type tup4 deriving (Dump, Eq, Show, Typeable, Pickle, Bounded) 155 | type withref deriving (Eq, Show, Typeable, Pickle) 156 | module M : sig type t deriving (Show, Eq, Dump) end 157 | module P : sig type 'a t end 158 | type 'a constrained constraint 'a = int deriving (Functor) 159 | type p1 deriving (Show, Eq) 160 | module Private : sig type p2 end 161 | type t deriving (Eq, Enum, Bounded, Dump, Show, Typeable, Pickle, Functor) 162 | end 163 | = Defs 164 | 165 | 166 | (* A signature with no deriving (to make sure that the types are still 167 | compatible) *) 168 | module T_no_deriving : 169 | sig 170 | type sum = S0 | S1 of int | S2 of int * float | S3 of int * float * bool | Sunit of unit | Stup of (int * float) | Stup1 of (int) 171 | 172 | type nullsum = N0 | N1 | N2 | N3 173 | 174 | type r1 = { 175 | r1_l1 : int; 176 | r1_l2 : int; 177 | } 178 | 179 | type r2 = { 180 | mutable r2_l1 : int; 181 | mutable r2_l2 : int; 182 | } 183 | 184 | type r3 = { 185 | r3_l1 : int; 186 | mutable r3_l2 : int; 187 | } 188 | 189 | type r4 = { 190 | r4_l1 : 'a . 'a list 191 | } 192 | type label = x:int -> int 193 | 194 | type funct = int -> int 195 | 196 | type intseq = INil | ICons of int * intseq 197 | 198 | type 'a seq = Nil | Cons of 'a * 'a seq 199 | 200 | type uses_seqs = (intseq * float seq) 201 | 202 | type obj = < x : int > 203 | 204 | type poly0 = [`T0 | `T1 | `T2 | `T3] 205 | 206 | type poly1 = [`T0 | `T1 of int] 207 | 208 | type poly2 = P of int * [`T0 | `T1 of int] * float 209 | 210 | type poly3 = [`Nil | `Cons of int * 'c] as 'c 211 | 212 | type poly3b = int * ([`Nil | `Cons of int * 'c] as 'c) * [`F] 213 | 214 | type 'a poly7 = Foo of [`F of 'a] 215 | and 'a poly8 = { x : [`G of [`H of [`I of 'a poly7]]] } 216 | 217 | type poly10 = [`F | poly3] 218 | 219 | type mutrec_a = mutrec_c 220 | and mutrec_b = { l1 : mutrec_c ; l2 : mutrec_a } 221 | and mutrec_c = S of int * mutrec_a | N 222 | and mutrec_d = [`T of mutrec_b] 223 | 224 | type ('a,'b) pmutrec_a = ('a,'b) pmutrec_c 225 | and ('a,'b) pmutrec_b = { pl1 : ('a,'b) pmutrec_c ; pl2 : ('a,'b) pmutrec_a } 226 | and ('a,'b) pmutrec_c = SS of 'a * ('a,'b) pmutrec_a * 'b 227 | and ('a,'b) pmutrec_d = [`T of ('a,'b) pmutrec_b] 228 | 229 | type 'a ff1 = F of 'a * 'a | G of int 230 | type ('a,'b) ff2 = F1 of ('a,'b) ff2 | F2 of 'a seq * int * 'b option 231 | 232 | type tup0 = unit 233 | type tup2 = int * float 234 | type tup3 = int * float * bool 235 | type tup4 = int * int * bool * unit 236 | type withref = WR of int * (int ref) 237 | 238 | module M : sig 239 | type t 240 | end 241 | 242 | module P : sig 243 | type 'a t 244 | end 245 | 246 | type 'a constrained = [`F of 'a] constraint 'a = int 247 | 248 | type p1 = private P1 249 | 250 | module Private : sig 251 | type p2 = private Q 252 | end 253 | 254 | type t = int 255 | end 256 | = Defs 257 | -------------------------------------------------------------------------------- /lib/monad.ml: -------------------------------------------------------------------------------- 1 | (* Copyright Jeremy Yallop 2007. 2 | This file is free software, distributed under the MIT license. 3 | See the file COPYING for details. 4 | *) 5 | 6 | module type Monad = 7 | sig 8 | type +'a m 9 | val return : 'a -> 'a m 10 | val fail : string -> 'a m 11 | val (>>=) : 'a m -> ('a -> 'b m) -> 'b m 12 | val (>>) : 'a m -> 'b m -> 'b m 13 | end 14 | 15 | module type MonadPlus = 16 | sig 17 | include Monad 18 | val mzero : 'a m 19 | val mplus : 'a m -> 'a m -> 'a m 20 | end 21 | 22 | module MonadDefault 23 | (M : 24 | sig 25 | type +'a m 26 | val return : 'a -> 'a m 27 | val fail : string -> 'a m 28 | val (>>=) : 'a m -> ('a -> 'b m) -> 'b m 29 | end) : Monad with type 'a m = 'a M.m = 30 | struct 31 | include M 32 | let (>>) x y = x >>= (fun _ -> y) 33 | end 34 | 35 | module Monad_option : MonadPlus 36 | with type 'a m = 'a option = 37 | struct 38 | include MonadDefault( 39 | struct 40 | type 'a m = 'a option 41 | let fail _ = None 42 | let return x = Some x 43 | let (>>=) x f = 44 | match x with 45 | | None -> None 46 | | Some x -> f x 47 | 48 | end) 49 | let mzero = None 50 | let mplus l r = match l, r with 51 | | None, r -> r 52 | | l, _ -> l 53 | end 54 | 55 | module Monad_list : MonadPlus 56 | with type 'a m = 'a list = 57 | struct 58 | include MonadDefault( 59 | struct 60 | type 'a m = 'a list 61 | let return x = [x] 62 | let fail _ = [] 63 | let (>>=) m f = List.concat (List.map f m) 64 | end) 65 | let mzero = [] 66 | let mplus = (@) 67 | end 68 | 69 | module IO = 70 | (struct 71 | type 'a m = unit -> 'a 72 | let return a = fun () -> a 73 | let (>>=) m k = 74 | fun () -> 75 | let v = m () in 76 | k v () 77 | let (>>) x y = x >>= (fun _ -> y) 78 | let fail = failwith 79 | let putStr s = fun () -> print_string s 80 | let runIO f = f () 81 | let mkIO (f : unit -> 'b) = return (f ()) 82 | end) 83 | 84 | module type MonadUtilsSig = 85 | sig 86 | include Monad 87 | val liftM : ('a -> 'b) -> 'a m -> 'b m 88 | val liftM2 : ('a -> 'b -> 'c) -> 'a m -> 'b m -> 'c m 89 | val liftM3 : ('a -> 'b -> 'c -> 'd) -> 'a m -> 'b m -> 'c m -> 'd m 90 | val liftM4 : 91 | ('a -> 'b -> 'c -> 'd -> 'e) -> 'a m -> 'b m -> 'c m -> 'd m -> 'e m 92 | val liftM5 : 93 | ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 94 | 'a m -> 'b m -> 'c m -> 'd m -> 'e m -> 'f m 95 | val ap : ('a -> 'b) m -> 'a m -> 'b m 96 | val sequence : 'a m list -> 'a list m 97 | val sequence_ : 'a m list -> unit m 98 | val mapM : ('a -> 'b m) -> 'a list -> 'b list m 99 | val mapM_ : ('a -> 'b m) -> 'a list -> unit m 100 | val ( =<< ) : ('a -> 'b m) -> 'a m -> 'b m 101 | val join : 'a m m -> 'a m 102 | val filterM : ('a -> bool m) -> 'a list -> 'a list m 103 | val mapAndUnzipM : 104 | ('a -> ('b * 'c) m) -> 'a list -> ('b list * 'c list) m 105 | val zipWithM : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> 'c list m 106 | val zipWithM_ : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> unit m 107 | val foldM : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m 108 | val foldM_ : ('a -> 'b -> 'a m) -> 'a -> 'b list -> unit m 109 | val replicateM : int -> 'a m -> 'a list m 110 | val replicateM_ : int -> 'a m -> unit m 111 | val quand : bool -> unit m -> unit m 112 | val unless : bool -> unit m -> unit m 113 | end 114 | 115 | (* Control.Monad *) 116 | module MonadUtils (M : Monad) = 117 | struct 118 | include M 119 | let liftM : ('a1 -> 'r) -> 'a1 m -> 'r m 120 | = fun f m1 -> m1 >>= (fun x1 -> return (f x1)) 121 | let liftM2 : ('a1 -> 'a2 -> 'r) -> 'a1 m -> 'a2 m -> 'r m 122 | = fun f m1 m2 123 | -> m1 >>= (fun x1 124 | -> m2 >>= (fun x2 125 | -> return (f x1 x2))) 126 | let liftM3 : ('a1 -> 'a2 -> 'a3 -> 'r) -> 'a1 m -> 'a2 m -> 'a3 m -> 'r m 127 | = fun f m1 m2 m3 128 | -> m1 >>= (fun x1 129 | -> m2 >>= (fun x2 130 | -> m3 >>= (fun x3 131 | -> return (f x1 x2 x3)))) 132 | let liftM4 : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'r) -> 'a1 m -> 'a2 m -> 'a3 m -> 'a4 m -> 'r m 133 | = fun f m1 m2 m3 m4 134 | -> m1 >>= (fun x1 135 | -> m2 >>= (fun x2 136 | -> m3 >>= (fun x3 137 | -> m4 >>= (fun x4 138 | -> return (f x1 x2 x3 x4))))) 139 | let liftM5 : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'r) -> 'a1 m -> 'a2 m -> 'a3 m -> 'a4 m -> 'a5 m -> 'r m 140 | = fun f m1 m2 m3 m4 m5 141 | -> m1 >>= (fun x1 142 | -> m2 >>= (fun x2 143 | -> m3 >>= (fun x3 144 | -> m4 >>= (fun x4 145 | -> m5 >>= (fun x5 146 | -> return (f x1 x2 x3 x4 x5)))))) 147 | let ap : ('a -> 'b) m -> 'a m -> 'b m 148 | = fun f -> liftM2 (fun x -> x) f 149 | 150 | let sequence : ('a m) list -> ('a list) m 151 | = let mcons p q = p >>= (fun x -> q >>= (fun y -> return (x::y))) 152 | in 153 | fun l -> List.fold_right mcons l (return []) 154 | 155 | let sequence_ : ('a m) list -> unit m 156 | = fun l -> List.fold_right (>>) l (return ()) 157 | 158 | let mapM : ('a -> 'b m) -> 'a list -> ('b list) m 159 | = fun f xs -> sequence (List.map f xs) 160 | 161 | let mapM_ : ('a -> 'b m) -> 'a list -> unit m 162 | = fun f xs -> sequence_ (List.map f xs) 163 | 164 | let (=<<) : ('a -> 'b m) -> 'a m -> 'b m 165 | = fun f x -> x >>= f 166 | 167 | let join : ('a m) m -> 'a m 168 | = fun x -> x >>= (fun x -> x) 169 | 170 | let rec filterM : ('a -> bool m) -> 'a list -> ('a list) m 171 | = fun p -> function 172 | | [] -> return [] 173 | | x::xs -> p x >>= (fun flg -> 174 | filterM p xs >>= (fun ys -> 175 | return (if flg then (x::ys) else ys))) 176 | 177 | let mapAndUnzipM : ('a -> ('b *'c) m) -> 'a list -> ('b list * 'c list) m 178 | = fun f xs -> sequence (List.map f xs) >>= fun x -> return (List.split x) 179 | 180 | let zipWithM : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> ('c list) m 181 | = fun f xs ys -> sequence (List.map2 f xs ys) 182 | 183 | let zipWithM_ : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> unit m 184 | = fun f xs ys -> sequence_ (List.map2 f xs ys) 185 | 186 | let rec foldM : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m 187 | = fun f a -> function 188 | | [] -> return a 189 | | x::xs -> f a x >>= (fun fax -> foldM f fax xs) 190 | 191 | let foldM_ : ('a -> 'b -> 'a m) -> 'a -> 'b list -> unit m 192 | = fun f a xs -> foldM f a xs >> return () 193 | 194 | let ((replicateM : int -> 'a m -> ('a list) m), 195 | (replicateM_ : int -> 'a m -> unit m)) 196 | = let replicate n i = 197 | let rec aux accum = function 198 | | 0 -> accum 199 | | n -> aux (i::accum) (n-1) 200 | in aux [] n 201 | in 202 | ((fun n x -> sequence (replicate n x)), 203 | (fun n x -> sequence_ (replicate n x))) 204 | 205 | let quand (* when *) : bool -> unit m -> unit m 206 | = fun p s -> if p then s else return () 207 | 208 | let unless : bool -> unit m -> unit m 209 | = fun p s -> if p then return () else s 210 | end 211 | 212 | module type MonadPlusUtilsSig = 213 | sig 214 | include MonadUtilsSig 215 | val mzero : 'a m 216 | val mplus : 'a m -> 'a m -> 'a m 217 | val guard : bool -> unit m 218 | val msum : 'a m list -> 'a m 219 | end 220 | 221 | module MonadPlusUtils (M : MonadPlus) = 222 | struct 223 | include MonadUtils(M) 224 | let mzero = M.mzero 225 | let mplus = M.mplus 226 | let guard : bool -> unit M.m 227 | = function 228 | | true -> M.return () 229 | | false -> M.mzero 230 | 231 | let msum : ('a M.m) list -> 'a M.m 232 | = fun l -> List.fold_right M.mplus l M.mzero 233 | end 234 | 235 | module MonadPlusUtils_option = MonadPlusUtils(Monad_option) 236 | module MonadPlusUtils_list = MonadPlusUtils(Monad_list) 237 | module Monad_IO = MonadUtils(MonadDefault (IO)) 238 | 239 | module type Monad_state_type = 240 | sig 241 | include MonadUtilsSig 242 | type state 243 | val get : state m 244 | val put : state -> unit m 245 | val runState : 'a m -> state -> 'a * state 246 | end 247 | 248 | module Monad_state_impl (A : sig type state end) = 249 | struct 250 | type state = A.state 251 | type 'a m = State of (A.state -> ('a * A.state)) 252 | let get = State (fun s -> s,s) 253 | let put s = State (fun _ -> (), s) 254 | let runState (State s) = s 255 | let return a = State (fun state -> (a, state)) 256 | let fail s = failwith ("state monad error " ^ s) 257 | let (>>=) (State x) f = State (fun s -> (let v, s' = x s in 258 | runState (f v) s')) 259 | let (>>) s f = s >>= fun _ -> f 260 | end 261 | 262 | module Monad_state(S : sig type state end) : 263 | Monad_state_type with type state = S.state = 264 | struct 265 | module M = Monad_state_impl(S) 266 | include MonadUtils(M) 267 | type state = M.state 268 | let get = M.get 269 | let put = M.put 270 | let runState = M.runState 271 | end 272 | -------------------------------------------------------------------------------- /lib/dump.ml: -------------------------------------------------------------------------------- 1 | (** Dump **) 2 | 3 | (* Copyright Jeremy Yallop 2007. 4 | This file is free software, distributed under the MIT license. 5 | See the file COPYING for details. 6 | *) 7 | 8 | (* TODO: we could have an additional debugging deserialisation method. *) 9 | module type Dump = sig 10 | type a 11 | val to_buffer : Buffer.t -> a -> unit 12 | val to_string : a -> string 13 | val to_channel : out_channel -> a -> unit 14 | val from_stream : char Stream.t -> a 15 | val from_string : string -> a 16 | val from_channel : in_channel -> a 17 | end 18 | 19 | module type SimpleDump = sig 20 | type a 21 | val to_buffer : Buffer.t -> a -> unit 22 | val from_stream : char Stream.t -> a 23 | end 24 | 25 | exception Dump_error of string 26 | 27 | let bad_tag tag stream typename = 28 | raise (Dump_error 29 | (Printf.sprintf 30 | "Dump: failure during %s deserialisation at character %d; unexpected tag %d" 31 | typename (Stream.count stream) tag)) 32 | 33 | module Defaults (P : sig 34 | type a 35 | val to_buffer : Buffer.t -> a -> unit 36 | val from_stream : char Stream.t -> a 37 | end) : Dump with type a = P.a = 38 | struct 39 | include P 40 | 41 | (* is there a reasonable value to use here? *) 42 | let buffer_size = 128 43 | 44 | let to_string obj = 45 | let buffer = Buffer.create buffer_size in 46 | P.to_buffer buffer obj; 47 | Buffer.contents buffer 48 | (* should we explicitly deallocate the buffer? *) 49 | and from_string string = P.from_stream (Stream.of_string string) 50 | and from_channel in_channel = 51 | from_stream (Stream.of_channel in_channel) 52 | and to_channel out_channel obj = 53 | let buffer = Buffer.create buffer_size in 54 | P.to_buffer buffer obj; 55 | Buffer.output_buffer out_channel buffer 56 | end 57 | 58 | 59 | (* Generic int dumper. This should work for any (fixed-size) integer 60 | type with suitable operations. *) 61 | module Dump_intN (P : sig 62 | type t 63 | val zero : t 64 | val logand : t -> t -> t 65 | val logor : t -> t -> t 66 | val lognot : t -> t 67 | val shift_right_logical : t -> int -> t 68 | val shift_left : t -> int -> t 69 | val of_int : int -> t 70 | val to_int : t -> int 71 | end) = Defaults ( 72 | struct 73 | type a = P.t 74 | (* Format an integer using the following scheme: 75 | 76 | The lower 7 bits of each byte are used to store successive 7-bit 77 | chunks of the integer. 78 | 79 | The highest bit of each byte is used as a flag to indicate 80 | whether the next byte is present. 81 | *) 82 | open Buffer 83 | open Char 84 | open P 85 | 86 | let to_buffer buffer = 87 | let rec aux int = 88 | (* are there more than 7 bits? *) 89 | if logand int (lognot (of_int 0x7f)) <> zero 90 | (* if there are, write the lowest 7 bite plus a high bit (to 91 | indicate that there's more). Then recurse, shifting the value 92 | 7 bits right *) 93 | then begin 94 | add_char buffer (chr (to_int (logor (of_int 0x80) (logand int (of_int 0x7f))))); 95 | aux (shift_right_logical int 7) 96 | end 97 | (* otherwise, write the bottom 7 bits only *) 98 | else add_char buffer (chr (to_int int)) 99 | in aux 100 | 101 | and from_stream stream = 102 | let rec aux (int : t) shift = 103 | let c = of_int (code (Stream.next stream)) in 104 | let int = logor int (shift_left (logand c (of_int 0x7f)) shift) in 105 | if logand c (of_int 0x80) <> zero then aux int (shift + 7) 106 | else int 107 | in aux zero 0 108 | end 109 | ) 110 | 111 | module Dump_int32 = Dump_intN (Int32) 112 | module Dump_int64 = Dump_intN (Int64) 113 | module Dump_nativeint = Dump_intN (Nativeint) 114 | module Dump_int = Defaults ( 115 | struct 116 | type a = int 117 | let to_buffer buffer int = Dump_nativeint.to_buffer buffer (Nativeint.of_int int) 118 | and from_stream stream = Nativeint.to_int (Dump_nativeint.from_stream stream) 119 | end 120 | ) 121 | 122 | module Dump_char = Defaults ( 123 | struct 124 | type a = char 125 | let to_buffer = Buffer.add_char 126 | and from_stream = Stream.next 127 | end 128 | ) 129 | 130 | (* This is questionable; it doesn't preserve sharing *) 131 | module Dump_string = Defaults ( 132 | struct 133 | type a = string 134 | let to_buffer buffer string = 135 | begin 136 | Dump_int.to_buffer buffer (String.length string); 137 | Buffer.add_string buffer string 138 | end 139 | and from_stream stream = 140 | let len = Dump_int.from_stream stream in 141 | let s = String.create len in 142 | for i = 0 to len - 1 do 143 | String.set s i (Stream.next stream) (* could use String.unsafe_set here *) 144 | done; 145 | s 146 | end 147 | ) 148 | 149 | module Dump_float = Defaults ( 150 | struct 151 | type a = float 152 | let to_buffer buffer f = Dump_int64.to_buffer buffer (Int64.bits_of_float f) 153 | and from_stream stream = Int64.float_of_bits (Dump_int64.from_stream stream) 154 | end 155 | ) 156 | 157 | (* This should end up a bit more compact than the derived version *) 158 | module Dump_list (P : SimpleDump) = Defaults ( 159 | (* This could perhaps be more efficient by serialising the list in 160 | reverse: this would result in only one traversal being needed 161 | during serialisation, and no "reverse" being needed during 162 | deserialisation. (However, dumping would no longer be 163 | tail-recursive) *) 164 | struct 165 | type a = P.a list 166 | let to_buffer buffer items = 167 | begin 168 | Dump_int.to_buffer buffer (List.length items); 169 | List.iter (P.to_buffer buffer) items 170 | end 171 | and from_stream stream = 172 | let rec aux items = function 173 | | 0 -> items 174 | | n -> aux (P.from_stream stream :: items) (n-1) 175 | in List.rev (aux [] (Dump_int.from_stream stream)) 176 | end 177 | ) 178 | 179 | (* Dump_ref and Dump_array cannot preserve sharing, so we don't 180 | provide implementations *) 181 | 182 | module Dump_option (P : SimpleDump) = Defaults ( 183 | struct 184 | type a = P.a option 185 | let to_buffer buffer = function 186 | | None -> Dump_int.to_buffer buffer 0 187 | | Some s -> 188 | begin 189 | Dump_int.to_buffer buffer 1; 190 | P.to_buffer buffer s 191 | end 192 | and from_stream stream = 193 | match Dump_int.from_stream stream with 194 | | 0 -> None 195 | | 1 -> Some (P.from_stream stream) 196 | | i -> bad_tag i stream "option" 197 | end 198 | ) 199 | 200 | 201 | module Dump_bool = Defaults ( 202 | struct 203 | type a = bool 204 | let to_buffer buffer = function 205 | | false -> Buffer.add_char buffer '\000' 206 | | true -> Buffer.add_char buffer '\001' 207 | and from_stream stream = 208 | match Stream.next stream with 209 | | '\000' -> false 210 | | '\001' -> true 211 | | c -> bad_tag (Char.code c) stream "bool" 212 | end 213 | ) 214 | 215 | module Dump_unit = Defaults ( 216 | struct 217 | type a = unit 218 | let to_buffer _ () = () 219 | and from_stream _ = () 220 | end 221 | ) 222 | 223 | module Dump_num = Defaults ( 224 | struct 225 | (* TODO: a less wasteful dumper for nums. A good start would be 226 | using half a byte per decimal-coded digit, instead of a whole 227 | byte. *) 228 | type a = Num.num 229 | let to_buffer buffer n = Dump_string.to_buffer buffer (Num.string_of_num n) 230 | and from_stream stream = Num.num_of_string (Dump_string.from_stream stream) 231 | end 232 | ) 233 | 234 | module Dump_undumpable (P : sig type a val tname : string end) = Defaults ( 235 | struct 236 | type a = P.a 237 | let to_buffer _ _ = failwith ("Dump: attempt to serialise a value of unserialisable type : " ^ P.tname) 238 | let from_stream _ = failwith ("Dump: attempt to deserialise a value of unserialisable type : " ^ P.tname) 239 | end 240 | ) 241 | 242 | (* Uses Marshal to serialise the values that the parse-the-declarations 243 | technique can't reach. *) 244 | module Dump_via_marshal (P : sig type a end) = Defaults ( 245 | (* Rather inefficient. *) 246 | struct 247 | include P 248 | let to_buffer buffer obj = Buffer.add_string buffer (Marshal.to_string obj [Marshal.Closures]) 249 | let from_stream stream = 250 | let readn n = 251 | let s = String.create n in 252 | for i = 0 to n - 1 do 253 | String.set s i (Stream.next stream) 254 | done; 255 | s 256 | in 257 | let header = readn Marshal.header_size in 258 | let datasize = Marshal.data_size header 0 in 259 | let datapart = readn datasize in 260 | Marshal.from_string (header ^ datapart) 0 261 | end) 262 | -------------------------------------------------------------------------------- /lib/typeable.ml: -------------------------------------------------------------------------------- 1 | (*pp deriving *) 2 | 3 | (* Copyright Jeremy Yallop 2007. 4 | This file is free software, distributed under the MIT license. 5 | See the file COPYING for details. 6 | *) 7 | 8 | (** A type is viewed as the application of type constructors to zero 9 | or more type arguments. We provide equality and ordering 10 | operations on types. The ordering is unspecified, but consistent 11 | within a process, i.e. sufficient for use in Map etc. 12 | 13 | This might be considered to break abstraction, since it exposes 14 | the fact that two types are the same, even if that fact has been 15 | hidden by type abstraction (modules etc.). This is considered a 16 | good thing, since it assists with the intended use, which is to 17 | maximise value sharing. 18 | *) 19 | 20 | module TypeRep : 21 | sig 22 | type t 23 | type delayed = unit -> t 24 | val compare : t -> t -> int 25 | val eq : t -> t -> bool 26 | val mkFresh : string -> delayed list -> delayed 27 | val mkTuple : delayed list -> delayed 28 | val mkPolyv : (string * delayed option) list -> delayed list -> delayed 29 | end = 30 | struct 31 | module StringMap = Map.Make(Interned) 32 | module IntMap = Map.Make(struct type t = int let compare = Pervasives.compare end) 33 | module StringSet = Set.Make(Interned) 34 | 35 | let counter = ref 0 36 | let fresh () = 37 | let c = !counter in 38 | incr counter; 39 | c 40 | type t = 41 | [`Variant of (delayed option StringMap.t) 42 | |`Gen of Interned.t * delayed list ] * int 43 | 44 | and delayed = unit -> t 45 | 46 | let make_fresh row : t = 47 | (* Just allocate a pointer for now. Dereference the row later *) 48 | `Variant row, fresh () 49 | 50 | module EqualMap = 51 | struct 52 | type map = int list IntMap.t 53 | let equalp : map -> int -> int -> bool 54 | = fun map l r -> 55 | try List.mem r (IntMap.find l map) 56 | with Not_found -> false 57 | 58 | let record_equality : map -> int -> int -> map = 59 | fun map l r -> 60 | let add map l r = 61 | try 62 | let vals = IntMap.find l map 63 | in IntMap.add l (r::vals) map 64 | with Not_found -> 65 | IntMap.add l [r] map 66 | in add (add map l r) r l 67 | end 68 | 69 | let keys : 'a StringMap.t -> StringSet.t = 70 | fun m -> 71 | StringMap.fold (fun k _ set -> StringSet.add k set) m StringSet.empty 72 | 73 | let rec equal : EqualMap.map -> t -> t -> bool 74 | = fun equalmap (l,lid) (r,rid) -> 75 | if lid = rid then true 76 | else if EqualMap.equalp equalmap lid rid then true 77 | else match l, r with 78 | | `Variant lrow, `Variant rrow -> 79 | (* distinct types. assume they're equal for now; record 80 | that fact in the map, then look inside the types for 81 | evidence to the contrary *) 82 | equal_rows (EqualMap.record_equality equalmap lid rid) lrow rrow 83 | | `Gen (lname, ls), `Gen (rname, rs) when Interned.eq lname rname -> 84 | List.for_all2 (fun l r -> equal equalmap (l ()) (r ())) ls rs 85 | | _ -> false 86 | and equal_rows equalmap lfields rfields = 87 | equal_names lfields rfields 88 | && StringMap.fold 89 | (fun name t eq -> 90 | let t' = StringMap.find name rfields in 91 | match t, t' with 92 | | None, None -> eq 93 | | Some t, Some t' -> 94 | equal equalmap (t ()) (t' ()) && eq 95 | | _ -> false) 96 | lfields 97 | true 98 | and equal_names lmap rmap = 99 | StringSet.equal (keys lmap) (keys rmap) 100 | 101 | let mkFresh name args = 102 | let t : t = `Gen (Interned.intern name, args), fresh () in 103 | fun () -> t 104 | 105 | let mkTuple args = 106 | mkFresh (string_of_int (List.length args)) args 107 | 108 | let mkPolyv (args : (string * delayed option) list) (extends : delayed list) : delayed = 109 | (* assume all extensions have to be completely known types at this 110 | point *) 111 | let initial = 112 | List.fold_left 113 | (fun map extension -> 114 | match fst (extension ()) with 115 | | `Variant map' -> 116 | StringMap.fold StringMap.add map map' 117 | | `Gen _ -> assert false) 118 | StringMap.empty 119 | extends 120 | in 121 | let row = 122 | List.fold_left 123 | (fun map (name, t) -> 124 | StringMap.add (Interned.intern name) t map) 125 | initial 126 | args in 127 | let fresh = make_fresh row in 128 | fun () -> fresh 129 | let eq = equal IntMap.empty 130 | 131 | let rec compare recargs (lrep,lid as l) (rrep,rid as r) = 132 | if eq l r then 0 133 | else if EqualMap.equalp recargs lid rid then 0 134 | else match lrep, rrep with 135 | | `Gen (lname, ls), `Gen (rname, rs) -> 136 | begin match Pervasives.compare lname rname with 137 | | 0 -> 138 | begin match Pervasives.compare (List.length ls) (List.length rs) with 139 | | 0 -> 140 | List.fold_left2 141 | (fun cmp l r -> 142 | if cmp <> 0 then cmp 143 | else compare recargs (l ()) (r ())) 144 | 0 ls rs 145 | | n -> n 146 | end 147 | | n -> n 148 | end 149 | | `Variant lrow, `Variant rrow -> 150 | compare_rows (EqualMap.record_equality recargs lid rid) lrow rrow 151 | | `Variant _, `Gen _ -> -1 152 | | `Gen _, `Variant _ -> 1 153 | and compare_rows recargs lrow rrow = 154 | match StringSet.compare (keys lrow) (keys rrow) with 155 | | 0 -> StringMap.compare 156 | (fun l r -> match l, r with 157 | | None, None -> 0 158 | | Some l, Some r -> compare recargs (l ()) (r ()) 159 | | None, Some _ -> -1 160 | | Some _, None -> 1) lrow rrow 161 | | n -> n 162 | 163 | let compare = compare IntMap.empty 164 | end 165 | 166 | (* Dynamic types *) 167 | type dynamic = Obj.t * TypeRep.t 168 | let tagOf (_, tag) = tag 169 | let untag (obj, tag) target = 170 | if TypeRep.eq tag target 171 | then Some obj 172 | else None 173 | 174 | (* Signature for type representations *) 175 | module type Typeable = 176 | sig 177 | type a 178 | val type_rep : unit -> TypeRep.t 179 | val has_type : dynamic -> bool 180 | val cast : dynamic -> a option 181 | val throwing_cast : dynamic -> a 182 | val make_dynamic : a -> dynamic 183 | val mk : a -> dynamic 184 | end 185 | 186 | exception CastFailure of string 187 | 188 | module Defaults (T : (sig 189 | type a 190 | val type_rep : unit -> TypeRep.t 191 | end)) 192 | : Typeable with type a = T.a = 193 | struct 194 | include T 195 | let has_type o = tagOf o = type_rep () 196 | let cast d = 197 | match untag d (type_rep ()) with 198 | | Some c -> Some (Obj.obj c) 199 | | None -> None 200 | let make_dynamic o = (Obj.repr o, type_rep ()) 201 | let mk = make_dynamic 202 | let throwing_cast d = 203 | match cast d with 204 | | None -> (*raise (CastFailure ("cast from type "^ 205 | TypeRep.Show_t.show (tagOf d) ^" to type "^ 206 | TypeRep.Show_t.show (T.type_rep ()) ^" failed"))*) 207 | raise (CastFailure "cast failed") 208 | | Some s -> s 209 | end 210 | 211 | module Typeable_list (A:Typeable) : Typeable with type a = A.a list = 212 | Defaults(struct type a = A.a list 213 | let type_rep = TypeRep.mkFresh "Primitive.list" [A.type_rep] 214 | end) 215 | 216 | module Typeable_option (A:Typeable) : Typeable with type a = A.a option = 217 | Defaults(struct type a = A.a option 218 | let type_rep = TypeRep.mkFresh "Primitive.option" [A.type_rep] 219 | end) 220 | 221 | module Primitive_typeable (T : sig type t val magic : string end) : Typeable with type a = T.t = 222 | Defaults(struct type a = T.t 223 | let type_rep = TypeRep.mkFresh T.magic [] 224 | end) 225 | module Typeable_unit = Primitive_typeable(struct type t = unit let magic = "Primitive.unit" end) 226 | module Typeable_int = Primitive_typeable(struct type t = int let magic = "Primitive.int" end) 227 | module Typeable_num = Primitive_typeable(struct type t = Num.num let magic = "Primitive.Num.num" end) 228 | module Typeable_float = Primitive_typeable(struct type t = float let magic = "Primitive.float" end) 229 | module Typeable_bool = Primitive_typeable(struct type t = bool let magic = "Primitive.bool" end) 230 | module Typeable_string = Primitive_typeable(struct type t = string let magic = "Primitive.string" end) 231 | module Typeable_char = Primitive_typeable(struct type t = char let magic = "Primitive.char" end) 232 | 233 | module Typeable_ref(A : Typeable) : Typeable with type a = A.a ref = 234 | Defaults(struct type a = A.a ref 235 | let type_rep = TypeRep.mkFresh "Primitive.ref" [A.type_rep] 236 | end) 237 | 238 | -------------------------------------------------------------------------------- /tests/pickle_tests.ml: -------------------------------------------------------------------------------- 1 | (*pp deriving *) 2 | 3 | open Defs 4 | 5 | module Test (S : Pickle.Pickle) = 6 | struct 7 | let test v = S.E.eq (S.from_string (S.to_string v)) v 8 | end 9 | 10 | let sum = 11 | begin 12 | let test = let module T = Test(Pickle_sum) in T.test in 13 | assert (test S0); 14 | assert (test (S1 3)); 15 | assert (test (S2 (10,2.0))); 16 | assert (test (Sunit ())); 17 | assert (test (Stup (10,2.0))); 18 | assert (test (Stup1 3)); 19 | end 20 | 21 | let nullsum = 22 | begin 23 | let test = let module T = Test(Pickle_nullsum) in T.test in 24 | assert (test N0); 25 | assert (test N1); 26 | assert (test N2); 27 | assert (test N3); 28 | end 29 | 30 | let r1 = 31 | begin 32 | let test = let module T = Test(Pickle_r1) in T.test in 33 | assert (test {r1_l1 = 10; r1_l2 = 20}); 34 | assert (test {r1_l1 = min_int; r1_l2 = max_int}); 35 | assert (test {r1_l1 = max_int; r1_l2 = min_int}); 36 | end 37 | 38 | let r2 = 39 | begin 40 | let v = { r2_l1 = 10; 41 | r2_l2 = 14 } in 42 | assert (not (Eq_r2.eq 43 | (Pickle_r2.from_string 44 | (Pickle_r2.to_string v)) v)); 45 | assert (Pickle_r2.from_string 46 | (Pickle_r2.to_string v) = v); 47 | end 48 | 49 | let r3 = 50 | begin 51 | let v = { r3_l1 = 10; 52 | r3_l2 = 14 } in 53 | assert (not (Eq_r3.eq 54 | (Pickle_r3.from_string 55 | (Pickle_r3.to_string v)) v)); 56 | assert (Pickle_r3.from_string 57 | (Pickle_r3.to_string v) = v); 58 | end 59 | 60 | let intseq = 61 | begin 62 | let test = let module T = Test(Pickle_intseq) in T.test in 63 | assert (test INil); 64 | assert (test (ICons (10, ICons (20, ICons (30, ICons (40, INil)))))); 65 | assert (test (ICons (max_int, ICons (min_int, INil)))); 66 | end 67 | 68 | let seq = 69 | begin 70 | let test = let module T = Test(Pickle_seq(Pickle.Pickle_bool)) in T.test in 71 | let test' = let module T = Test(Pickle_seq(Pickle_seq(Pickle.Pickle_bool))) in T.test in 72 | 73 | assert (test Nil); 74 | assert (test (Cons (false, Cons (true, Cons (false, Nil))))); 75 | assert (test' Nil); 76 | assert (test' (Cons (Cons (false, Cons (true, Nil)), 77 | Cons (Cons (true, Cons (false, Nil)), 78 | Nil)))); 79 | end 80 | 81 | let uses_seqs = 82 | begin 83 | let test = let module T = Test(Pickle_uses_seqs) in T.test in 84 | assert (test (INil, Nil)); 85 | assert (test (INil, Cons (0.0, Cons(10.0, Nil)))); 86 | assert (test (ICons (10, ICons(20, INil)), Nil)); 87 | assert (test (ICons (10, ICons(20, INil)), 88 | Cons (0.0, Cons(10.0, Nil)))); 89 | end 90 | 91 | type permute0 = [`T3 | `T1 | `T2 | `T0] deriving (Typeable, Eq, Pickle) 92 | let poly0 = 93 | begin 94 | let test v = Eq_permute0.eq (Pickle_permute0.from_string (Pickle_poly0.to_string v)) v in 95 | assert (test `T0); 96 | assert (test `T1); 97 | assert (test `T2); 98 | assert (test `T3); 99 | end 100 | 101 | type permute3 = [`Nil | `Cons of int * permute3] deriving (Typeable, Eq, Pickle) 102 | let _ = 103 | begin 104 | let test v = Eq_permute3.eq (Pickle_permute3.from_string (Pickle_poly3.to_string v)) v in 105 | assert (test `Nil); 106 | assert (test (`Cons (0, `Cons (1, `Cons (2, `Nil))))); 107 | end 108 | 109 | let poly3b = 110 | begin 111 | let test = let module T = Test(Pickle_poly3b) in T.test in 112 | assert (test (10, `Nil, `F)); 113 | assert (test (10, `Cons (10, `Cons (-20, `Nil)), `F)); 114 | end 115 | 116 | let _ = 117 | begin 118 | let test = let module T = Test(Pickle_poly7(Pickle.Pickle_bool)) in T.test 119 | and test' = let module T = Test(Pickle_poly8(Pickle.Pickle_int)) in T.test in 120 | assert (test (Foo (`F true))); 121 | assert (test (Foo (`F false))); 122 | assert (test' {x = `G (`H (`I (Foo (`F (max_int - 1)))))}); 123 | assert (test' {x = `G (`H (`I (Foo (`F (min_int + 1)))))}); 124 | end 125 | 126 | let _ = 127 | begin 128 | let test = let module T = Test(Pickle_poly10) in T.test in 129 | assert (test `F); 130 | assert (test `Nil); 131 | assert (test (`Cons (12, `Cons (14, `Nil)))); 132 | end 133 | 134 | let mutrec = 135 | begin 136 | let module A = Test(Pickle_mutrec_a) in 137 | let module B = Test(Pickle_mutrec_b) in 138 | let module C = Test(Pickle_mutrec_c) in 139 | let module D = Test(Pickle_mutrec_d) in 140 | let a = N in 141 | let b = { l1 = S (3, a); l2 = a } in 142 | let c = S (3, S (4, S (5, N))) in 143 | let d = `T b in 144 | assert (A.test a); 145 | assert (B.test b); 146 | assert (C.test c); 147 | assert (D.test d); 148 | end 149 | 150 | let pmutrec = 151 | begin 152 | (* 153 | type ('a,'b) pmutrec_a = ('a,'b) pmutrec_c 154 | and ('a,'b) pmutrec_b = { pl1 : ('a,'b) pmutrec_c ; pl2 : ('a,'b) pmutrec_a } 155 | and ('a,'b) pmutrec_c = SS of 'a * ('a,'b) pmutrec_a * 'b 156 | and ('a,'b) pmutrec_d = [`T of ('a,'b) pmutrec_b] 157 | *) 158 | end 159 | 160 | let ff1 = 161 | begin 162 | let test = let module T = Test(Pickle_ff1(Pickle.Pickle_bool)) in T.test in 163 | assert (test (F (true,false))); 164 | assert (test (G 435)); 165 | end 166 | 167 | let ff2 = 168 | begin 169 | let test = let module T = Test(Pickle_ff2(Pickle.Pickle_bool)(Pickle.Pickle_int)) in T.test in 170 | assert (test (F1 (F2 (Nil, 10, None)))); 171 | assert (test (F1 (F2 (Cons (true, Cons (false, Nil)), 10, Some 14)))); 172 | end 173 | 174 | let unit = 175 | begin 176 | let test = let module T = Test(Pickle_unit) in T.test in 177 | assert (test ()); 178 | end 179 | 180 | let tup2 = 181 | begin 182 | let test = let module T = Test(Pickle_tup2) in T.test in 183 | assert (test (-10,12e4)); 184 | assert (test (max_int,12e4)); 185 | end 186 | 187 | let tup3 = 188 | begin 189 | let test = let module T = Test(Pickle_tup3) in T.test in 190 | assert (test (0,12.3,true)); 191 | assert (test (min_int,-12.3,false)); 192 | end 193 | 194 | let tup4 = 195 | begin 196 | let test = let module T = Test(Pickle_tup4) in T.test in 197 | assert (test (0,0,true,())); 198 | assert (test (min_int,max_int,false,())); 199 | end 200 | 201 | let withref = 202 | begin 203 | let v = WR (10, ref 20) in 204 | assert (not 205 | (Eq_withref.eq (Pickle_withref.from_string 206 | (Pickle_withref.to_string v)) v)); 207 | assert (Pickle_withref.from_string 208 | (Pickle_withref.to_string v) = v); 209 | end 210 | 211 | let t = 212 | begin 213 | let test v = Eq_int.eq (Pickle_int.from_string (Pickle_t.to_string v)) v in 214 | assert (test min_int); 215 | assert (test max_int); 216 | assert (test 10); 217 | end 218 | 219 | type refobj = A | B of refobj ref 220 | deriving (Eq, Typeable, Pickle) 221 | 222 | let circular = 223 | let s = ref A in 224 | let r = B s in 225 | s := r; 226 | r 227 | 228 | let _ = 229 | let v = Pickle_refobj.from_string (Pickle_refobj.to_string circular) in 230 | let (B {contents = 231 | B {contents = 232 | B {contents = 233 | B {contents = 234 | B {contents = 235 | B {contents = 236 | B {contents = _ }}}}}}}) = v in 237 | () 238 | 239 | 240 | type mut = { 241 | mutable x : mut option; 242 | mutable y : mut option; 243 | z : int; 244 | } deriving (Eq, Typeable, Pickle) 245 | 246 | let circularm = 247 | let i = {z = 1; x = None; y = None} in 248 | let j = {z = 2; x = None; y = Some i} in 249 | i.x <- Some j; 250 | i.y <- Some i; 251 | j.x <- Some j; 252 | i 253 | 254 | let _ = 255 | let v = Pickle_mut.from_string (Pickle_mut.to_string circularm) in 256 | let {z = 1; 257 | x = Some {z = 2; x = Some {z = 2; 258 | x = Some _; 259 | y = Some _}; 260 | y = Some _}; 261 | y = Some {z = 1; 262 | x = Some {z = 2; x = Some {z = 2; 263 | x = Some {z = 2; 264 | x = Some _; 265 | y = Some _}; 266 | y = Some _}; 267 | y = Some _}; 268 | y = Some _}} = v in 269 | () 270 | 271 | type t1 = { mutable x : t2 option } 272 | and t2 = { y : t1 option } 273 | deriving (Eq, Typeable, Pickle) 274 | 275 | let circular_a = 276 | let a = { x = None } in 277 | let b = { y = Some a } in 278 | a.x <- Some b; 279 | a 280 | 281 | let _ = 282 | let {x = Some {y = Some 283 | {x = Some {y = Some 284 | {x = Some {y = Some 285 | {x = Some {y = Some _}}}}}}}} = 286 | Pickle_t1.from_string (Pickle_t1.to_string circular_a) in 287 | () 288 | -------------------------------------------------------------------------------- /syntax/pickle_class.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4of *) 2 | 3 | (* Copyright Jeremy Yallop 2007. 4 | This file is free software, distributed under the MIT license. 5 | See the file COPYING for details. 6 | *) 7 | 8 | module InContext (L : Base.Loc) = 9 | struct 10 | open Base 11 | open Utils 12 | open Type 13 | open Camlp4.PreCast 14 | include Base.InContext(L) 15 | module UT = Type.Untranslate(L) 16 | 17 | let typeable_defaults t = <:module_expr< Typeable.Defaults($t$) >> 18 | 19 | module Typeable = Typeable_class.InContext(L) 20 | module Eq = Eq_class.InContext(L) 21 | 22 | let classname = "Pickle" 23 | let bind, seq = 24 | let bindop = ">>=" and seqop = ">>" in 25 | <:expr< $lid:bindop$ >>, <:expr< $lid:seqop$ >> 26 | 27 | let unpickle_record_bindings ctxt (tname,params,rhs,cs,_) (fields : field list) e = <:expr< 28 | let module Mutable = struct 29 | type $Ast.TyDcl (loc, "t", [], UT.repr 30 | (instantiate_modargs_repr ctxt 31 | (Record (List.map (fun (n,p,_) -> (n,p,`Mutable)) fields))), [])$ 32 | end in $e$ >> 33 | 34 | let unpickle_record ctxt (tname,_,_,_,_ as decl) fields expr = 35 | let msg = "unexpected object encountered unpickling "^tname in 36 | let assignments = 37 | List.fold_right 38 | (fun (id,_,_) exp -> 39 | <:expr< this.Mutable.$lid:id$ <- $lid:id$; $exp$ >>) 40 | fields 41 | <:expr< return self >> in 42 | let inner = 43 | List.fold_right 44 | (fun (id,([],t),_) exp -> 45 | <:expr< $bind$ ($mproject (expr ctxt t) "unpickle"$ $lid:id$) 46 | (fun $lid:id$ -> $exp$) >>) 47 | fields 48 | assignments in 49 | let idpat = patt_list (List.map (fun (id,_,_) -> <:patt< $lid:id$ >>) fields) in 50 | unpickle_record_bindings ctxt decl fields 51 | (<:expr< W.record 52 | (fun self -> function 53 | | $idpat$ -> let this = (Obj.magic self : Mutable.t) in $inner$ 54 | | _ -> raise (UnpicklingError $str:msg$)) $`int:List.length fields$ >>) 55 | 56 | let pickle_record ctxt decl fields expr = 57 | let inner = 58 | List.fold_right 59 | (fun (id,([],t),_) e -> 60 | <:expr< $bind$ ($mproject (expr ctxt t) "pickle"$ $lid:id$) 61 | (fun $lid:id$ -> $e$) >>) 62 | fields 63 | <:expr< (W.store_repr this 64 | (Repr.make 65 | $expr_list (List.map (fun (id,_,_) -> <:expr< $lid:id$ >>) fields)$)) >> 66 | in 67 | [ <:match_case< ($record_pattern fields$ as obj) -> 68 | W.allocate obj (fun this -> $inner$) >> ] 69 | 70 | 71 | let typeable_instance ctxt tname = 72 | <:module_expr< Typeable.Defaults( 73 | $apply_functor <:module_expr< $uid:"Typeable_" ^ tname$ >> 74 | (List.map (fun (p,_) -> <:module_expr< $uid:NameMap.find p ctxt.argmap$.T >>) 75 | ctxt.params)$) >> 76 | 77 | let eq_instance ctxt tname = 78 | apply_functor <:module_expr< $uid:"Eq_" ^ tname$ >> 79 | (List.map (fun (p,_) -> <:module_expr< $uid:NameMap.find p ctxt.argmap$.E >>) 80 | ctxt.params) 81 | 82 | let rebind_params ctxt name : Ast.str_item = 83 | NameMap.fold 84 | (fun _ param s -> <:str_item< $s$ module $uid:param$ = $uid:param$.$uid:name$ >>) 85 | ctxt.argmap 86 | <:str_item< >> 87 | 88 | let wrap ~ctxt ~atype ~tymod ~eqmod ~picklers ~unpickler = 89 | <:module_expr< struct open Eq open Typeable 90 | module T = $tymod$ 91 | module E = $eqmod$ 92 | type $Ast.TyDcl (loc, "a", [], atype, [])$ 93 | open Write 94 | let pickle = let module W = Utils(T)(E) in function $list:picklers$ 95 | open Read 96 | let unpickle = let module W = Utils(T) in $unpickler$ 97 | end >> 98 | 99 | let instance = object (self) 100 | inherit make_module_expr ~classname ~allow_private:false 101 | 102 | method tuple ctxt ts = 103 | let nts = List.length ts in 104 | let ids = (List.mapn (fun t n -> (Printf.sprintf "id%d" n, t)) ts) in 105 | let eidlist = expr_list (List.map (fun (id,_) -> <:expr< $lid:id$ >>) ids) in 106 | let pidlist = patt_list (List.map (fun (id,_) -> <:patt< $lid:id$ >>) ids) in 107 | let tpatt,texpr = tuple ~param:"id" nts in 108 | let tymod = Typeable.tup ctxt ts <:expr< M.T.type_rep >> (self#expr) 109 | and eqmod = Eq.tup ctxt ts <:expr< M.E.eq >> (self#expr) 110 | and picklers = 111 | let inner = 112 | List.fold_right 113 | (fun (id,t) expr -> 114 | <:expr< $bind$ ($mproject (self#expr ctxt t) "pickle"$ $lid:id$) 115 | (fun $lid:id$ -> $expr$) >>) 116 | ids 117 | <:expr< W.store_repr this (Repr.make $eidlist$) >> in 118 | [ <:match_case< ($tpatt$ as obj) -> 119 | W.allocate obj (fun this -> $inner$) >>] 120 | 121 | and unpickler = 122 | let msg = "unexpected object encountered unpickling "^string_of_int nts^"-tuple" in 123 | let inner = 124 | List.fold_right 125 | (fun (id,t) expr -> 126 | <:expr< $bind$ ($mproject (self#expr ctxt t) "unpickle"$ $lid:id$) (fun $lid:id$ -> $expr$) >>) 127 | ids 128 | <:expr< return $texpr$ >> in 129 | <:expr< W.tuple 130 | (function 131 | | $pidlist$ -> $inner$ 132 | | _ -> raise (UnpicklingError $str:msg$)) >> 133 | and atype = atype_expr ctxt (`Tuple ts) in 134 | <:module_expr< Pickle.Defaults($wrap ~ctxt ~atype ~tymod ~eqmod ~picklers ~unpickler$) >> 135 | 136 | method polycase ctxt tagspec : Ast.match_case = match tagspec with 137 | | Tag (name, None) -> <:match_case< 138 | (`$name$ as obj) -> 139 | W.allocate obj 140 | (fun thisid -> 141 | W.store_repr thisid 142 | (Repr.make ~constructor:$`int:(tag_hash name)$ [])) >> 143 | | Tag (name, Some t) -> <:match_case< 144 | (`$name$ v1 as obj) -> 145 | W.allocate obj 146 | (fun thisid -> 147 | $bind$ ($mproject (self#expr ctxt t) "pickle"$ v1) 148 | (fun mid -> 149 | (W.store_repr thisid 150 | (Repr.make ~constructor:$`int:(tag_hash name)$ [mid])))) >> 151 | | Extends t -> 152 | let patt, guard, cast = cast_pattern ctxt t in <:match_case< 153 | ($patt$ as obj) when $guard$ -> 154 | ($mproject (self#expr ctxt t) "pickle"$ $cast$) >> 155 | 156 | method polycase_un ctxt tagspec : Ast.match_case = match tagspec with 157 | | (name, None) -> <:match_case< $`int:(tag_hash name)$, [] -> return `$name$ >> 158 | | (name, Some t) -> <:match_case< $`int:(tag_hash name)$, [x] -> 159 | $bind$ ($mproject (self#expr ctxt t) "unpickle"$ x) (fun o -> return (`$name$ o)) >> 160 | 161 | method extension ctxt tname ts : Ast.match_case = 162 | (* Try each extension in turn. If we get an UnknownTag failure, 163 | try the next one. This is 164 | 165 | * safe because any two extensions that define the same tag 166 | must be compatible at that point 167 | 168 | * fast because we can tell on the first integer comparison 169 | whether we've picked the right path or not. 170 | *) 171 | let inner = List.fold_right 172 | (fun t exp -> <:expr< 173 | let module M = $(self#expr ctxt t)$ in 174 | try $exp$ 175 | with UnknownTag (n,_) -> (M.unpickle id :> a Read.m) >>) 176 | ts 177 | <:expr< raise (UnknownTag (n, ($str:"Unexpected tag encountered during unpickling of " 178 | ^tname$))) >> 179 | in <:match_case< n,_ -> $inner$ >> 180 | 181 | method variant ctxt (tname,_,_,_,_ as decl) (_, tags) = 182 | let unpickler = 183 | let tags, extensions = either_partition 184 | (function Tag (name,t) -> Left (name,t) | Extends t -> Right t) tags in 185 | let tag_cases = List.map (self#polycase_un ctxt) tags in 186 | let extension_case = self#extension ctxt tname extensions in 187 | <:expr< fun id -> W.sum (function $list:tag_cases @ [extension_case]$) id >> 188 | in 189 | wrap ~ctxt ~atype:(atype ctxt decl) ~tymod:(typeable_instance ctxt tname) 190 | ~eqmod:(eq_instance ctxt tname) 191 | ~picklers:(List.map (self#polycase ctxt) tags) ~unpickler 192 | 193 | method case ctors ctxt (name, params') n : Ast.match_case * Ast.match_case = 194 | let nparams = List.length params' in 195 | let ids = List.map (fun n -> <:expr< $lid:Printf.sprintf "id%d" n$ >>) (List.range 0 nparams) in 196 | let exp = 197 | List.fold_right2 198 | (fun p n tail -> 199 | <:expr< $bind$ ($mproject (self#expr ctxt p) "pickle"$ $lid:Printf.sprintf "v%d" n$) 200 | (fun $lid:Printf.sprintf "id%d" n$ -> $tail$)>>) 201 | params' 202 | (List.range 0 nparams) 203 | <:expr< W.store_repr thisid (Repr.make ~constructor:$`int:n$ $expr_list ids$) >> in 204 | match params' with 205 | | [] -> <:match_case< $uid:name$ as obj -> 206 | W.allocate obj (fun thisid -> $exp$) >>, 207 | <:match_case< $`int:n$, [] -> return $uid:name$ >> 208 | | _ -> <:match_case< $uid:name$ $fst (tuple ~param:"v" nparams)$ as obj -> 209 | W.allocate obj (fun thisid -> $exp$) >>, 210 | let _, tuple = tuple ~param:"id" nparams in 211 | let patt, exp = 212 | List.fold_right2 213 | (fun n t (pat, exp) -> 214 | let m = Printf.sprintf "M%d" n and id = Printf.sprintf "id%d" n in 215 | <:patt< $lid:id$ :: $pat$ >>, 216 | <:expr< let module $uid:m$ = $self#expr ctxt t$ 217 | in $bind$ ($uid:m$.unpickle $lid:id$) (fun $lid:id$ -> $exp$) >>) 218 | (List.range 0 nparams) 219 | params' 220 | (<:patt< [] >>, <:expr< return ($uid:name$ $tuple$) >>) in 221 | <:match_case< $`int:n$, $patt$ -> $exp$ >> 222 | 223 | method sum ?eq ctxt (tname,_,_,_,_ as decl) summands = 224 | let nctors = List.length summands in 225 | let picklers, unpicklers = List.split (List.mapn (self#case nctors ctxt) summands) in 226 | wrap ~ctxt ~atype:(atype ctxt decl) 227 | ~tymod:(typeable_instance ctxt tname) 228 | ~eqmod:(eq_instance ctxt tname) 229 | ~picklers 230 | ~unpickler:<:expr< fun id -> 231 | let f = function $list:unpicklers$ 232 | | n,_ -> raise (UnpicklingError ($str:"Unexpected tag when unpickling " 233 | ^tname^": "$^ string_of_int n)) 234 | in W.sum f id >> 235 | 236 | method record ?eq ctxt (tname,_,_,_,_ as decl) (fields : Type.field list) = 237 | wrap ~ctxt ~atype:(atype ctxt decl) 238 | ~picklers:(pickle_record ctxt decl fields (self#expr)) 239 | ~unpickler:(unpickle_record ctxt decl fields (self#expr)) 240 | ~tymod:(typeable_instance ctxt tname) 241 | ~eqmod:(eq_instance ctxt tname) 242 | end 243 | end 244 | 245 | let _ = Base.register "Pickle" 246 | ((fun (loc, context, decls) -> 247 | let module M = InContext(struct let loc = loc end) in 248 | M.generate ~context ~decls ~make_module_expr:M.instance#rhs ~classname:M.classname 249 | ~default_module:"Defaults" ()), 250 | (fun (loc, context, decls) -> 251 | let module M = InContext(struct let loc = loc end) in 252 | M.gen_sigs ~context ~decls ~classname:M.classname)) 253 | -------------------------------------------------------------------------------- /syntax/base.ml: -------------------------------------------------------------------------------- 1 | (*pp camlp4of *) 2 | 3 | (* Copyright Jeremy Yallop 2007. 4 | This file is free software, distributed under the MIT license. 5 | See the file COPYING for details. 6 | *) 7 | 8 | open Utils 9 | open Type 10 | open Camlp4.PreCast 11 | 12 | type context = { 13 | loc : Loc.t; 14 | (* mapping from type parameters to functor arguments *) 15 | argmap : name NameMap.t; 16 | (* ordered list of type parameters *) 17 | params : param list; 18 | (* type names *) 19 | tnames : NameSet.t; 20 | } 21 | 22 | exception Underivable of string 23 | exception NoSuchClass of string 24 | 25 | (* display a fatal error and exit *) 26 | let error loc (msg : string) = 27 | Syntax.print_warning loc msg; 28 | exit 1 29 | 30 | module type Loc = sig val loc : Loc.t end 31 | 32 | let contains_tvars, contains_tvars_decl = 33 | let o = object 34 | inherit [bool] fold as default 35 | method crush = List.exists F.id 36 | method expr = function 37 | | `Param _ -> true 38 | | e -> default#expr e 39 | end in (o#expr, o#decl) 40 | 41 | module InContext(L : Loc) = 42 | struct 43 | include L 44 | module Untranslate = Untranslate(L) 45 | 46 | let instantiate, instantiate_repr = 47 | let o lookup = object 48 | inherit transform as super 49 | method expr = function 50 | | `Param (name, _) -> lookup name 51 | | e -> super # expr e 52 | end in 53 | (fun (lookup : name -> expr) -> (o lookup)#expr), 54 | (fun (lookup : name -> expr) -> (o lookup)#repr) 55 | 56 | let instantiate_modargs, instantiate_modargs_repr = 57 | let lookup ctxt var = 58 | try 59 | `Constr ([NameMap.find var ctxt.argmap; "a"], []) 60 | with Not_found -> 61 | failwith ("Unbound type parameter '" ^ var) 62 | in (fun ctxt -> instantiate (lookup ctxt)), 63 | (fun ctxt -> instantiate_repr (lookup ctxt)) 64 | 65 | let substitute env = 66 | (object 67 | inherit transform as default 68 | method expr = function 69 | | `Param (p,v) when NameMap.mem p env -> 70 | `Param (NameMap.find p env,v) 71 | | e -> default# expr e 72 | end) # expr 73 | 74 | let cast_pattern ctxt ?(param="x") t = 75 | let t = Untranslate.expr (instantiate_modargs ctxt t) in 76 | (<:patt< $lid:param$ >>, 77 | <:expr< 78 | let module M = 79 | struct 80 | type $Ast.TyDcl (loc, "t", [], t, [])$ 81 | let test = function #t -> true | _ -> false 82 | end in M.test $lid:param$ >>, 83 | <:expr< 84 | (let module M = 85 | struct 86 | type $Ast.TyDcl (loc, "t", [], t, [])$ 87 | let cast = function #t as t -> t | _ -> assert false 88 | end in M.cast $lid:param$ )>>) 89 | 90 | let seq l r = <:expr< $l$ ; $r$ >> 91 | 92 | let record_pattern ?(prefix="") (fields : Type.field list) : Ast.patt = 93 | <:patt<{$list: 94 | (List.map (fun (label,_,_) -> <:patt< $lid:label$ = $lid:prefix ^ label$ >>) 95 | fields) $}>> 96 | 97 | let record_expr : (string * Ast.expr) list -> Ast.expr = 98 | fun fields -> 99 | let fs = 100 | List.fold_left1 101 | (fun l r -> <:rec_binding< $l$ ; $r$ >>) 102 | (List.map (fun (label, exp) -> <:rec_binding< $lid:label$ = $exp$ >>) 103 | fields) in 104 | Ast.ExRec (loc, fs, Ast.ExNil loc) 105 | 106 | let record_expression ?(prefix="") : Type.field list -> Ast.expr = 107 | fun fields -> 108 | let es = List.fold_left1 109 | (fun l r -> <:rec_binding< $l$ ; $r$ >>) 110 | (List.map (fun (label,_,_) -> <:rec_binding< $lid:label$ = $lid:prefix ^ label$ >>) 111 | fields) in 112 | Ast.ExRec (loc, es, Ast.ExNil loc) 113 | 114 | let mproject mexpr name = 115 | match mexpr with 116 | | <:module_expr< $id:m$ >> -> <:expr< $id:m$.$lid:name$ >> 117 | | _ -> <:expr< let module M = $mexpr$ in M.$lid:name$ >> 118 | 119 | let expr_list : Ast.expr list -> Ast.expr = 120 | (fun exprs -> 121 | List.fold_right 122 | (fun car cdr -> <:expr< $car$ :: $cdr$ >>) 123 | exprs 124 | <:expr< [] >>) 125 | 126 | let patt_list : Ast.patt list -> Ast.patt = 127 | (fun patts -> 128 | List.fold_right 129 | (fun car cdr -> <:patt< $car$ :: $cdr$ >>) 130 | patts 131 | <:patt< [] >>) 132 | 133 | let tuple_expr : Ast.expr list -> Ast.expr = function 134 | | [] -> <:expr< () >> 135 | | [x] -> x 136 | | x::xs -> Ast.ExTup (loc, List.fold_left (fun e t -> Ast.ExCom (loc, e,t)) x xs) 137 | 138 | let tuple ?(param="v") n : Ast.patt * Ast.expr = 139 | let v n = Printf.sprintf "%s%d" param n in 140 | match n with 141 | | 0 -> <:patt< () >>, <:expr< () >> 142 | | 1 -> <:patt< $lid:v 0$ >>, <:expr< $lid:v 0$ >> 143 | | n -> 144 | let patts, exprs = 145 | (* At time of writing I haven't managed to write anything 146 | using quotations that generates an n-tuple *) 147 | List.fold_left 148 | (fun (p, e) (patt, expr) -> Ast.PaCom (loc, p, patt), Ast.ExCom (loc, e, expr)) 149 | (<:patt< >>, <:expr< >>) 150 | (List.map (fun n -> <:patt< $lid:v n$ >>, <:expr< $lid:v n $ >>) 151 | (List.range 0 n)) 152 | in 153 | Ast.PaTup (loc, patts), Ast.ExTup (loc, exprs) 154 | 155 | let rec modname_from_qname ~qname ~classname = 156 | match qname with 157 | | [] -> invalid_arg "modname_from_qname" 158 | | [t] -> <:ident< $uid:classname ^ "_"^ t$ >> 159 | | t::ts -> <:ident< $uid:t$.$modname_from_qname ~qname:ts ~classname$ >> 160 | 161 | let apply_functor (f : Ast.module_expr) (args : Ast.module_expr list) : Ast.module_expr = 162 | List.fold_left (fun f p -> <:module_expr< $f$ ($p$) >>) f args 163 | 164 | class virtual make_module_expr ~classname ~allow_private = 165 | object (self) 166 | 167 | method mapply ctxt (funct : Ast.module_expr) args = 168 | apply_functor funct (List.map (self#expr ctxt) args) 169 | 170 | method virtual variant : context -> decl -> variant -> Ast.module_expr 171 | method virtual sum : ?eq:expr -> context -> decl -> summand list -> Ast.module_expr 172 | method virtual record : ?eq:expr -> context -> decl -> field list -> Ast.module_expr 173 | method virtual tuple : context -> expr list -> Ast.module_expr 174 | 175 | method param ctxt (name, variance) = 176 | <:module_expr< $uid:NameMap.find name ctxt.argmap$ >> 177 | 178 | method object_ _ o = raise (Underivable (classname ^ " cannot be derived for object types")) 179 | method class_ _ c = raise (Underivable (classname ^ " cannot be derived for class types")) 180 | method label _ l = raise (Underivable (classname ^ " cannot be derived for label types")) 181 | method function_ _ f = raise (Underivable (classname ^ " cannot be derived for function types")) 182 | 183 | method constr ctxt (qname, args) = 184 | match qname with 185 | | [name] when NameSet.mem name ctxt.tnames -> 186 | <:module_expr< $uid:Printf.sprintf "%s_%s" classname name$ >> 187 | | _ -> 188 | let f = (modname_from_qname ~qname ~classname) in 189 | self#mapply ctxt (Ast.MeId (loc, f)) args 190 | 191 | method expr (ctxt : context) : expr -> Ast.module_expr = function 192 | | `Param p -> self#param ctxt p 193 | | `Object o -> self#object_ ctxt o 194 | | `Class c -> self#class_ ctxt c 195 | | `Label l -> self#label ctxt l 196 | | `Function f -> self#function_ ctxt f 197 | | `Constr c -> self#constr ctxt c 198 | | `Tuple t -> self#tuple ctxt t 199 | 200 | method rhs ctxt (tname, params, rhs, constraints, _ as decl : Type.decl) : Ast.module_expr = 201 | match rhs with 202 | | `Fresh (_, _, (`Private : [`Private|`Public])) when not allow_private -> 203 | raise (Underivable ("The class "^ classname ^" cannot be derived for private types")) 204 | | `Fresh (eq, Sum summands, _) -> self#sum ?eq ctxt decl summands 205 | | `Fresh (eq, Record fields, _) -> self#record ?eq ctxt decl fields 206 | | `Expr e -> self#expr ctxt e 207 | | `Variant v -> self# variant ctxt decl v 208 | | `Nothing -> <:module_expr< >> 209 | end 210 | 211 | let atype_expr ctxt expr = 212 | Untranslate.expr (instantiate_modargs ctxt expr) 213 | 214 | let atype ctxt (name, params, rhs, _, _) = 215 | match rhs with 216 | | `Fresh _ | `Variant _ | `Nothing -> 217 | Untranslate.expr (`Constr ([name], 218 | List.map (fun (p,_) -> `Constr ([NameMap.find p ctxt.argmap; "a"],[])) params)) 219 | | `Expr e -> atype_expr ctxt e 220 | 221 | let make_safe (decls : (decl * Ast.module_binding) list) : Ast.module_binding list = 222 | (* re-order a set of mutually recursive modules in an attempt to 223 | make initialization problems less likely *) 224 | List.map snd 225 | (List.sort 226 | (fun ((_,_,lrhs,_,_), _) ((_,_,rrhs,_,_), _) -> match (lrhs : rhs), rrhs with 227 | (* aliases to types in the group score higher than 228 | everything else. 229 | 230 | In general, things that must come first receive a 231 | positive score when they occur on the left and a 232 | negative score when they occur on the right. *) 233 | | (`Fresh _|`Variant _), (`Fresh _|`Variant _) -> 0 234 | | (`Fresh _|`Variant _), _ -> -1 235 | | _, (`Fresh _|`Variant _) -> 1 236 | | (`Nothing, `Nothing) -> 0 237 | | (`Nothing, _) -> 1 238 | | (_, `Nothing) -> -1 239 | | `Expr l, `Expr r -> 240 | let module M = 241 | struct 242 | type low = 243 | [`Param of param 244 | |`Tuple of expr list] 245 | end in 246 | match l, r with 247 | | #M.low, _ -> 1 248 | | _, #M.low -> -1 249 | | _ -> 0) 250 | decls) 251 | 252 | let generate ~context ~decls ~make_module_expr ~classname ?default_module () = 253 | (* plan: 254 | set up an enclosing recursive module 255 | generate functors for all types in the clique 256 | project out the inner modules afterwards. 257 | 258 | later: generate simpler code for simpler cases: 259 | - where there are no type parameters 260 | - where there's only one type 261 | - where there's no recursion 262 | - etc. 263 | *) 264 | (* let _ = ensure_no_polymorphic_recursion in *) 265 | let wrapper_name = Printf.sprintf "%s_%s" classname (random_id 32) in 266 | let make_functor = 267 | List.fold_right 268 | (fun (p,_) rhs -> 269 | let arg = NameMap.find p context.argmap in 270 | <:module_expr< functor ($arg$ : $uid:classname$.$uid:classname$) -> $rhs$ >>) 271 | context.params in 272 | let apply_defaults mexpr = match default_module with 273 | | None -> mexpr 274 | | Some default -> <:module_expr< $uid:classname$.$uid:default$ ($mexpr$) >> in 275 | let mbinds = 276 | List.map 277 | (fun (name,_,_,_,_ as decl) -> 278 | if name = "a" then 279 | raise (Underivable ("deriving: types called `a' are not allowed.\n" 280 | ^"Please change the name of your type and try again.")) 281 | else 282 | (decl, 283 | <:module_binding< 284 | $uid:classname ^ "_"^ name$ 285 | : $uid:classname$.$uid:classname$ with type a = $atype context decl$ 286 | = $apply_defaults (make_module_expr context decl)$ >>)) 287 | decls in 288 | let sorted_mbinds = make_safe mbinds in 289 | let mrec = 290 | <:str_item< open $uid:classname$ module rec $list:sorted_mbinds$ >> in 291 | match context.params with 292 | | [] -> mrec 293 | | _ -> 294 | let fixed = make_functor <:module_expr< struct $mrec$ end >> in 295 | let applied = apply_functor <:module_expr< $uid:wrapper_name$ >> 296 | (List.map (fun (p,_) -> <:module_expr< $uid:NameMap.find p context.argmap$>>) 297 | context.params) in 298 | let projected = 299 | List.map (fun (name,params,rhs,_,_) -> 300 | let modname = classname ^ "_"^ name in 301 | let rhs = <:module_expr< struct module P = $applied$ include P.$uid:modname$ end >> in 302 | <:str_item< module $uid:modname$ = $make_functor rhs$>>) 303 | decls in 304 | let m = <:str_item< module $uid:wrapper_name$ = $fixed$ >> in 305 | <:str_item< $m$ $list:projected$ >> 306 | 307 | let gen_sig ~classname ~context (tname,params,_,_,generated as decl) = 308 | if tname = "a" then 309 | raise (Underivable ("deriving: types called `a' are not allowed.\n" 310 | ^"Please change the name of your type and try again.")) 311 | else 312 | if generated then <:sig_item< >> 313 | else 314 | let t = List.fold_right 315 | (fun (p,_) m -> <:module_type< functor ($NameMap.find p context.argmap$ : $uid:classname$.$uid:classname$) -> $m$ >>) 316 | params 317 | <:module_type< $uid:classname$.$uid:classname$ with type a = $atype context decl$ >> in 318 | <:sig_item< module $uid:Printf.sprintf "%s_%s" classname tname$ : $t$ >> 319 | 320 | let gen_sigs ~classname ~context ~decls = 321 | <:sig_item< $list:List.map (gen_sig ~classname ~context) decls$ >> 322 | end 323 | 324 | let find_non_regular params tnames decls : name list = 325 | List.concat_map 326 | (object 327 | inherit [name list] fold as default 328 | method crush = List.concat 329 | method expr = function 330 | | `Constr ([t], args) 331 | when NameSet.mem t tnames -> 332 | (List.concat_map2 333 | (fun (p,_) a -> match a with 334 | | `Param (q,_) when p = q -> [] 335 | | _ -> [t]) 336 | params 337 | args) 338 | | e -> default#expr e 339 | end)#decl decls 340 | 341 | let extract_params = 342 | let has_params params (_, ps, _, _, _) = ps = params in 343 | function 344 | | [] -> invalid_arg "extract_params" 345 | | (_,params,_,_,_)::rest 346 | when List.for_all (has_params params) rest -> 347 | params 348 | | (_,_,rhs,_,_)::_ -> 349 | (* all types in a clique must have the same parameters *) 350 | raise (Underivable ("Instances can only be derived for " 351 | ^"recursive groups where all types\n" 352 | ^"in the group have the same parameters.")) 353 | 354 | let setup_context loc (tdecls : decl list) : context = 355 | let params = extract_params tdecls 356 | and tnames = NameSet.fromList (List.map (fun (name,_,_,_,_) -> name) tdecls) in 357 | match find_non_regular params tnames tdecls with 358 | | _::_ as names -> 359 | failwith ("The following types contain non-regular recursion:\n " 360 | ^String.concat ", " names 361 | ^"\nderiving does not support non-regular types") 362 | | [] -> 363 | let argmap = 364 | List.fold_right 365 | (fun (p,_) m -> NameMap.add p (Printf.sprintf "V_%s" p) m) 366 | params 367 | NameMap.empty in 368 | { loc = loc; 369 | argmap = argmap; 370 | params = params; 371 | tnames = tnames } 372 | 373 | type deriver = Loc.t * context * Type.decl list -> Ast.str_item 374 | and sigderiver = Loc.t * context * Type.decl list -> Ast.sig_item 375 | let derivers : (name, (deriver * sigderiver)) Hashtbl.t = Hashtbl.create 15 376 | let register = Hashtbl.add derivers 377 | let find classname = 378 | try Hashtbl.find derivers classname 379 | with Not_found -> raise (NoSuchClass classname) 380 | let is_registered : name -> bool = 381 | fun classname -> try ignore (find classname); true with NoSuchClass _ -> false 382 | -------------------------------------------------------------------------------- /lib/pickle.ml: -------------------------------------------------------------------------------- 1 | (*pp deriving *) 2 | 3 | (* Copyright Jeremy Yallop 2007. 4 | This file is free software, distributed under the MIT license. 5 | See the file COPYING for details. 6 | *) 7 | 8 | (* 9 | Idea: 10 | 1. every object receives a serializable id. 11 | 2. an object is serialized using the ids of its subobjects 12 | *) 13 | module Pickle = 14 | struct 15 | exception UnknownTag of int * string 16 | exception UnpicklingError of string 17 | 18 | module Id : 19 | sig 20 | type t deriving (Show, Dump, Eq) 21 | val initial : t 22 | val compare : t -> t -> int 23 | val next : t -> t 24 | end = 25 | struct 26 | type t = int deriving (Show, Dump, Eq) 27 | let initial = 0 28 | let compare = compare 29 | let next = succ 30 | end 31 | module IdMap = Map.Make (Id) 32 | type id = Id.t deriving (Show, Dump) 33 | 34 | module Repr : sig 35 | (* Break abstraction for the sake of efficiency for now *) 36 | type t = Bytes of string | CApp of (int option * Id.t list) deriving (Dump, Show) 37 | val of_string : string -> t 38 | val to_string : t -> string 39 | val make : ?constructor:int -> id list -> t 40 | val unpack_ctor : t -> int option * id list 41 | end = 42 | struct 43 | type t = Bytes of string | CApp of (int option * Id.t list) deriving (Dump, Show) 44 | let of_string s = Bytes s 45 | let to_string = function 46 | | Bytes s -> s 47 | | _ -> invalid_arg "string_of_repr" 48 | let make ?constructor ids = 49 | match constructor with 50 | | Some n -> CApp (Some n, ids) 51 | | None -> CApp (None, ids) 52 | let unpack_ctor = function 53 | | CApp arg -> arg 54 | | _ -> raise (UnpicklingError "Error unpickling constructor") 55 | end 56 | type repr = Repr.t 57 | 58 | module Write : sig 59 | type s = { 60 | nextid : Id.t; 61 | obj2id : Id.t Dynmap.DynMap.t; 62 | id2rep : repr IdMap.t; 63 | } 64 | val initial_output_state : s 65 | include Monad.Monad_state_type with type state = s 66 | 67 | module Utils (T : Typeable.Typeable) (E : Eq.Eq with type a = T.a) : sig 68 | val allocate : T.a -> (id -> unit m) -> id m 69 | val store_repr : id -> Repr.t -> unit m 70 | end 71 | end = 72 | struct 73 | type s = { 74 | nextid : Id.t; (* the next id to be allocated *) 75 | obj2id : Id.t Dynmap.DynMap.t; (* map from typerep to id cache for the corresponding type *) 76 | id2rep : repr IdMap.t; 77 | } 78 | let initial_output_state = { 79 | nextid = Id.initial; 80 | obj2id = Dynmap.DynMap.empty; 81 | id2rep = IdMap.empty; 82 | } 83 | include Monad.Monad_state (struct type state = s end) 84 | module Utils (T : Typeable.Typeable) (E : Eq.Eq with type a = T.a) = 85 | struct 86 | module C = Dynmap.Comp(T)(E) 87 | let comparator = C.eq 88 | 89 | let allocate o f = 90 | let obj = T.make_dynamic o in 91 | get >>= fun ({nextid=nextid;obj2id=obj2id} as t) -> 92 | match Dynmap.DynMap.find obj obj2id with 93 | | Some id -> return id 94 | | None -> 95 | let id, nextid = nextid, Id.next nextid in 96 | put {t with 97 | obj2id=Dynmap.DynMap.add obj id comparator obj2id; 98 | nextid=nextid} >> 99 | f id >> return id 100 | 101 | let store_repr id repr = 102 | get >>= fun state -> 103 | put {state with id2rep = IdMap.add id repr state.id2rep} 104 | end 105 | end 106 | 107 | module Read : sig 108 | type s = (repr * (Typeable.dynamic option)) IdMap.t 109 | include Monad.Monad_state_type with type state = s 110 | val find_by_id : id -> (Repr.t * Typeable.dynamic option) m 111 | module Utils (T : Typeable.Typeable) : sig 112 | val sum : (int * id list -> T.a m) -> id -> T.a m 113 | val tuple : (id list -> T.a m) -> id -> T.a m 114 | val record : (T.a -> id list -> T.a m) -> int -> id -> T.a m 115 | val update_map : id -> (T.a -> unit m) 116 | end 117 | end = 118 | struct 119 | type s = (repr * (Typeable.dynamic option)) IdMap.t 120 | include Monad.Monad_state (struct type state = s end) 121 | 122 | let find_by_id id = 123 | get >>= fun state -> 124 | return (IdMap.find id state) 125 | 126 | module Utils (T : Typeable.Typeable) = struct 127 | let decode_repr_ctor c = match Repr.unpack_ctor c with 128 | | (Some c, ids) -> (c, ids) 129 | | _ -> invalid_arg "decode_repr_ctor" 130 | 131 | let decode_repr_noctor c = match Repr.unpack_ctor c with 132 | | (None, ids) -> ids 133 | | _ -> invalid_arg "decode_repr_ctor" 134 | 135 | let update_map id obj = 136 | let dynamic = T.make_dynamic obj in 137 | get >>= fun state -> 138 | match IdMap.find id state with 139 | | (repr, None) -> 140 | put (IdMap.add id (repr, Some dynamic) state) 141 | | (_, Some _) -> 142 | return () 143 | (* Checking for id already present causes unpickling to fail 144 | when there is circularity involving immutable values (even 145 | if the recursion wholly depends on mutability). 146 | 147 | For example, consider the code 148 | 149 | type t = A | B of t ref deriving (Typeable, Eq, Pickle) 150 | let s = ref A in 151 | let r = B s in 152 | s := r; 153 | let pickled = Pickle_t.pickleS r in 154 | Pickle_t.unpickleS r 155 | 156 | which results in the value 157 | B {contents = B {contents = B { ... }}} 158 | 159 | During deserialization the following steps occur: 160 | 1. lookup "B {...}" in the dictionary (not there) 161 | 2. unpickle the contents of B: 162 | 3. lookup the contents in the dictionary (not there) 163 | 4. create a blank reference, insert it into the dictionary 164 | 5. unpickle the contents of the reference: 165 | 6. lookup ("B {...}") in the dictionary (not there) 166 | 7. unpickle the contents of B: 167 | 8. lookup the contents in the dictionary (there) 168 | 9. insert "B{...}" into the dictionary. 169 | 10. insert "B{...}" into the dictionary. 170 | *) 171 | 172 | 173 | let whizzy f id decode = 174 | find_by_id id >>= fun (repr, dynopt) -> 175 | match dynopt with 176 | | None -> 177 | f (decode repr) >>= fun obj -> 178 | update_map id obj >> 179 | return obj 180 | | Some obj -> return (T.throwing_cast obj) 181 | 182 | let sum f id = whizzy f id decode_repr_ctor 183 | let tuple f id = whizzy f id decode_repr_noctor 184 | let record_tag = 0 185 | let record f size id = 186 | find_by_id id >>= fun (repr, obj) -> 187 | match obj with 188 | | None -> 189 | let this = Obj.magic (Obj.new_block record_tag size) in 190 | update_map id this >> 191 | f this (decode_repr_noctor repr) >> 192 | return this 193 | | Some obj -> return (T.throwing_cast obj) 194 | 195 | 196 | end 197 | end 198 | 199 | 200 | module type Pickle = 201 | sig 202 | type a 203 | module T : Typeable.Typeable with type a = a 204 | module E : Eq.Eq with type a = a 205 | val pickle : a -> id Write.m 206 | val unpickle : id -> a Read.m 207 | val to_buffer : Buffer.t -> a -> unit 208 | val to_string : a -> string 209 | val to_channel : out_channel -> a -> unit 210 | val from_stream : char Stream.t -> a 211 | val from_string : string -> a 212 | val from_channel : in_channel -> a 213 | end 214 | 215 | module Defaults 216 | (S : sig 217 | type a 218 | module T : Typeable.Typeable with type a = a 219 | module E : Eq.Eq with type a = a 220 | val pickle : a -> id Write.m 221 | val unpickle : id -> a Read.m 222 | end) : Pickle with type a = S.a = 223 | struct 224 | include S 225 | 226 | type ids = (Id.t * Repr.t) list 227 | deriving (Dump, Show) 228 | 229 | type dumpable = id * ids 230 | deriving (Show, Dump) 231 | 232 | type ('a,'b) pair = 'a * 'b deriving (Dump) 233 | type capp = int option * Id.t list deriving (Dump) 234 | 235 | (* We don't serialize ids of each object at all: we just use the 236 | ordering in the output file to implicitly record the ids of 237 | objects. 238 | 239 | Also, we don't serialize the repr constructors. All values with 240 | a particular constructor are grouped in a single list. 241 | 242 | This can (and should) all be written much more efficiently. 243 | *) 244 | type discriminated = 245 | (Id.t * string) list 246 | * (Id.t * (int * Id.t list)) list 247 | * (Id.t * (Id.t list)) list 248 | deriving (Dump, Show) 249 | 250 | type discriminated_ordered = 251 | string list 252 | * (int * Id.t list) list 253 | * (Id.t list) list 254 | deriving (Dump, Show) 255 | 256 | let reorder : Id.t * discriminated -> Id.t * discriminated_ordered = 257 | fun (root,(a,b,c)) -> 258 | let collect_ids items (map,counter) = 259 | List.fold_left 260 | (fun (map,counter) (id,_) -> 261 | IdMap.add id counter map, Id.next counter) 262 | (map,counter) items in 263 | 264 | let map, _ = 265 | collect_ids c 266 | (collect_ids b 267 | (collect_ids a 268 | (IdMap.empty, Id.initial))) in 269 | let lookup id = IdMap.find id map in 270 | (lookup root, 271 | (List.map snd a, 272 | List.map (fun (_,(c,l)) -> c, List.map lookup l) b, 273 | List.map (fun (_,l) -> List.map lookup l) c)) 274 | 275 | let unorder : Id.t * discriminated_ordered -> Id.t * discriminated 276 | = fun (root,(a,b,c)) -> 277 | let number_sequentially id items = 278 | List.fold_left 279 | (fun (id,items) item -> 280 | (Id.next id, (id,item)::items)) 281 | (id,[]) items in 282 | let id = Id.initial in 283 | let id, a = number_sequentially id a in 284 | let id, b = number_sequentially id b in 285 | let _, c = number_sequentially id c in 286 | (root, (a,b,c)) 287 | 288 | type ('a,'b) either = Left of 'a | Right of 'b 289 | let either_partition (f : 'a -> ('b, 'c) either) (l : 'a list) 290 | : 'b list * 'c list = 291 | let rec aux (lefts, rights) = function 292 | | [] -> (List.rev lefts, List.rev rights) 293 | | x::xs -> 294 | match f x with 295 | | Left l -> aux (l :: lefts, rights) xs 296 | | Right r -> aux (lefts, r :: rights) xs 297 | in aux ([], []) l 298 | 299 | type discriminated_dumpable = Id.t * discriminated deriving (Dump) 300 | 301 | let discriminate : (Id.t * Repr.t) list -> discriminated 302 | = fun input -> 303 | let bytes, others = 304 | either_partition 305 | (function 306 | | id, (Repr.Bytes s) -> Left (id,s) 307 | | id, (Repr.CApp c) -> Right (id,c)) 308 | input in 309 | let ctors, no_ctors = 310 | either_partition 311 | (function 312 | | id, (Some c, ps) -> Left (id, (c,ps)) 313 | | id, (None, ps) -> Right (id,ps)) 314 | others in 315 | (bytes, ctors, no_ctors) 316 | 317 | let undiscriminate : discriminated -> (Id.t * Repr.t) list 318 | = fun (a,b,c) -> 319 | List.map (fun (id,s) -> (id,Repr.Bytes s)) a 320 | @ List.map (fun (id,(c,ps)) -> (id,Repr.CApp (Some c,ps))) b 321 | @ List.map (fun (id,(ps)) -> (id,Repr.CApp (None,ps))) c 322 | 323 | type do_pair = Id.t * discriminated_ordered 324 | deriving (Show, Dump) 325 | 326 | let write_discriminated f 327 | = fun (root,map) -> 328 | let dmap = discriminate map in 329 | let rmap = reorder (root,dmap) in 330 | f rmap 331 | 332 | let read_discriminated (f : 'b -> 'a) : 'b -> Id.t * (Id.t * Repr.t) list 333 | = fun s -> 334 | let rmap = f s in 335 | let (root,dmap) = unorder rmap in 336 | (root, undiscriminate dmap) 337 | 338 | open Write 339 | 340 | let decode_pickled_string (f : 'a -> Id.t * discriminated_ordered) : 'b -> Id.t * Read.s = 341 | fun s -> 342 | let (id, state : dumpable) = 343 | read_discriminated f s 344 | in 345 | id, (List.fold_right 346 | (fun (id,repr) map -> IdMap.add id (repr,None) map) 347 | state 348 | IdMap.empty) 349 | 350 | let encode_pickled_string f = 351 | fun (id,state) -> 352 | let input_state = 353 | id, IdMap.fold (fun id repr output -> (id,repr)::output) 354 | state.id2rep [] in 355 | write_discriminated f input_state 356 | 357 | let doPickle f v : 'a = 358 | let id, state = runState (S.pickle v) initial_output_state in 359 | encode_pickled_string f (id, state) 360 | 361 | let doUnpickle f input = 362 | let id, initial_input_state = decode_pickled_string f input in 363 | let value, _ = Read.runState (S.unpickle id) initial_input_state in 364 | value 365 | 366 | let from_channel = doUnpickle Dump.from_channel 367 | let from_string = doUnpickle Dump.from_string 368 | let from_stream = doUnpickle Dump.from_stream 369 | let to_channel channel = doPickle (Dump.to_channel channel) 370 | let to_buffer buffer = doPickle (Dump.to_buffer buffer) 371 | let to_string = doPickle Dump.to_string 372 | end 373 | 374 | module Pickle_from_dump 375 | (P : Dump.Dump) 376 | (E : Eq.Eq with type a = P.a) 377 | (T : Typeable.Typeable with type a = P.a) 378 | : Pickle with type a = P.a 379 | and type a = T.a = Defaults 380 | (struct 381 | type a = T.a 382 | module T = T 383 | module E = E 384 | module Comp = Dynmap.Comp(T)(E) 385 | open Write 386 | module W = Utils(T)(E) 387 | let pickle obj = 388 | W.allocate obj 389 | (fun id -> W.store_repr id (Repr.of_string (P.to_string obj))) 390 | open Read 391 | module U = Utils(T) 392 | let unpickle id = 393 | find_by_id id >>= fun (repr, dynopt) -> 394 | match dynopt with 395 | | None -> 396 | let obj : a = P.from_string (Repr.to_string repr) in 397 | U.update_map id obj >> 398 | return obj 399 | | Some obj -> return (T.throwing_cast obj) 400 | end) 401 | 402 | module Pickle_unit : Pickle with type a = unit = Pickle_from_dump(Dump.Dump_unit)(Eq.Eq_unit)(Typeable.Typeable_unit) 403 | module Pickle_bool = Pickle_from_dump(Dump.Dump_bool)(Eq.Eq_bool)(Typeable.Typeable_bool) 404 | module Pickle_int = Pickle_from_dump(Dump.Dump_int)(Eq.Eq_int)(Typeable.Typeable_int) 405 | module Pickle_char = Pickle_from_dump(Dump.Dump_char)(Eq.Eq_char)(Typeable.Typeable_char) 406 | module Pickle_float = Pickle_from_dump(Dump.Dump_float)(Eq.Eq_float)(Typeable.Typeable_float) 407 | module Pickle_num = Pickle_from_dump(Dump.Dump_num)(Eq.Eq_num)(Typeable.Typeable_num) 408 | module Pickle_string = Pickle_from_dump(Dump.Dump_string)(Eq.Eq_string)(Typeable.Typeable_string) 409 | 410 | module Pickle_option (V0 : Pickle) : Pickle with type a = V0.a option = Defaults( 411 | struct 412 | module T = Typeable.Typeable_option (V0.T) 413 | module E = Eq.Eq_option (V0.E) 414 | module Comp = Dynmap.Comp (T) (E) 415 | open Write 416 | type a = V0.a option 417 | let rec pickle = 418 | let module W = Utils(T)(E) in 419 | function 420 | None as obj -> 421 | W.allocate obj 422 | (fun id -> W.store_repr id (Repr.make ~constructor:0 [])) 423 | | Some v0 as obj -> 424 | W.allocate obj 425 | (fun thisid -> 426 | V0.pickle v0 >>= fun id0 -> 427 | W.store_repr thisid (Repr.make ~constructor:1 [id0])) 428 | open Read 429 | let unpickle = 430 | let module W = Utils(T) in 431 | let f = function 432 | | 0, [] -> return None 433 | | 1, [id] -> V0.unpickle id >>= fun obj -> return (Some obj) 434 | | n, _ -> raise (UnpicklingError 435 | ("Unexpected tag encountered unpickling " 436 | ^"option : " ^ string_of_int n)) in 437 | W.sum f 438 | end) 439 | 440 | 441 | module Pickle_list (V0 : Pickle) 442 | : Pickle with type a = V0.a list = Defaults ( 443 | struct 444 | module T = Typeable.Typeable_list (V0.T) 445 | module E = Eq.Eq_list (V0.E) 446 | module Comp = Dynmap.Comp (T) (E) 447 | type a = V0.a list 448 | open Write 449 | module U = Utils(T)(E) 450 | let rec pickle = function 451 | [] as obj -> 452 | U.allocate obj 453 | (fun this -> U.store_repr this (Repr.make ~constructor:0 [])) 454 | | (v0::v1) as obj -> 455 | U.allocate obj 456 | (fun this -> V0.pickle v0 >>= fun id0 -> 457 | pickle v1 >>= fun id1 -> 458 | U.store_repr this (Repr.make ~constructor:1 [id0; id1])) 459 | open Read 460 | module W = Utils (T) 461 | let rec unpickle id = 462 | let f = function 463 | | 0, [] -> return [] 464 | | 1, [car;cdr] -> 465 | V0.unpickle car >>= fun car -> 466 | unpickle cdr >>= fun cdr -> 467 | return (car :: cdr) 468 | | n, _ -> raise (UnpicklingError 469 | ("Unexpected tag encountered unpickling " 470 | ^"option : " ^ string_of_int n)) in 471 | W.sum f id 472 | end) 473 | end 474 | include Pickle 475 | 476 | type 'a ref = 'a Pervasives.ref = { mutable contents : 'a } 477 | deriving (Pickle) 478 | 479 | (* Idea: keep pointers to values that we've serialized in a global 480 | weak hash table so that we can share structure with them if we 481 | deserialize any equal values in the same process *) 482 | 483 | (* Idea: serialize small objects (bools, chars) in place rather than 484 | using the extra level of indirection (and space) introduced by ids 485 | *) 486 | 487 | (* Idea: bitwise output instead of bytewise. Probably a bit much to 488 | implement now, but should have a significant impact (e.g. one using 489 | bit instead of one byte for two-constructor sums) *) 490 | 491 | (* Should we use a different representation for lists? i.e. write out 492 | the length followed by the elements? we could no longer claim 493 | sharing maximization, but it would actually be more efficient in 494 | most cases. 495 | *) 496 | --------------------------------------------------------------------------------