pax_global_header00006660000000000000000000000064127213540500014511gustar00rootroot0000000000000052 comment=7e4f973411cceaf2d2a8db8dc5fcec14531ed8db deriving-0.7.1/000077500000000000000000000000001272135405000133255ustar00rootroot00000000000000deriving-0.7.1/.gitignore000066400000000000000000000001751272135405000153200ustar00rootroot00000000000000._* *~ #* *# _build setup.log setup.data *.native *.byte syntax/common/id.ml *.bak *.ba0 setup.exe *.mllib *.mlpack lib/META deriving-0.7.1/.jenkins.sh000066400000000000000000000005011272135405000153740ustar00rootroot00000000000000 opam pin add --no-action deriving . opam install type_conv opam install --deps-only deriving opam install --verbose deriving do_build_doc () { make wikidoc cp -Rf doc/manual-wiki/*.wiki ${MANUAL_SRC_DIR} cp -Rf _build/deriving-api.wikidocdir/*.wiki ${API_DIR} } do_remove () { opam remove --verbose deriving } deriving-0.7.1/CHANGES000066400000000000000000000031361272135405000143230ustar00rootroot00000000000000== 0.7.1 * Compatibility with OCaml 4.03 == 0.7 * Compatibility with ocaml-4.02 (Peter Zotoz, Hugo Heuzard) * Fix toplevel usage (Vincent Bernardoff) * Class: add equality for sets (Jeremy Yallop) == 0.6 * Added a 'Default' class (Hugo Heuzard) * Allow private variant in the 'Functor' class (Pierre Chambart) * Switch build system to oasis and improved META == 0.5-ocsigen * Experimental minimalistic support of GADT * Allows to register predefined instances == 0.4-ocsigen * Compatibility with typeconv >= 108.07.00 == 0.3-ocsigen * Use "lazy first-order module" instead of "recursive module" to be compatible with {{{js_of_ocaml}}}. * Be less restrictive with mutually recursive type definition * Split runtime into deriving.cma and deriving_num.cma * Class: ** Typeable: use OCaml's lazy for {{{type_rep}}} ** Show: added separators to {{{map}}} and {{{set}}} ** Show, Dump and Eq: Allow polymorphic type fields. == 0.2-ocsigen * Add compatibility with ocamlfind * Add a type-conv compatibility mode * Simplify the definition of new class * Syntax: Add {{{Class}}} in module_expr. * Small bug fixes in class: ** Show: Added parentheses around tuples. ** Pickle: remove warning in generated code. == 0.1.1 * Renamed serialisation classes: ** Pickle -> Dump ** Shelve -> Pickle * Made Dump and Pickle interface compatible with each other and more compatible with Marshal. * Bugfix in the tag hash function on 64-bit platforms. * Fixed a bug with a functor application quotation that used revised syntax. == 0.1 * Initial release deriving-0.7.1/COPYING000066400000000000000000000020621272135405000143600ustar00rootroot00000000000000The MIT License Copyright (c) 2007 Jeremy Yallop Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. deriving-0.7.1/Makefile000066400000000000000000000021701272135405000147650ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 9a60866e2fa295c5e33a3fe33b8f3a32) SETUP = ./setup.exe build: setup.data $(SETUP) $(SETUP) -build $(BUILDFLAGS) doc: setup.data $(SETUP) build $(SETUP) -doc $(DOCFLAGS) test: setup.data $(SETUP) build $(SETUP) -test $(TESTFLAGS) all: $(SETUP) $(SETUP) -all $(ALLFLAGS) install: setup.data $(SETUP) $(SETUP) -install $(INSTALLFLAGS) uninstall: setup.data $(SETUP) $(SETUP) -uninstall $(UNINSTALLFLAGS) reinstall: setup.data $(SETUP) $(SETUP) -reinstall $(REINSTALLFLAGS) clean: $(SETUP) $(SETUP) -clean $(CLEANFLAGS) distclean: $(SETUP) $(SETUP) -distclean $(DISTCLEANFLAGS) $(RM) $(SETUP) setup.data: $(SETUP) $(SETUP) -configure $(CONFIGUREFLAGS) configure: $(SETUP) $(SETUP) -configure $(CONFIGUREFLAGS) setup.exe: setup.ml ocamlfind ocamlopt -o $@ -linkpkg -package oasis.dynrun $< || ocamlfind ocamlc -o $@ -linkpkg -package oasis.dynrun $< || true $(RM) setup.cmi setup.cmo setup.cmx setup.o .PHONY: build doc test all install uninstall reinstall clean distclean configure # OASIS_STOP wikidoc: $(SETUP) setup.data build $(SETUP) -build deriving-api.wikidocdir/index.wiki deriving-0.7.1/Makefile.dist000066400000000000000000000017371272135405000157370ustar00rootroot00000000000000 ## ## Usage: ## ## If the released version is tagged in the main repository, use: ## ## make -f Makefile.dist ## ## If the tag has not been pushed, use: ## ## make -f Makefile.dist REPO=${PWD} ## ## otherwise, use: ## ## make -f Makefile.dist REPO=${PWD} VERSION=master ## VERSION?=$(shell grep Version: _oasis | cut -d ' ' -f 2) REPO?=https://github.com/ocsigen/deriving all: dist sign dist: @rm -rf deriving-${VERSION} \ deriving-${VERSION}.tar.gz \ deriving-${VERSION}.tar.gz.asc git clone --local -b ${VERSION} ${REPO} deriving-${VERSION} oasis -C deriving-${VERSION} setup sed -i "s/SETUP := setup-dev.exe/SETUP := setup.exe/" \ deriving-${VERSION}/Makefile cd deriving-${VERSION} && rm -rf .git .gitignore Makefile.dist opam tar cvzf deriving-${VERSION}.tar.gz deriving-${VERSION} @rm -rf deriving-${VERSION} sign: deriving-${VERSION}.tar.gz.asc deriving-${VERSION}.tar.gz.asc: deriving-${VERSION}.tar.gz gpg --armor -b $^ .PHONY: dist sign deriving-0.7.1/README.md000066400000000000000000000027711272135405000146130ustar00rootroot00000000000000Deriving (was Deriving-ocsigen) =============================== This release of deriving is based on the library by Jeremy Yallop. See: * http://code.google.com/p/deriving/ Compared to the original library, it adds: * META file for ocamlfind compatibility * a type-conv compatibility mode * the generated code do not rely on recursive modules (this allows compatibility with js_of_ocaml) * minimalistic support of GADT See CHANGES for more details. Requirements: ------------- * ocaml and camlp4 (>= 3.12) * optcomp * type-conv (optionnal) Build intructions: ------------------ ``` $ ./configure [--disable-tc] $ make # make install ``` Documention and examples of the original library: ------------------------------------------------- * http://code.google.com/p/deriving/wiki/Introduction * http://code.google.com/p/deriving/wiki/Classes Examples: --------- ``` $ ocaml Objective Caml version 4.01.0 # #use "topfind";; - : unit = () # #camlp4o;; Camlp4 Parsing version 4.01.0 # #require "deriving";; # type t = A of int | B of t deriving (Show);; type t = A of int | B of t module rec Show_t : sig ... end # Show.show (B (A 4));; - : string = "B A 4" ``` Examples with type-conv: ------------------------ ``` $ ocaml Objective Caml version 4.01.0@ # #use "topfind";; - : unit = () # #camlp4o;; Camlp4 Parsing version 4.01.0 # #require "deriving.tc";; # type t = A of int | B of t with show;; type t = A of int | B of t module rec Show_t : sig ... end ``` deriving-0.7.1/_oasis000066400000000000000000000054321272135405000145310ustar00rootroot00000000000000OASISFormat: 0.4 Name: deriving OCamlVersion: >= 3.12.1 Version: 0.7.1 Synopsis: Extension to OCaml for deriving functions from type declarations Authors: Jeremy Yallop License: MIT BuildTools: ocamlbuild FilesAB: syntax/common/id.ml.ab, lib/META.ab Plugins: DevFiles (0.4) AlphaFeatures: compiled_setup_ml Flag tc Description: type-conv support Default: false Library "deriving" Path : lib FindlibName : deriving Modules : Deriving_Show, Deriving_Eq, Deriving_Bounded, Deriving_Enum, Deriving_monad, Deriving_Dump, Deriving_Typeable, Deriving_Pickle, Deriving_Functor, Deriving_Default InternalModules : Deriving_interned, Deriving_dynmap BuildDepends : deriving.syntax Library "deriving_num" Path : lib FindlibParent : deriving FindlibName : num Modules : Deriving_num BuildDepends : deriving Library "pa_deriving_classes" Path : syntax/classes FindlibParent : deriving FindlibName : syntax Modules : Show_class, Dump_class, Enum_class, Bounded_class, Eq_class, Typeable_class, Pickle_class, Functor_class, Default_class BuildDepends : deriving.syntax.std Library "pa_deriving_common" Path : syntax/common FindlibParent : pa_deriving_classes FindlibName : common Pack : true Modules : Id, Utils, Type, Defs, Clusters, Base, Extend BuildDepends : camlp4,camlp4.extend,camlp4.quotations.o,optcomp,bytes Library "pa_deriving_std" Path : syntax/std FindlibParent : pa_deriving_classes FindlibName : std Modules : Pa_deriving_std BuildDepends : deriving.syntax.common,optcomp,camlp4.quotations.o Library "pa_deriving_tc" Path : syntax/tc FindlibParent : pa_deriving_classes FindlibName : tc Modules : Pa_deriving_tc BuildDepends : deriving.syntax.common,type_conv Build$: flag(tc) Install$: flag(tc) Document "deriving-api" Title: API reference for Deriving Type: ocamlbuild (0.3) Install: true InstallDir: $htmldir/api BuildTools: ocamldoc XOCamlbuildPath: ./ XOCamlbuildLibraries: deriving, deriving.num, deriving.syntax, deriving.syntax.common Executable test Path : tests/std CompiledObject : best MainIs : notc.ml BuildDepends : deriving,optcomp Install : false Build$: flag(tests) Executable test_tc Path : tests/tc Install : false CompiledObject : best MainIs : tc.ml BuildDepends : deriving,type_conv Build$: flag(tests) && flag(tc) Test std TestTools : test Command : $test Run$: flag(tests) Test tc TestTools : test_tc Command : $test_tc Run$: flag(tests) && flag(tc) deriving-0.7.1/_tags000066400000000000000000000005511272135405000143460ustar00rootroot00000000000000# OASIS_START # OASIS_STOP <**/*.ml{,i}>:syntax(camlp4o) :-package(camlp4.quotations.o) :package(camlp4.quotations.r) :-use_pa_deriving_std :use_pa_deriving_tc ## BUG in oasis: not generated when using 'oasis setup' "syntax/common/id.cmx": for-pack(Pa_deriving_common) deriving-0.7.1/configure000077500000000000000000000005571272135405000152430ustar00rootroot00000000000000#!/bin/sh # OASIS_START # DO NOT EDIT (digest: 6f7b8221311e800a7093dc3b793f67ca) set -e FST=true for i in "$@"; do if $FST; then set -- FST=false fi case $i in --*=*) ARG=${i%%=*} VAL=${i##*=} set -- "$@" "$ARG" "$VAL" ;; *) set -- "$@" "$i" ;; esac done make configure CONFIGUREFLAGS="$*" # OASIS_STOP deriving-0.7.1/doc/000077500000000000000000000000001272135405000140725ustar00rootroot00000000000000deriving-0.7.1/doc/apiref-intro000066400000000000000000000007371272135405000164230ustar00rootroot00000000000000{1 Deriving - API Reference} {2 Runtime library} Runtime for deriving classes shipped with deriving. {!modules: Deriving_Show Deriving_Eq Deriving_Bounded Deriving_Enum Deriving_monad Deriving_Dump Deriving_Typeable Deriving_Pickle Deriving_Functor Deriving_Default } {!modules: Deriving_num } {2 Syntax} The {e deriving.syntax.common} package contains modules needed to write deriving classes. {!modules: Id Utils Type Defs Clusters Base Extend } {2 Index} {!indexlist} deriving-0.7.1/doc/manual-wiki/000077500000000000000000000000001272135405000163105ustar00rootroot00000000000000deriving-0.7.1/doc/manual-wiki/classes.wiki000066400000000000000000000117561272135405000206440ustar00rootroot00000000000000= Standard classes = == Show == < a -> unit val format_list : Format.formatter -> a list -> unit val show : a -> string val show_list : a list -> string end >> If you're writing your own instance then you'll find the Defaults useful. The only method you have to write yourself is format: < a -> unit end) : Show with type a = S.a >> == Eq == < a -> bool end >> == Typeable == < t -> int val eq : t -> t -> bool ... end >> The exception CastFailure is thrown when throwing_cast fails: <> < TypeRep.t val has_type : dynamic -> bool val cast : dynamic -> a option val throwing_cast : dynamic -> a val make_dynamic : a -> dynamic val mk : a -> dynamic end >> If you're writing your own instance (which is not recommended in this case!) you can just supply the type_rep method and use the Defaults functor: < TypeRep.t end)) : Typeable with type a = T.a >> == Dump == < a -> unit val to_string : a -> string val to_channel : out_channel -> a -> unit val from_stream : char Stream.t -> a val from_string : string -> a val from_channel : in_channel -> a end >> If the input doesn't match the type then deserialisation will fail with the exception: <> If you're writing your own instance then you use the Defaults functor, which requires implementations of the methods to_buffer and from_stream. < a -> unit val from_stream : char Stream.t -> a end) : Dump with type a = P.a >> == Pickle == < id Write.m val unpickle : id -> a Read.m val to_buffer : Buffer.t -> a -> unit val to_string : a -> string val to_channel : out_channel -> a -> unit val from_stream : char Stream.t -> a val from_string : string -> a val from_channel : in_channel -> a end >> If deserialisation (unmarshalling) fails then one of the following exceptions is thrown: <> As usual, you can use the Defaults method when writing your own instance: < id Write.m val unpickle : id -> a Read.m end) : Pickle with type a = S.a >> You can also create a Pickle instance from a Dump instance, although you may limit the opportunities for sharing if you do: <> == Enum == < a val pred : a -> a val to_enum : int -> a val from_enum : a -> int val enum_from : a -> a list val enum_from_then : a -> a -> a list val enum_from_to : a -> a -> a list val enum_from_then_to : a -> a -> a -> a list end >> There are two easy ways to write your own instance of Enum: you can supply an explicit mapping from values of your type to integers: <> or you can supply the mapping as a pair of functions, together with suitable bounds for your type: < int val to_enum : int -> a end) (B : Bounded.Bounded with type a = E.a) : Enum with type a = B.a >> == Bounded == <> == Functor == There is no signature for Functor, since the type of the derived function depends on the number of type parameters. For example, a type with one parameter will result in a singature < 'b) -> 'a f -> 'b f end >> whereas a type with three parameters will generate an instance with signature < 'd) -> ('b -> 'e) -> ('c -> 'f) -> ('a,'b,'c) f -> ('d,'e,'f) f end >> deriving-0.7.1/doc/manual-wiki/intro.wiki000066400000000000000000000221051272135405000203300ustar00rootroot00000000000000= deriving examples = == Pretty printing == The deriving preprocessor and library provide common functionality which has an obvious definition at most types. For example, it's usually easy, although tedious, to write a to_string function for a new type you've defined; deriving will save you the trouble by writing the function for you automatically. To call a deriving function at a particular type you use a special notation: < argument >> (Note that the terms "Class" and "method" are taken from Haskell's type classes, and has nothing to do with OCaml's object-oriented class system.) For example, to call the show method of the Show class to convert an integer to a string you would write: < 3 => "3" >> You can also specify more complex types: < factors => "[(10,[2; 5]); (11, []); 12, [2; 3; 4; 6]]" >> To use a deriving function at a type you've defined, you need to add the phrase deriving (Class) to the end of your type definition. For example, < points => "Branch (Leaf {x =193.11; y =132.13}, {x =211.91; y =201.11}, Branch (Leaf {x =113.12; y =1.}, {x =12.7; y =44.1}, Leaf {x =0.; y =13.41}))" >> If you want to show values of an abstract type defined in a module outside the module you should add the deriving annotation to the signature as well: < t -> t val top : t -> int val pop : t -> t end = struct type t = Stack of int list deriving (Show) let empty = Stack [] let push item (Stack list) = Stack (item::list) let top (Stack (top::_)) = top let pop (Stack (_::rest)) = Stack rest end Show.show (IntStack.push 3 (IntStack.push 4 (IntStack.push 5 IntStack.empty))) => "Stack [3; 4; 5]" >> You can derive Show for most types, including recursive (and mutually recursive) types, normal and polymorphic variants, records, tuples and types containing other types for which Show has been derived. You can't derive Show for functions because there's usually no meaningful way to display them. If you have a way to display values of a type for which Show cannot be derived then you can always write your own definition and make it available to deriving; see the section "Extending definitions". == Dynamic typing == The `Typeable' class provides operations for converting between a universal type `dynamic' and any other type. Converting from dynamic to another type succeeds only if the type specified in the conversion matches the type used to create the dynamic value. The upcast operation is called mk (or make_dynamic if you prefer to be verbose). The downcasts are cast, which returns an option value, and throwing_cast, which throws an exception if the downcast fails. < 3; Typeable.mk 3.0; Typeable.mk (Leaf "three")] => [; ; ] Typeable.cast (List.hd items) => Some 3 Typeable.throwing_cast (List.hd items) => 3 Typeable.cast (List.hd items) => None Typeable.throwing_cast (List.hd items) => Exception: Typeable.CastFailure "cast failed". >> Casts also work between equivalent polymorphic variant types (even if the types used for the upcast and downcast are defined differently): < (Typeable.mk l) => Some (`Cons (3, `Cons (2, `Cons (1, `Nil)))) >> Casts don't work between record or normal variant types which are defined separately, even if the definitions are identical. < (Typeable.mk {x : -1.0; y : 0.0}) => None >> However, abstraction using module signatures does not change whether types are interconvertible, so you can use Typeable to access the representation of an abstract type if you know it. < (Typeable.mk T.v) => 12 >> == Equality == There are two polymorphic equality operators in OCaml: {{{=}}} tests for structural equality. {{{==}}} tests for physical equality. Sometimes neither of these is appropriate. Instead, we want to test for structural equality at immutable types and physical equality (identity) at mutable types (as in SML). This sort of equality tests whether two values can be used interchangeably in a program. < (ref 1) (ref 1) => false let x = ref 1 in Eq.eq x x => true Eq.eq [1;2;3] [1;2;3] => true type mpoint = { mutable x : float; mutable y : float} deriving (Eq) Eq.eq {x = 1.0; y = 2.0} {x = 1.0; y = 2.0} => false let p = {x = 1.0; y = 2.0} in Eq.eq p p => true type ipoint = { x : float; y : float} deriving (Eq) Eq.eq {x = 1.0; y = 2.0} {x = 1.0; y = 2.0} => true >> == Serialisation == The `Pickle' class provides operations for structure-sharing serialisation (marshalling). If any value to be serialised contains two equal subvalues then only one copy of the subvalue will be serialised. Cycles that are created by mutable record fields, including references, are preserved. All "instances" of Pickle must also be "instances" of Eq and Typeable. (As in Haskell, we use "instance" to mean a set of functions that implement the methods of a class at a particular type.) < points => "\007\003\t\128\128\128\128\128\128\128\248?\t\128\128\128\128\128\128\128\128@\001\000\005\000\001\008\000\001\n\001\003\004\t\003\000\001\012\001\003\006\011\005\005\002\002\000\002\000\002\002\000\000\002\001\001\002\002\002" Pickle.from_string (Pickle.to_string points) => Branch (Leaf {x =193.11; y =132.13}, {x =211.91; y =201.11}, Branch (Leaf {x =113.12; y =1.}, {x =12.7; y =44.1}, Leaf {x =0.; y =13.41})) >> You can supply a custom definition of equality (see the section "Extending definitions") to increase sharing: see the file tests/exp.ml in the distribution for an example. There is another class, `Dump', that provides simpler value-oriented serialisation, but doesn't deal with references or cycles. == Map == Given a type ('a1,...,'an) t, the `Functor' class will derive a map operation: <'b1) -> ... ('an->'bn} -> ('a1,...,'an) t -> ('b1,...,'bn) t >> For example, < (Branch (Leaf 4, 5, Leaf 6)) >> The notation is not currently available for Functor. == Enumerations == Enumerations provide several operations for dealing with variant types where all constructors have no argument. < 0 10 => [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10] type fruit = Apple | Orange | Banana | Kiwi deriving (Enum) Enum.enum_from_to Apple Kiwi => [Apple; Orange; Banana; Kiwi] Enum.succ Orange => Banana >> == Minimum and maximum values == Instances of bounded have maximum and minimum values: <, Bounded.max_bound) => ((-1073741824, Apple), (1073741823, Kiwi)) >> == Extending definitions == Instead of deriving a definition automatically you can provide your own by writing a module with the same signature as the standard definitions with a name formed from the class name, an underscore, and the name of the type constructor for which you want to provide the definition. < true | _ -> false end) Eq.eq [Apple; Orange; Banana] [Orange; Orange; Banana] => true >> deriving-0.7.1/lib/000077500000000000000000000000001272135405000140735ustar00rootroot00000000000000deriving-0.7.1/lib/META.ab000066400000000000000000000054201272135405000151260ustar00rootroot00000000000000version = "$(pkg_version)" description = "Deriving" requires = "$(pkg_name).runtime, $(pkg_name).syntax" archive(syntax, preprocessor) = "-ignore dummy" error(pkg_type_conv, pkg_deriving) = "Could not be loaded together with 'type_conv'. Please use $(pkg_name).tc instead." package "runtime" ( archive(byte) = "deriving.cma" archive(native) = "deriving.cmxa" archive(byte, pkg_num) += "deriving_num.cma" archive(native, pkg_num) += "deriving_num.cmxa" requires = "bytes" ) package "syntax" ( requires(syntax, preprocessor) = "$(pkg_name).syntax.std, $(pkg_name).syntax.classes" requires(toploop) = "$(pkg_name).syntax.std, $(pkg_name).syntax.classes" archive(syntax, preprocessor) = "-ignore dummy" error(pkg_type_conv, pkg_deriving.syntax, -pkg_deriving) = "Could not be loaded together with 'type_conv'. Please use $(pkg_name).syntax_tc instead." package "common" ( requires(syntax, preprocessor) = "unix, camlp4" requires(toploop) = "unix, camlp4" archive(syntax, preprocessor) = "pa_deriving_common.cma" archive(syntax, toploop) = "pa_deriving_common.cma" ) package "std" ( description = "Deriving syntax extension" version = "$(pkg_version)" requires(syntax, preprocessor) = "$(pkg_name).syntax.common" requires(toploop) = "$(pkg_name).syntax.common" error(pkg_type_conv, -pkg_deriving.syntax, -pkg_deriving) = "Could not be loaded together with 'type_conv'. Please use $(pkg_name).syntax.tc instead." exists_if = "pa_deriving_std.cma" archive(syntax, preprocessor) = "pa_deriving_std.cma" archive(syntax, toploop) = "pa_deriving_std.cma" ) package "tc" ( description = "Deriving syntax extension (type_conv compatible syntax)" version = "$(pkg_version)" requires(syntax, preprocessor) = "$(pkg_name).syntax.common, type_conv" requires(toploop) = "$(pkg_name).syntax.common, type_conv" exists_if = "pa_deriving_tc.cma" archive(syntax, preprocessor) = "pa_deriving_tc.cma" archive(syntax, toploop) = "pa_deriving_tc.cma" ) package "classes" ( description = "Deriving syntax extension (predefined classes)" version = "$(pkg_version)" requires(syntax, preprocessor) = "$(pkg_name).syntax.common" requires(toploop) = "$(pkg_name).syntax.common" exists_if = "pa_deriving_classes.cma" archive(syntax, preprocessor) = "pa_deriving_classes.cma" archive(syntax, toploop) = "pa_deriving_classes.cma" ) ) package "tc" ( requires = "$(pkg_name).runtime, $(pkg_name).syntax_tc" archive(syntax, preprocessor) = "-ignore dummy" ) package "syntax_tc" ( requires(syntax, preprocessor) = "$(pkg_name).syntax.tc, $(pkg_name).syntax.classes" requires(toploop) = "$(pkg_name).syntax.tc, $(pkg_name).syntax.classes" archive(syntax, preprocessor) = "-ignore dummy" ) deriving-0.7.1/lib/deriving_Bounded.ml000066400000000000000000000033301272135405000176730ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) (** Primitive instanecs for bounded **) module Deriving_Bounded = struct module type Bounded = sig type a val min_bound : a val max_bound : a end module Bounded_integer(B : sig type t val max_int : t val min_int : t end) : Bounded with type a = B.t = struct type a = B.t let min_bound = B.min_int let max_bound = B.max_int end module Bounded_int32 = Bounded_integer(Int32) module Bounded_int64 = Bounded_integer(Int64) module Bounded_nativeint = Bounded_integer(Nativeint) module Bounded_int = struct type a = int let min_bound = Pervasives.min_int let max_bound = Pervasives.max_int end module Bounded_bool = struct type a = bool let min_bound = false let max_bound = true end module Bounded_char = struct type a = char let min_bound = Char.chr 0 let max_bound = Char.chr 0xff (* Is this guaranteed? *) end module Bounded_unit = struct type a = unit let min_bound = () let max_bound = () end end include Deriving_Bounded type open_flag = Pervasives.open_flag = | Open_rdonly | Open_wronly | Open_append | Open_creat | Open_trunc | Open_excl | Open_binary | Open_text | Open_nonblock deriving (Bounded) type fpclass = Pervasives.fpclass = | FP_normal | FP_subnormal | FP_zero | FP_infinite | FP_nan deriving (Bounded) deriving-0.7.1/lib/deriving_Bounded.mli000066400000000000000000000011351272135405000200450ustar00rootroot00000000000000module type Bounded = sig type a val min_bound : a val max_bound : a end module Bounded_bool : Bounded with type a = bool module Bounded_char : Bounded with type a = char module Bounded_int : Bounded with type a = int module Bounded_int32 : Bounded with type a = int32 module Bounded_int64 : Bounded with type a = int64 module Bounded_nativeint : Bounded with type a = nativeint module Bounded_unit : Bounded with type a = unit module Bounded_open_flag : Bounded with type a = Pervasives.open_flag module Bounded_fpclass : Bounded with type a = Pervasives.fpclass deriving-0.7.1/lib/deriving_Default.ml000066400000000000000000000022051272135405000176770ustar00rootroot00000000000000module type Default = sig type a val default : unit -> a end module Defaults(D : Default) : Default with type a = D.a = struct include D end module Default_string = Defaults(struct type a = string let default () = "" end) module Default_int64 = Defaults(struct type a = int64 let default () = 0L end) module Default_int = Defaults(struct type a = int let default () = 0 end) module Default_bool = Defaults(struct type a = bool let default () = true end) module Default_unit = Defaults(struct type a = unit let default () = () end) module Default_char = Defaults(struct type a = char let default () = '0' end) module Default_float = Defaults(struct type a = float let default () = 0.0 end) module Default_list (A : Default) = Defaults(struct type a = A.a list let default () = [] end) module Default_option (A : Default) = Defaults(struct type a = A.a option let default () = None end) module Default_array (A : Default) = Defaults(struct type a = A.a array let default () = [||] end) module Default_ref (A : Default) = Defaults(struct type a = A.a ref let default () = ref (A.default ()) end) deriving-0.7.1/lib/deriving_Default.mli000066400000000000000000000013521272135405000200520ustar00rootroot00000000000000 module type Default = sig type a val default : unit -> a end module Defaults(D : Default) : Default with type a = D.a module Default_string : Default with type a = string module Default_int64 : Default with type a = int64 module Default_int : Default with type a = int module Default_bool : Default with type a = bool module Default_unit : Default with type a = unit module Default_char : Default with type a = char module Default_float : Default with type a = float module Default_list (A : Default) : Default with type a = A.a list module Default_option (A : Default) : Default with type a = A.a option module Default_array (A : Default) : Default with type a = A.a array module Default_ref (A : Default) : Default with type a = A.a ref deriving-0.7.1/lib/deriving_Dump.ml000066400000000000000000000170101272135405000172200ustar00rootroot00000000000000(** Dump **) (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) (* TODO: we could have an additional debugging deserialisation method. *) module type Dump = sig type a val to_buffer : Buffer.t -> a -> unit val to_string : a -> string val to_channel : out_channel -> a -> unit val from_stream : char Stream.t -> a val from_string : string -> a val from_channel : in_channel -> a end module type SimpleDump = sig type a val to_buffer : Buffer.t -> a -> unit val from_stream : char Stream.t -> a end exception Dump_error of string let bad_tag tag stream typename = raise (Dump_error (Printf.sprintf "Dump: failure during %s deserialisation at character %d; unexpected tag %d" typename (Stream.count stream) tag)) module Defaults (P : sig type a val to_buffer : Buffer.t -> a -> unit val from_stream : char Stream.t -> a end) : Dump with type a = P.a = struct include P (* is there a reasonable value to use here? *) let buffer_size = 128 let to_string obj = let buffer = Buffer.create buffer_size in P.to_buffer buffer obj; Buffer.contents buffer (* should we explicitly deallocate the buffer? *) and from_string string = P.from_stream (Stream.of_string string) and from_channel in_channel = from_stream (Stream.of_channel in_channel) and to_channel out_channel obj = let buffer = Buffer.create buffer_size in P.to_buffer buffer obj; Buffer.output_buffer out_channel buffer end (* Generic int dumper. This should work for any (fixed-size) integer type with suitable operations. *) module Dump_intN (P : sig type t val zero : t val logand : t -> t -> t val logor : t -> t -> t val lognot : t -> t val shift_right_logical : t -> int -> t val shift_left : t -> int -> t val of_int : int -> t val to_int : t -> int end) = Defaults ( struct type a = P.t (* Format an integer using the following scheme: The lower 7 bits of each byte are used to store successive 7-bit chunks of the integer. The highest bit of each byte is used as a flag to indicate whether the next byte is present. *) open Buffer open Char open P let to_buffer buffer = let rec aux int = (* are there more than 7 bits? *) if logand int (lognot (of_int 0x7f)) <> zero (* if there are, write the lowest 7 bite plus a high bit (to indicate that there's more). Then recurse, shifting the value 7 bits right *) then begin add_char buffer (chr (to_int (logor (of_int 0x80) (logand int (of_int 0x7f))))); aux (shift_right_logical int 7) end (* otherwise, write the bottom 7 bits only *) else add_char buffer (chr (to_int int)) in aux and from_stream stream = let rec aux (int : t) shift = let c = of_int (code (Stream.next stream)) in let int = logor int (shift_left (logand c (of_int 0x7f)) shift) in if logand c (of_int 0x80) <> zero then aux int (shift + 7) else int in aux zero 0 end ) module Dump_int32 = Dump_intN (Int32) module Dump_int64 = Dump_intN (Int64) module Dump_nativeint = Dump_intN (Nativeint) module Dump_int = Defaults ( struct type a = int let to_buffer buffer int = Dump_nativeint.to_buffer buffer (Nativeint.of_int int) and from_stream stream = Nativeint.to_int (Dump_nativeint.from_stream stream) end ) module Dump_char = Defaults ( struct type a = char let to_buffer = Buffer.add_char and from_stream = Stream.next end ) (* This is questionable; it doesn't preserve sharing *) module Dump_string = Defaults ( struct type a = string let to_buffer buffer string = begin Dump_int.to_buffer buffer (String.length string); Buffer.add_string buffer string end and from_stream stream = let len = Dump_int.from_stream stream in let s = Bytes.create len in for i = 0 to len - 1 do Bytes.unsafe_set s i (Stream.next stream) done; s end ) module Dump_float = Defaults ( struct type a = float let to_buffer buffer f = Dump_int64.to_buffer buffer (Int64.bits_of_float f) and from_stream stream = Int64.float_of_bits (Dump_int64.from_stream stream) end ) (* This should end up a bit more compact than the derived version *) module Dump_list (P : SimpleDump) = Defaults ( (* This could perhaps be more efficient by serialising the list in reverse: this would result in only one traversal being needed during serialisation, and no "reverse" being needed during deserialisation. (However, dumping would no longer be tail-recursive) *) struct type a = P.a list let to_buffer buffer items = begin Dump_int.to_buffer buffer (List.length items); List.iter (P.to_buffer buffer) items end and from_stream stream = let rec aux items = function | 0 -> items | n -> aux (P.from_stream stream :: items) (n-1) in List.rev (aux [] (Dump_int.from_stream stream)) end ) (* Dump_ref and Dump_array cannot preserve sharing, so we don't provide implementations *) module Dump_option (P : SimpleDump) = Defaults ( struct type a = P.a option let to_buffer buffer = function | None -> Dump_int.to_buffer buffer 0 | Some s -> begin Dump_int.to_buffer buffer 1; P.to_buffer buffer s end and from_stream stream = match Dump_int.from_stream stream with | 0 -> None | 1 -> Some (P.from_stream stream) | i -> bad_tag i stream "option" end ) module Dump_bool = Defaults ( struct type a = bool let to_buffer buffer = function | false -> Buffer.add_char buffer '\000' | true -> Buffer.add_char buffer '\001' and from_stream stream = match Stream.next stream with | '\000' -> false | '\001' -> true | c -> bad_tag (Char.code c) stream "bool" end ) module Dump_unit = Defaults ( struct type a = unit let to_buffer _ () = () and from_stream _ = () end ) module Dump_alpha(P: sig type a end) = Defaults(struct type a = P.a let to_buffer _ _ = assert false let from_stream _ = assert false end) module Dump_undumpable (P : sig type a val tname : string end) = Defaults ( struct type a = P.a let to_buffer _ _ = failwith ("Dump: attempt to serialise a value of unserialisable type : " ^ P.tname) let from_stream _ = failwith ("Dump: attempt to deserialise a value of unserialisable type : " ^ P.tname) end ) (* Uses Marshal to serialise the values that the parse-the-declarations technique can't reach. *) module Dump_via_marshal (P : sig type a end) = Defaults ( (* Rather inefficient. *) struct include P let to_buffer buffer obj = Buffer.add_string buffer (Marshal.to_string obj [Marshal.Closures]) let from_stream stream = let readn n = let s = Bytes.create n in for i = 0 to n - 1 do Bytes.set s i (Stream.next stream) done; s in let header = readn Marshal.header_size in let datasize = Marshal.data_size header 0 in let datapart = readn datasize in Marshal.from_string (header ^ datapart) 0 end) deriving-0.7.1/lib/deriving_Dump.mli000066400000000000000000000023611272135405000173740ustar00rootroot00000000000000module type Dump = sig type a val to_buffer : Buffer.t -> a -> unit val to_string : a -> string val to_channel : out_channel -> a -> unit val from_stream : char Stream.t -> a val from_string : string -> a val from_channel : in_channel -> a end module Defaults (P : sig type a val to_buffer : Buffer.t -> a -> unit val from_stream : char Stream.t -> a end) : Dump with type a = P.a exception Dump_error of string module Dump_int32 : Dump with type a = Int32.t module Dump_int64 : Dump with type a = Int64.t module Dump_nativeint : Dump with type a = Nativeint.t module Dump_int : Dump with type a = int module Dump_char : Dump with type a = char module Dump_string : Dump with type a = string module Dump_float : Dump with type a = float module Dump_bool : Dump with type a = bool module Dump_unit : Dump with type a = unit module Dump_list (P : Dump) : Dump with type a = P.a list module Dump_option (P : Dump) : Dump with type a = P.a option module Dump_undumpable (P : sig type a val tname : string end) : Dump with type a = P.a module Dump_via_marshal (P : sig type a end) : Dump with type a = P.a module Dump_alpha (P : sig type a end) : Dump with type a = P.a deriving-0.7.1/lib/deriving_Enum.ml000066400000000000000000000105441272135405000172240ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) open Deriving_Bounded let rec rassoc (rkey : 'b) : ('a * 'b) list -> 'a = function | [] -> raise Not_found | (a,b)::_ when b = rkey -> a | _::xs -> rassoc rkey xs let rec last : 'a list -> 'a = function | [] -> raise (Invalid_argument "last") | [x] -> x | _::xs -> last xs module Deriving_Enum = struct (** Enum **) module type Enum = sig type a val succ : a -> a val pred : a -> a val to_enum : int -> a val from_enum : a -> int val enum_from : a -> a list val enum_from_then : a -> a -> a list val enum_from_to : a -> a -> a list val enum_from_then_to : a -> a -> a -> a list end let startThenTo (start : int) (next : int) (until : int) : int list = let step = next - start in if step <= 0 then invalid_arg "startThenTo" else let rec upFrom current = if current > until then [] else current :: upFrom (current+step) in upFrom start let range : int -> int -> int list = fun f t -> startThenTo f (f+1) t module Defaults (E : (sig type a val numbering : (a * int) list end)) : Enum with type a = E.a = struct let firstCon = fst (List.hd E.numbering) let lastCon = fst (last E.numbering) type a = E.a let from_enum a = List.assoc a E.numbering let to_enum i = try rassoc i E.numbering with Not_found -> raise (Invalid_argument "to_enum") let succ s = try to_enum ((from_enum s) + 1) with Invalid_argument "to_enum" -> raise (Invalid_argument "succ") let pred s = try to_enum ((from_enum s) - 1) with Invalid_argument "to_enum" -> raise (Invalid_argument "pred") let enum_from_to x y = List.map to_enum (range (from_enum x) (from_enum y)) let enum_from_then_to x y z = List.map to_enum (startThenTo (from_enum x) (from_enum y) (from_enum z)) let enum_from_then x y = (enum_from_then_to x y (if from_enum y >= from_enum x then lastCon else firstCon)) let enum_from x = enum_from_to x lastCon end module Defaults' (E : (sig type a val from_enum : a -> int val to_enum : int -> a end)) (B : Bounded with type a = E.a) : Enum with type a = E.a and type a = B.a = struct include E let firstCon = B.min_bound let lastCon = B.max_bound let succ s = try to_enum ((from_enum s) + 1) with Invalid_argument "to_enum" -> raise (Invalid_argument "succ") let pred s = try to_enum ((from_enum s) - 1) with Invalid_argument "to_enum" -> raise (Invalid_argument "pred") let enum_from_to x y = List.map to_enum (range (from_enum x) (from_enum y)) let enum_from_then_to x y z = List.map to_enum (startThenTo (from_enum x) (from_enum y) (from_enum z)) let enum_from_then x y = (enum_from_then_to x y (if from_enum y >= from_enum x then lastCon else firstCon)) let enum_from x = enum_from_to x lastCon end module Enum_bool = Defaults(struct type a = bool let numbering = [false, 0; true, 1] end) module Enum_char = Defaults'(struct type a = char let from_enum = Char.code let to_enum = Char.chr end) (Bounded_char) module Enum_int = Defaults' (struct type a = int let from_enum i = i let to_enum i = i end)(Bounded_int) (* Can `instance Enum Float' be justified? For some floats `f' we have `succ f == f'. Furthermore, float is wider than int, so from_enum will necessarily give nonsense on many inputs. *) module Enum_unit = Defaults' (struct type a = unit let from_enum () = 0 let to_enum = function | 0 -> () | _ -> raise (Invalid_argument "to_enum") end) (Bounded_unit) end include Deriving_Enum type open_flag = Pervasives.open_flag = | Open_rdonly | Open_wronly | Open_append | Open_creat | Open_trunc | Open_excl | Open_binary | Open_text | Open_nonblock deriving (Bounded,Enum) type fpclass = Pervasives.fpclass = | FP_normal | FP_subnormal | FP_zero | FP_infinite | FP_nan deriving (Bounded,Enum) deriving-0.7.1/lib/deriving_Enum.mli000066400000000000000000000013511272135405000173710ustar00rootroot00000000000000module type Enum = sig type a val succ : a -> a val pred : a -> a val to_enum : int -> a val from_enum : a -> int val enum_from : a -> a list val enum_from_then : a -> a -> a list val enum_from_to : a -> a -> a list val enum_from_then_to : a -> a -> a -> a list end module Defaults (E : sig type a val numbering : (a * int) list end) : Enum with type a = E.a module Defaults' (E : sig type a val from_enum : a -> int val to_enum : int -> a end) (B : Deriving_Bounded.Bounded with type a = E.a) : Enum with type a = B.a module Enum_bool : Enum with type a = bool module Enum_char : Enum with type a = char module Enum_int : Enum with type a = int module Enum_unit : Enum with type a = unit deriving-0.7.1/lib/deriving_Eq.ml000066400000000000000000000034441272135405000166660ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) module type Eq = sig type a val eq : a -> a -> bool end module Eq_immutable(S : sig type a end) : Eq with type a = S.a = struct type a = S.a let eq = (=) end module Eq_mutable(S : sig type a end) : Eq with type a = S.a = struct type a = S.a let eq = (==) end module Eq_alpha(S : sig type a end) = struct type a = S.a let eq _ _ = assert false end module Eq_int = Eq_immutable(struct type a = int end) module Eq_bool = Eq_immutable(struct type a = bool end) module Eq_float = Eq_immutable(struct type a = float end) module Eq_unit = Eq_immutable(struct type a = unit end) module Eq_char = Eq_immutable(struct type a = char end) module Eq_int32 = Eq_immutable(struct type a = int32 end) module Eq_int64 = Eq_immutable(struct type a = int64 end) module Eq_nativeint = Eq_immutable(struct type a = nativeint end) module Eq_string = Eq_mutable(struct type a = string end) module Eq_ref (E : Eq) = Eq_mutable(struct type a = E.a ref end) module Eq_array (E : Eq) = Eq_mutable(struct type a = E.a array end) module Eq_option (E : Eq) : Eq with type a = E.a option = struct type a = E.a option let eq l r = match l, r with | None, None -> true | Some l, Some r -> E.eq l r | _ -> false end module Eq_map_s_t (E : Eq) (M : Map.S) : Eq with type a = E.a M.t = struct type a = E.a M.t let eq = M.equal (E.eq) end module Eq_set_s_t (S : Set.S) : Eq with type a = S.t = struct type a = S.t let eq = S.equal end module Eq_list (E : Eq) : Eq with type a = E.a list = struct type a = E.a list let rec eq l r = match l, r with | [], [] -> true | (lfst::lrst), (rfst::rrst) when E.eq lfst rfst -> eq lrst rrst | _ -> false end deriving-0.7.1/lib/deriving_Eq.mli000066400000000000000000000022311272135405000170300ustar00rootroot00000000000000(* A module for SML-style equality, i.e. where equality of mutables is physical equality and equality of immutables is structural equality. *) module type Eq = sig type a val eq : a -> a -> bool end module Eq_immutable (S : sig type a end) : Eq with type a = S.a module Eq_mutable (S : sig type a end) : Eq with type a = S.a module Eq_alpha(S : sig type a end) : Eq with type a = S.a module Eq_int : Eq with type a = int module Eq_bool : Eq with type a = bool module Eq_float : Eq with type a = float module Eq_unit : Eq with type a = unit module Eq_char : Eq with type a = char module Eq_string : Eq with type a = string module Eq_int32 : Eq with type a = int32 module Eq_int64 : Eq with type a = int64 module Eq_nativeint : Eq with type a = nativeint module Eq_ref (E : Eq) : Eq with type a = E.a ref module Eq_array (E : Eq) : Eq with type a = E.a array module Eq_list (E : Eq) : Eq with type a = E.a list module Eq_option (E : Eq): Eq with type a = E.a option module Eq_map_s_t (E : Eq) (M : Map.S) : Eq with type a = E.a M.t module Eq_set_s_t (S : Set.S) : Eq with type a = S.t deriving-0.7.1/lib/deriving_Functor.ml000066400000000000000000000023131272135405000177330ustar00rootroot00000000000000open Deriving_monad (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) module type Functor = sig type 'a f val map : ('a -> 'b) -> 'a f -> 'b f end module MonadFunctor (M : Monad) : Functor with type 'a f = 'a M.m = struct open M type 'a f = 'a M.m let map f x = x >>= (fun x -> return (f x)) end module Functor_option = MonadFunctor(Monad_option) module Functor_list = MonadFunctor(Monad_list) module Functor_map (O : Map.OrderedType) : Functor with type 'a f = 'a Map.Make(O).t = struct include Map.Make(O) type 'a f = 'a t end (* NB: Instances for mutable types (including ref queue stack array stream buffer) are deliberately omitted. Since sharing is detectable for values of these types we have two distinct design choices: 1. Always create a new copy that shares no structure with the original. 2. Always mutate the original copy Neither of these seems like the right thing to do, so instead we simply don't handle mutable types at all. (Lazy.t is another example: we'd like map to be total and side-effect free, which is impossible to guarantee if we handle lazy. *) deriving-0.7.1/lib/deriving_Functor.mli000066400000000000000000000005531272135405000201100ustar00rootroot00000000000000module type Functor = sig type 'a f val map : ('a -> 'b) -> 'a f -> 'b f end module MonadFunctor (M : Deriving_monad.Monad) : Functor with type 'a f = 'a M.m module Functor_option : Functor with type 'a f = 'a option module Functor_list : Functor with type 'a f = 'a list module Functor_map (O : Map.OrderedType) : Functor with type 'a f = 'a Map.Make(O).t deriving-0.7.1/lib/deriving_Pickle.ml000066400000000000000000000403301272135405000175230ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) (* Idea: 1. every object receives a serializable id. 2. an object is serialized using the ids of its subobjects *) open Deriving_Typeable open Deriving_Eq open Deriving_Dump module Deriving_Pickle = struct exception UnknownTag of int * string exception UnpicklingError of string module Id : sig type t deriving (Show, Dump, Eq) val initial : t val compare : t -> t -> int val next : t -> t end = struct type t = int deriving (Show, Dump, Eq) let initial = 0 let compare = compare let next = succ end module IdMap = Map.Make (Id) type id = Id.t deriving (Show, Dump) module Repr : sig (* Break abstraction for the sake of efficiency for now *) type t = Bytes of string | CApp of (int option * Id.t list) deriving (Dump, Show) val of_string : string -> t val to_string : t -> string val make : ?constructor:int -> id list -> t val unpack_ctor : t -> int option * id list end = struct type t = Bytes of string | CApp of (int option * Id.t list) deriving (Dump, Show) let of_string s = Bytes s let to_string = function | Bytes s -> s | _ -> invalid_arg "string_of_repr" let make ?constructor ids = match constructor with | Some n -> CApp (Some n, ids) | None -> CApp (None, ids) let unpack_ctor = function | CApp arg -> arg | _ -> raise (UnpicklingError "Error unpickling constructor") end type repr = Repr.t module Write : sig type s = { nextid : Id.t; obj2id : Id.t Deriving_dynmap.DynMap.t; id2rep : repr IdMap.t; } val initial_output_state : s include Deriving_monad.Monad_state_type with type state = s module Utils (T : Typeable) (E : Eq with type a = T.a) : sig val allocate : T.a -> (id -> unit m) -> id m val store_repr : id -> Repr.t -> unit m end end = struct type s = { nextid : Id.t; (* the next id to be allocated *) obj2id : Id.t Deriving_dynmap.DynMap.t; (* map from typerep to id cache for the corresponding type *) id2rep : repr IdMap.t; } let initial_output_state = { nextid = Id.initial; obj2id = Deriving_dynmap.DynMap.empty; id2rep = IdMap.empty; } include Deriving_monad.Monad_state (struct type state = s end) module Utils (T : Typeable) (E : Eq with type a = T.a) = struct module C = Deriving_dynmap.Comp(T)(E) let comparator = C.eq let allocate o f = let obj = T.make_dynamic o in get >>= fun ({nextid=nextid;obj2id=obj2id} as t) -> match Deriving_dynmap.DynMap.find obj obj2id with | Some id -> return id | None -> let id, nextid = nextid, Id.next nextid in put {t with obj2id=Deriving_dynmap.DynMap.add obj id comparator obj2id; nextid=nextid} >> f id >> return id let store_repr id repr = get >>= fun state -> put {state with id2rep = IdMap.add id repr state.id2rep} end end module Read : sig type s = (repr * (dynamic option)) IdMap.t include Deriving_monad.Monad_state_type with type state = s val find_by_id : id -> (Repr.t * dynamic option) m module Utils (T : Typeable) : sig val sum : (int * id list -> T.a m) -> id -> T.a m val tuple : (id list -> T.a m) -> id -> T.a m val record : (T.a -> id list -> T.a m) -> int -> id -> T.a m val update_map : id -> (T.a -> unit m) end end = struct type s = (repr * (dynamic option)) IdMap.t include Deriving_monad.Monad_state (struct type state = s end) let find_by_id id = get >>= fun state -> return (IdMap.find id state) module Utils (T : Typeable) = struct let decode_repr_ctor c = match Repr.unpack_ctor c with | (Some c, ids) -> (c, ids) | _ -> invalid_arg "decode_repr_ctor" let decode_repr_noctor c = match Repr.unpack_ctor c with | (None, ids) -> ids | _ -> invalid_arg "decode_repr_ctor" let update_map id obj = let dynamic = T.make_dynamic obj in get >>= fun state -> match IdMap.find id state with | (repr, None) -> put (IdMap.add id (repr, Some dynamic) state) | (_, Some _) -> return () (* Checking for id already present causes unpickling to fail when there is circularity involving immutable values (even if the recursion wholly depends on mutability). For example, consider the code type t = A | B of t ref deriving (Typeable, Eq, Pickle) let s = ref A in let r = B s in s := r; let pickled = Pickle_t.pickleS r in Pickle_t.unpickleS r which results in the value B {contents = B {contents = B { ... }}} During deserialization the following steps occur: 1. lookup "B {...}" in the dictionary (not there) 2. unpickle the contents of B: 3. lookup the contents in the dictionary (not there) 4. create a blank reference, insert it into the dictionary 5. unpickle the contents of the reference: 6. lookup ("B {...}") in the dictionary (not there) 7. unpickle the contents of B: 8. lookup the contents in the dictionary (there) 9. insert "B{...}" into the dictionary. 10. insert "B{...}" into the dictionary. *) let whizzy f id decode = find_by_id id >>= fun (repr, dynopt) -> match dynopt with | None -> f (decode repr) >>= fun obj -> update_map id obj >> return obj | Some obj -> return (T.throwing_cast obj) let sum f id = whizzy f id decode_repr_ctor let tuple f id = whizzy f id decode_repr_noctor let record_tag = 0 let record f size id = find_by_id id >>= fun (repr, obj) -> match obj with | None -> let this = Obj.magic (Obj.new_block record_tag size) in update_map id this >> f this (decode_repr_noctor repr) >> return this | Some obj -> return (T.throwing_cast obj) end end module type Pickle = sig type a module Typeable : Typeable with type a = a module Eq : Eq with type a = a val pickle : a -> id Write.m val unpickle : id -> a Read.m val to_buffer : Buffer.t -> a -> unit val to_string : a -> string val to_channel : out_channel -> a -> unit val from_stream : char Stream.t -> a val from_string : string -> a val from_channel : in_channel -> a end module Defaults (S : sig type a module Typeable : Typeable with type a = a module Eq : Eq with type a = a val pickle : a -> id Write.m val unpickle : id -> a Read.m end) : Pickle with type a = S.a = struct include S type ids = (Id.t * Repr.t) list deriving (Dump, Show) type dumpable = id * ids deriving (Show, Dump) type ('a,'b) pair = 'a * 'b deriving (Dump) type capp = int option * Id.t list deriving (Dump) (* We don't serialize ids of each object at all: we just use the ordering in the output file to implicitly record the ids of objects. Also, we don't serialize the repr constructors. All values with a particular constructor are grouped in a single list. This can (and should) all be written much more efficiently. *) type discriminated = (Id.t * string) list * (Id.t * (int * Id.t list)) list * (Id.t * (Id.t list)) list deriving (Dump, Show) type discriminated_ordered = string list * (int * Id.t list) list * (Id.t list) list deriving (Dump, Show) let reorder : Id.t * discriminated -> Id.t * discriminated_ordered = fun (root,(a,b,c)) -> let collect_ids items (map,counter) = List.fold_left (fun (map,counter) (id,_) -> IdMap.add id counter map, Id.next counter) (map,counter) items in let map, _ = collect_ids c (collect_ids b (collect_ids a (IdMap.empty, Id.initial))) in let lookup id = IdMap.find id map in (lookup root, (List.map snd a, List.map (fun (_,(c,l)) -> c, List.map lookup l) b, List.map (fun (_,l) -> List.map lookup l) c)) let unorder : Id.t * discriminated_ordered -> Id.t * discriminated = fun (root,(a,b,c)) -> let number_sequentially id items = List.fold_left (fun (id,items) item -> (Id.next id, (id,item)::items)) (id,[]) items in let id = Id.initial in let id, a = number_sequentially id a in let id, b = number_sequentially id b in let _, c = number_sequentially id c in (root, (a,b,c)) type ('a,'b) either = Left of 'a | Right of 'b let either_partition (f : 'a -> ('b, 'c) either) (l : 'a list) : 'b list * 'c list = let rec aux (lefts, rights) = function | [] -> (List.rev lefts, List.rev rights) | x::xs -> match f x with | Left l -> aux (l :: lefts, rights) xs | Right r -> aux (lefts, r :: rights) xs in aux ([], []) l type discriminated_dumpable = Id.t * discriminated deriving (Dump) let discriminate : (Id.t * Repr.t) list -> discriminated = fun input -> let bytes, others = either_partition (function | id, (Repr.Bytes s) -> Left (id,s) | id, (Repr.CApp c) -> Right (id,c)) input in let ctors, no_ctors = either_partition (function | id, (Some c, ps) -> Left (id, (c,ps)) | id, (None, ps) -> Right (id,ps)) others in (bytes, ctors, no_ctors) let undiscriminate : discriminated -> (Id.t * Repr.t) list = fun (a,b,c) -> List.map (fun (id,s) -> (id,Repr.Bytes s)) a @ List.map (fun (id,(c,ps)) -> (id,Repr.CApp (Some c,ps))) b @ List.map (fun (id,(ps)) -> (id,Repr.CApp (None,ps))) c type do_pair = Id.t * discriminated_ordered deriving (Show, Dump) let write_discriminated f = fun (root,map) -> let dmap = discriminate map in let rmap = reorder (root,dmap) in f rmap let read_discriminated (f : 'b -> 'a) : 'b -> Id.t * (Id.t * Repr.t) list = fun s -> let rmap = f s in let (root,dmap) = unorder rmap in (root, undiscriminate dmap) open Write let decode_pickled_string (f : 'a -> Id.t * discriminated_ordered) : 'b -> Id.t * Read.s = fun s -> let (id, state : dumpable) = read_discriminated f s in id, (List.fold_right (fun (id,repr) map -> IdMap.add id (repr,None) map) state IdMap.empty) let encode_pickled_string f = fun (id,state) -> let input_state = id, IdMap.fold (fun id repr output -> (id,repr)::output) state.id2rep [] in write_discriminated f input_state let doPickle f v : 'a = let id, state = runState (S.pickle v) initial_output_state in encode_pickled_string f (id, state) let doUnpickle f input = let id, initial_input_state = decode_pickled_string f input in let value, _ = Read.runState (S.unpickle id) initial_input_state in value let from_channel = doUnpickle Dump.from_channel let from_string = doUnpickle Dump.from_string let from_stream = doUnpickle Dump.from_stream let to_channel channel = doPickle (Dump.to_channel channel) let to_buffer buffer = doPickle (Dump.to_buffer buffer) let to_string = doPickle Dump.to_string end module Pickle_from_dump (P : Dump) (E : Eq with type a = P.a) (T : Typeable with type a = P.a) : Pickle with type a = P.a and type a = E.a and type a = T.a = Defaults (struct type a = T.a module Typeable = T module Eq = E module Comp = Deriving_dynmap.Comp(T)(E) open Write module W = Utils(T)(E) let pickle obj = W.allocate obj (fun id -> W.store_repr id (Repr.of_string (P.to_string obj))) open Read module U = Utils(T) let unpickle id = find_by_id id >>= fun (repr, dynopt) -> match dynopt with | None -> let obj : a = P.from_string (Repr.to_string repr) in U.update_map id obj >> return obj | Some obj -> return (T.throwing_cast obj) end) module Pickle_unit : Pickle with type a = unit = Pickle_from_dump(Dump_unit)(Eq_unit)(Typeable_unit) module Pickle_bool = Pickle_from_dump(Dump_bool)(Eq_bool)(Typeable_bool) module Pickle_int = Pickle_from_dump(Dump_int)(Eq_int)(Typeable_int) module Pickle_char = Pickle_from_dump(Dump_char)(Eq_char)(Typeable_char) module Pickle_float = Pickle_from_dump(Dump_float)(Eq_float)(Typeable_float) module Pickle_string = Pickle_from_dump(Dump_string)(Eq_string)(Typeable_string) module Pickle_int32 = Pickle_from_dump(Dump_int32)(Eq_int32)(Typeable_int32) module Pickle_int64 = Pickle_from_dump(Dump_int64)(Eq_int64)(Typeable_int64) module Pickle_nativeint = Pickle_from_dump(Dump_nativeint)(Eq_nativeint)(Typeable_nativeint) module Pickle_option (V0 : Pickle) : Pickle with type a = V0.a option = Defaults( struct module Typeable = Typeable_option (V0.Typeable) module Eq = Eq_option (V0.Eq) module Comp = Deriving_dynmap.Comp (Typeable) (Eq) open Write type a = V0.a option let rec pickle = let module W = Utils(Typeable)(Eq) in function None as obj -> W.allocate obj (fun id -> W.store_repr id (Repr.make ~constructor:0 [])) | Some v0 as obj -> W.allocate obj (fun thisid -> V0.pickle v0 >>= fun id0 -> W.store_repr thisid (Repr.make ~constructor:1 [id0])) open Read let unpickle = let module W = Utils(Typeable) in let f = function | 0, [] -> return None | 1, [id] -> V0.unpickle id >>= fun obj -> return (Some obj) | n, _ -> raise (UnpicklingError ("Unexpected tag encountered unpickling " ^"option : " ^ string_of_int n)) in W.sum f end) module Pickle_list (V0 : Pickle) : Pickle with type a = V0.a list = Defaults ( struct module Typeable = Typeable_list (V0.Typeable) module Eq = Eq_list (V0.Eq) module Comp = Deriving_dynmap.Comp (Typeable) (Eq) type a = V0.a list open Write module U = Utils(Typeable)(Eq) let rec pickle = function [] as obj -> U.allocate obj (fun this -> U.store_repr this (Repr.make ~constructor:0 [])) | (v0::v1) as obj -> U.allocate obj (fun this -> V0.pickle v0 >>= fun id0 -> pickle v1 >>= fun id1 -> U.store_repr this (Repr.make ~constructor:1 [id0; id1])) open Read module W = Utils (Typeable) let rec unpickle id = let f = function | 0, [] -> return [] | 1, [car;cdr] -> V0.unpickle car >>= fun car -> unpickle cdr >>= fun cdr -> return (car :: cdr) | n, _ -> raise (UnpicklingError ("Unexpected tag encountered unpickling " ^"option : " ^ string_of_int n)) in W.sum f id end) end include Deriving_Pickle type 'a ref = 'a Pervasives.ref = { mutable contents : 'a } deriving (Eq,Typeable,Pickle) (* Idea: keep pointers to values that we've serialized in a global weak hash table so that we can share structure with them if we deserialize any equal values in the same process *) (* Idea: serialize small objects (bools, chars) in place rather than using the extra level of indirection (and space) introduced by ids *) (* Idea: bitwise output instead of bytewise. Probably a bit much to implement now, but should have a significant impact (e.g. one using bit instead of one byte for two-constructor sums) *) (* Should we use a different representation for lists? i.e. write out the length followed by the elements? we could no longer claim sharing maximization, but it would actually be more efficient in most cases. *) deriving-0.7.1/lib/deriving_Pickle.mli000066400000000000000000000044331272135405000177000ustar00rootroot00000000000000open Deriving_Typeable open Deriving_Eq open Deriving_Dump type id (* representation of values of user-defined types *) module Repr : sig type t val make : ?constructor:int -> id list -> t end (* Utilities for serialization *) module Write : sig type s include Deriving_monad.Monad_state_type with type state = s module Utils (T : Typeable) (E : Eq with type a = T.a) : sig val allocate : T.a -> (id -> unit m) -> id m val store_repr : id -> Repr.t -> unit m end end (* Utilities for deserialization *) module Read : sig type s include Deriving_monad.Monad_state_type with type state = s module Utils (T : Typeable) : sig val sum : (int * id list -> T.a m) -> (id -> T.a m) val tuple : (id list -> T.a m) -> (id -> T.a m) val record : (T.a -> id list -> T.a m) -> int -> (id -> T.a m) end end exception UnpicklingError of string exception UnknownTag of int * string module type Pickle = sig type a module Typeable : Typeable with type a = a module Eq : Eq with type a = a val pickle : a -> id Write.m val unpickle : id -> a Read.m val to_buffer : Buffer.t -> a -> unit val to_string : a -> string val to_channel : out_channel -> a -> unit val from_stream : char Stream.t -> a val from_string : string -> a val from_channel : in_channel -> a end module Defaults (S : sig type a module Typeable : Typeable with type a = a module Eq : Eq with type a = a val pickle : a -> id Write.m val unpickle : id -> a Read.m end) : Pickle with type a = S.a module Pickle_unit : Pickle with type a = unit module Pickle_bool : Pickle with type a = bool module Pickle_int : Pickle with type a = int module Pickle_char : Pickle with type a = char module Pickle_float : Pickle with type a = float module Pickle_string : Pickle with type a = string module Pickle_int32 : Pickle with type a = int32 module Pickle_int64 : Pickle with type a = int64 module Pickle_nativeint : Pickle with type a = nativeint module Pickle_option (V0 : Pickle) : Pickle with type a = V0.a option module Pickle_list (V0 : Pickle) : Pickle with type a = V0.a list module Pickle_ref (S : Pickle) : Pickle with type a = S.a ref module Pickle_from_dump (P : Dump) (E : Eq with type a = P.a) (T : Typeable with type a = P.a) : Pickle with type a = P.a deriving-0.7.1/lib/deriving_Show.ml000066400000000000000000000144221272135405000172370ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) module Deriving_Show = struct (** Show **) module type Show = sig type a val format : Format.formatter -> a -> unit val format_list : Format.formatter -> a list -> unit val show : a -> string val show_list : a list -> string end module type SimpleFormatter = sig type a val format : Format.formatter -> a -> unit end module ShowFormatterDefault (S : SimpleFormatter) = struct include S let format_list formatter items = let rec writeItems formatter = function | [] -> () | [x] -> S.format formatter x; | x :: xs -> Format.fprintf formatter "%a;@;%a" S.format x writeItems xs in Format.fprintf formatter "@[[%a]@]" writeItems items end module ShowDefaults' (S : (sig type a val format : Format.formatter -> a -> unit val format_list : Format.formatter -> a list -> unit end)) : Show with type a = S.a = struct include S let showFormatted f item = let b = Buffer.create 16 in let formatter = Format.formatter_of_buffer b in Format.fprintf formatter "@[%a@]@?" f item; Buffer.sub b 0 (Buffer.length b) (* Warning: do not eta-reduce either of the following *) let show item = showFormatted S.format item let show_list items = showFormatted S.format_list items end module Defaults (S : SimpleFormatter) : Show with type a = S.a = ShowDefaults' (ShowFormatterDefault (S)) module Show_unprintable (S : sig type a end) (*: Show with type a = S.a *) = Defaults (struct type a = S.a let format formatter _ = Format.pp_print_string formatter "..." end) (* instance Show a => Show [a] *) module Show_list (S : Show) : Show with type a = S.a list = Defaults (struct type a = S.a list let format = S.format_list end) (* instance Show a => Show (a option) *) module Show_option (S : Show) : Show with type a = S.a option = Defaults (struct type a = S.a option let format formatter = function | None -> Format.fprintf formatter "@[None@]" | Some s -> Format.fprintf formatter "@[Some@;<1 2>(%a)@]" S.format s end) (* instance Show a => Show (a array) *) module Show_array (S : Show) : Show with type a = S.a array = Defaults (struct type a = S.a array let format formatter obj = let writeItems formatter items = let length = Array.length items in for i = 0 to length - 2 do Format.fprintf formatter "@[%a;@;@]" S.format (Array.get items i) done; if length <> 0 then S.format formatter (Array.get items (length -1)); in Format.fprintf formatter "@[[|%a|]@]" writeItems obj end) module Show_map (O : Map.OrderedType) (K : Show with type a = O.t) (V : Show) : Show with type a = V.a Map.Make(O).t = Defaults( struct module M = Map.Make(O) type a = V.a M.t let format formatter map = Format.pp_open_box formatter 0; Format.pp_print_string formatter "{"; M.iter (fun key value -> Format.pp_open_box formatter 0; K.format formatter key; Format.pp_print_string formatter " => "; V.format formatter value; Format.fprintf formatter ";@;"; Format.pp_close_box formatter (); ) map; Format.pp_print_string formatter "}"; Format.pp_close_box formatter (); end) module Show_set (O : Set.OrderedType) (K : Show with type a = O.t) : Show with type a = Set.Make(O).t = Defaults( struct module S = Set.Make(O) type a = S.t let format formatter set = Format.pp_open_box formatter 0; Format.pp_print_string formatter "{"; S.iter (fun elt -> Format.pp_open_box formatter 0; K.format formatter elt; Format.fprintf formatter ";@;"; Format.pp_close_box formatter (); ) set; Format.pp_print_string formatter "}"; Format.pp_close_box formatter (); end) module Show_bool = Defaults (struct type a = bool let format formatter item = match item with | true -> Format.pp_print_string formatter "true" | false -> Format.pp_print_string formatter "false" end) module Show_integer (S : sig type t val to_string : t -> string end) = Defaults (struct type a = S.t let format formatter item = Format.pp_print_string formatter (S.to_string item) end) module Show_int32 = Show_integer(Int32) module Show_int64 = Show_integer(Int64) module Show_nativeint = Show_integer(Nativeint) module Show_char = Defaults (struct type a = char let format formatter item = Format.pp_print_string formatter ("'" ^ Char.escaped item ^ "'") end) module Show_int = Defaults (struct type a = int let format formatter item = Format.pp_print_string formatter (string_of_int item) end) module Show_float = Defaults(struct type a = float let format formatter item = Format.pp_print_string formatter (string_of_float item) end) module Show_string = Defaults (struct type a = string let format formatter item = Format.pp_print_char formatter '"'; Format.pp_print_string formatter (String.escaped item); Format.pp_print_char formatter '"' end) module Show_unit = Defaults(struct type a = unit let format formatter () = Format.pp_print_string formatter "()" end) end include Deriving_Show type open_flag = Pervasives.open_flag = | Open_rdonly | Open_wronly | Open_append | Open_creat | Open_trunc | Open_excl | Open_binary | Open_text | Open_nonblock deriving (Show) type fpclass = Pervasives.fpclass = | FP_normal | FP_subnormal | FP_zero | FP_infinite | FP_nan deriving (Show) type 'a ref = 'a Pervasives.ref = { mutable contents : 'a; } deriving (Show) deriving-0.7.1/lib/deriving_Show.mli000066400000000000000000000024531272135405000174110ustar00rootroot00000000000000module type Show = sig type a val format : Format.formatter -> a -> unit val format_list : Format.formatter -> a list -> unit val show : a -> string val show_list : a list -> string end module Defaults (S : sig type a val format : Format.formatter -> a -> unit end) : Show with type a = S.a module Show_unprintable (S : sig type a end) : Show with type a = S.a module Show_char : Show with type a = char module Show_bool : Show with type a = bool module Show_unit : Show with type a = unit module Show_int : Show with type a = int module Show_int32 : Show with type a = int32 module Show_int64 : Show with type a = int64 module Show_nativeint : Show with type a = nativeint module Show_float : Show with type a = float module Show_string : Show with type a = string module Show_list (S : Show) : Show with type a = S.a list module Show_ref (S : Show) : Show with type a = S.a ref module Show_option (S : Show) : Show with type a = S.a option module Show_array (S : Show) : Show with type a = S.a array module Show_map (O : Map.OrderedType) (K : Show with type a = O.t) (V : Show) : Show with type a = V.a Map.Make(O).t module Show_set (O : Set.OrderedType) (K : Show with type a = O.t) : Show with type a = Set.Make(O).t deriving-0.7.1/lib/deriving_Typeable.ml000066400000000000000000000204011272135405000200560ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) (** A type is viewed as the application of type constructors to zero or more type arguments. We provide equality and ordering operations on types. The ordering is unspecified, but consistent within a process, i.e. sufficient for use in Map etc. This might be considered to break abstraction, since it exposes the fact that two types are the same, even if that fact has been hidden by type abstraction (modules etc.). This is considered a good thing, since it assists with the intended use, which is to maximise value sharing. *) module TypeRep : sig type t type delayed = t Lazy.t val compare : t -> t -> int val eq : t -> t -> bool val mkFresh : string -> delayed list -> t val mkTuple : delayed list -> t val mkPolyv : (string * delayed option) list -> delayed list -> t end = struct module StringMap = Map.Make(Deriving_interned) module IntMap = Map.Make(struct type t = int let compare = Pervasives.compare end) module StringSet = Set.Make(Deriving_interned) let counter = ref 0 let fresh () = let c = !counter in incr counter; c type t = [`Variant of (delayed option StringMap.t) |`Gen of Deriving_interned.t * delayed list ] * int and delayed = t Lazy.t let make_fresh row : t = (* Just allocate a pointer for now. Dereference the row later *) `Variant row, fresh () module EqualMap = struct type map = int list IntMap.t let equalp : map -> int -> int -> bool = fun map l r -> try List.mem r (IntMap.find l map) with Not_found -> false let record_equality : map -> int -> int -> map = fun map l r -> let add map l r = try let vals = IntMap.find l map in IntMap.add l (r::vals) map with Not_found -> IntMap.add l [r] map in add (add map l r) r l end let keys : 'a StringMap.t -> StringSet.t = fun m -> StringMap.fold (fun k _ set -> StringSet.add k set) m StringSet.empty let rec equal : EqualMap.map -> t -> t -> bool = fun equalmap (l,lid) (r,rid) -> if lid = rid then true else if EqualMap.equalp equalmap lid rid then true else match l, r with | `Variant lrow, `Variant rrow -> (* distinct types. assume they're equal for now; record that fact in the map, then look inside the types for evidence to the contrary *) equal_rows (EqualMap.record_equality equalmap lid rid) lrow rrow | `Gen (lname, ls), `Gen (rname, rs) when Deriving_interned.eq lname rname -> List.for_all2 (fun l r -> equal equalmap (Lazy.force l) (Lazy.force r)) ls rs | _ -> false and equal_rows equalmap lfields rfields = equal_names lfields rfields && StringMap.fold (fun name t eq -> let t' = StringMap.find name rfields in match t, t' with | None, None -> eq | Some t, Some t' -> equal equalmap (Lazy.force t) (Lazy.force t') && eq | _ -> false) lfields true and equal_names lmap rmap = StringSet.equal (keys lmap) (keys rmap) let mkFresh name args = `Gen (Deriving_interned.intern name, args), fresh () let mkTuple args = mkFresh (string_of_int (List.length args)) args let mkPolyv (args : (string * delayed option) list) (extends : delayed list) = (* assume all extensions have to be completely known types at this point *) let initial = List.fold_left (fun map extension -> match fst (Lazy.force extension) with | `Variant map' -> StringMap.fold StringMap.add map map' | `Gen _ -> assert false) StringMap.empty extends in let row = List.fold_left (fun map (name, t) -> StringMap.add (Deriving_interned.intern name) t map) initial args in make_fresh row let eq = equal IntMap.empty let rec compare recargs (lrep,lid as l) (rrep,rid as r) = if eq l r then 0 else if EqualMap.equalp recargs lid rid then 0 else match lrep, rrep with | `Gen (lname, ls), `Gen (rname, rs) -> begin match Pervasives.compare lname rname with | 0 -> begin match Pervasives.compare (List.length ls) (List.length rs) with | 0 -> List.fold_left2 (fun cmp l r -> if cmp <> 0 then cmp else compare recargs (Lazy.force l) (Lazy.force r)) 0 ls rs | n -> n end | n -> n end | `Variant lrow, `Variant rrow -> compare_rows (EqualMap.record_equality recargs lid rid) lrow rrow | `Variant _, `Gen _ -> -1 | `Gen _, `Variant _ -> 1 and compare_rows recargs lrow rrow = match StringSet.compare (keys lrow) (keys rrow) with | 0 -> StringMap.compare (fun l r -> match l, r with | None, None -> 0 | Some l, Some r -> compare recargs (Lazy.force l) (Lazy.force r) | None, Some _ -> -1 | Some _, None -> 1) lrow rrow | n -> n let compare = compare IntMap.empty end (* Dynamic types *) type dynamic = Obj.t * TypeRep.t let tagOf (_, tag) = tag let untag (obj, tag) target = if TypeRep.eq tag target then Some obj else None (* Signature for type representations *) module type Typeable = sig type a val type_rep : TypeRep.t Lazy.t val has_type : dynamic -> bool val cast : dynamic -> a option val throwing_cast : dynamic -> a val make_dynamic : a -> dynamic val mk : a -> dynamic end exception CastFailure of string module Defaults (T : (sig type a val type_rep : TypeRep.t Lazy.t end)) : Typeable with type a = T.a = struct include T let has_type o = tagOf o = Lazy.force type_rep let cast d = match untag d (Lazy.force type_rep) with | Some c -> Some (Obj.obj c) | None -> None let make_dynamic o = (Obj.repr o, Lazy.force type_rep) let mk = make_dynamic let throwing_cast d = match cast d with | None -> (*raise (CastFailure ("cast from type "^ TypeRep.Show_t.show (tagOf d) ^" to type "^ TypeRep.Show_t.show (T.type_rep ()) ^" failed"))*) raise (CastFailure "cast failed") | Some s -> s end module Typeable_list (A:Typeable) : Typeable with type a = A.a list = Defaults(struct type a = A.a list let type_rep = lazy (TypeRep.mkFresh "Primitive.list" [A.type_rep]) end) module Typeable_option (A:Typeable) : Typeable with type a = A.a option = Defaults(struct type a = A.a option let type_rep = lazy (TypeRep.mkFresh "Primitive.option" [A.type_rep]) end) module Primitive_typeable (T : sig type t val magic : string end) : Typeable with type a = T.t = Defaults(struct type a = T.t let type_rep = lazy (TypeRep.mkFresh T.magic []) end) module Typeable_unit = Primitive_typeable(struct type t = unit let magic = "Primitive.unit" end) module Typeable_int = Primitive_typeable(struct type t = int let magic = "Primitive.int" end) module Typeable_float = Primitive_typeable(struct type t = float let magic = "Primitive.float" end) module Typeable_bool = Primitive_typeable(struct type t = bool let magic = "Primitive.bool" end) module Typeable_string = Primitive_typeable(struct type t = string let magic = "Primitive.string" end) module Typeable_char = Primitive_typeable(struct type t = char let magic = "Primitive.char" end) module Typeable_int32 = Primitive_typeable(struct type t = int32 let magic = "Primitive.int32" end) module Typeable_int64 = Primitive_typeable(struct type t = int64 let magic = "Primitive.int64" end) module Typeable_nativeint = Primitive_typeable(struct type t = nativeint let magic = "Primitive.nativeint" end) module Typeable_ref(A : Typeable) : Typeable with type a = A.a ref = Defaults(struct type a = A.a ref let type_rep = lazy (TypeRep.mkFresh "Primitive.ref" [A.type_rep]) end) deriving-0.7.1/lib/deriving_Typeable.mli000066400000000000000000000031601272135405000202320ustar00rootroot00000000000000module TypeRep : sig type t type delayed = t Lazy.t val compare : t -> t -> int val eq : t -> t -> bool val mkFresh : string -> delayed list -> t val mkTuple : delayed list -> t val mkPolyv : (string * delayed option) list -> delayed list -> t end exception CastFailure of string type dynamic val tagOf : dynamic -> TypeRep.t module type Typeable = sig type a val type_rep : TypeRep.t Lazy.t val has_type : dynamic -> bool val cast : dynamic -> a option val throwing_cast : dynamic -> a val make_dynamic : a -> dynamic val mk : a -> dynamic end module Defaults (T : (sig type a val type_rep : TypeRep.t Lazy.t end)) : Typeable with type a = T.a module Typeable_list (A : Typeable) : Typeable with type a = A.a list module Typeable_option (A : Typeable) : Typeable with type a = A.a option module Typeable_ref (A : Typeable) : Typeable with type a = A.a ref (*module Primitive_typeable (T : sig type t end): Typeable with type a = T.t *) module Typeable_unit : Typeable with type a = unit module Typeable_int : Typeable with type a = int module Typeable_float : Typeable with type a = float module Typeable_bool : Typeable with type a = bool module Typeable_string : Typeable with type a = string module Typeable_char : Typeable with type a = char module Typeable_int32 : Typeable with type a = int32 module Typeable_int64 : Typeable with type a = int64 module Typeable_nativeint : Typeable with type a = nativeint (**/**) module Primitive_typeable (T : sig type t val magic : string end) : Typeable with type a = T.t deriving-0.7.1/lib/deriving_dynmap.ml000066400000000000000000000032761272135405000176140ustar00rootroot00000000000000(* Finite maps : t -> dynamic *) (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) open Deriving_Typeable open Deriving_Eq module Comp (T : Typeable) (E : Eq with type a = T.a) = struct type a = T.a let adjust_comparator : (T.a -> T.a -> bool) -> dynamic -> dynamic -> bool = fun comparator d1 d2 -> match T.cast d1, T.cast d2 with | Some l, Some r -> comparator l r | _ -> assert false let eq = adjust_comparator E.eq end module DynMap = struct module TypeMap = Map.Make(TypeRep) type comparator = dynamic -> dynamic -> bool type 'value t = (((dynamic * 'value) list * comparator) TypeMap.t) let empty = TypeMap.empty let add dynamic value comparator map = let typeRep = tagOf dynamic in let monomap = try (List.filter (fun (k,_) -> not (comparator k dynamic)) (fst (TypeMap.find typeRep map))) with Not_found -> [] in TypeMap.add typeRep (((dynamic,value)::monomap), comparator) map let mem dynamic map = try let monomap, comparator = TypeMap.find (tagOf dynamic) map in (List.exists (fun (k,_) -> (comparator dynamic k)) monomap) with Not_found -> false let find dynamic map = try let monomap, comparator = TypeMap.find (tagOf dynamic) map in Some (snd (List.find (fun (k,_) -> comparator dynamic k) monomap)) with Not_found -> None let iter : (dynamic -> 'a -> unit) -> 'a t -> unit = fun f -> TypeMap.iter (fun _ (monomap,_) -> List.iter (fun (k, v) -> f k v) monomap) end deriving-0.7.1/lib/deriving_dynmap.mli000066400000000000000000000007511272135405000177600ustar00rootroot00000000000000(* Finite map : dynamic |-> t *) open Deriving_Typeable open Deriving_Eq module Comp (T : Typeable) (E : Eq with type a = T.a) : sig type a = T.a val eq : dynamic -> dynamic -> bool end module DynMap : sig type comparator = dynamic -> dynamic -> bool type 'a t val empty : 'a t val add : dynamic -> 'a -> comparator -> 'a t -> 'a t val mem : dynamic -> 'a t -> bool val find : dynamic -> 'a t -> 'a option val iter : (dynamic -> 'a -> unit) -> 'a t -> unit end deriving-0.7.1/lib/deriving_interned.ml000066400000000000000000000011641272135405000201260ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) (* Interned strings *) module BytesMap = Map.Make(Bytes) (* global state *) let map = ref BytesMap.empty let counter = ref 0 type t = int * string deriving (Show) let intern s = try BytesMap.find s !map with Not_found -> let fresh = (!counter, Bytes.of_string s) in begin map := BytesMap.add s fresh !map; incr counter; fresh end let to_string (_,s) = Bytes.to_string s let name = snd let compare (l,_) (r,_) = compare l r let eq (l,_) (r,_) = l = r deriving-0.7.1/lib/deriving_interned.mli000066400000000000000000000002371272135405000202770ustar00rootroot00000000000000(* Interned strings *) type t val compare : t -> t -> int val eq : t -> t -> bool val intern : string -> t val to_string : t -> string val name : t -> string deriving-0.7.1/lib/deriving_monad.ml000066400000000000000000000171771272135405000174270ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) module type Monad = sig type +'a m val return : 'a -> 'a m val fail : string -> 'a m val (>>=) : 'a m -> ('a -> 'b m) -> 'b m val (>>) : 'a m -> 'b m -> 'b m end module type MonadPlus = sig include Monad val mzero : 'a m val mplus : 'a m -> 'a m -> 'a m end module MonadDefault (M : sig type +'a m val return : 'a -> 'a m val fail : string -> 'a m val (>>=) : 'a m -> ('a -> 'b m) -> 'b m end) : Monad with type 'a m = 'a M.m = struct include M let (>>) x y = x >>= (fun _ -> y) end module Monad_option : MonadPlus with type 'a m = 'a option = struct include MonadDefault( struct type 'a m = 'a option let fail _ = None let return x = Some x let (>>=) x f = match x with | None -> None | Some x -> f x end) let mzero = None let mplus l r = match l, r with | None, r -> r | l, _ -> l end module Monad_list : MonadPlus with type 'a m = 'a list = struct include MonadDefault( struct type 'a m = 'a list let return x = [x] let fail _ = [] let (>>=) m f = List.concat (List.map f m) end) let mzero = [] let mplus = (@) end module IO = (struct type 'a m = unit -> 'a let return a = fun () -> a let (>>=) m k = fun () -> let v = m () in k v () let (>>) x y = x >>= (fun _ -> y) let fail = failwith let putStr s = fun () -> print_string s let runIO f = f () let mkIO (f : unit -> 'b) = return (f ()) end) module type MonadUtilsSig = sig include Monad val liftM : ('a -> 'b) -> 'a m -> 'b m val liftM2 : ('a -> 'b -> 'c) -> 'a m -> 'b m -> 'c m val liftM3 : ('a -> 'b -> 'c -> 'd) -> 'a m -> 'b m -> 'c m -> 'd m val liftM4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a m -> 'b m -> 'c m -> 'd m -> 'e m val liftM5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'a m -> 'b m -> 'c m -> 'd m -> 'e m -> 'f m val ap : ('a -> 'b) m -> 'a m -> 'b m val sequence : 'a m list -> 'a list m val sequence_ : 'a m list -> unit m val mapM : ('a -> 'b m) -> 'a list -> 'b list m val mapM_ : ('a -> 'b m) -> 'a list -> unit m val ( =<< ) : ('a -> 'b m) -> 'a m -> 'b m val join : 'a m m -> 'a m val filterM : ('a -> bool m) -> 'a list -> 'a list m val mapAndUnzipM : ('a -> ('b * 'c) m) -> 'a list -> ('b list * 'c list) m val zipWithM : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> 'c list m val zipWithM_ : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> unit m val foldM : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m val foldM_ : ('a -> 'b -> 'a m) -> 'a -> 'b list -> unit m val replicateM : int -> 'a m -> 'a list m val replicateM_ : int -> 'a m -> unit m val quand : bool -> unit m -> unit m val unless : bool -> unit m -> unit m end (* Control.Monad *) module MonadUtils (M : Monad) = struct include M let liftM : ('a1 -> 'r) -> 'a1 m -> 'r m = fun f m1 -> m1 >>= (fun x1 -> return (f x1)) let liftM2 : ('a1 -> 'a2 -> 'r) -> 'a1 m -> 'a2 m -> 'r m = fun f m1 m2 -> m1 >>= (fun x1 -> m2 >>= (fun x2 -> return (f x1 x2))) let liftM3 : ('a1 -> 'a2 -> 'a3 -> 'r) -> 'a1 m -> 'a2 m -> 'a3 m -> 'r m = fun f m1 m2 m3 -> m1 >>= (fun x1 -> m2 >>= (fun x2 -> m3 >>= (fun x3 -> return (f x1 x2 x3)))) let liftM4 : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'r) -> 'a1 m -> 'a2 m -> 'a3 m -> 'a4 m -> 'r m = fun f m1 m2 m3 m4 -> m1 >>= (fun x1 -> m2 >>= (fun x2 -> m3 >>= (fun x3 -> m4 >>= (fun x4 -> return (f x1 x2 x3 x4))))) let liftM5 : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'r) -> 'a1 m -> 'a2 m -> 'a3 m -> 'a4 m -> 'a5 m -> 'r m = fun f m1 m2 m3 m4 m5 -> m1 >>= (fun x1 -> m2 >>= (fun x2 -> m3 >>= (fun x3 -> m4 >>= (fun x4 -> m5 >>= (fun x5 -> return (f x1 x2 x3 x4 x5)))))) let ap : ('a -> 'b) m -> 'a m -> 'b m = fun f -> liftM2 (fun x -> x) f let sequence : ('a m) list -> ('a list) m = let mcons p q = p >>= (fun x -> q >>= (fun y -> return (x::y))) in fun l -> List.fold_right mcons l (return []) let sequence_ : ('a m) list -> unit m = fun l -> List.fold_right (>>) l (return ()) let mapM : ('a -> 'b m) -> 'a list -> ('b list) m = fun f xs -> sequence (List.map f xs) let mapM_ : ('a -> 'b m) -> 'a list -> unit m = fun f xs -> sequence_ (List.map f xs) let (=<<) : ('a -> 'b m) -> 'a m -> 'b m = fun f x -> x >>= f let join : ('a m) m -> 'a m = fun x -> x >>= (fun x -> x) let rec filterM : ('a -> bool m) -> 'a list -> ('a list) m = fun p -> function | [] -> return [] | x::xs -> p x >>= (fun flg -> filterM p xs >>= (fun ys -> return (if flg then (x::ys) else ys))) let mapAndUnzipM : ('a -> ('b *'c) m) -> 'a list -> ('b list * 'c list) m = fun f xs -> sequence (List.map f xs) >>= fun x -> return (List.split x) let zipWithM : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> ('c list) m = fun f xs ys -> sequence (List.map2 f xs ys) let zipWithM_ : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> unit m = fun f xs ys -> sequence_ (List.map2 f xs ys) let rec foldM : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m = fun f a -> function | [] -> return a | x::xs -> f a x >>= (fun fax -> foldM f fax xs) let foldM_ : ('a -> 'b -> 'a m) -> 'a -> 'b list -> unit m = fun f a xs -> foldM f a xs >> return () let ((replicateM : int -> 'a m -> ('a list) m), (replicateM_ : int -> 'a m -> unit m)) = let replicate n i = let rec aux accum = function | 0 -> accum | n -> aux (i::accum) (n-1) in aux [] n in ((fun n x -> sequence (replicate n x)), (fun n x -> sequence_ (replicate n x))) let quand (* when *) : bool -> unit m -> unit m = fun p s -> if p then s else return () let unless : bool -> unit m -> unit m = fun p s -> if p then return () else s end module type MonadPlusUtilsSig = sig include MonadUtilsSig val mzero : 'a m val mplus : 'a m -> 'a m -> 'a m val guard : bool -> unit m val msum : 'a m list -> 'a m end module MonadPlusUtils (M : MonadPlus) = struct include MonadUtils(M) let mzero = M.mzero let mplus = M.mplus let guard : bool -> unit M.m = function | true -> M.return () | false -> M.mzero let msum : ('a M.m) list -> 'a M.m = fun l -> List.fold_right M.mplus l M.mzero end module MonadPlusUtils_option = MonadPlusUtils(Monad_option) module MonadPlusUtils_list = MonadPlusUtils(Monad_list) module Monad_IO = MonadUtils(MonadDefault (IO)) module type Monad_state_type = sig include MonadUtilsSig type state val get : state m val put : state -> unit m val runState : 'a m -> state -> 'a * state end module Monad_state_impl (A : sig type state end) = struct type state = A.state type 'a m = State of (A.state -> ('a * A.state)) let get = State (fun s -> s,s) let put s = State (fun _ -> (), s) let runState (State s) = s let return a = State (fun state -> (a, state)) let fail s = failwith ("state monad error " ^ s) let (>>=) (State x) f = State (fun s -> (let v, s' = x s in runState (f v) s')) let (>>) s f = s >>= fun _ -> f end module Monad_state(S : sig type state end) : Monad_state_type with type state = S.state = struct module M = Monad_state_impl(S) include MonadUtils(M) type state = M.state let get = M.get let put = M.put let runState = M.runState end deriving-0.7.1/lib/deriving_monad.mli000066400000000000000000000054441272135405000175720ustar00rootroot00000000000000module type Monad = sig type +'a m val return : 'a -> 'a m val fail : string -> 'a m val ( >>= ) : 'a m -> ('a -> 'b m) -> 'b m val ( >> ) : 'a m -> 'b m -> 'b m end module type MonadPlus = sig include Monad val mzero : 'a m val mplus : 'a m -> 'a m -> 'a m end module MonadDefault (M : sig type +'a m val return : 'a -> 'a m val fail : string -> 'a m val ( >>= ) : 'a m -> ('a -> 'b m) -> 'b m end) : Monad with type +'a m = 'a M.m module Monad_option : MonadPlus with type 'a m = 'a option module Monad_list : MonadPlus with type 'a m = 'a list module IO : sig include Monad val putStr : string -> unit m val runIO : 'a m -> 'a val mkIO : (unit -> 'b) -> 'b m end module type MonadUtilsSig = sig include Monad val liftM : ('a -> 'b) -> 'a m -> 'b m val liftM2 : ('a -> 'b -> 'c) -> 'a m -> 'b m -> 'c m val liftM3 : ('a -> 'b -> 'c -> 'd) -> 'a m -> 'b m -> 'c m -> 'd m val liftM4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a m -> 'b m -> 'c m -> 'd m -> 'e m val liftM5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'a m -> 'b m -> 'c m -> 'd m -> 'e m -> 'f m val ap : ('a -> 'b) m -> 'a m -> 'b m val sequence : 'a m list -> 'a list m val sequence_ : 'a m list -> unit m val mapM : ('a -> 'b m) -> 'a list -> 'b list m val mapM_ : ('a -> 'b m) -> 'a list -> unit m val ( =<< ) : ('a -> 'b m) -> 'a m -> 'b m val join : 'a m m -> 'a m val filterM : ('a -> bool m) -> 'a list -> 'a list m val mapAndUnzipM : ('a -> ('b * 'c) m) -> 'a list -> ('b list * 'c list) m val zipWithM : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> 'c list m val zipWithM_ : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> unit m val foldM : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m val foldM_ : ('a -> 'b -> 'a m) -> 'a -> 'b list -> unit m val replicateM : int -> 'a m -> 'a list m val replicateM_ : int -> 'a m -> unit m val quand : bool -> unit m -> unit m val unless : bool -> unit m -> unit m end module MonadUtils (M : Monad) : MonadUtilsSig with type 'a m = 'a M.m module type MonadPlusUtilsSig = sig include MonadUtilsSig val mzero : 'a m val mplus : 'a m -> 'a m -> 'a m val guard : bool -> unit m val msum : 'a m list -> 'a m end module MonadPlusUtils (M : MonadPlus) : MonadPlusUtilsSig with type 'a m = 'a M.m module MonadPlusUtils_option : MonadPlusUtilsSig with type 'a m = 'a Monad_option.m module MonadPlusUtils_list : MonadPlusUtilsSig with type 'a m = 'a Monad_list.m module Monad_IO : MonadUtilsSig with type 'a m = 'a IO.m module type Monad_state_type = sig include MonadUtilsSig type state val get : state m val put : state -> unit m val runState : 'a m -> state -> 'a * state end module Monad_state (S : sig type state end) : Monad_state_type with type state = S.state deriving-0.7.1/lib/deriving_num.ml000066400000000000000000000016141272135405000171150ustar00rootroot00000000000000 module Show_num = Deriving_Show.Defaults (struct type a = Num.num let format formatter item = Format.pp_print_string formatter (Num.string_of_num item) end) module Typeable_num = Deriving_Typeable.Primitive_typeable(struct type t = Num.num let magic = "Primitive.Num.num" end) module Eq_num : Deriving_Eq.Eq with type a = Num.num = struct type a = Num.num let eq = Num.eq_num end module Dump_num = Deriving_Dump.Defaults ( struct (* TODO: a less wasteful dumper for nums. A good start would be using half a byte per decimal-coded digit, instead of a whole byte. *) type a = Num.num let to_buffer buffer n = Deriving_Dump.Dump_string.to_buffer buffer (Num.string_of_num n) and from_stream stream = Num.num_of_string (Deriving_Dump.Dump_string.from_stream stream) end ) module Pickle_num = Deriving_Pickle.Pickle_from_dump(Dump_num)(Eq_num)(Typeable_num) deriving-0.7.1/lib/deriving_num.mli000066400000000000000000000005171272135405000172670ustar00rootroot00000000000000 module Show_num : Deriving_Show.Show with type a = Num.num module Eq_num : Deriving_Eq.Eq with type a = Num.num module Typeable_num : Deriving_Typeable.Typeable with type a = Num.num module Dump_num : Deriving_Dump.Dump with type a = Num.num module Pickle_num : Deriving_Pickle.Pickle with type a = Num.num deriving-0.7.1/myocamlbuild.ml000066400000000000000000000046161272135405000163470ustar00rootroot00000000000000(* OASIS_START *) (* OASIS_STOP *) let _ = (* FIX START *) (* fix needed by ocaml(build) 3.12.1(,4.00.1?) in order to pick the right ocamlfind *) (* Fixed in later version with the following commit *) (* ocamlbuild should look for ocamlfind on the path not in the root directory *) (* https://github.com/ocaml/ocaml/commit/9d51dccfaebb2c3303ae0bb1d4f28fe6f8d10915 *) let _ = Ocamlbuild_pack.Ocamlbuild_where.bindir := "/" in (* FIX STOP *) Ocamlbuild_plugin.dispatch (fun hook -> dispatch_default hook; match hook with | After_rules -> (* Internal syntax extension *) List.iter (fun dir -> let tag = "use_pa_deriving_" ^ dir and file = "syntax/" ^ dir ^ "/pa_deriving_" ^ dir ^ ".cma" in flag ["ocaml"; "compile"; tag] & S[A"-ppopt"; A file]; flag ["ocaml"; "ocamldep"; tag] & S[A"-ppopt"; A file]; flag ["ocaml"; "doc"; tag] & S[A"-ppopt"; A file]; dep ["ocaml"; "ocamldep"; tag] [file]) ["common"; "std"; "tc"; "classes"]; (* Use an introduction page with categories *) tag_file "deriving-api.docdir/index.html" ["apiref"]; dep ["apiref"] ["doc/apiref-intro"]; flag ["apiref"] & S[A "-intro"; P "doc/apiref-intro"; A"-colorize-code"]; | _ -> ()) (* Compile the wiki version of the Ocamldoc. Thanks to Till Varoquaux on usenet: http://www.digipedia.pl/usenet/thread/14273/231/ *) let ocamldoc_wiki tags deps docout docdir = let tags = tags -- "extension:html" in Ocamlbuild_pack.Ocaml_tools.ocamldoc_l_dir tags deps docout docdir let () = try let wikidoc_dir = let base = Ocamlbuild_pack.My_unix.run_and_read "ocamlfind query wikidoc" in String.sub base 0 (String.length base - 1) in Ocamlbuild_pack.Rule.rule "ocamldoc: document ocaml project odocl & *odoc -> wikidocdir" ~insert:`top ~prod:"%.wikidocdir/index.wiki" ~stamp:"%.wikidocdir/wiki.stamp" ~dep:"%.odocl" (Ocamlbuild_pack.Ocaml_tools.document_ocaml_project ~ocamldoc:ocamldoc_wiki "%.odocl" "%.wikidocdir/index.wiki" "%.wikidocdir"); tag_file "deriving-api.wikidocdir/index.wiki" ["apiref";"wikidoc"]; flag ["wikidoc"] & S[A"-i";A wikidoc_dir;A"-g";A"odoc_wiki.cma"] with Failure e -> () (* Silently fail if the package wikidoc isn't available *) deriving-0.7.1/opam000066400000000000000000000012131272135405000142010ustar00rootroot00000000000000opam-version: "1.2" name: "deriving" version: "dev" maintainer: "dev@ocsigen.org" author: "Jeremy Yallop " homepage: "http://github.com/ocsigen/deriving/" bug-reports: "https://github.com/ocsigen/deriving/issues/" dev-repo: "https://github.com/ocsigen/deriving.git" license: "MIT" build: [ [ "./configure" "--prefix" prefix "--%{type_conv:enable}%-tc" ] [ make ] ] install: [ make "install" ] remove: [ "ocamlfind" "remove" "deriving" ] depends: [ "ocamlfind" "camlp4" "optcomp" ## OASIS is not required in released version "oasis" {>= "0.4.4"} ] depopts: [ "type_conv" ] conflicts: [ "type_conv" {< "108.07.00"} ] deriving-0.7.1/setup.ml000066400000000000000000000034561272135405000150270ustar00rootroot00000000000000 (* OASIS_START *) (* DO NOT EDIT (digest: 172e37fc4b327922311f6cf9389bc560) *) (******************************************************************************) (* OASIS: architecture for building OCaml libraries and applications *) (* *) (* Copyright (C) 2011-2013, Sylvain Le Gall *) (* Copyright (C) 2008-2011, OCamlCore SARL *) (* *) (* This library is free software; you can redistribute it and/or modify it *) (* under the terms of the GNU Lesser General Public License as published by *) (* the Free Software Foundation; either version 2.1 of the License, or (at *) (* your option) any later version, with the OCaml static compilation *) (* exception. *) (* *) (* This library is distributed in the hope that it will be useful, but *) (* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *) (* or FITNESS FOR A PARTICULAR PURPOSE. See the file COPYING for more *) (* details. *) (* *) (* You should have received a copy of the GNU Lesser General Public License *) (* along with this library; if not, write to the Free Software Foundation, *) (* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (******************************************************************************) open OASISDynRun (* OASIS_STOP *) let () = setup ();; deriving-0.7.1/syntax/000077500000000000000000000000001272135405000146535ustar00rootroot00000000000000deriving-0.7.1/syntax/classes/000077500000000000000000000000001272135405000163105ustar00rootroot00000000000000deriving-0.7.1/syntax/classes/bounded_class.ml000066400000000000000000000060471272135405000214560ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) open Pa_deriving_common open Utils module Description : Defs.ClassDescription = struct let classname = "Bounded" let runtimename = "Deriving_Bounded" let default_module = None let alpha = None let allow_private = false let predefs = [ ["unit"], ["Deriving_Bounded";"unit"]; ["bool"], ["Deriving_Bounded";"bool"]; ["char"], ["Deriving_Bounded";"char"]; ["int"], ["Deriving_Bounded";"int"]; ["int32"], ["Deriving_Bounded";"int32"]; ["Int32";"t"], ["Deriving_Bounded";"int32"]; ["int64"], ["Deriving_Bounded";"int64"]; ["Int64";"t"], ["Deriving_Bounded";"int64"]; ["nativeint"], ["Deriving_Bounded";"nativeint"]; ["open_flag"], ["Deriving_Bounded";"open_flag"]; ["fpclass"], ["Deriving_Bounded";"fpclass"]; ] let depends = [] end module Builder(Generator : Defs.Generator) = struct open Generator.Loc open Camlp4.PreCast open Description module Helpers = Generator.AstHelpers let wrap min max = [ <:str_item< let min_bound = $min$ >>; <:str_item< let max_bound = $max$ >> ] let generator = (object (self) inherit Generator.generator method proxy () = None, [ <:ident< min_bound >>; <:ident< max_bound >>; ] method tuple ctxt ts = let expr t = let e = self#expr ctxt t in <:expr< let module M = $e$ in M.min_bound >>, <:expr< let module M = $e$ in M.max_bound >> in let minBounds, maxBounds = List.split (List.map expr ts) in wrap (Helpers.tuple_expr minBounds) (Helpers.tuple_expr maxBounds) method sum ?eq ctxt tname params constraints summands = let extract_name = function | (name,[]) -> name | (name,_) -> raise (Base.Underivable (classname ^" cannot be derived for the type " ^ tname ^ " because the constructor " ^ name ^ " is not nullary")) in let names = List.map extract_name summands in wrap <:expr< $uid:List.hd names$ >> <:expr< $uid:List.last names$ >> method variant ctxt tname params constraints (_, tags) = let extract_name = function | Type.Tag (name, []) -> name | Type.Tag (name, _) -> raise (Base.Underivable (classname^" cannot be derived because " ^ "the tag " ^ name^" is not nullary")) | _ -> raise (Base.Underivable (classname^" cannot be derived for this " ^ "polymorphic variant type")) in let names = List.map extract_name tags in wrap <:expr< `$List.hd names$ >> <:expr< `$List.last names$ >> (* should perhaps implement this one *) method record ?eq _ tname params constraints = raise (Base.Underivable (classname^" cannot be derived for record types (i.e. " ^ tname ^ ")")) end :> Generator.generator) let generate = Generator.generate generator let generate_sigs = Generator.generate_sigs generator end include Base.RegisterClass(Description)(Builder) deriving-0.7.1/syntax/classes/default_class.ml000066400000000000000000000057071272135405000214640ustar00rootroot00000000000000open Pa_deriving_common open Utils module Description : Defs.ClassDescription = struct let classname = "Default" let default_module = None let runtimename = "Deriving_Default" let alpha = None let allow_private = true let predefs = [ ["int" ], ["Deriving_Default";"int"]; ["bool" ], ["Deriving_Default";"bool"]; ["unit" ], ["Deriving_Default";"unit"]; ["char" ], ["Deriving_Default";"char"]; ["int32" ], ["Deriving_Default";"int32"]; ["Int32";"t"], ["Deriving_Default";"int32"]; ["int64" ], ["Deriving_Default";"int64"]; ["Int64";"t"], ["Deriving_Default";"int64"]; ["nativeint"], ["Deriving_Default";"nativeint"]; ["float" ], ["Deriving_Default";"float"]; ["string" ], ["Deriving_Default";"string"]; ["list" ], ["Deriving_Default";"list"]; ["ref" ], ["Deriving_Default";"ref"]; ["option" ], ["Deriving_Default";"option"]; ["array" ], ["Deriving_Default";"array"]; ] let depends = [] end module Builder(Generator : Defs.Generator) = struct open Generator.Loc open Camlp4.PreCast open Description module Helpers = Generator.AstHelpers let wrap expr = [ <:str_item< let default () = $expr$ >> ] let generator = (object (self) inherit Generator.generator method proxy unit = None, [ <:ident< default >> ] method tuple ctxt args = let l : Ast.expr list = List.map (fun ty -> <:expr<$self#call_expr ctxt ty "default"$ () >>) args in wrap (Helpers.tuple_expr l) method case ctxt (name, args) = match args with | [] -> <:expr< $uid:name$ >> | _ -> let tuple = List.map (fun ty -> <:expr<$self#call_expr ctxt ty "default"$ () >>) args in <:expr< $uid:name$ $Helpers.tuple_expr tuple$ >> method sum ?eq ctxt tname params constraints summands = wrap (self#case ctxt (List.hd summands)) method record ?eq ctxt tname params constraints fields = let contents = List.map (fun (name, (_,ty), _) -> name, <:expr< $ self # call_expr ctxt ty "default"$ ()>> ) fields in wrap (Helpers.record_expr contents) method polycase ctxt = function | Type.Tag (name, []) -> <:expr< `$name$ >> | Type.Tag (name, [ty]) -> let c = self#call_expr ctxt ty "default" in <:expr<`$name$ ($c$ ()) >> | Type.Tag (name, tys) -> let ty = `Tuple tys in let c = self#call_expr ctxt ty "default" in <:expr<`$name$ ($c$ ()) >> | Type.Extends t -> <:expr< assert false >> method variant ctxt tname params constraints (_,tags) = wrap (self#polycase ctxt (List.hd tags)) end :> Generator.generator) let classname = Description.classname let runtimename = Description.runtimename let generate = Generator.generate generator let generate_sigs = Generator.generate_sigs generator let generate_expr = Generator.generate_expr generator end include Base.RegisterFullClass(Description)(Builder) deriving-0.7.1/syntax/classes/dump_class.ml000066400000000000000000000137701272135405000210040ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) open Pa_deriving_common open Utils module Description : Defs.ClassDescription = struct let classname = "Dump" let runtimename = "Deriving_Dump" let default_module = Some "Defaults" let alpha = Some "Dump_alpha" let allow_private = false let predefs = [ ["unit"], ["Deriving_Dump";"unit"]; ["bool"], ["Deriving_Dump";"bool"]; ["char"], ["Deriving_Dump";"char"]; ["int"], ["Deriving_Dump";"int"]; ["int32"], ["Deriving_Dump";"int32"]; ["Int32";"t"], ["Deriving_Dump";"int32"]; ["int64"], ["Deriving_Dump";"int64"]; ["Int64";"t"], ["Deriving_Dump";"int64"]; ["nativeint"], ["Deriving_Dump";"nativeint"]; ["float"], ["Deriving_Dump";"float"]; ["num"], ["Deriving_Dump";"num"]; ["string"], ["Deriving_Dump";"string"]; ["list"], ["Deriving_Dump";"list"]; ["option"], ["Deriving_Dump";"option"]; ] let depends = [] end module Builder(Generator : Defs.Generator) = struct open Generator.Loc open Camlp4.PreCast open Description module Helpers = Generator.AstHelpers let wrap ?(buffer="buffer") ?(stream="stream") to_buffer from_stream = [ <:str_item< let to_buffer $lid:buffer$ = function $list:to_buffer$ >> ; <:str_item< let from_stream $lid:stream$ = $from_stream$ >> ] let generator = (object (self) inherit Generator.generator method proxy () = None, [ <:ident< to_buffer >>; <:ident< to_string >>; <:ident< to_channel >>; <:ident< from_stream >>; <:ident< from_string >>; <:ident< from_channel >>; ] method dump_int ctxt n = <:expr< $self#call_expr ctxt (`Constr (["int"],[])) "to_buffer"$ buffer $`int:n$ >> method read_int ctxt = <:expr< $self#call_expr ctxt (`Constr (["int"],[])) "from_stream"$ stream >> method nargs ctxt tvars args = let to_buffer id ty = <:expr< $self#call_expr ctxt ty "to_buffer"$ buffer $lid:id$ >> in let from_stream id ty e = <:expr< let $lid:id$ = $self#call_expr ctxt ty "from_stream"$ stream in $e$ >> in Helpers.seq_list (List.map2 to_buffer tvars args), (fun expr -> List.fold_right2 from_stream tvars args expr) method tuple ctxt tys = let tvars, patt, expr = Helpers.tuple (List.length tys) in let dumper, undump = self#nargs ctxt tvars tys in wrap [ <:match_case< $patt$ -> $dumper$ >> ] (undump expr) method case ctxt (ctor,args) n = match args with | [] -> <:match_case< $uid:ctor$ -> $self#dump_int ctxt n$ >>, <:match_case< $`int:n$ -> $uid:ctor$ >> | _ -> let tvars, patt, expr = Helpers.tuple (List.length args) in let expr = <:expr< $uid:ctor$ $expr$ >> in let dumper, undumper = self#nargs ctxt tvars args in <:match_case< $uid:ctor$ $patt$ -> $self#dump_int ctxt n$; $dumper$ >>, <:match_case< $`int:n$ -> $undumper expr$ >> method sum ?eq ctxt tname params constraints summands = let msg = "Dump: unexpected tag %d at character %d when deserialising " ^ tname in let dumpers, undumpers = List.split (List.mapn (self#case ctxt) summands) in let undumpers = <:expr< match $self#read_int ctxt$ with $list:undumpers$ | n -> raise ($uid:runtimename$.$uid:classname^ "_error"$ (Printf.sprintf $str:msg$ n (Stream.count stream))) >> in wrap dumpers undumpers method field ctxt (name, ty, mut) = if mut = `Mutable then raise (Base.Underivable (classname ^ " cannot be derived for record types " ^ " with mutable fields (" ^ name ^ ")")); <:expr< $self#call_poly_expr ctxt ty "to_buffer"$ buffer $lid:name$ >>, <:binding< $lid:name$ = $self#call_poly_expr ctxt ty "from_stream"$ stream >> method record ?eq ctxt tname params constraints fields = let dumpers, undumpers = List.split (List.map (self#field ctxt) fields) in let bind b e = <:expr< let $b$ in $e$ >> in let undump = List.fold_right bind undumpers (Helpers.record_expression fields) in let dumper = <:match_case< $Helpers.record_pattern fields$ -> $Helpers.seq_list dumpers$ >> in wrap [dumper] undump method polycase ctxt tagspec n : Ast.match_case * Ast.match_case = match tagspec with | Type.Tag (name, []) -> <:match_case< `$name$ -> $self#dump_int ctxt n$ >>, <:match_case< $`int:n$ -> `$name$ >> | Type.Tag (name, es) -> let to_buffer = <:expr< $self#call_expr ctxt (`Tuple es) "to_buffer"$ buffer x >> in let from_stream = <:expr< $self#call_expr ctxt (`Tuple es) "from_stream"$ stream >> in <:match_case< `$name$ x -> $self#dump_int ctxt n$; $to_buffer$ >>, <:match_case< $`int:n$ -> `$name$ ($from_stream$) >> | Type.Extends t -> let patt, guard, cast = Generator.cast_pattern ctxt t in let to_buffer = <:expr< $self#call_expr ctxt t "to_buffer"$ buffer $cast$ >> in let from_stream = <:expr< $self#call_expr ctxt t "from_stream"$ stream >> in <:match_case< $patt$ when $guard$ -> $self#dump_int ctxt n$; $to_buffer$ >>, <:match_case< $`int:n$ -> ($from_stream$ :> a) >> method variant ctxt tname params constraints (_, tags) = let msg = "Dump: unexpected tag %d at character %d " ^ "when deserialising polymorphic variant" in let dumpers, undumpers = List.split (List.mapn (self#polycase ctxt) tags) in let undumpers = <:expr< match $self#read_int ctxt$ with $list:undumpers$ | n -> raise ($uid:runtimename$.$uid:classname^ "_error"$ (Printf.sprintf $str:msg$ n (Stream.count stream))) >> in wrap (dumpers @ [ <:match_case< _ -> assert false >>]) undumpers end :> Generator.generator) let generate = Generator.generate generator let generate_sigs = Generator.generate_sigs generator end include Base.RegisterClass(Description)(Builder) deriving-0.7.1/syntax/classes/enum_class.ml000066400000000000000000000055531272135405000210030ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) open Pa_deriving_common open Utils module Description : Defs.ClassDescription = struct let classname = "Enum" let runtimename = "Deriving_Enum" let default_module = Some "Defaults" let alpha = None let allow_private = false let predefs = [ ["int"], ["Deriving_Enum";"int"]; ["bool"], ["Deriving_Enum";"bool"]; ["unit"], ["Deriving_Enum";"unit"]; ["char"], ["Deriving_Enum";"char"]; ] let depends = [] end module Builder(Generator : Defs.Generator) = struct open Generator.Loc open Camlp4.PreCast open Description module Helpers = Generator.AstHelpers let wrap numbering = [ <:str_item< let numbering = $numbering$ >> ] let generator = (object(self) inherit Generator.generator method proxy () = None, [ <:ident< succ >>; <:ident< pred >>; <:ident< to_enum >>; <:ident< from_enum >>; <:ident< enum_from >>; <:ident< enum_from_then >>; <:ident< enum_from_to >>; <:ident< enum_from_then_to >>; ] method sum ?eq ctxt tname params constraints summands = let numbering = List.fold_right2 (fun n ctor rest -> match ctor with | (name, []) -> <:expr< ($uid:name$, $`int:n$) :: $rest$ >> | (name,_) -> raise (Base.Underivable (classname ^ " cannot be derived for the type " ^ tname ^" because the constructor " ^ name^" is not nullary"))) (List.range 0 (List.length summands)) summands <:expr< [] >> in wrap numbering method variant ctxt tname params constraints (_, tags) = let numbering = List.fold_right2 (fun n tagspec rest -> match tagspec with | Type.Tag (name, []) -> <:expr< (`$name$, $`int:n$) :: $rest$ >> | Type.Tag (name, _) -> raise (Base.Underivable (classname ^" cannot be derived because the tag " ^ name^" is not nullary")) | _ -> raise (Base.Underivable (classname ^" cannot be derived for this " ^"polymorphic variant type"))) (List.range 0 (List.length tags)) tags <:expr< [] >> in wrap numbering method tuple ctxt tys = match tys with | [ty] -> wrap <:expr< $self#call_expr ctxt ty "numbering"$ >> | _ -> raise (Base.Underivable (classname ^" cannot be derived for tuple types")) method record ?eq _ tname params constraints = raise (Base.Underivable (classname ^" cannot be derived for record types (i.e. "^tname^")")) end :> Generator.generator) let generate = Generator.generate generator let generate_sigs = Generator.generate_sigs generator end include Base.RegisterClass(Description)(Builder) deriving-0.7.1/syntax/classes/eq_class.ml000066400000000000000000000107241272135405000204400ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) open Pa_deriving_common open Utils module Description : Defs.ClassDescription = struct let classname = "Eq" let runtimename = "Deriving_Eq" let default_module = None let alpha = Some "Eq_alpha" let allow_private = true let predefs = [ ["unit"], ["Deriving_Eq";"unit"]; ["bool"], ["Deriving_Eq";"bool"]; ["char"], ["Deriving_Eq";"char"]; ["int"], ["Deriving_Eq";"int"]; ["int32"], ["Deriving_Eq";"int32"]; ["Int32";"t"], ["Deriving_Eq";"int32"]; ["int64"], ["Deriving_Eq";"int64"]; ["Int64";"t"], ["Deriving_Eq";"int64"]; ["nativeint"], ["Deriving_Eq";"nativeint"]; ["float"], ["Deriving_Eq";"float"]; ["num"], ["Deriving_num";"num"]; ["list"], ["Deriving_Eq";"list"]; ["option"], ["Deriving_Eq";"option"]; ["string"], ["Deriving_Eq";"string"]; ["ref"], ["Deriving_Eq";"ref"]; ["array"], ["Deriving_Eq";"array"]; ] let depends = [] end module Builder(Generator : Defs.Generator) = struct open Generator.Loc open Camlp4.PreCast open Description module Helpers = Generator.AstHelpers let and_guard x y = match x, y with | <:expr< >>, e | e, <:expr< >> -> e | x, y -> <:expr< $x$ && $y$ >> let lprefix = "l" and rprefix = "r" let wrap eq = [ <:str_item< let eq l r = match l, r with $list:eq$ >>] let generator = (object (self) method proxy () = None, [ <:ident< eq >>; ] inherit Generator.generator method tuple ctxt tys = let n = List.length tys in let lnames, lpatt, _ = Helpers.tuple ~param:lprefix n in let rnames, rpatt, _ = Helpers.tuple ~param:rprefix n in let test_and ty (lid, rid) e = <:expr< $self#call_expr ctxt ty "eq"$ $lid:lid$ $lid:rid$ && $e$ >> in let expr = List.fold_right2 test_and tys (List.zip lnames rnames) <:expr< true >> in wrap [ <:match_case< (($lpatt$),($rpatt$)) -> $expr$ >> ] method case ctxt (name,args) = match args with | [] -> <:match_case< ($uid:name$, $uid:name$) -> true >> | _ -> let nargs = List.length args in let _, lpatt, lexpr = Helpers.tuple ~param:lprefix nargs and _, rpatt, rexpr = Helpers.tuple ~param:rprefix nargs in let patt = <:patt< ($uid:name$ $lpatt$, $uid:name$ $rpatt$) >> in let eq = <:expr< $self#call_expr ctxt (`Tuple args) "eq"$ $lexpr$ $rexpr$ >> in <:match_case< $patt$ -> $eq$ >> method sum ?eq ctxt tname params constraints summands = let wildcard = match summands with | [_] -> [] | _ -> [ <:match_case< _ -> false >>] in wrap (List.map (self#case ctxt) summands @ wildcard) method field ctxt (name, ty, mut) = assert(mut <> `Mutable); <:expr< $self#call_poly_expr ctxt ty "eq"$ $lid:lprefix ^ name$ $lid:rprefix ^ name$ >> method record ?eq ctxt tname params constraints fields = if List.exists (function (_,_,`Mutable) -> true | _ -> false) fields then wrap [ <:match_case< (l,r) -> l==r >> ] else let lpatt = Helpers.record_pattern ~prefix:lprefix fields in let rpatt = Helpers.record_pattern ~prefix:rprefix fields in let test_and f e = <:expr< $self#field ctxt f$ && $e$ >> in let expr = List.fold_right test_and fields <:expr< true >> in wrap [ <:match_case< (($lpatt$), ($rpatt$)) -> $expr$ >> ] method polycase ctxt : Pa_deriving_common.Type.tagspec -> Ast.match_case = function | Type.Tag (name, []) -> <:match_case< `$name$, `$name$ -> true >> | Type.Tag (name, es) -> <:match_case< `$name$ l, `$name$ r -> $self#call_expr ctxt (`Tuple es) "eq"$ l r >> | Type.Extends t -> let lpatt, lguard, lcast = Generator.cast_pattern ctxt ~param:"l" t in let rpatt, rguard, rcast = Generator.cast_pattern ctxt ~param:"r" t in let patt = <:patt< ($lpatt$, $rpatt$) >> in let eq = <:expr< $self#call_expr ctxt t "eq"$ $lcast$ $rcast$ >> in <:match_case< $patt$ when $and_guard lguard rguard$ -> $eq$ >> method variant ctxt tname params constraints (spec, tags) = wrap (List.map (self#polycase ctxt) tags @ [ <:match_case< _ -> false >> ]) end :> Generator.generator) let classname = Description.classname let runtimename = Description.runtimename let generate = Generator.generate generator let generate_sigs = Generator.generate_sigs generator let generate_expr = Generator.generate_expr generator end include Base.RegisterFullClass(Description)(Builder) deriving-0.7.1/syntax/classes/functor_class.ml000066400000000000000000000172261272135405000215170ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) open Pa_deriving_common open Utils module Description : Defs.ClassDescription = struct let classname = "Functor" let runtimename = "Deriving_Functor" let default_module = None let alpha = None let allow_private = false let predefs = [ ["list"], ["Deriving_Functor";"list"]; ["ref"], ["Deriving_Functor";"ref"]; ["option"], ["Deriving_Functor";"option"]; ] let depends = [] end module Builder(Generator : Defs.Generator) = struct open Generator.Loc open Camlp4.PreCast open Description module Helpers = Generator.AstHelpers type context = { argmap : Type.qname Type.NameMap.t; params : Type.param list; } let substitute env = (object inherit Type.transform as default method expr = function | `Param (p,v) when Type.NameMap.mem p env -> `Param (Type.NameMap.find p env,v) | e -> default# expr e end) # expr let setup_context (_,params,_,_,_ : Type.decl) : context = let argmap = List.fold_right (fun (p,_) m -> Type.NameMap.add p [Printf.sprintf "V_%s" p] m) params Type.NameMap.empty in { argmap = argmap; params = params; } let param_map context : string Type.NameMap.t = List.fold_right (fun (name,_) map -> Type.NameMap.add name ("f_" ^ name) map) context.params Type.NameMap.empty let tdec, sigdec = let dec context name = ("f", context.params, `Expr (`Constr ([name], List.map (fun p -> `Param p) context.params)), [], false) in (fun context name -> Helpers.Untranslate.decl (dec context name)), (fun context name -> Helpers.Untranslate.sigdecl (dec context name)) let wrapper context name expr = let param_map = param_map context in let patts :Ast.patt list = List.map (fun (name,_) -> <:patt< $lid:Type.NameMap.find name param_map$ >>) context.params in let rhs = List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) patts expr in <:module_expr< struct type $tdec context name$ let map = $rhs$ end >> (* prototype: [[t]] : t -> t[b_i/a_i] [[a_i]] = f_i [[C1|...CN]] = function [[C1]] ... [[CN]] sum [[`C1|...`CN]] = function [[`C1]] ... [[`CN]] variant [[{t1,...tn}]] = fun (t1,tn) -> ([[t1]],[[tn]]) tuple [[{l1:t1; ... ln:tn}]] = fun {l1=t1;...ln=tn} -> {l1=[[t1]];...ln=[[tn]]} record [[(t1,...tn) c]] = c_map [[t1]]...[[tn]] constructor [[a -> b]] = f . [[a]] (where a_i \notin fv(b)) function [[C0]] = C0->C0 nullary constructors [[C1 (t1...tn)]] = C1 t -> C0 ([[t1]] t1...[[tn]] tn) unary constructor [[`C0]] = `C0->`C0 nullary tag [[`C1 t]] = `C1 t->`C0 [[t]] t unary tag *) let rec polycase context = function | Type.Tag (name, []) -> <:match_case< `$name$ -> `$name$ >> | Type.Tag (name, es) -> <:match_case< `$name$ x -> `$name$ ($expr context (`Tuple es)$ x) >> | Type.Extends t -> let patt, guard, exp = Helpers.cast_pattern context.argmap t in <:match_case< $patt$ when $guard$ -> $expr context t$ $exp$ >> and expr context : Pa_deriving_common.Type.expr -> Ast.expr = function | t when not (Type.contains_tvars t) -> <:expr< fun x -> x >> | `Param (p,_) -> <:expr< $lid:Type.NameMap.find p (param_map context)$ >> | `Function (f,t) when not (Type.contains_tvars t) -> <:expr< fun f x -> f ($expr context f$ x) >> | `Constr (qname, ts) -> let qname = try List.assoc qname predefs with Not_found -> qname in List.fold_left (fun fn arg -> <:expr< $fn$ $expr context arg$ >>) <:expr< $id:Helpers.modname_from_qname ~qname ~classname$.map >> ts | `Tuple ts -> tup context ts | _ -> raise (Base.Underivable "Functor cannot be derived for this type") and tup context = function | [t] -> expr context t | ts -> let args, exps = (List.fold_right2 (fun t n (p,e) -> let v = Printf.sprintf "t%d" n in Ast.PaCom (_loc, <:patt< $lid:v$ >>, p), Ast.ExCom (_loc, <:expr< $expr context t$ $lid:v$ >>, e)) ts (List.range 0 (List.length ts)) (<:patt< >>, <:expr< >>)) in let pat, exp = Ast.PaTup (_loc, args), Ast.ExTup (_loc, exps) in <:expr< fun $pat$ -> $exp$ >> and case context = function | (name, []) -> <:match_case< $uid:name$ -> $uid:name$ >> | (name, args) -> let f = tup context args and _, tpatt, texp = Helpers.tuple (List.length args) in <:match_case< $uid:name$ $tpatt$ -> let $tpatt$ = ($f$ $texp$) in $uid:name$ ($texp$) >> and field context (name, (_,t), _) : Ast.expr = <:expr< $expr context t$ $lid:name$ >> let rhs context : Pa_deriving_common.Type.rhs -> Ast.expr = function |`Fresh (_, _, `Private) -> raise (Base.Underivable "Functor cannot be derived for private types") |`Fresh (_, Type.GSum (tname, summands), _) -> raise (Base.Underivable "Functor cannot be derived for GADT") |`Fresh (_, Type.Sum summands, _) -> <:expr< function $list:List.map (case context) summands$ >> |`Fresh (_, Type.Record fields, _) -> <:expr< fun $Helpers.record_pattern fields$ -> $Helpers.record_expr (List.map (fun ((l,_,_) as f) -> (l,field context f)) fields)$ >> |`Expr e -> expr context e |`Variant ((_, tags), _) -> <:expr< function $list:List.map (polycase context) tags$ | _ -> assert false >> | `Nothing -> raise (Base.Underivable "Cannot generate functor instance for the empty type") let maptype context name = let param_map = param_map context in let ctor_in = `Constr ([name], List.map (fun p -> `Param p) context.params) in let ctor_out = substitute param_map ctor_in (* c[f_i/a_i] *) in List.fold_right (* (a_i -> f_i) -> ... -> c[a_i] -> c[f_i/a_i] *) (fun (p,_) out -> (<:ctyp< ('$lid:p$ -> '$lid:Type.NameMap.find p param_map$) -> $out$>>)) context.params (Helpers.Untranslate.expr (`Function (ctor_in, ctor_out))) let signature context name : Ast.sig_item list = [ <:sig_item< type $list:sigdec context name$ >>; <:sig_item< val map : $maptype context name$ >> ] let decl (name, _, r, _, _ as decl) : Camlp4.PreCast.Ast.module_binding = let context = setup_context decl in if name = "f" then raise (Base.Underivable ("deriving: Functor cannot be derived for types called `f'.\n" ^"Please change the name of your type and try again.")) else <:module_binding< $uid:classname ^ "_" ^ name$ : sig $list:signature context name$ end = $wrapper context name (rhs context r)$ >> let gen_sig (tname, params, _, _, generated as decl) = let context = setup_context decl in if tname = "f" then raise (Base.Underivable ("deriving: Functor cannot be derived for types called `f'.\n" ^"Please change the name of your type and try again.")) else if generated then <:sig_item< >> else <:sig_item< module $uid:classname ^ "_" ^ tname$ : sig type $tdec context tname$ val map : $maptype context tname$ end >> let generate decls = <:str_item< module rec $list:List.map decl decls$ >> let generate_sigs decls = <:sig_item< $list:List.map gen_sig decls$>> end include Base.RegisterClass(Description)(Builder) deriving-0.7.1/syntax/classes/pickle_class.ml000066400000000000000000000243751272135405000213110ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) open Pa_deriving_common open Utils module Description : Defs.ClassDescription = struct let classname = "Pickle" let runtimename = "Deriving_Pickle" let default_module = Some "Defaults" let alpha = None let allow_private = false let predefs = [ ["int"], ["Deriving_Pickle";"int"]; ["bool"], ["Deriving_Pickle";"bool"]; ["unit"], ["Deriving_Pickle";"unit"]; ["char"], ["Deriving_Pickle";"char"]; ["int32"], ["Deriving_Pickle";"int32"]; ["Int32";"t"], ["Deriving_Pickle";"int32"]; ["int64"], ["Deriving_Pickle";"int64"]; ["Int64";"t"], ["Deriving_Pickle";"int64"]; ["nativeint"], ["Deriving_Pickle";"nativeint"]; ["float"], ["Deriving_Pickle";"float"]; ["num"], ["Deriving_num";"num"]; ["string"], ["Deriving_Pickle";"string"]; ["list"], ["Deriving_Pickle";"list"]; ["ref"], ["Deriving_Pickle";"ref"]; ["option"], ["Deriving_Pickle";"option"]; ] let depends = [Typeable_class.depends; Eq_class.depends] end module Builder(Generator : Defs.Generator) = struct open Generator.Loc open Camlp4.PreCast open Description module Helpers = Generator.AstHelpers let bind, seq = let bindop = ">>=" and seqop = ">>" in <:expr< $lid:bindop$ >>, <:expr< $lid:seqop$ >> let wrap ctxt ~picklers ~unpickler = let unpickler = <:expr< let module R = Utils(Typeable) in $unpickler$ >> in let pickle = <:expr< let module W = Utils(Typeable)(Eq) in let pickle = function $list:picklers$ in pickle >> in [ <:str_item< open $uid:runtimename$.Write >>; <:str_item< let pickle = $pickle$ >>; <:str_item< open $uid:runtimename$.Read >>; <:str_item< let unpickle = $unpickler$ >> ] let generator = (object(self) inherit Generator.generator method proxy () = None, [ <:ident< pickle >>; <:ident< unpickle >>; <:ident< to_buffer >>; <:ident< to_string >>; <:ident< to_channel >>; <:ident< from_stream >>; <:ident< from_string >>; <:ident< from_channel >>; ] method tuple ctxt tys = let ntys = List.length tys in let ids, tpatt,texpr = Helpers.tuple ~param:"id" ntys in let picklers = let eidlist = Helpers.expr_list (List.map (fun id -> <:expr< $lid:id$ >>) ids) in let inner = List.fold_right2 (fun id ty expr -> <:expr< $bind$ ($self#call_expr ctxt ty "pickle"$ $lid:id$) (fun $lid:id$ -> $expr$) >>) ids tys <:expr< W.store_repr this ($uid:runtimename$.Repr.make $eidlist$) >> in [ <:match_case< ($tpatt$ as obj) -> W.allocate obj (fun this -> $inner$) >>] and unpickler = let msg = "unexpected object encountered unpickling " ^ string_of_int ntys ^ "-tuple" in let pidlist = Helpers.patt_list (List.map (fun id -> <:patt< $lid:id$ >>) ids) in let inner = List.fold_right2 (fun id ty expr -> <:expr< $bind$ ($self#call_expr ctxt ty "unpickle"$ $lid:id$) (fun $lid:id$ -> $expr$) >>) ids tys <:expr< return $texpr$ >> in <:expr< R.tuple (function | $pidlist$ -> $inner$ | _ -> raise ($uid:runtimename$.UnpicklingError $str:msg$)) >> in wrap ctxt ~picklers ~unpickler method case_pickle ctxt (name, params') n = let nparams = List.length params' in let ids = List.mapn (fun _ n -> Printf.sprintf "id%d" n) params' in let svalue = Helpers.expr_list (List.map (fun id -> <:expr< $lid:id$>>) ids) in let repr = <:expr< $uid:runtimename$.Repr.make ~constructor:$`int:n$ $svalue$ >> in let expr = <:expr< W.store_repr thisid $repr$ >> in match params' with | [] -> <:match_case< $uid:name$ as obj -> W.allocate obj (fun thisid -> $expr$) >> | _ -> let vs, tpatt, _ = Helpers.tuple ~param:"v" nparams in let bind_param p (id, v) expr = <:expr< $bind$ ($self#call_expr ctxt p "pickle"$ $lid:v$) (fun $lid:id$ -> $expr$)>> in let expr = List.fold_right2 bind_param params' (List.zip ids vs) expr in <:match_case< $uid:name$ $tpatt$ as obj -> W.allocate obj (fun thisid -> $expr$) >> method case_unpickle ctxt (name, params') n = match params' with | [] -> <:match_case< $`int:n$, [] -> return $uid:name$ >> | _ -> let nparams = List.length params' in let ids, _, texpr = Helpers.tuple ~param:"id" nparams in let ms = List.mapn (fun _ n -> Printf.sprintf "M%d" n) params' in let bind_param t (id, m) (pat, exp) = <:patt< $lid:id$ :: $pat$ >>, <:expr< let module $uid:m$ = $self#expr ctxt t$ in $bind$ ($uid:m$.unpickle $lid:id$) (fun $lid:id$ -> $exp$) >> in let patt, expr = List.fold_right2 bind_param params' (List.zip ids ms) (<:patt< [] >>, <:expr< return ($uid:name$ $texpr$) >>) in <:match_case< $`int:n$, $patt$ -> $expr$ >> method sum ?eq ctxt tname params constraints summands = let picklers = List.mapn (self#case_pickle ctxt) summands in let unpickler = <:expr< fun id -> let f = function $list:List.mapn (self#case_unpickle ctxt) summands$ | n,_ -> raise ($uid:runtimename$.UnpicklingError ($str:"Unexpected tag when unpickling " ^ tname ^ ": "$ ^ string_of_int n)) in R.sum f id >> in wrap ctxt ~picklers ~unpickler method record_pickler ctxt fields = let ids = List.map (fun (id,_,_) -> <:expr< $lid:id$ >>) fields in let expr = <:expr< (W.store_repr this ($uid:runtimename$.Repr.make $Helpers.expr_list ids$)) >> in let bind_field (id,t,_) e = <:expr< $bind$ ($self#call_poly_expr ctxt t "pickle"$ $lid:id$) (fun $lid:id$ -> $e$) >> in let inner = List.fold_right bind_field fields expr in <:match_case< ($Helpers.record_pattern fields$ as obj) -> W.allocate obj (fun this -> $inner$) >> method record_unpickle ctxt tname fields = let msg = "unexpected object encountered unpickling " ^ tname in let assignments = List.fold_right (fun (id,_,_) exp -> <:expr< this.Mutable.$lid:id$ <- $lid:id$; $exp$ >>) fields <:expr< return self >> in let bind_field (id,t,_) exp = <:expr< $bind$ ($self#call_poly_expr ctxt t "unpickle"$ $lid:id$) (fun $lid:id$ -> $exp$) >> in let inner = List.fold_right bind_field fields assignments in let idpat = Helpers.patt_list (List.map (fun (id,_,_) -> <:patt< $lid:id$ >>) fields) in let record = <:expr< R.record (fun self -> function | $idpat$ -> let this = (Obj.magic self : Mutable.t) in $inner$ | _ -> raise ($uid:runtimename$.UnpicklingError $str:msg$)) $`int:List.length fields$ >> in let mutable_type = Generator.instantiate_modargs_repr ctxt (Type.Record (List.map (fun (n,p,_) -> (n,p,`Mutable)) fields)) in <:expr< let module Mutable = struct type $Ast.TyDcl (_loc, "t", [], Helpers.Untranslate.repr mutable_type, [])$ end in $record$ >> method record ?eq ctxt tname params constraints (fields : Pa_deriving_common.Type.field list) = wrap ctxt ~picklers:[self#record_pickler ctxt fields] ~unpickler:(self#record_unpickle ctxt tname fields) method polycase_pickle ctxt = function | Type.Tag (name, []) -> <:match_case< (`$name$ as obj) -> W.allocate obj (fun thisid -> W.store_repr thisid ($uid:runtimename$.Repr.make ~constructor:$`int:tag_hash name$ [])) >> | Type.Tag (name, ts) -> <:match_case< (`$name$ v1 as obj) -> W.allocate obj (fun thisid -> $bind$ ($self#call_expr ctxt (`Tuple ts) "pickle"$ v1) (fun mid -> (W.store_repr thisid ($uid:runtimename$.Repr.make ~constructor:$`int:tag_hash name$ [mid])))) >> | Type.Extends t -> let patt, guard, cast = Generator.cast_pattern ctxt t in <:match_case< ($patt$) when $guard$ -> ($self#call_expr ctxt t "pickle"$ $cast$) >> method polycase_unpickler ctxt tname tags = let do_tag = function | (name, []) -> <:match_case< $`int:(tag_hash name)$, [] -> return `$name$ >> | (name, ts) -> <:match_case< $`int:(tag_hash name)$, [x] -> $bind$ ($self#call_expr ctxt (`Tuple ts) "unpickle"$ x) (fun o -> return (`$name$ o)) >> in let do_extensions tys = (* Try each extension in turn. If we get an UnknownTag failure, try the next one. This is * safe because any two extensions that define the same tag must be compatible at that point * fast because we can tell on the first integer comparison whether we've picked the right path or not. *) let fail = <:expr< raise ($uid:runtimename$.UnknownTag (n, ($str:"Unexpected tag encountered during unpickling of " ^ tname$))) >> in let try_extension ty expr = <:expr< let module M = $(self#expr ctxt ty)$ in try $expr$ with $uid:runtimename$.UnknownTag _ -> (M.unpickle id :> a $uid:runtimename$.Read.m) >> in <:match_case< n,_ -> $List.fold_right try_extension tys fail$ >> in let tags, extensions = either_partition (function Type.Tag (name,t) -> Left (name,t) | Type.Extends t -> Right t) tags in let tag_cases = List.map do_tag tags in let extension_case = do_extensions extensions in <:expr< fun id -> R.sum (function $list:tag_cases @ [extension_case]$) id >> method variant ctxt tname params constraints (_, tags) = let wildcard = <:match_case< _ -> assert false >> in wrap ctxt ~picklers:(List.map (self#polycase_pickle ctxt) tags @ [ wildcard ]) ~unpickler:(self#polycase_unpickler ctxt tname tags) end :> Generator.generator) let generate = Generator.generate generator let generate_sigs = Generator.generate_sigs generator end include Base.RegisterClass(Description)(Builder) deriving-0.7.1/syntax/classes/show_class.ml000066400000000000000000000127641272135405000210210ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) open Pa_deriving_common open Utils module Description : Defs.ClassDescription = struct let classname = "Show" let default_module = Some "Defaults" let runtimename = "Deriving_Show" let alpha = Some "Show_unprintable" let allow_private = true let predefs = [ ["int" ], ["Deriving_Show";"int"]; ["bool" ], ["Deriving_Show";"bool"]; ["unit" ], ["Deriving_Show";"unit"]; ["char" ], ["Deriving_Show";"char"]; ["int32" ], ["Deriving_Show";"int32"]; ["Int32";"t"], ["Deriving_Show";"int32"]; ["int64" ], ["Deriving_Show";"int64"]; ["Int64";"t"], ["Deriving_Show";"int64"]; ["nativeint"], ["Deriving_Show";"nativeint"]; ["float" ], ["Deriving_Show";"float"]; ["num" ], ["Deriving_num" ;"num"]; ["string" ], ["Deriving_Show";"string"]; ["list" ], ["Deriving_Show";"list"]; ["ref" ], ["Deriving_Show";"ref"]; ["option" ], ["Deriving_Show";"option"]; ["array" ], ["Deriving_Show";"array"]; ] let depends = [] end module Builder(Generator : Defs.Generator) = struct open Generator.Loc open Camlp4.PreCast open Description module Helpers = Generator.AstHelpers let wrap formatter = [ <:str_item< let format formatter : a -> unit = function $list:formatter$ >> ] let in_a_box box i e = <:expr< Format.$lid:box$ formatter $`int:i$; $e$; Format.pp_close_box formatter () >> let in_paren e = <:expr< Format.pp_print_string formatter "("; $e$; Format.pp_print_string formatter ")" >> let in_hovbox ?(indent = 0) = in_a_box "pp_open_hovbox" indent and in_box ?(indent = 0) = in_a_box "pp_open_box" indent let generator = (object (self) inherit Generator.generator method proxy () = None, [ <:ident< format >>; <:ident< format_list >>; <:ident< show >>; <:ident< show_list >>; ] method nargs ctxt tvars args = match tvars, args with | [id], [ty] -> <:expr< $self#call_expr ctxt ty "format"$ formatter $lid:id$ >> | id::ids, ty::tys -> let format_expr id ty = <:expr< $self#call_expr ctxt ty "format"$ formatter $lid:id$ >> in let format_expr' id ty = <:expr< Format.pp_print_string formatter ","; Format.pp_print_space formatter (); $format_expr id ty$>> in let exprs = format_expr id ty :: List.map2 format_expr' ids tys in in_paren (in_hovbox ~indent:1 (Helpers.seq_list exprs)) | _ -> assert false method tuple ctxt args = let tvars, tpatt, _ = Helpers.tuple (List.length args) in wrap [ <:match_case< $tpatt$ -> $self#nargs ctxt tvars args$ >> ] method case ctxt (name, args) = match args with | [] -> <:match_case< $uid:name$ -> Format.pp_print_string formatter $str:name$ >> | _ -> let tvars, patt, exp = Helpers.tuple (List.length args) in let format_expr = <:expr< Format.pp_print_string formatter $str:name$; Format.pp_print_break formatter 1 2; $self#nargs ctxt tvars args$ >> in <:match_case< $uid:name$ $patt$ -> $in_hovbox format_expr$ >> method sum ?eq ctxt tname params constraints summands = wrap (List.map (self#case ctxt) summands) method gsum ?eq ctxt tname params constraints gsummands = let summands = List.map (fun (name, args, _) -> (name, args)) gsummands in wrap (List.map (self#case ctxt) summands) method field ctxt (name, ty, mut) = <:expr< Format.pp_print_string formatter $str:name ^ " = "$; $self#call_poly_expr ctxt ty "format"$ formatter $lid:name$ >> method record ?eq ctxt tname params constraints fields = let format_fields = List.fold_left1 (fun l r -> <:expr< $l$; Format.pp_print_string formatter "; "; $r$ >>) (List.map (self#field ctxt) fields) in let format_record = <:expr< Format.pp_print_char formatter '{'; $format_fields$; Format.pp_print_char formatter '}'; >> in wrap [ <:match_case< $Helpers.record_pattern fields$ -> $in_hovbox format_record$ >>] method polycase ctxt has_guard : Pa_deriving_common.Type.tagspec -> Ast.match_case = function | Type.Tag (name, []) -> let format_expr = <:expr< Format.pp_print_string formatter $str:"`" ^ name ^" "$ >> in <:match_case< `$uid:name$ -> $format_expr$ >> | Type.Tag (name, es) -> let format_expr = <:expr< Format.pp_print_string formatter $str:"`" ^ name ^" "$; $self#call_expr ctxt (`Tuple es) "format"$ formatter x >> in <:match_case< `$uid:name$ x -> $in_hovbox format_expr$ >> | Type.Extends t -> let patt, guard, cast = Generator.cast_pattern ctxt t in let format_expr = <:expr< $self#call_expr ctxt t "format"$ formatter $cast$ >> in if guard <> <:expr< >> then has_guard := true; <:match_case< $patt$ when $guard$ -> $in_hovbox format_expr$ >> method variant ctxt tname params constraints (_,tags) = let has_guard = ref false in let body = List.map (self#polycase ctxt has_guard) tags in wrap (if !has_guard then body @ [ <:match_case< _ -> assert false >> ] else body) end :> Generator.generator) let generate = Generator.generate generator let generate_sigs = Generator.generate_sigs generator end include Base.RegisterClass(Description)(Builder) deriving-0.7.1/syntax/classes/typeable_class.ml000066400000000000000000000065251272135405000216440ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) open Pa_deriving_common open Utils module Description : Defs.ClassDescription = struct let classname = "Typeable" let runtimename = "Deriving_Typeable" let default_module = Some "Defaults" let alpha = None let allow_private = true let predefs = [ ["int"], ["Deriving_Typeable";"int"]; ["bool"], ["Deriving_Typeable";"bool"]; ["unit"], ["Deriving_Typeable";"unit"]; ["char"], ["Deriving_Typeable";"char"]; ["int32"], ["Deriving_Typeable";"int32"]; ["Int32";"t"], ["Deriving_Typeable";"int32"]; ["int64"], ["Deriving_Typeable";"int64"]; ["Int64";"t"], ["Deriving_Typeable";"int64"]; ["nativeint"], ["Deriving_Typeable";"nativeint"]; ["float"], ["Deriving_Typeable";"float"]; ["num"], ["Deriving_num";"num"]; ["string"], ["Deriving_Typeable";"string"]; ["list"], ["Deriving_Typeable";"list"]; ["ref"], ["Deriving_Typeable";"ref"]; ["option"], ["Deriving_Typeable";"option"]; ] let depends = [] end module Builder(Generator : Defs.Generator) = struct open Generator.Loc open Camlp4.PreCast open Description module Helpers = Generator.AstHelpers let mkName tname = let file_name, sl, _, _, _, _, _, _ = Loc.to_tuple _loc in Printf.sprintf "%s_%d_%f_%s" file_name sl (Unix.gettimeofday ()) tname let wrap type_rep = [ <:str_item< let type_rep = lazy $type_rep$ >> ] let generator = (object(self) inherit Generator.generator method proxy () = None, [ <:ident< type_rep >>; <:ident< has_type >>; <:ident< cast >>; <:ident< throwing_cast >>; <:ident< make_dynamic >>; <:ident< mk >>; ] method tuple ctxt ts = let params = List.map (fun t -> <:expr< $self#call_expr ctxt t "type_rep"$ >>) ts in wrap <:expr< $uid:runtimename$.TypeRep.mkTuple $Helpers.expr_list params$ >> method gen ?eq ctxt tname params constraints = let paramList = List.fold_right (fun p cdr -> <:expr< $self#call_expr ctxt p "type_rep"$ :: $cdr$ >>) params <:expr< [] >> in wrap <:expr< $uid:runtimename$.TypeRep.mkFresh $str:mkName tname$ $paramList$ >> method sum ?eq ctxt tname params constraints _ = self#gen ~eq ctxt tname params constraints method record ?eq ctxt tname params constraints _ = self#gen ~eq ctxt tname params constraints method variant ctxt tname params constraints (_,tags) = let tags, extends = List.fold_left (fun (tags, extends) -> function | Type.Tag (l, []) -> <:expr< ($str:l$, None) :: $tags$ >>, extends | Type.Tag (l, ts) -> <:expr< ($str:l$, Some $self#call_expr ctxt (`Tuple ts) "type_rep"$) ::$tags$ >>, extends | Type.Extends t -> tags, <:expr< $self#call_expr ctxt t "type_rep"$::$extends$ >>) (<:expr< [] >>, <:expr< [] >>) tags in wrap <:expr< $uid:runtimename$.TypeRep.mkPolyv $tags$ $extends$ >> end :> Generator.generator) let classname = Description.classname let runtimename = Description.runtimename let generate = Generator.generate generator let generate_sigs = Generator.generate_sigs generator let generate_expr = Generator.generate_expr generator end include Base.RegisterFullClass(Description)(Builder) deriving-0.7.1/syntax/common/000077500000000000000000000000001272135405000161435ustar00rootroot00000000000000deriving-0.7.1/syntax/common/base.ml000066400000000000000000000564201272135405000174160ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. Copyright Grégoire Henry 2011. This file is free software, distributed under the MIT license. See the file COPYING for details. *) open Utils open Type open Defs open Camlp4.PreCast exception Underivable of string exception NoSuchClass of string let fatal_error loc msg = Syntax.print_warning loc msg; exit 1 let display_errors loc f p = try f p with Underivable msg | Failure msg -> fatal_error loc msg (** *) let instantiate, instantiate_repr = let o lookup = object inherit transform as super method expr = function | `Param (name, _) -> lookup name | `GParam ((name, _), e) -> if not (contains_tvars e) then e else lookup name | e -> super # expr e end in (fun (lookup : name -> expr) -> (o lookup)#expr), (fun (lookup : name -> expr) -> (o lookup)#repr) let instantiate_modargs, instantiate_modargs_repr = let lookup argmap var = try `Constr (NameMap.find var argmap @ ["a"], []) with NameMap.Not_found _ -> `Param (var, None) in (fun argmap -> instantiate (lookup argmap)), (fun argmap -> instantiate_repr (lookup argmap)) module AstHelpers(Loc : Loc) = struct open Loc module Loc = Loc module Untranslate = Type.Untranslate(Loc) (** Expression sequences *) let seq l r = <:expr< $l$ ; $r$ >> let rec seq_list = function | [] -> <:expr< () >> | [e] -> e | e::es -> seq e (seq_list es) (** Record *) let record_pattern ?(prefix="") (fields : Type.field list) : Ast.patt = <:patt<{$list: (List.map (fun (label,_,_) -> <:patt< $lid:label$ = $lid:prefix ^ label$ >>) fields) $}>> let record_expr : (string * Ast.expr) list -> Ast.expr = fun fields -> let fs = List.fold_left1 (fun l r -> <:rec_binding< $l$ ; $r$ >>) (List.map (fun (label, exp) -> <:rec_binding< $lid:label$ = $exp$ >>) fields) in Ast.ExRec (_loc, fs, Ast.ExNil _loc) let record_expression ?(prefix="") : Type.field list -> Ast.expr = fun fields -> let es = List.fold_left1 (fun l r -> <:rec_binding< $l$ ; $r$ >>) (List.map (fun (label,_,_) -> <:rec_binding< $lid:label$ = $lid:prefix ^ label$ >>) fields) in Ast.ExRec (_loc, es, Ast.ExNil _loc) (** Record *) let expr_list : Ast.expr list -> Ast.expr = (fun exprs -> List.fold_right (fun car cdr -> <:expr< $car$ :: $cdr$ >>) exprs <:expr< [] >>) let patt_list : Ast.patt list -> Ast.patt = (fun patts -> List.fold_right (fun car cdr -> <:patt< $car$ :: $cdr$ >>) patts <:patt< [] >>) (** Tuple *) let tuple_expr : Ast.expr list -> Ast.expr = function | [] -> <:expr< () >> | [x] -> x | x::xs -> Ast.ExTup (_loc, List.fold_left (fun e t -> Ast.ExCom (_loc, e,t)) x xs) let tuple_patt : Ast.patt list -> Ast.patt = function | [] -> <:patt< () >> | [x] -> x | x::xs -> Ast.PaTup (_loc, List.fold_left (fun e t -> Ast.PaCom (_loc, e,t)) x xs) let tuple ?(param="v") n : string list * Ast.patt * Ast.expr = let v n = Printf.sprintf "%s%d" param n in match n with | 0 -> [], <:patt< () >>, <:expr< () >> | 1 -> [v 0], <:patt< $lid:v 0$ >>, <:expr< $lid:v 0$ >> | n -> let patts, exprs = (* At time of writing I haven't managed to write anything using quotations that generates an n-tuple *) List.fold_left (fun (p, e) (patt, expr) -> Ast.PaCom (_loc, p, patt), Ast.ExCom (_loc, e, expr)) (<:patt< >>, <:expr< >>) (List.map (fun n -> <:patt< $lid:v n$ >>, <:expr< $lid:v n $ >>) (List.range 0 n)) in List.map v (List.range 0 n), Ast.PaTup (_loc, patts), Ast.ExTup (_loc, exprs) (** *) let rec lident qname = match qname with | [] -> invalid_arg "ident" | [t] -> <:ident< $lid:t$ >> | t::ts -> <:ident< $uid:t$.$lident ts$ >> let cast_pattern argmap ?(param="x") ty = match ty with | `Constr (id, _) -> (<:patt< #$id:lident id$ as $lid:param$ >>, <:expr< >>, <:expr< $lid:param$ >>) | ty -> let ty = Untranslate.expr (instantiate_modargs argmap ty) in (<:patt< $lid:param$ >>, <:expr< let module M = struct type $Ast.TyDcl (_loc, "t", [], ty, [])$ let test = function #t -> true | _ -> false end in M.test $lid:param$ >>, <:expr< (let module M = struct type $Ast.TyDcl (_loc, "t", [], ty, [])$ let cast = function #t as t -> t | _ -> assert false end in M.cast $lid:param$ )>>) (** *) let atype_expr argmap ty = let ty = instantiate_modargs argmap ty in match ty with | `Constr(["a"],_) -> raise (Underivable ("deriving: types called `a' are not allowed.\n" ^ "Please change the name of your type and try again.")); | ty -> Untranslate.expr ty let rec modname_from_qname ~qname ~classname = match qname with | [] -> invalid_arg "modname_from_qname" | [t] -> <:ident< $uid:classname ^ "_"^ t$ >> | t::ts -> <:ident< $uid:t$.$modname_from_qname ~qname:ts ~classname$ >> let mproject mexpr (name:string) = match mexpr with | <:module_expr< $id:m$ >> -> <:expr< $id:m$.$lid:name$ >> | _ -> <:expr< let module M = $mexpr$ in M.$lid:name$ >> let mProject mexpr name = match mexpr with | <:module_expr< $uid:m$ >> -> <:module_expr< $uid:m$.$uid:name$ >> | _ -> <:module_expr< struct module M = $mexpr$ include M.$uid:name$ end >> end module type InnerClassDescription = sig include ClassDescription val find_predefined: Type.qname -> Type.qname val depends: (module DepClassBuilder) list end module InnerGenerator(Loc: Loc)(Desc : InnerClassDescription) = struct (** How does it works ? For each type declaration, we generate a functor taking as parameters the class instances for the type parameters. For (mutually) recursive type declaration(s), we compute the (finite) set of required recursive class instances (see "cluster.mli") and generate a functor containing all these class instances. Then we generate a non-recursive functor for each type declaration. For the set of recursive class instances we use "lazy first-order module" instead of "recursive modules" to be compatible with 'js_of_ocaml' (that do not allow recursive modules). E.g. for two mutually recursive type 'a t and 'a t2: module Show_RandomId(M_a: Show) = struct let rec make_t = lazy (module struct ... end : Show with type a = M_a.a t) and make_t2 = lazy (module struct ... end : Show with type a = M_a.a t2) end module Show_t(M_a: Show) = struct module Show_RandomId = Show_RandomId(M_a) type a = M_a.a t let show = let module M = (val Lazy.force Show_RandomId.make_t) in M.show ... end module Show_t2(M_a: Show) = module Show_RandomId = Show_RandomId(M_a) type a = M_a.a t2 let show = let module M = (val Lazy.force Show_RandomId.make_t2) in M.show ... end *) module Loc = Loc module AstHelpers = AstHelpers(Loc) module Helpers = AstHelpers module Untranslate = Helpers.Untranslate open Loc type context = { (* Maps type expression to name of a module's value inside the cluster's functor. *) mod_insts : Ast.module_expr Type.EMap.t; (* Maps name of type's parameter name to module name of functor's parameters *) argmap : Type.qname Type.NameMap.t; } let make_argmap params = List.fold_left (fun params (name, _) -> NameMap.add name (["M_" ^ name]) params) NameMap.empty params let cast_pattern ctxt ?param ty = Helpers.cast_pattern ctxt.argmap ?param ty let instantiate_modargs_repr ctxt = instantiate_modargs_repr ctxt.argmap let instantiate_gparam e = let map = object (self) inherit Type.transform as super method expr e = match e with | `GParam (p, e) -> if Type.contains_tvars e then `Param p else e | e -> super#expr e end in map#expr e let import_depend ctxt ty depend = let module Dep = (val depend : DepClassBuilder)(Loc) in let argmap = NameMap.map (fun qname -> qname @ [Dep.classname]) ctxt.argmap and mod_insts = EMap.map (fun m -> Helpers.mProject m Dep.classname) ctxt.mod_insts in let mod_insts = match ty with | `Constr ([tname],params) -> EMap.remove (tname,params) mod_insts | _ -> mod_insts in <:str_item< module $uid:Dep.classname$ = $Dep.generate_expr mod_insts argmap ty$ >> let import_depends ctxt ty = List.map (import_depend ctxt ty) Desc.depends class virtual generator = object (self) (* *) method call_expr ctxt ty name = Helpers.mproject (self#expr ctxt ty) name method call_poly_expr ctxt (params, ty : Type.poly_expr) name = match Desc.alpha with | None when params <> [] -> raise (Underivable (Desc.classname ^ " cannot be derived for record types " ^ "with polymorphic fields")) | None -> self#call_expr ctxt ty name | Some mod_name -> let ctxt = { ctxt with argmap = List.fold_left (fun argmap (pname, _) -> NameMap.add pname ["M_"^pname] argmap) ctxt.argmap params} in let expr = self#call_expr ctxt ty name in List.fold_right (fun (pname,_) expr -> (* This is not a function... much more a scope for a type variable... *) <:expr< fun (type t) -> let module $uid:"M_"^pname$ = $uid:Desc.runtimename$.$uid:mod_name$(struct type a = t end) in $expr$ >>) params expr (* *) method class_sig argmap ty = <:module_type< $uid:Desc.runtimename$.$uid:Desc.classname$ with type a = $Helpers.atype_expr argmap ty$ >> method pack argmap ty m = match m with | <:module_expr< (val $e$) >> -> e | _ -> (* <:expr< (module $m$ : $class_sig ctxt decl) >> *) Ast.ExPkg (_loc, (Ast.MeTyc (_loc, m, self#class_sig argmap ty))) method unpack argmap ty e = match e with | <:expr< (module $m$) >> -> m | _ -> (* (val $e$ : $class_sig gen argmap decl$) *) Ast.MePkg (_loc, Ast.ExTyc (_loc, e, Ast.TyPkg (_loc, self#class_sig argmap ty))) (** *) method wrap ctxt ?(default = Desc.default_module) ty items = let mexpr = <:module_expr< struct type a = ($Helpers.atype_expr ctxt.argmap ty$) $list:import_depends ctxt ty$ $list:items$ end >> in match default with | None -> mexpr | Some name -> <:module_expr< $uid:Desc.runtimename$.$uid:name$($mexpr$) >> (** *) method expr ctxt (ty: Type.expr) = match ty with | `Param p -> (self#param ctxt p) | `GParam p -> (self#gparam ctxt p) | `Object o -> self#wrap ctxt ty (self#object_ ctxt o) | `Class c -> self#wrap ctxt ty (self#class_ ctxt c) | `Label l -> self#wrap ctxt ty (self#label ctxt l) | `Function f -> self#wrap ctxt ty (self#function_ ctxt f) | `Constr c -> (self#constr ctxt c) | `Tuple t -> self#wrap ctxt ty (self#tuple ctxt t) method rhs ctxt subst (tname, params, rhs, constraints, _ : Type.decl) = let params = List.map (substitute_expr subst) (List.map (fun p -> `Param p) params) in let ty = `Constr([tname], params) in let rhs = substitute_rhs subst rhs in match rhs with | `Fresh (_, _, `Private) when not Desc.allow_private -> raise (Underivable ("The class " ^ Desc.classname ^ " cannot be derived for private types")) | `Fresh (eq, Sum summands, _) -> self#wrap ctxt ty (self#sum ?eq ctxt tname params constraints summands) | `Fresh (eq, GSum (tname', summands), _) -> self#wrap ctxt ty (self#gsum ?eq ctxt tname params constraints summands) | `Fresh (eq, Record fields, _) -> self#wrap ctxt ty (self#record ?eq ctxt tname params constraints fields) | `Expr e -> self#expr ctxt e | `Variant ((var, _ as v),p) -> if p = `Private && var = `Gt then failwith "Private row is only allowed in signature"; self#wrap ctxt ty (self#variant ctxt tname params constraints v) | `Nothing -> <:module_expr< >> method param ctxt (name, _) = <:module_expr< $id:Untranslate.qName (NameMap.find name ctxt.argmap)$ >> method gparam ctxt (p, e) = if Type.contains_tvars e then self#param ctxt p else self#expr ctxt e method constr ctxt (qname, params) = match qname with | [tname] when EMap.mem (tname,params) ctxt.mod_insts -> (* Instance in the current cluster. *) EMap.find (tname, params) ctxt.mod_insts | _ -> (* External module: apply classical functor. *) let qname = try Desc.find_predefined qname with Not_found -> qname in List.fold_left (fun m p -> <:module_expr< $m$ ($self#expr ctxt p$) >>) <:module_expr< $id:Helpers.modname_from_qname ~qname ~classname:Desc.classname$ >> params method virtual proxy: unit -> Type.name option * Ast.ident list (* *) method virtual variant: context -> Type.name -> Type.expr list -> Type.constraint_ list -> variant -> Ast.str_item list method virtual sum: ?eq:expr -> context -> Type.name -> Type.expr list -> Type.constraint_ list -> summand list -> Ast.str_item list method virtual record: ?eq:expr -> context -> Type.name -> Type.expr list -> Type.constraint_ list -> field list -> Ast.str_item list method virtual tuple: context -> expr list -> Ast.str_item list method gsum ?eq ctxt tname params constraints gsummands = raise (Underivable (Desc.classname ^ " cannot be derived for GADT")) method object_ _ o = raise (Underivable (Desc.classname ^ " cannot be derived for object types")) method class_ _ c = raise (Underivable (Desc.classname ^ " cannot be derived for class types")) method label _ l = raise (Underivable (Desc.classname ^ " cannot be derived for label types")) method function_ _ f = raise (Underivable (Desc.classname ^ " cannot be derived for function types")) end let add_functor_param argmap (pname,_) body = match NameMap.find pname argmap with | [name] -> <:module_expr< functor ( $uid:name$ : $uid:Desc.runtimename$.$uid:Desc.classname$) -> $body$ >> | _ -> assert false let add_functor_param_sig argmap (pname,_) body = match NameMap.find pname argmap with | [name] -> <:module_type< functor ( $uid:name$ : $uid:Desc.runtimename$.$uid:Desc.classname$) -> $body$ >> | _ -> assert false let create_subst params eparams = List.fold_right2 NameMap.add (* (fun p ep map -> *) (* match ep with *) (* | `Param (p',_ ) when p' = p -> map *) (* | _ -> NameMap.add p ep map) *) (List.map fst params) eparams NameMap.empty (** ... *) let generate (gen : generator) decls = let generate_cluster cluster = let cluster_name = let id = random_id 32 in Printf.sprintf "%s_%s" Desc.classname id in let fun_names = let cpt = ref 0 in List.fold_left (fun map (tname, _ as inst) -> incr cpt; EMap.add inst (Printf.sprintf "make_%s_%d" tname !cpt) map) EMap.empty cluster.Clusters.instances in let cluster_argmap = make_argmap cluster.Clusters.params in let rec wrap_local_types (args : expr list) body = #if ocaml_version < (4, 00) body #else match args with | [] -> body | `Param (arg, _) :: args | `GParam ((arg, _),_) :: args -> let id = "deriving_" ^ random_id 8 ^ "_" ^ arg in let pat = (* (module $M_arg$ : $class_sig ...$ ) *) Ast.PaTyc(_loc, Ast.PaMod (_loc, "M_" ^ arg), Ast.TyPkg(_loc, gen#class_sig NameMap.empty (`Constr ([id], [])))) in wrap_local_types args <:expr< (fun (type $lid:id$) -> (function $pat$ -> $body$)) (module $uid:"M_"^arg$) >> | _ -> assert false #endif in let generate_instance (tname, eparams as inst) = let mod_insts = EMap.mapi (fun (tname, params) fname -> gen#unpack cluster_argmap (`Constr ([tname], params)) (<:expr< Lazy.force $lid:fname$ >>)) fun_names in let ctxt = { argmap = cluster_argmap; mod_insts; } in let ty = `Constr([tname], eparams) in let (_,params,_,_,_ as decl) = List.find (fun (tn,_,_,_,_) -> tname = tn) decls in let subst = create_subst params eparams in let body = gen#pack ctxt.argmap ty (gen#rhs ctxt subst decl) in let id = EMap.find inst fun_names in id, <:expr< lazy (ignore($lid:id$); $body$) >> in let generate_functor (tname,params,_,_,_ as decl) = let argmap = make_argmap params in let mod_insts = EMap.mapi (fun (tname, params) fname -> let e = Helpers.mproject (List.fold_left (fun m (pname,_) -> let p = NameMap.find pname argmap in <:module_expr< $m$ ($id:Untranslate.qName p$) >>) (<:module_expr< $uid:cluster_name$ >>) cluster.Clusters.params) fname in let ty = `Constr ([tname], params) in gen#unpack argmap ty (<:expr< Lazy.force $e$ >>)) fun_names in let ctxt = { argmap; mod_insts; } in let body = let params = List.map (fun p -> `Param p) params in let ty = `Constr ([tname], params) in try let tfname = EMap.find (tname, params) fun_names in let default, ids = gen#proxy () in let m = List.fold_left (fun m p -> <:module_expr< $m$ ($gen#expr ctxt p$) >>) <:module_expr< $uid:cluster_name$ >> params in let items = <:str_item< module M = $m$ >> :: (let m = Helpers.mproject <:module_expr< M >> tfname in let m = gen#unpack argmap ty <:expr< Lazy.force $m$ >> in List.map (fun id -> <:str_item< let $id:id$ = let module M = $m$ in M.$id:id$ >>) ids) in (gen#wrap ~default ctxt ty items) with EMap.Not_found _ -> gen#rhs ctxt NameMap.empty decl in let body = let ty = `Constr ([tname], List.map (fun p -> `Param p) params) in <:module_expr< ($body$ : $gen#class_sig argmap ty$) >> in let body = List.fold_right (add_functor_param argmap) params body in <:str_item< module $uid:Printf.sprintf "%s_%s" Desc.classname tname$ = $body$ >> in let is_gadt = function | (_,_,`Fresh(_,GSum _,_),_,_) -> true | _ -> false in let contains_gadt c = List.exists is_gadt c.Clusters.decls in if cluster.Clusters.instances <> [] then let inst_exprs = List.map generate_instance cluster.Clusters.instances in let bindings = List.map (fun (id, e) -> <:binding< $lid:id$ = $e$ >>) inst_exprs in let items = if not (contains_gadt cluster) then <:str_item< let rec $list:bindings$ >> else let e = List.map (fun (id, _) -> <:expr< $lid:id$ >>) inst_exprs in let p = List.map (fun (id, _) -> <:patt< $lid:id$ >>) inst_exprs in let body = wrap_local_types (List.map (fun p -> `Param p) cluster.Clusters.params) <:expr< let rec $list:bindings$ in $Helpers.tuple_expr e$ >> in <:str_item< let $Helpers.tuple_patt p$ = $body$ >> in let mod_expr = List.fold_right (add_functor_param cluster_argmap) cluster.Clusters.params <:module_expr< struct $items$ end >> in <:str_item< module $uid:cluster_name$ = $mod_expr$ $list:List.map generate_functor cluster.Clusters.decls$ >> else <:str_item< $list:List.map generate_functor cluster.Clusters.decls$ >> in <:str_item< $list:List.map generate_cluster (Clusters.make decls)$ >> (** ... *) let generate_sigs (gen:generator) decls = let generate_sig (tname,params,rhs,_,generated) = if generated then <:sig_item< >> else let argmap = make_argmap params in let ty = match rhs with | `Fresh _ | `Variant _ | `Nothing -> `Constr ([tname], List.map (fun p -> `Param p) params) | `Expr e -> e in let body = List.fold_right (add_functor_param_sig argmap) params (gen#class_sig argmap ty) in <:sig_item< module $uid:Printf.sprintf "%s_%s" Desc.classname tname$ : $body$ >> in <:sig_item< $list:List.map generate_sig decls$ >> let generate_expr (gen:generator) mod_insts argmap ty = gen#expr { argmap; mod_insts; } ty end let derive_str _loc decls class_builder = let module Loc = struct let _loc = _loc end in let module Class = (val class_builder : InnerClassBuilder)(Loc) in display_errors _loc Class.generate decls let derive_sig _loc decls class_builder = let module Loc = struct let _loc = _loc end in let module Class = (val class_builder : InnerClassBuilder)(Loc) in display_errors _loc Class.generate_sigs decls let generators : (string, (module ClassDescription) * (module InnerClassBuilder)) Hashtbl.t = Hashtbl.create 15 let hashtbl_add desc deriver = let module Desc = (val desc : ClassDescription) in Hashtbl.add generators Desc.classname (desc, deriver) let register_hook = ref [hashtbl_add] let add_register_hook (f : ((module ClassDescription) -> generator -> unit)) = Hashtbl.iter (fun _ (desc, deriver) -> f desc deriver) generators; register_hook := f :: !register_hook let register desc deriver = List.iter (fun f -> f desc deriver) !register_hook let find classname = try snd (Hashtbl.find generators classname) with Not_found -> raise (NoSuchClass classname) let is_registered classname = Hashtbl.mem generators classname module MakeInnerDesc(Desc : Defs.ClassDescription) = struct include Desc let predefs_tbl : (Type.qname, Type.qname) Hashtbl.t = Hashtbl.create 17 let find_predefined qname = Hashtbl.find predefs_tbl qname let register_predefined ty instance = Hashtbl.add predefs_tbl ty instance let () = List.iter (fun (a, b) -> register_predefined a b) predefs end module RegisterClass (Desc : Defs.ClassDescription) (MakeClass : ClassBuilder) = struct module InnerDesc = MakeInnerDesc(Desc) module Builder(Loc: Loc) = MakeClass(InnerGenerator(Loc)(InnerDesc)) let _ = register (module Desc : Defs.ClassDescription) (module Builder : InnerClassBuilder) let register_predefs = InnerDesc.register_predefined end module RegisterFullClass (Desc : Defs.ClassDescription) (MakeClass : FullBuilder) = struct module InnerDesc = MakeInnerDesc(Desc) module Builder(Loc: Loc) = MakeClass(InnerGenerator(Loc)(InnerDesc)) let _ = register (module Desc : Defs.ClassDescription) (module Builder : InnerClassBuilder) let depends = (module Builder : DepClassBuilder) let register_predefs = InnerDesc.register_predefined end (* Compat with <= 0.4-ocsigen *) module Register (Desc : Defs.ClassDescription) (MakeClass : InnerClassBuilder) = struct let _ = register (module Desc : Defs.ClassDescription) (module MakeClass : InnerClassBuilder) end module Generator(Loc : Loc)(Desc : ClassDescription) = InnerGenerator(Loc)(MakeInnerDesc(Desc)) deriving-0.7.1/syntax/common/base.mli000066400000000000000000000022761272135405000175670ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. Copyright Grégoire Henry 2011. This file is free software, distributed under the MIT license. See the file COPYING for details. *) exception Underivable of string exception NoSuchClass of string open Camlp4.PreCast val fatal_error : Loc.t -> string -> 'a val display_errors : Loc.t -> ('a -> 'b) -> 'a -> 'b open Defs val derive_str : Loc.t -> Type.decl list -> generator -> Ast.str_item val derive_sig : Loc.t -> Type.decl list -> generator -> Ast.sig_item module RegisterClass(Desc : ClassDescription)(MakeClass : ClassBuilder) : sig val register_predefs : Type.qname -> Type.qname -> unit end module RegisterFullClass(Desc : ClassDescription)(MakeClass : FullBuilder) : sig val depends : (module DepClassBuilder) val register_predefs : Type.qname -> Type.qname -> unit end val is_registered : Type.name -> bool val add_register_hook: ((module ClassDescription) -> generator -> unit) -> unit val find : Type.name -> generator (**/**) module Register(Desc : ClassDescription)(MakeClass : InnerClassBuilder) : sig (* Side effects only *) end module Generator(Loc : Loc)(Desc : ClassDescription) : Generator module AstHelpers(Loc : Loc) : AstHelpers deriving-0.7.1/syntax/common/clusters.ml000066400000000000000000000122371272135405000203460ustar00rootroot00000000000000(* Copyright Grégoire Henry 2011. This file is free software, distributed under the MIT license. See the file COPYING for details. *) open Utils open Type (* See cluster.mli for a description of "clusters". *) let extract_recursive_calls decls : ESet.t list = let names = List.map (fun (name,_,_,_,_) -> name) decls in let obj = (object (self) inherit [ESet.t] fold as default method crush sets = List.fold_left ESet.union ESet.empty sets method expr e = match e with | `Constr ([name], args) as e when List.mem name names -> ESet.add (name, args) (default#expr e) | e -> default#expr e method decl d = match d with | (tname, params, `Fresh (_, GSum _, _), _, _) -> (* All GADT are considered recursives... cf. base.ml*) ESet.add (tname, List.map (fun p -> `Param p) params) (default#decl d) | _ -> default#decl d end) in List.map obj#decl decls (** The function [close_decls decls] computes, for the set of type declarations [decls], the actual instances of these types that are used in their definitions. It throws an exception if the set is known to be infinite (a.k.a. non-regural types). *) let close_decls (decls: Type.decl list) : (Type.decl * ESet.t) list = let check_regular_instance name (name', args') = name <> name' || List.for_all (function (`Constr _ | `Tuple _ | `Function _) as e -> not (contains_tvars e) | _ -> true) args' in let expand (tys : (Type.decl * ESet.t) list) name ty_set (name', args') = let ((_, params',_,_,_), ty_set') = List.find (fun ((n,_,_,_,_),_) -> n = name') tys in let subst = NameMap.fromList (List.map2 (fun (p, _) a -> p, a) params' args') in ESet.fold (fun (name'', args'') acc -> let new_ty = name'', List.map (substitute_expr subst) args'' in if not (check_regular_instance name new_ty) then failwith ("The following types contain non-regular recursion:\n " ^String.concat ", " (List.map (fun ((n,_,_,_,_),_)->n) tys) ^"\nderiving does not support non-regular types"); if ESet.mem new_ty ty_set then acc else ESet.add new_ty acc) ty_set' ESet.empty in let expands (tys : (Type.decl * ESet.t) list) = List.map (fun ((name,_,_,_,_),ty_set) -> ESet.fold (fun ty acc -> ESet.union (expand tys name ty_set ty) acc) ty_set ESet.empty) tys in let aggregate_new_tys (tys : (Type.decl * ESet.t) list) new_tys = List.map2 (fun (d,set) new_set -> d, ESet.union set new_set) tys new_tys in let rec loop_close_decls (tys : (Type.decl * ESet.t) list) new_tys = if List.for_all (fun l -> l = ESet.empty) new_tys then tys else let tys = aggregate_new_tys tys new_tys in let new_tys = expands tys in loop_close_decls tys new_tys in loop_close_decls (List.map (fun d -> d, ESet.empty) decls) (extract_recursive_calls decls) (** The function [rename_param decl] rename the type parameters with 'a 'b 'c ... *) let rename_params (name, params, rhs, constraints, deriving as decl) = if deriving then decl else let map = List.mapn (fun (o, v) n -> let n' = if o.[0] = '_' then "_" ^ typevar_of_int n else typevar_of_int n in (o, (n', v))) params in let subst = NameMap.fromList (List.map (fun (o, (n, _)) -> o, n) map) in ((name, List.map snd map, rename_rhs subst rhs, List.map (rename_constraint subst) constraints, false)) (** Group type declaration (and the associated instances involved in recursion) by the set of freevars in there "associated recursives instances". *) let aggregate_clusters decls = let add_instances acc (((name,params,_,_,_ : Type.decl) as decl), insts) = (* Determine types variables involved in recursion. *) let freevars = ESet.fold (fun (name, args) acc -> ParamSet.union (Type.free_tvars (`Constr ([name], args))) acc) insts ParamSet.empty in ParamSet.iter (* TODO error message instead of assert (unknown variable) *) (fun (n, _ as var) -> if not (List.exists (fun p -> var = p) params) then failwith ("Unkown variable " ^ n) ) freevars; assert (ParamSet.for_all (* TODO error message instead of assert (unknown variable) *) (fun var -> List.exists (fun p -> var = p) params) freevars); (* Then regroups with instances that shares effective parameters. *) let rec loop acc = match acc with | [] -> [insts, freevars, [decl]] | (insts', vars, decls) :: acc when ParamSet.equal freevars vars -> (ESet.union insts insts', vars, decl :: decls) :: acc | e :: acc -> e :: loop acc in loop acc in List.fold_left add_instances [] decls let sort_freevars (fv: ParamSet.t) : param list = List.sort compare (ParamSet.fold (fun v acc -> v :: acc) fv []) type cluster = { params: Type.param list; decls: Type.decl list; instances: (Type.name * Type.expr list) list; } let ( >>> ) x f = f x let make decls = let sets = List.map rename_params decls >>> close_decls >>> aggregate_clusters in List.map (fun (insts, fv, decls) -> { instances = ESet.toList insts; params = sort_freevars fv; decls; }) sets deriving-0.7.1/syntax/common/clusters.mli000066400000000000000000000022511272135405000205120ustar00rootroot00000000000000(* Copyright Grégoire Henry 2011. This file is free software, distributed under the MIT license. See the file COPYING for details. *) (* A cluster is the finite set of recursive class instances needed for deriving a "regular" recursive type declaration. For example: type 'a t = A of 'a | B of 'a * 'a t | I of int t The corresponding cluster is: { 'a t ; int t }. For multiple recursives declarations, we may group clusters by the set of free variables involved in the required instances. For example: type 'a t1 = ('a, int) t2 and ('a, 'b) t2 = A of 'a t1 | B of 'b deriving (Show) Types declaration t1 and t2 share the same clusters: { 'a t1; ('a, int) t2 }. This notion of clusters allows to be less restrictive with recursive type declaration than previous version of deriving. It's still not sufficient for handling "non-regular" datatypes like: type 'a nested = Z of nested | S of ('a * 'a) nested because the set of required instance would be infinite. *) type cluster = { params: Type.param list; decls: Type.decl list; instances: (Type.name * Type.expr list) list; } val make: Type.decl list -> cluster list deriving-0.7.1/syntax/common/defs.ml000077700000000000000000000000001272135405000210352defs.mliustar00rootroot00000000000000deriving-0.7.1/syntax/common/defs.mli000066400000000000000000000110141272135405000175640ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. Copyright Grégoire Henry 2011. This file is free software, distributed under the MIT license. See the file COPYING for details. *) open Camlp4.PreCast module type Loc = sig val _loc : Loc.t (* location of the type definition being derived *) end module type AstHelpers = sig module Untranslate : Type.Untranslate val seq: Ast.expr -> Ast.expr -> Ast.expr val seq_list: Ast.expr list -> Ast.expr val record_pattern: ?prefix:string -> Type.field list -> Ast.patt val record_expr: (string * Ast.expr) list -> Ast.expr val record_expression: ?prefix:string -> Type.field list -> Ast.expr val expr_list: Ast.expr list -> Ast.expr val patt_list: Ast.patt list -> Ast.patt val tuple_expr: Ast.expr list -> Ast.expr val tuple: ?param:string -> int -> string list * Ast.patt * Ast.expr val cast_pattern: Type.qname Type.NameMap.t -> ?param:string -> Type.expr -> Ast.patt * Ast.expr * Ast.expr val modname_from_qname: qname:string list -> classname:string -> Ast.ident end module type Generator = sig type context module Loc : Loc module AstHelpers : AstHelpers val cast_pattern: context -> ?param:string -> Type.expr -> Ast.patt * Ast.expr * Ast.expr val instantiate_modargs_repr: context -> Type.repr -> Type.repr class virtual generator : object method pack: Type.qname Type.NameMap.t -> Type.expr -> Ast.module_expr -> Ast.expr method unpack: Type.qname Type.NameMap.t -> Type.expr -> Ast.expr -> Ast.module_expr method class_sig: Type.qname Type.NameMap.t -> Type.expr -> Ast.module_type method rhs: context -> Type.subst -> Type.decl -> Ast.module_expr method expr: context -> Type.expr -> Ast.module_expr method constr: context -> Type.qname * Type.expr list -> Ast.module_expr method param: context -> Type.param -> Ast.module_expr method gparam: context -> Type.param * Type.expr -> Ast.module_expr method wrap: context -> ?default:Type.name option -> Type.expr -> Ast.str_item list -> Ast.module_expr method call_expr: context -> Type.expr -> string -> Ast.expr method call_poly_expr: context -> Type.poly_expr -> string -> Ast.expr method virtual proxy: unit -> Type.name option * Ast.ident list method virtual sum: ?eq:Type.expr -> context -> Type.name -> Type.expr list -> Type.constraint_ list -> Type.summand list -> Ast.str_item list method gsum: ?eq:Type.expr -> context -> Type.name -> Type.expr list -> Type.constraint_ list -> Type.gsummand list -> Ast.str_item list method virtual tuple: context -> Type.expr list -> Ast.str_item list method virtual variant: context -> Type.name -> Type.expr list -> Type.constraint_ list -> Type.variant -> Ast.str_item list method virtual record: ?eq:Type.expr -> context -> Type.name -> Type.expr list -> Type.constraint_ list -> Type.field list -> Ast.str_item list method class_: context -> [ `NYI ] -> Ast.str_item list method function_: context -> Type.expr * Type.expr -> Ast.str_item list method label: context -> [ `NonOptional | `Optional ] * Type.name * Type.expr * Type.expr -> Ast.str_item list method object_: context -> [ `NYI ] -> Ast.str_item list end val generate: generator -> Type.decl list -> Ast.str_item val generate_sigs: generator -> Type.decl list -> Ast.sig_item val generate_expr: generator -> Ast.module_expr Type.EMap.t -> Type.qname Type.NameMap.t -> Type.expr -> Ast.module_expr end (** *) module type Class = sig val generate: Type.decl list -> Ast.str_item val generate_sigs: Type.decl list -> Ast.sig_item end module type ClassBuilder = functor (Generator : Generator) -> Class module type InnerClassBuilder = functor (Loc: Loc) -> Class module type FullClass = sig val classname: Type.name val runtimename: Type.name include Class val generate_expr: Ast.module_expr Type.EMap.t -> Type.qname Type.NameMap.t -> Type.expr -> Ast.module_expr end module type FullBuilder = functor (Generator: Generator) -> FullClass module type DepClassBuilder = functor (Loc: Loc) -> FullClass module type ClassDescription = sig val classname: Type.name val runtimename: Type.name val default_module: Type.name option val alpha: Type.name option val allow_private: bool val predefs: (Type.qname * Type.qname) list val depends: (module DepClassBuilder) list end type generator = (module InnerClassBuilder) (**/**) (* Compat with <= 0.4-ocsigen *) module type FullClassBuilder = functor (Loc: Loc) -> FullClass deriving-0.7.1/syntax/common/extend.ml000066400000000000000000000062101272135405000177630ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) (* Extend the OCaml grammar to include the `deriving' clause after type declarations in structure and signatures. *) open Utils open Camlp4.PreCast let instantiate _loc t classname = try let class_ = Base.find classname in let module U = Type.Untranslate(struct let _loc = _loc end) in let binding = Ast.TyDcl (_loc, "inline", [], t, []) in let decls = Base.display_errors _loc Type.Translate.decls binding in if List.exists Type.contains_tvars_decl decls then Base.fatal_error _loc ("deriving: type variables cannot be used in `method' instantiations"); let tdecls = List.map U.decl decls in let m = Base.derive_str _loc decls class_ in <:module_expr< struct type $list:tdecls$ $m$ include $uid:classname ^ "_inline"$ end >> with Base.NoSuchClass classname -> Base.fatal_error _loc ("deriving: " ^ classname ^ " is not a known `class'") module Deriving (S : Camlp4.Sig.Camlp4Syntax) = struct include Syntax let rec drop n l = if n <= 0 then l else match l with | [] -> [] | _ :: l -> drop (n - 1) l let test_val_longident_dot_lt = Gram.Entry.of_parser "test_val_longident_dot_lt" (fun strm -> let rec test_longident_dot pos tokens = match tokens with | (ANTIQUOT ((""|"id"|"anti"|"list"), _), _) :: tokens -> test_longident_dot (pos+1) tokens | (UIDENT _, _) :: (KEYWORD ".", _) :: (LIDENT _, _) :: tokens -> test_longident_dot (pos+3) tokens | _ :: _ -> test_delim pos tokens | [] -> fetch_more test_longident_dot pos and test_delim pos tokens = if pos = 0 then raise Stream.Failure else match tokens with | (KEYWORD ("<"), _) :: _ -> () | _ :: _ -> raise Stream.Failure | [] -> fetch_more test_delim pos and fetch_more k pos = match drop pos (Stream.npeek (pos + 10) strm) with | [] -> raise Stream.Failure | tokens -> k pos tokens in fetch_more test_longident_dot 0 ) open Ast EXTEND Gram expr: LEVEL "simple" [ [ TRY[ test_val_longident_dot_lt; e1 = val_longident ; "<" ; t = ctyp; ">" -> match e1 with | <:ident< $uid:classname$ . $lid:methodname$ >> -> let m = instantiate _loc t classname in <:expr< let module $uid:classname$ = $m$ in $uid:classname$.$lid:methodname$ >> | _ -> Base.fatal_error _loc ("deriving: this looks a bit like a method application, but " ^"the syntax is not valid"); ]]]; module_expr: LEVEL "simple" [ [ TRY[ test_val_longident_dot_lt; e1 = val_longident ; "<" ; t = ctyp; ">" -> match e1 with | <:ident< $uid:classname$ >> -> instantiate _loc t classname | _ -> Base.fatal_error _loc ("deriving: this looks a bit like a class instantiation, but " ^"the syntax is not valid"); ]]]; END end module M = Camlp4.Register.OCamlSyntaxExtension(Id)(Deriving) deriving-0.7.1/syntax/common/extend.mli000066400000000000000000000005141272135405000201350ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) (* Extend the OCaml grammar to include the `deriving' clause after type declarations in structure and signatures. *) module Deriving (S : Camlp4.Sig.Camlp4Syntax): Camlp4.Sig.Camlp4Syntax deriving-0.7.1/syntax/common/id.ml.ab000066400000000000000000000000701272135405000174470ustar00rootroot00000000000000let version = "$(pkg_version)" let name = "$(pkg_name)" deriving-0.7.1/syntax/common/type.ml000066400000000000000000000617331272135405000174700ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. Copyright Grégoire Henry 2011. This file is free software, distributed under the MIT license. See the file COPYING for details. *) open Utils (* auxiliary definitions *) type name = string type qname = name list module NameMap = Map.Make(String) module NameSet = Set.Make(String) type param = name * [`Plus | `Minus] option (* no support for private types yet *) type decl = name * param list * rhs * constraint_ list (* whether the type was inserted by deriving *) * bool and rhs = [`Fresh of expr option * repr * [`Private|`Public] |`Expr of expr |`Variant of variant * [ `Private | `Public ] |`Nothing] and repr = Sum of summand list | GSum of name * gsummand list | Record of field list and field = name * poly_expr * [`Mutable | `Immutable] and summand = name * expr list and gsummand = name * expr list * expr list and constraint_ = expr * expr and expr = (* elements that can be nested *) [ `Param of param | `GParam of param * expr | `Label of ([`Optional|`NonOptional] * name * expr * expr) | `Function of (expr * expr) | `Constr of (qname * expr list) | `Tuple of expr list | `Object of [`NYI] | `Class of [`NYI] ] and poly_expr = param list * expr (* no support for < > variants yet. no support for '&' yet. *) and variant = [`Gt | `Lt | `Eq] * tagspec list and tagspec = Tag of name * expr list | Extends of expr let rec compare_expr (e1: expr) (e2: expr) = match e1, e2 with | `Param p1, `Param p2 | `Param p1, `GParam (p2, _) | `GParam (p1, _), `Param p2 | `GParam (p1, _), `GParam(p2, _) -> compare p1 p2 | _, `Param _ -> -1 | `Param _, _ -> 1 | _, `GParam _ -> -1 | `GParam _, _ -> 1 | `Label (t1, n1, e1, e1'), `Label (t2, n2, e2, e2') -> let c = compare t1 t2 in if c <> 0 then c else let c = compare n1 n2 in if c <> 0 then c else let c = compare_expr e1 e2 in if c <> 0 then c else let c = compare_expr e1' e2' in c | _, `Label _ -> -1 | `Label _, _ -> 1 | `Function (e1, e1'), `Function (e2, e2') -> let c = compare_expr e1 e2 in if c <> 0 then c else let c = compare_expr e1' e2' in c | `Function _, _ -> -1 | _, `Function _ -> 1 | `Constr (n1, es1), `Constr (n2, es2) -> let c = compare n1 n2 in if c <> 0 then c else let c = compare_expr_list es1 es2 in c | `Constr _, _ -> -1 | _, `Constr _ -> 1 | `Tuple es1, `Tuple es2 -> compare_expr_list es1 es2 | _, `Tuple _ -> -1 | `Tuple _, _ -> 1 | `Object _, `Object _ -> 0 | `Object _, _ -> -1 | _, `Object _ -> 1 | `Class _, `Class _ -> 0 and compare_expr_list es1 es2 = match es1, es2 with | [], [] -> 0 | _, [] -> -1 | [], _ -> 1 | e1 :: es1, e2 :: es2 -> let c = compare_expr e1 e2 in if c <> 0 then c else let c = compare_expr_list es1 es2 in c module Param = struct type t = param let compare = compare end module ParamSet = Set.Make(Param) module ParamMap = Map.Make(Param) module Expr = struct type t = expr let compare = compare_expr end module ExprSet = Set.Make(Expr) module ExprMap = Map.Make(Expr) module E = struct type t = name * expr list let compare (n1, es1) (n2, es2) = let c = compare n1 n2 in if c <> 0 then c else let c = compare_expr_list es1 es2 in c end module ESet = Set.Make(E) module EMap = Map.Make(E) class virtual ['result] fold = object (self : 'self) method virtual crush : 'result list -> 'result method decl (d:decl) = self#crush (match d with | (_, _, rhs, cs,_) -> self#rhs rhs :: List.map self#constraint_ cs) method rhs (r:rhs) = self#crush (match r with | `Fresh (Some e, r, _) -> [self#expr e; self#repr r] | `Fresh (None, r, _) -> [self#repr r] | `Expr e -> [self#expr e] | `Variant (v,_) -> [self#variant v] | `Nothing -> []) method repr r = self#crush (match r with | Sum summands -> List.map self#summand summands | GSum (_, summands) -> List.map self#gsummand summands | Record fields -> List.map self#field fields) method field (name, pexpr, flag) = self#crush [self#poly_expr pexpr] method summand (_,es) = self#crush (List.map self#expr es) method gsummand (_,es1,es2) = self#crush (List.map self#expr (es1 @ es2)) method constraint_ (e1,e2) = self#crush [self#expr e1; self#expr e2] method expr e = self#crush (match e with `Param _ | `GParam (_, _) | `Object _ | `Class _ -> [] | `Label (_, _, e1, e2) | `Function (e1, e2) -> [self#expr e1; self#expr e2] | `Constr (_, exprs) | `Tuple exprs -> List.map self#expr exprs) method poly_expr (params,e) = self#crush [self#expr e] method variant (_,tagspecs) = self#crush (List.map self#tagspec tagspecs) method tagspec t = self#crush (match t with | Tag (_, exprs) -> List.map self#expr exprs | Extends e -> [self#expr e]) end class transform = object (self : 'self) method decl (name, params, rhs, constraints,g:decl) : decl = (name, params, self#rhs rhs, List.map (self # constraint_) constraints, g) method rhs = function | `Fresh (eopt, repr, p) -> `Fresh (Option.map (self # expr) eopt, self # repr repr, p) | `Expr e -> `Expr (self # expr e) | `Variant (v,p) -> `Variant (self # variant v, p) | `Nothing -> `Nothing method repr = function | Sum summands -> Sum (List.map (self # summand) summands) | GSum (name, summands) -> GSum (name, List.map (self # gsummand) summands) | Record fields -> Record (List.map (self # field) fields) method field (name, poly_expr, flag) = (name, self # poly_expr poly_expr, flag) method summand (name, exprs) = (name, List.map (self # expr) exprs) method gsummand (name, exprs, params) = (name, List.map (self # expr) exprs, List.map (self # expr) params) method constraint_ (e1, e2) = (self#expr e1, self#expr e2) method expr = function | `Object _ | `Class _ | `Param _ | `GParam _ as e -> e | `Label (flag, name, e1, e2) -> `Label (flag, name, self # expr e1, self # expr e2) | `Function (e1, e2) -> `Function (self # expr e1, self # expr e2) | `Constr (qname, exprs) -> `Constr (qname, List.map (self # expr) exprs) | `Tuple exprs -> `Tuple (List.map self # expr exprs) method poly_expr (params, expr) = (params, self # expr expr) method variant (t, tagspecs) = (t, List.map (self # tagspec) tagspecs) method tagspec = function | Tag (name, exprs) -> Tag (name, List.map self # expr exprs) | Extends e -> Extends (self # expr e) end module Translate = struct open Camlp4.PreCast let anon_param = let id = ref 0 in fun () -> incr id; "_" ^ string_of_int !id let param = function | Ast.TyQuP (loc, name) -> name, Some `Plus | Ast.TyQuM (loc, name) -> name, Some `Minus | Ast.TyQuo (loc, name) -> name, None #if ocaml_version >= (4, 00) | Ast.TyAnP _ -> anon_param (), Some `Plus | Ast.TyAnM _ -> anon_param (), Some `Minus | Ast.TyAny _ -> anon_param (), None #endif | _ -> assert false let params = List.map param let split_and = function | Ast.TyAnd (_,l,r) -> Left (l,r) | t -> Right t let split_comma = function | Ast.TyCom (_,l,r) -> Left (l,r) | t -> Right t let split_semi = function | Ast.TySem (_,l,r) -> Left (l,r) | t -> Right t let split_or = function | Ast.TyOr (_,l,r) -> Left (l,r) | t -> Right t let split_amp = function | Ast.TyAmp (_,l,r) -> Left (l,r) | t -> Right t let split_ofamp = function | Ast.TyOfAmp (_,l,r) -> Left (l,r) | t -> Right t let split_star = function | Ast.TySta (_,l,r) -> Left (l,r) | t -> Right t let list (one : Ast.ctyp -> 'a) (split : Ast.ctyp -> (Ast.ctyp * Ast.ctyp, Ast.ctyp) either) : Ast.ctyp -> 'a list = let rec aux = function | Ast.TyNil _ -> [] | ctyp -> match split ctyp with | Left (l,r) -> aux l @ aux r | Right item -> [one item] in aux let ident : Ast.ident -> name = function | Ast.IdAcc _ | Ast.IdAnt _ | Ast.IdApp _ -> assert false | Ast.IdLid (_, i) | Ast.IdUid (_, i) -> i let rec qident : Ast.ident -> qname = function | Ast.IdAcc (_,l,r) -> qident l @ qident r | Ast.IdAnt _ | Ast.IdApp _ -> assert false | Ast.IdLid _ | Ast.IdUid _ as i -> [ident i] type vmap = (name * variant * name option) list let fresh_name, set_name_prefix = let name_prefix = ref "" in let counter = ref 0 in ((fun () -> incr counter; "deriving_" ^ !name_prefix ^ "_" ^ string_of_int !counter), (fun name -> name_prefix := name; counter := 0)) module WithParams(P : sig val params : param list end) = struct include P let apply_t name = `Constr([name], List.map (fun p -> `Param p) params) let rec expr : Ast.ctyp -> expr * vmap = function | Ast.TyObj _ -> `Object `NYI, [] | Ast.TyCls _ -> `Class `NYI, [] | Ast.TyQuP (_,_) | Ast.TyQuM (_,_) | Ast.TyQuo (_,_) as p -> `Param (param p), [] | Ast.TySum _ | Ast.TyRec _ -> failwith "deriving: top level element found nested" | Ast.TyAny _ -> failwith "deriving does not support `_' in type definitions" | Ast.TyArr (_,f,t) -> let f, v1 = expr f and t,v2 = expr t in `Function (f, t), v1 @ v2 | Ast.TyApp _ as app -> let app, v = application app in `Constr app, v | Ast.TyId (_, i) -> `Constr (qident i, []), [] | Ast.TyTup (_, t) -> let es, vs = List.split (list expr split_star t) in `Tuple es, List.concat vs | Ast.TyVrnEq (_, t) -> variant t `Eq | Ast.TyVrnSup (_, t) -> variant t `Gt | Ast.TyVrnInf (_, t) -> variant t `Lt | Ast.TyAli (_, _, Ast.TyQuo (_,name)) when List.mem_assoc name params -> failwith ("Alias names must be distinct from parameter names for " ^"\nderived types, but '"^name^" is both an alias and a parameter") | Ast.TyAli (_, Ast.TyVrnEq (_, t), Ast.TyQuo (_,name)) -> variant t ~alias:name `Eq | Ast.TyAli (_, Ast.TyVrnSup (_, t), Ast.TyQuo (_,name)) -> variant t ~alias:name `Gt | Ast.TyAli (_, Ast.TyVrnInf (_, t), Ast.TyQuo (_,name)) -> variant t ~alias:name `Lt | Ast.TyVrnInfSup (_, _, _) -> failwith "deriving does not currently support [ < > ] variant types" | Ast.TyLab _ -> failwith "deriving does not support label types" | e -> failwith ("unexpected type at expr : " ^ Utils.DumpAst.ctyp e) and tagspec = function | Ast.TyVrn (_,tag) -> Tag (tag, []), [] | Ast.TyOf (_, Ast.TyVrn (_,tag), t) -> let es, vs = List.split (list expr split_comma t) in Tag (tag, es), List.concat vs | t -> let e, v = expr t in Extends e, v and application : Ast.ctyp -> (qname * expr list) * vmap = function | Ast.TyApp (_, (Ast.TyApp _ as a), t) -> let (tcon, args), vs = application a in let e, vs' = expr t in (tcon, args @ [e]), vs @ vs' | Ast.TyApp (_, (Ast.TyId (_, tcon)), t) -> let e, v = expr t in (qident tcon, [e]), v | _ -> assert false and variant tags ?alias spec = let name = fresh_name () in let tags, vs = List.split (list tagspec split_or tags) in (apply_t name, [name, (spec, tags), alias] @ List.concat vs) let rec polyexpr : Ast.ctyp -> poly_expr * vmap = function | Ast.TyPol (_, ps, t) -> begin match polyexpr t with | (ps',t'), [] -> (list param split_comma ps @ ps', t'), [] | _ -> failwith ("deriving does not support polymorphic variant " ^"definitions within polymorphic record field types") end | t -> let e, v = expr t in ([], e), v let field : Ast.ctyp -> field * vmap = function | Ast.TyCol (_, Ast.TyId (_,name), Ast.TyMut (_, t)) -> let p, v = polyexpr t in (ident name, p, `Mutable), v | Ast.TyCol (_, Ast.TyId (_,name), t) -> let p, v = polyexpr t in (ident name, p, `Immutable), v | _ -> assert false let summand : Ast.ctyp -> summand * vmap = function | Ast.TyId (_, c) -> (ident c, []), [] | Ast.TyOf (_, Ast.TyId (_, c), t) -> let es, vs = List.split (list expr split_and t) in (ident c, es), List.concat vs | _ -> assert false let replace_param params e = let params = List.combine params P.params in let map = object (self) inherit transform as super method expr e = try let p = List.assoc e params in `GParam (p, e) with Not_found -> match e with | `Param p -> failwith ("deriving does not support existantial type " ^"or partially instantiated return type in GADT"); | e -> super # expr e end in map # expr e let ret_type rt = match expr rt with | `Constr ([id], params), [] -> id, params | `Constr ([_], _), _ :: _ -> failwith ("deriving does not currently support polymorphic variant " ^"within GADT") | _ -> assert false let gsummand : Ast.ctyp -> string * gsummand = function | Ast.TyCol (_, Ast.TyId (_, c), Ast.TyArr(_, t, rt)) -> let tname, params = ret_type rt in let args, vs = List.split (list expr split_and t) in if List.concat vs <> [] then failwith ("deriving does not currently support polymorphic variant " ^"within GADT"); let args = List.map (replace_param params) args in tname, (ident c, args, params) | Ast.TyCol (_, Ast.TyId (_, c), rt) -> let tname, params = ret_type rt in tname, (ident c, [], params) | _ -> assert false let is_gadt summands = List.exists (function Ast.TyCol _ -> true | _ -> false) summands let rec repr = function | Ast.TyRec (loc, fields) -> let fields, vs = List.split (list field split_semi fields) in Record fields, List.concat vs | Ast.TySum (loc, summands) -> let summands = list (fun x -> x) split_or summands in if is_gadt summands then let tname, summands = List.split (List.map gsummand summands) in GSum (List.hd tname, summands), [] else let summands, vs = List.split (List.map summand summands) in Sum summands, List.concat vs | e -> failwith ("deriving: unexpected representation type ("^Utils.DumpAst.ctyp e^")") let toplevel : Ast.ctyp -> rhs * vmap = function | Ast.TyPrv (_, (Ast.TyRec _ | Ast.TySum _ as r)) -> let repr, vs = repr r in `Fresh (None, repr, `Private), vs | Ast.TyRec _ | Ast.TySum _ as r -> let repr, vs = repr r in `Fresh (None, repr, `Public), vs | Ast.TyVrnEq (_, t) -> let es, vs = List.split (list tagspec split_or t) in `Variant ((`Eq, es), `Public), List.concat vs | Ast.TyPrv (_, Ast.TyVrnSup (_, t)) -> let es, vs = List.split (list tagspec split_or t) in `Variant ((`Gt, es), `Private), List.concat vs | Ast.TyVrnSup (_, t) -> let es, vs = List.split (list tagspec split_or t) in `Variant ((`Gt, es), `Public), List.concat vs | Ast.TyVrnInf (_, t) -> let es, vs = List.split (list tagspec split_or t) in `Variant ((`Lt, es), `Public), List.concat vs | Ast.TyPrv (_, Ast.TyVrnInf (_, t)) -> let es, vs = List.split (list tagspec split_or t) in `Variant ((`Lt, es), `Private), List.concat vs | Ast.TyVrnInfSup (_, _, _) -> failwith "deriving does not currently support [ < > ] types" | Ast.TyNil _ -> `Nothing, [] | Ast.TyPrv _ -> failwith "This fixed type has no row variable" | Ast.TyMan (_, eq, (Ast.TyRec _ | Ast.TySum _ as r)) -> let repr, v1 = repr r and ex, v2 = expr eq in `Fresh (Some ex, repr, `Public), v1 @ v2 | Ast.TyMan (_, eq, Ast.TyPrv (_, (Ast.TyRec _ | Ast.TySum _ as r))) -> let repr, v1 = repr r and ex, v2 = expr eq in `Fresh (Some ex, repr, `Private), v1 @ v2 | t -> let e, v = expr t in `Expr e, v let constraints : (Ast.ctyp * Ast.ctyp) list -> constraint_ list * vmap = fun cs -> List.fold_right (fun (c1,c2) (es,vs) -> let e1,v1 = expr c1 and e2,v2 = expr c2 in ((e1,e2)::es), (v1 @ v2 @ vs)) cs ([],[]) let declify = let declify1 (name, variant, alias) : decl * (name * expr) option = (name, params, `Variant (variant,`Public), [], true), Option.map (fun a -> a, apply_t name) alias in List.map declify1 end type alias_map = expr NameMap.t let build_alias_map : (name * expr) option list -> alias_map = fun m -> NameMap.fromList (List.concat_map (function None -> [] | Some e -> [e]) m) let split : Ast.ctyp -> Ast.ctyp list = let rec aux t = match split_and t with | Left (l, r) -> aux l @ aux r | Right t -> [t] in aux let rec decl : Ast.ctyp -> decl list * alias_map = function | Ast.TyDcl (loc, name, ps, rhs, cs) -> set_name_prefix name; let module P = WithParams(struct let params = params ps end) in let tl, vs = P.toplevel rhs in let cs, vcs = P.constraints cs in let decls, aliases = List.split (P.declify (vs @ vcs)) in [(name, P.params, tl, cs, false)] @ decls, build_alias_map aliases | _ -> assert false let substitute_aliases : alias_map -> decl -> decl = fun map -> object inherit transform as super method expr = function | `Param (p,_) when NameMap.mem p map -> NameMap.find p map | e -> super#expr e end # decl let decls : Ast.ctyp -> decl list = fun ctyp -> let decls, aliases = List.split (List.map decl (split ctyp)) in List.concat (List.map (List.map (substitute_aliases (NameMap.union_disjoint aliases))) decls) end module type Untranslate = sig open Camlp4.PreCast val param: string * [< `Minus | `Plus ] option -> Ast.ctyp val qname: string list -> Ast.ident val qName: string list -> Ast.ident val expr: expr -> Ast.ctyp val poly: param list * expr -> Ast.ctyp val rhs: rhs -> Ast.ctyp val tagspec: tagspec -> Ast.ctyp val summand: summand -> Ast.ctyp val field: field -> Ast.ctyp val repr: repr -> Ast.ctyp val constraint_: expr * expr -> Ast.ctyp * Ast.ctyp val decl: decl -> Ast.ctyp val sigdecl: decl -> Ast.ctyp list end module Untranslate (C:sig val _loc : Camlp4.PreCast.Ast.Loc.t end) : Untranslate = struct open Camlp4.PreCast open C let param (name, v) = if name.[0] = '_' then #if ocaml_version < (4, 00) Ast.TyAny _loc #else match v with | None -> Ast.TyAny _loc | Some `Plus -> Ast.TyAnP _loc | Some `Minus -> Ast.TyAnM _loc #endif else match v with | None -> <:ctyp< '$lid:name$ >> | Some `Plus -> <:ctyp< +'$lid:name$ >> | Some `Minus -> <:ctyp< -'$lid:name$ >> let rec qname = function | [] -> assert false | [x] -> <:ident< $lid:x$ >> | x::xs -> <:ident< $uid:x$.$qname xs$ >> let rec qName = function | [] -> assert false | [x] -> <:ident< $uid:x$ >> | x::xs -> <:ident< $uid:x$.$qName xs$ >> let expr = let rec expr : expr -> Ast.ctyp = function `Param p -> param p | `GParam (p, e) -> expr e | `Function (f, t) -> <:ctyp< $expr f$ -> $expr t$ >> | `Tuple [t] -> expr t | `Tuple ts -> Ast.TyTup (_loc, Ast.tySta_of_list (List.map expr ts)) | `Constr (tcon, args) -> app (Ast.TyId (_loc, qname tcon)) args | _ -> assert false and app f = function | [] -> f | [x] -> <:ctyp< $f$ $expr x$ >> | x::xs -> app (<:ctyp< $f$ $expr x$ >>) xs in expr let poly (params, t) = List.fold_right (fun (p : param) (t : Ast.ctyp) -> Ast.TyPol (_loc, param p, t)) params (expr t) let rec rhs : rhs -> Ast.ctyp = function | `Fresh (None, t, `Private) -> <:ctyp< private $repr t$ >> | `Fresh (None, t, `Public) -> repr t | `Fresh (Some e, t, `Private) -> <:ctyp< $expr e$ == private $repr t$ >> | `Fresh (Some e, t, `Public) -> Ast.TyMan (_loc, expr e, repr t) | `Expr t -> expr t | `Variant ((`Eq, tags), `Public) -> <:ctyp< [= $Ast.tyOr_of_list (List.map tagspec tags)$ ] >> | `Variant ((`Eq, tags), `Private) -> <:ctyp< private [= $Ast.tyOr_of_list (List.map tagspec tags)$ ] >> | `Variant ((`Gt, tags), `Public) -> <:ctyp< [> $Ast.tyOr_of_list (List.map tagspec tags)$ ] >> | `Variant ((`Gt, tags), `Private) -> <:ctyp< private [> $Ast.tyOr_of_list (List.map tagspec tags)$ ] >> | `Variant ((`Lt, tags), `Public) -> <:ctyp< [< $Ast.tyOr_of_list (List.map tagspec tags)$ ] >> | `Variant ((`Lt, tags), `Private) -> <:ctyp< private [< $Ast.tyOr_of_list (List.map tagspec tags)$ ] >> | `Nothing -> <:ctyp< >> and tagspec = function | Tag (c, []) -> <:ctyp< `$c$ >> | Tag (c, ts) -> <:ctyp< `$c$ of $expr (`Tuple ts)$ >> | Extends t -> <:ctyp< $expr t$ >> and summand (name, (args : expr list)) = let args = Ast.tyAnd_of_list (List.map expr args) in <:ctyp< $uid:name$ of $args$ >> and gsummand tname (name, (args : expr list), (params : expr list)) = let rt = expr (`Constr ([tname], params)) in let arg = match args with | [] -> rt | _ :: _ -> <:ctyp< $Ast.tyAnd_of_list (List.map expr args)$ -> $rt$ >> in <:ctyp< $uid:name$ : $arg$ >> and field ((name, t, mut) : field) = match mut with | `Mutable -> <:ctyp< $lid:name$ : mutable $poly t$ >> (* mutable l : t doesn't work; perhaps a camlp4 bug *) | `Immutable -> <:ctyp< $lid:name$ : $poly t$ >> and repr = function | Sum summands -> Ast.TySum (_loc,Ast.tyOr_of_list (List.map summand summands)) | GSum (tname, summands) -> Ast.TySum (_loc,Ast.tyOr_of_list (List.map (gsummand tname) summands)) | Record fields -> <:ctyp< { $list:List.map field fields $ }>> let constraint_ (e1,e2) = (expr e1, expr e2) let decl ((name, params, r, constraints,_): decl) = Ast.TyDcl (_loc, name, List.map param params, rhs r, List.map constraint_ constraints) let sigdecl ((name, params, r, constraints, _): decl) = [Ast.TyDcl (_loc, name, List.map param params, rhs r, List.map constraint_ constraints)] end let free_tvars = (* FIXME polycase *) let o = object inherit [ParamSet.t] fold as default method crush = List.fold_left ParamSet.union ParamSet.empty method poly_expr = assert false method expr = function | `Param p -> ParamSet.singleton p | `GParam (p, _) -> ParamSet.singleton p | e -> default#expr e end in o#expr let contains_tvars, contains_tvars_decl = let o = object inherit [bool] fold as default method crush = List.exists F.id method expr = function | `Param _ | `GParam _ -> true | e -> default#expr e end in (o#expr, o#decl) type subst = expr NameMap.t let build_subst l = NameMap.fromList l let substitute map = object inherit transform as super method expr = function | `Param (p,_) when NameMap.mem p map -> begin match NameMap.find p map with | `GParam (p, _) -> `Param p | e -> e end | `GParam ((p, _), e) when NameMap.mem p map -> begin match NameMap.find p map with | `Param p -> `GParam (p, e) | e -> e end | e -> super#expr e end let substitute_decl map = (substitute map)#decl let substitute_expr map = (substitute map)#expr let substitute_rhs map = (substitute map)#rhs let substitute_constraint map = (substitute map)#constraint_ let rename map = object (self) inherit transform as super method expr = function | `Param (p,v) when NameMap.mem p map -> `Param(NameMap.find p map,v) | `GParam ((p,v),e) when NameMap.mem p map -> `GParam((NameMap.find p map,v), self#expr e) | e -> super#expr e end let rename_rhs map = (rename map)#rhs let rename_constraint map = (rename map)#constraint_ (** Pretty-print for error-message *) open Camlp4.PreCast module Printer = Camlp4.Printers.OCaml.Make(Syntax) module Unt = Untranslate(struct let _loc = Loc.ghost end) let print_expr ty = ignore(Format.flush_str_formatter ()); Printer.print None (fun p fmt -> p#ctyp Format.str_formatter) (Unt.expr ty); Format.flush_str_formatter () let print_rhs ty = ignore(Format.flush_str_formatter ()); Printer.print None (fun p fmt -> p#ctyp Format.str_formatter) (Unt.rhs ty); Format.flush_str_formatter () deriving-0.7.1/syntax/common/type.mli000066400000000000000000000132201272135405000176250ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. Copyright Grégoire Henry 2011. This file is free software, distributed under the MIT license. See the file COPYING for details. *) open Utils (* More convenient representation for types, and translation from the Camlp4 representation *) type name = string type qname = name list module NameMap : Map.S with type key = string module NameSet : Set.S with type elt = string (* *) type param = name * [ `Minus | `Plus ] option type decl = name * param list * rhs * constraint_ list * bool and rhs = [ `Expr of expr | `Fresh of expr option * repr * [ `Private | `Public ] | `Nothing | `Variant of variant * [ `Private | `Public ] ] and repr = Sum of summand list | GSum of name * gsummand list | Record of field list and field = name * poly_expr * [ `Immutable | `Mutable ] and summand = name * expr list and gsummand = name * expr list * expr list and constraint_ = expr * expr and expr = [ `Class of [ `NYI ] | `Constr of qname * expr list | `Function of expr * expr | `Label of [ `NonOptional | `Optional ] * name * expr * expr | `Object of [ `NYI ] | `Param of param | `GParam of param * expr | `Tuple of expr list ] and poly_expr = param list * expr and variant = [ `Eq | `Gt | `Lt ] * tagspec list and tagspec = Tag of name * expr list | Extends of expr module ParamSet : Set.S with type elt = param module ParamMap : Map.S with type key = param module ExprSet : Set.S with type elt = expr module ExprMap : Map.S with type key = expr module ESet : Set.S with type elt = name * expr list module EMap : Map.S with type key = name * expr list val free_tvars : expr -> ParamSet.t val contains_tvars : expr -> bool val contains_tvars_decl : decl -> bool type subst = expr NameMap.t val build_subst : (name * expr) list -> subst val substitute_decl : subst -> decl -> decl val substitute_expr : subst -> expr -> expr val substitute_rhs : subst -> rhs -> rhs val substitute_constraint : subst -> constraint_ -> constraint_ val rename_rhs : name NameMap.t -> rhs -> rhs val rename_constraint : name NameMap.t -> constraint_ -> constraint_ (** *) class virtual ['a] fold : object method constraint_ : constraint_ -> 'a method virtual crush : 'a list -> 'a method decl : decl -> 'a method expr : expr -> 'a method field : field -> 'a method poly_expr : poly_expr -> 'a method repr : repr -> 'a method rhs : rhs -> 'a method summand : summand -> 'a method gsummand : gsummand -> 'a method tagspec : tagspec -> 'a method variant : variant -> 'a end class transform : object method constraint_ : constraint_ -> constraint_ method decl : decl -> decl method expr : expr -> expr method field : field -> field method poly_expr : poly_expr -> poly_expr method repr : repr -> repr method rhs : rhs -> rhs method summand : summand -> summand method gsummand : gsummand -> gsummand method tagspec : tagspec -> tagspec method variant : variant -> variant end open Camlp4.PreCast module Translate : sig val param : Ast.ctyp -> string * [> `Minus | `Plus ] option val params : Ast.ctyp list -> (string * [> `Minus | `Plus ] option) list val split_and : Ast.ctyp -> (Ast.ctyp * Ast.ctyp, Ast.ctyp) either val split_comma : Ast.ctyp -> (Ast.ctyp * Ast.ctyp, Ast.ctyp) either val split_semi : Ast.ctyp -> (Ast.ctyp * Ast.ctyp, Ast.ctyp) either val split_or : Ast.ctyp -> (Ast.ctyp * Ast.ctyp, Ast.ctyp) either val split_amp : Ast.ctyp -> (Ast.ctyp * Ast.ctyp, Ast.ctyp) either val split_ofamp : Ast.ctyp -> (Ast.ctyp * Ast.ctyp, Ast.ctyp) either val split_star : Ast.ctyp -> (Ast.ctyp * Ast.ctyp, Ast.ctyp) either val list : (Ast.ctyp -> 'a) -> (Ast.ctyp -> (Ast.ctyp * Ast.ctyp, Ast.ctyp) either) -> Ast.ctyp -> 'a list val ident : Ast.ident -> name val qident : Ast.ident -> qname type vmap = (name * variant * name option) list val fresh_name : unit -> string val set_name_prefix : name -> unit module WithParams(P : sig val params : param list end) : sig val params : param list val apply_t : 'a -> [> `Constr of 'a list * [> `Param of param ] list ] val expr : Ast.ctyp -> expr * vmap val tagspec : Ast.ctyp -> tagspec * vmap val application : Ast.ctyp -> (qname * expr list) * vmap val variant : Ast.ctyp -> ?alias:name -> [ `Eq | `Gt | `Lt ] -> expr * vmap val polyexpr : Ast.ctyp -> poly_expr * vmap val field : Ast.ctyp -> field * vmap val summand : Ast.ctyp -> summand * vmap val repr : Ast.ctyp -> repr * (name * variant * name option) list val toplevel : Ast.ctyp -> rhs * vmap val constraints : (Ast.ctyp * Ast.ctyp) list -> constraint_ list * vmap val declify : (name * variant * name option) list -> (decl * (name * expr) option) list end type alias_map = expr NameMap.t val build_alias_map : (NameMap.key * expr) option list -> alias_map val split : Ast.ctyp -> Ast.ctyp list val decl : Ast.ctyp -> decl list * alias_map val substitute_aliases : alias_map -> decl -> decl val decls : Ast.ctyp -> decl list end module type Untranslate = sig val param : string * [< `Minus | `Plus ] option -> Ast.ctyp val qname : string list -> Ast.ident val qName : string list -> Ast.ident val expr : expr -> Ast.ctyp val poly : param list * expr -> Ast.ctyp val rhs : rhs -> Ast.ctyp val tagspec : tagspec -> Ast.ctyp val summand : summand -> Ast.ctyp val field : field -> Ast.ctyp val repr : repr -> Ast.ctyp val constraint_ : expr * expr -> Ast.ctyp * Ast.ctyp val decl : decl -> Ast.ctyp val sigdecl : decl -> Ast.ctyp list end module Untranslate(C : sig val _loc : Ast.Loc.t end) : Untranslate (* Debug *) val print_expr : expr -> string val print_rhs : rhs -> string deriving-0.7.1/syntax/common/utils.ml000066400000000000000000000165621272135405000176470ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. Copyright Grégoire Henry 2011. This file is free software, distributed under the MIT license. See the file COPYING for details. *) type ('a,'b) either = Left of 'a | Right of 'b let either_partition (f : 'a -> ('b, 'c) either) (l : 'a list) : 'b list * 'c list = let rec aux (lefts, rights) = function | [] -> (List.rev lefts, List.rev rights) | x::xs -> match f x with | Left l -> aux (l :: lefts, rights) xs | Right r -> aux (lefts, r :: rights) xs in aux ([], []) l module List = struct include List let fold_left1 : ('a -> 'a -> 'a) -> 'a list -> 'a = fun f l -> match l with | x::xs -> List.fold_left f x xs | [] -> invalid_arg "fold_left1" let rec fold_right1 : ('a -> 'a -> 'a) -> 'a list -> 'a = fun f l -> match l with | [x] -> x | x::xs -> f x (fold_right1 f xs) | [] -> invalid_arg "fold_right1" let rec range from upto = let rec aux f t result = if f = t then result else aux (f+1) t (f::result) in if upto < from then raise (Invalid_argument "range") else List.rev (aux from upto []) let rec last : 'a list -> 'a = function | [] -> invalid_arg "last" | [x] -> x | _::xs -> last xs let concat_map f l = let rec aux = function | _, [] -> [] | f, x :: xs -> f x @ aux (f, xs) in aux (f,l) let concat_map2 (f : 'a -> 'b -> 'c list) (l1 : 'a list) (l2 : 'b list) : 'c list = let rec aux = function | [], [] -> [] | x::xs, y :: ys -> f x y @ aux (xs, ys) | _ -> invalid_arg "concat_map2" in aux (l1, l2) let mapn ?(init=0) f = let rec aux n = function | [] -> [] | x::xs -> f x n :: aux (n+1) xs in aux init let rec zip xs ys = match xs, ys with | [], [] -> [] | x::xs, y::ys -> (x, y) :: zip xs ys | _, _ -> invalid_arg "List.zip" let rec split3 xyzs = match xyzs with | [] -> [], [], [] | (x, y, z) :: xyzs -> let xs, ys, zs = split3 xyzs in x :: xs, y :: ys, z :: zs end module F = struct let id x = x let curry f x y = f (x,y) let uncurry f (x,y) = f x y end module Option = struct let map f = function | None -> None | Some x -> Some (f x) end module DumpAst = struct open Camlp4.PreCast.Ast let rec ident = function | IdAcc (_, i1, i2) -> "IdAcc ("^ident i1^","^ident i2^")" | IdApp (_, i1, i2) -> "IdApp ("^ident i1^","^ident i2^")" | IdLid (_, s) -> "IdLid("^s^")" | IdUid (_, s) -> "IdUid("^s^")" | IdAnt (_, s) -> "IdAnt("^s^")" let rec ctyp = function | TyLab (_, s, c) -> "TyLab ("^s ^ "," ^ ctyp c ^")" | TyDcl (_, s, cs, c2, ccs) -> "TyDcl ("^s ^", [" ^ String.concat ";" (List.map ctyp cs) ^"], "^ctyp c2 ^ ", ["^ String.concat "," (List.map (fun (c1,c2) -> "(" ^ ctyp c1 ^ ", " ^ ctyp c2 ^ ")") ccs) ^ "])" | TyObj (_, c, _) -> "TyObj ("^ ctyp c ^ ", ?)" | TyOlb (_, s, c) -> "TyOlb ("^s ^ "," ^ ctyp c ^")" | TyOf (_, c1, c2) -> "TyOf ("^ ctyp c1 ^ ", " ^ ctyp c2 ^ ")" | TyOr (_, c1, c2) -> "TyOr ("^ ctyp c1 ^ ", " ^ ctyp c2 ^ ")" | TyRec (_, c) -> "TyRec("^ctyp c^")" | TySum (_, c) -> "TySum("^ctyp c^")" | TyPrv (_, c) -> "TyPrv("^ctyp c^")" | TyMut (_, c) -> "TyMut("^ctyp c^")" | TyTup (_, c) -> "TyTup("^ctyp c^")" | TyVrnEq (_, c) -> "TyVrnEq("^ctyp c^")" | TyVrnSup (_, c) -> "TyVrnSup("^ctyp c^")" | TyVrnInf (_, c) -> "TyVrnInf("^ctyp c^")" | TyCls (_, i) -> "TyCls("^ident i^")" | TyId (_, i) -> "TyId("^ident i^")" | TyNil (_) -> "TyNil" | TyAli (_, c1, c2) -> "TyAli ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TyAny (_) -> "TyAny" | TyApp (_, c1, c2) -> "TyApp ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TyArr (_, c1, c2) -> "TyArr ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TyMan (_, c1, c2) -> "TyMan ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TyPol (_, c1, c2) -> "TyPol ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TyQuo (_, s) -> "TyQuo("^s^")" | TyQuP (_, s) -> "TyQuP("^s^")" | TyQuM (_, s) -> "TyQuM("^s^")" | TyVrn (_, s) -> "TyVrn("^s^")" | TyCol (_, c1, c2) -> "TyCol ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TySem (_, c1, c2) -> "TySem ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TyCom (_, c1, c2) -> "TyCom ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TyAnd (_, c1, c2) -> "TyAnd ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TySta (_, c1, c2) -> "TySta ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TyVrnInfSup (_, c1, c2) -> "TyVrnInfSup ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TyAmp (_, c1, c2) -> "TyAmp ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TyOfAmp (_, c1, c2) -> "TyOfAmp ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TyPkg (_, mt) -> failwith "first-class modules not supported" | TyAnt (_, s) -> "TyAnt("^s^")" #if ocaml_version >= (4, 00) | TyTypePol (_, c1, c2) -> "TyTypoPol("^ ctyp c1^ ", "^ ctyp c2 ^")" | TyAnP _ -> "TyAnP" | TyAnM _ -> "TyAnM" #endif #if ocaml_version >= (4, 02) | TyAtt (_,name,_,c) -> "TyAtt("^ name ^", "^ ctyp c ^")" | TyExt (_,name,args,c) -> "TyExt("^ ident name ^", ["^ (String.concat ", " (List.map ctyp args)) ^ "], " ^ ctyp c ^")" | TyOpn _ -> "TyOpn" #endif end module Map = struct module type OrderedType = Map.OrderedType module type S = sig include Map.S exception Not_found of key val fromList : (key * 'a) list -> 'a t val union_disjoint : 'a t list -> 'a t val union_disjoint2 : 'a t -> 'a t -> 'a t end module Make(Ord: OrderedType) = struct let nf = Not_found exception Not_found of Ord.t include Map.Make(Ord) let find s m = try find s m with e when e = nf -> raise (Not_found s) let fromList : (key * 'a) list -> 'a t = fun elems -> List.fold_right (F.uncurry add) elems empty let union_disjoint2 l r = fold (fun k v r -> if mem k r then invalid_arg "union_disjoint" else add k v r) l r let union_disjoint maps = List.fold_right union_disjoint2 maps empty end end module Set = struct module type OrderedType = Set.OrderedType module type S = sig include Set.S val toList : t -> elt list val fromList : elt list -> t end module Make (Ord : OrderedType) = struct include Set.Make(Ord) let toList t = fold (fun x acc -> x :: acc) t [] let fromList elems = List.fold_right add elems empty end end let random_id length = let idchars = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_'" in let nidchars = String.length idchars in let s = Bytes.create length in for i = 0 to length - 1 do Bytes.set s i idchars.[Random.int nidchars] done; s (* The function used in OCaml to convert variant labels to their integer representations. The formula is given in Jacques Garrigue's 1998 ML workshop paper. *) let tag_hash s = let acc = ref 0 in let len = String.length s in for i = 0 to len - 1 do let c = String.unsafe_get s i in let n = Char.code c in acc := (223 * !acc + n); done; acc := !acc land (1 lsl 31 - 1); if !acc > 0x3fffffff then !acc - (1 lsl 31) else !acc let _ = (* Sanity check to make sure the function doesn't change underneath us *) assert (tag_hash "premiums" = tag_hash "squigglier"); assert (tag_hash "deriving" = 398308260); assert (tag_hash "Candela" = -1019855834) (* For type variable renaming *) let c = "abcdefghijklmnopqrstuvwxyz" let rec typevar_of_int x = assert (x >= 0 && x < 26); String.make 1 (c.[x]) deriving-0.7.1/syntax/common/utils.mli000066400000000000000000000034751272135405000200170ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. Copyright Grégoire Henry 2011. This file is free software, distributed under the MIT license. See the file COPYING for details. *) type ('a, 'b) either = Left of 'a | Right of 'b val either_partition : ('a -> ('b, 'c) either) -> 'a list -> 'b list * 'c list module List : sig include module type of List val fold_left1 : ('a -> 'a -> 'a) -> 'a list -> 'a val fold_right1 : ('a -> 'a -> 'a) -> 'a list -> 'a val range : int -> int -> int list val last : 'a list -> 'a val concat_map : ('a -> 'b list) -> 'a list -> 'b list val concat_map2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list val mapn : ?init:int -> ('a -> int -> 'b) -> 'a list -> 'b list val zip : 'a list -> 'b list -> ('a * 'b) list val split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list end module F : sig val id : 'a -> 'a val curry : ('a * 'b -> 'c) -> 'a -> 'b -> 'c val uncurry : ('a -> 'b -> 'c) -> 'a * 'b -> 'c end module Option : sig val map : ('a -> 'b) -> 'a option -> 'b option end module DumpAst : sig val ident : Camlp4.PreCast.Ast.ident -> string val ctyp : Camlp4.PreCast.Ast.ctyp -> string end module Map : sig module type OrderedType = Map.OrderedType module type S = sig include Map.S exception Not_found of key val fromList : (key * 'a) list -> 'a t val union_disjoint : 'a t list -> 'a t val union_disjoint2 : 'a t -> 'a t -> 'a t end module Make (Ord : OrderedType) : S with type key = Ord.t end module Set : sig module type OrderedType = Set.OrderedType module type S = sig include Set.S val toList : t -> elt list val fromList : elt list -> t end module Make (Ord : OrderedType) : S with type elt = Ord.t end val random_id : int -> string val tag_hash : string -> int val typevar_of_int : int -> string deriving-0.7.1/syntax/std/000077500000000000000000000000001272135405000154455ustar00rootroot00000000000000deriving-0.7.1/syntax/std/pa_deriving_std.ml000066400000000000000000000041631272135405000211440ustar00rootroot00000000000000(* Copyright Jeremy Yallop 2007. Copyright Grégoire Henry 2011. This file is free software, distributed under the MIT license. See the file COPYING for details. *) (* Extend the OCaml grammar to include the `deriving' clause after type declarations in structure and signatures. *) open Pa_deriving_common.Utils module Deriving (Syntax : Camlp4.Sig.Camlp4Syntax) = struct open Pa_deriving_common.Base open Pa_deriving_common.Type open Pa_deriving_common.Extend open Camlp4.PreCast include Syntax #if ocaml_version >= (4, 03) DELETE_RULE Gram str_item: "type"; opt_nonrec; type_declaration END DELETE_RULE Gram sig_item: "type"; opt_nonrec; type_declaration END #else DELETE_RULE Gram str_item: "type"; type_declaration END DELETE_RULE Gram sig_item: "type"; type_declaration END #endif open Ast EXTEND Gram str_item: [[ "type"; types = type_declaration -> <:str_item< type $types$ >> | "type"; types = type_declaration; "deriving"; "("; cl = LIST0 [x = UIDENT -> x] SEP ","; ")" -> try let decls = display_errors _loc Translate.decls types in let module U = Untranslate(struct let _loc = _loc end) in let cl = List.map find cl in let tdecls = List.map U.decl decls in <:str_item< type $list:tdecls$ $list:List.map (derive_str _loc decls) cl$ >> with NoSuchClass classname -> fatal_error _loc ("deriving: " ^ classname ^ " is not a known `class'") ]] ; sig_item: [[ "type"; types = type_declaration -> <:sig_item< type $types$ >> | "type"; types = type_declaration; "deriving"; "("; cl = LIST0 [x = UIDENT -> x] SEP "," ; ")" -> try let decls = display_errors _loc Translate.decls types in let module U = Untranslate(struct let _loc = _loc end) in let tdecls = List.concat_map U.sigdecl decls in let cl = List.map find cl in let ms = List.map (derive_sig _loc decls) cl in <:sig_item< type $list:tdecls$ $list:ms$ >> with NoSuchClass classname -> fatal_error _loc ("deriving: " ^ classname ^ " is not a known `class'") ]] ; END end module M = Camlp4.Register.OCamlSyntaxExtension(Pa_deriving_common.Id)(Deriving) deriving-0.7.1/syntax/tc/000077500000000000000000000000001272135405000152615ustar00rootroot00000000000000deriving-0.7.1/syntax/tc/pa_deriving_tc.ml000066400000000000000000000015771272135405000206020ustar00rootroot00000000000000(* Copyright Grégoire Henry 2010. This file is free software, distributed under the MIT license. See the file COPYING for details. *) (* Registering type derivers into type-conv. *) open Camlp4.PreCast open Pa_deriving_common let translate_str deriver _ types = let _loc = Ast.loc_of_ctyp types in let decls = Base.display_errors _loc Type.Translate.decls types in Base.derive_str _loc decls deriver let translate_sig deriver _ types = let _loc = Ast.loc_of_ctyp types in let decls = Base.display_errors _loc Type.Translate.decls types in Base.derive_sig _loc decls deriver let register desc class_ = let module Desc = (val desc : Defs.ClassDescription) in let name = String.uncapitalize Desc.classname in Pa_type_conv.add_generator name (translate_str class_); Pa_type_conv.add_sig_generator name (translate_sig class_) let _ = Base.add_register_hook register deriving-0.7.1/tests/000077500000000000000000000000001272135405000144675ustar00rootroot00000000000000deriving-0.7.1/tests/rejected/000077500000000000000000000000001272135405000162545ustar00rootroot00000000000000deriving-0.7.1/tests/rejected/README000066400000000000000000000004251272135405000171350ustar00rootroot00000000000000This directory contains programs that are syntactically correct but that are rejected by deriving because the types invovled don't meet the requirements for the classses in the deriving list. They're here so that it's easy to check the quality of the error messages produced. deriving-0.7.1/tests/rejected/a.ml000066400000000000000000000001621272135405000170250ustar00rootroot00000000000000(* Reject types called 'a' to avoid confusion with the overloaded type parameter *) type a = A deriving (Eq) deriving-0.7.1/tests/rejected/alias.ml000066400000000000000000000001541272135405000176770ustar00rootroot00000000000000(* Alias variable names must be distinct from parameter names *) type 'a x = [`Foo] as 'a deriving (Eq) deriving-0.7.1/tests/rejected/dump1.ml000066400000000000000000000002131272135405000176300ustar00rootroot00000000000000(* private datatypes cannot be instances of dump (because Dump.from_string constructs values *) type p = private F deriving (Dump) deriving-0.7.1/tests/rejected/dump2.ml000066400000000000000000000002531272135405000176350ustar00rootroot00000000000000(* records with mutable fields cannot be instances of Dump (because it doesn't preserve sharing *) type t = { x : int; mutable y : int ; z : int } deriving (Dump) deriving-0.7.1/tests/rejected/enum1.ml000066400000000000000000000000741272135405000176340ustar00rootroot00000000000000(* enum for records *) type r = { x : int } deriving (Enum) deriving-0.7.1/tests/rejected/enum2.ml000066400000000000000000000001221272135405000176270ustar00rootroot00000000000000(* Enum for sum types with arguments *) type t = X of int | Y deriving (Enum) deriving-0.7.1/tests/rejected/enum3.ml000066400000000000000000000001431272135405000176330ustar00rootroot00000000000000(* Enum for polymorphic variant types with arguments *) type t = [`A of int | `B] deriving (Enum) deriving-0.7.1/tests/rejected/enum4.ml000066400000000000000000000001651272135405000176400ustar00rootroot00000000000000(* Enum for extending polymorphic variant types *) type t1 = [`A] deriving (Enum) type t2 = [`B|t1] deriving (Enum) deriving-0.7.1/tests/rejected/eq1.ml000066400000000000000000000000711272135405000172720ustar00rootroot00000000000000(* Eq for functions *) type t = int -> int deriving (Eq) deriving-0.7.1/tests/rejected/eq2.ml000066400000000000000000000001351272135405000172740ustar00rootroot00000000000000(* Eq for records with polymorphic fields *) type r4 = { l1 : 'a . 'a list } deriving (Eq) deriving-0.7.1/tests/rejected/eq3.ml000066400000000000000000000000701272135405000172730ustar00rootroot00000000000000(* Eq for classes *) class c = object end deriving (Eq) deriving-0.7.1/tests/rejected/eqparams.ml000066400000000000000000000001771272135405000204240ustar00rootroot00000000000000(* All types in a group must have the same parameters *) type 'a t1 = int and ('a,'b) t2 = int and t3 = int deriving (Eq) deriving-0.7.1/tests/rejected/functorf.ml000066400000000000000000000001621272135405000204330ustar00rootroot00000000000000(* Reject types called 'f' to avoid confusion with the overloaded type parameter *) type f = F deriving (Functor) deriving-0.7.1/tests/rejected/infsup.ml000066400000000000000000000001031272135405000201040ustar00rootroot00000000000000(* < > variant types *) type poly6 = [< `A > `B] deriving (Eq) deriving-0.7.1/tests/rejected/labels.ml000066400000000000000000000000521272135405000200450ustar00rootroot00000000000000type label = x:int -> int deriving (Eq) deriving-0.7.1/tests/rejected/polyrec.ml000066400000000000000000000001341272135405000202610ustar00rootroot00000000000000(* non-regular datatype *) type 'a seq = Nil | Cons of 'a * ('a * 'a) seq deriving (Eq) deriving-0.7.1/tests/rejected/polyrecord.ml000066400000000000000000000003621272135405000207710ustar00rootroot00000000000000(* Polymorphic variant definitions within polymorphic record field types *) type r = { (* I think this could be supported without too much difficulty, but it doesn't have much benefit *) x : 'a. [`Foo of 'a] } deriving (Eq) deriving-0.7.1/tests/rejected/privaterows1.ml000066400000000000000000000001131272135405000212470ustar00rootroot00000000000000(* Private rows are currently not supported *) type poly4 = private [< `A] deriving-0.7.1/tests/rejected/privaterows2.ml000066400000000000000000000001351272135405000212540ustar00rootroot00000000000000(* Private rows are currently not supported *) type poly4 = private [> `A] deriving (Eq) deriving-0.7.1/tests/std/000077500000000000000000000000001272135405000152615ustar00rootroot00000000000000deriving-0.7.1/tests/std/bimap.ml000066400000000000000000000010371272135405000167040ustar00rootroot00000000000000(* Bidirectional map {t -> t} *) module type S = sig type item type t val empty : t val add : item -> item -> t -> t val find : item -> t -> item val mem : item -> t -> bool val rmem : item -> t -> bool end module type OrderedType = sig type t val compare : t -> t -> int end module Make (Ord : OrderedType) = struct type item = Ord.t type t = (item * item) list let empty = [] let add l r list = (l,r)::list let find = List.assoc let mem = List.mem_assoc let rmem item = List.exists (fun (_,i) -> i = item) end deriving-0.7.1/tests/std/bounded_tests.ml000066400000000000000000000010131272135405000204500ustar00rootroot00000000000000open Tests_defs let nullsum = begin assert (Bounded_nullsum.min_bound = N0); assert (Bounded_nullsum.max_bound = N3); end let poly0 = begin assert (Bounded_poly0.min_bound = `T0); assert (Bounded_poly0.max_bound = `T3); end let tup4 = begin assert (Bounded_tup4.min_bound = (min_int, min_int, false, ())); assert (Bounded_tup4.max_bound = (max_int, max_int, true, ())); end let t = begin assert (Bounded_t.min_bound = min_int); assert (Bounded_t.max_bound = max_int); end deriving-0.7.1/tests/std/dump_tests.ml000066400000000000000000000101371272135405000200040ustar00rootroot00000000000000open Tests_defs open Deriving_Dump module Test (D : Dump) = struct let test v = D.from_string (D.to_string v) = v end let sum = begin let module T = Test (Dump_sum) in assert (T.test S0); assert (T.test (S1 max_int)); assert (T.test (S2 (min_int, 1243.2))); assert (T.test (S2 (min_int, 1243.2))); assert (T.test (S3 (12, 0.0, true))); assert (T.test (Sunit ())); assert (T.test (Stup (1001, 10.01))); end let r1 = begin let module T = Test (Dump_r1) in assert (T.test {r1_l1 = max_int - 10; r1_l2 = min_int + 10}); end let intseq = begin let module T = Test (Dump_intseq) in assert (T.test INil); assert (T.test (ICons (10, ICons (20, ICons (30, INil))))); end let seq = begin let module T = Test (Dump_seq (Dump_bool)) in assert (T.test Nil); assert (T.test (Cons (true, Cons (false, Cons (true, Nil))))); end let uses_seqs = begin let module T = Test (Dump_uses_seqs) in assert (T.test (INil, Nil)); assert (T.test (INil, Cons (0.0, Cons(10.0, Nil)))); assert (T.test (ICons (10, ICons(20, INil)), Nil)); assert (T.test (ICons (10, ICons(20, INil)), Cons (0.0, Cons(10.0, Nil)))); end let poly1 = begin let module T = Test (Dump_poly1) in assert (T.test `T0); assert (T.test (`T1 (-1231))); end let poly2 = begin let module T = Test (Dump_poly2) in assert (T.test (P (10, `T1 11, 12.0))); end let poly3 = begin let module T = Test (Dump_poly3) in assert (T.test `Nil); assert (T.test (`Cons (1, `Cons (2, `Cons (3, `Nil))))); end let poly3b = begin let module T = Test (Dump_poly3b) in assert (T.test (10, `Nil, `F)); assert (T.test (0, `Cons (10, `Cons (11, `Cons (12, `Nil))), `F)); end let poly7 = begin let module T = Test(Dump_poly7(Dump_bool)) in let module T' = Test(Dump_poly8(Dump_int)) in assert (T.test (Foo (`F true))); assert (T.test (Foo (`F false))); assert (T'.test {x = `G (`H (`I (Foo (`F (max_int - 1)))))}); assert (T'.test {x = `G (`H (`I (Foo (`F (min_int + 1)))))}); end let poly10 = begin let module T = Test (Dump_poly10) in assert (T.test `F); assert (T.test `Nil); assert (T.test (`Cons (12, `Cons (14, `Nil)))); end let mutrec = begin let module A = Test (Dump_mutrec_a) in let module B = Test (Dump_mutrec_b) in let module C = Test (Dump_mutrec_c) in let module D = Test (Dump_mutrec_d) in let a = N in let b = { l1 = S (3, a); l2 = a } in let c = S (3, S (4, S (5, N))) in let d = `T b in assert (A.test a); assert (B.test b); assert (C.test c); assert (D.test d); end let pmutrec = begin (* type ('a,'b) pmutrec_a = ('a,'b) pmutrec_c and ('a,'b) pmutrec_b = { pl1 : ('a,'b) pmutrec_c ; pl2 : ('a,'b) pmutrec_a } and ('a,'b) pmutrec_c = SS of 'a * ('a,'b) pmutrec_a * 'b and ('a,'b) pmutrec_d = [`T of ('a,'b) pmutrec_b] *) end let ff1 = begin let module T = Test(Dump_ff1(Dump_bool)) in assert (T.test (F (true,false))); assert (T.test (G 435)); end let ff2 = begin let module T = Test(Dump_ff2(Dump_bool)(Dump_int)) in assert (T.test (F1 (F2 (Nil, 10, None)))); assert (T.test (F1 (F2 (Cons (true, Cons (false, Nil)), 10, Some 14)))); end let tup0 = begin let module T = Test (Dump_tup0) in assert (T.test ()); end let tup2 = begin let module T = Test (Dump_tup2) in assert (T.test (10, 10.0)); assert (T.test (max_int, -10.0)); end let tup3 = begin let module T = Test (Dump_tup3) in assert (T.test (0,12.3,true)); assert (T.test (min_int,-12.3,false)); end let tup4 = begin let module T = Test (Dump_tup4) in assert (T.test (0,0,true,())); assert (T.test (min_int,max_int,false,())); end let t = begin let module T = Test (Dump_t) in assert (T.test min_int); assert (T.test max_int); assert (T.test 10); end let ii = begin let module T = Test (Dump_ii) in assert (T.test {int32 = 1073741824l ; int64 = 10737418230L ; nativeint = 2n; }); end let iii = begin let module T = Test (Dump_ii') in assert (T.test {int32' = 1073741824l ; int64' = 10737418230L ; }); end deriving-0.7.1/tests/std/enum_tests.ml000066400000000000000000000051261272135405000200050ustar00rootroot00000000000000open Tests_defs open Deriving_Enum let nullsum = begin let module E = Enum_nullsum in assert (E.succ N0 = N1); assert (E.succ N1 = N2); assert (E.succ N2 = N3); assert (try ignore (E.succ N3); false with Invalid_argument "succ" -> true); assert (try ignore (E.pred N0); false with Invalid_argument "pred" -> true); assert (E.pred N1 = N0); assert (E.pred N2 = N1); assert (E.pred N3 = N2); assert (E.from_enum N0 = 0); assert (E.from_enum N1 = 1); assert (E.from_enum N2 = 2); assert (E.from_enum N3 = 3); assert (E.to_enum 0 = N0); assert (E.to_enum 1 = N1); assert (E.to_enum 2 = N2); assert (E.to_enum 3 = N3); assert (try ignore (E.to_enum 4); false with Invalid_argument "to_enum" -> true); assert (E.enum_from N0 = [N0;N1;N2;N3]); assert (E.enum_from N1 = [N1;N2;N3]); assert (E.enum_from N2 = [N2;N3]); assert (E.enum_from N3 = [N3]); assert (E.enum_from_then N0 N1 = [N0;N1;N2;N3]); assert (E.enum_from_then N0 N2 = [N0;N2]); assert (E.enum_from_then N1 N2 = [N1;N2;N3]); assert (E.enum_from_then N1 N3 = [N1;N3]); assert (try ignore (E.enum_from_then N3 N3); false with Invalid_argument _ -> true); assert (try ignore (E.enum_from_then N3 N1); false with Invalid_argument _ -> true); assert (E.enum_from_to N0 N1 = [N0;N1]); assert (E.enum_from_to N1 N3 = [N1;N2;N3]); assert (E.enum_from_to N1 N1 = [N1]); assert (E.enum_from_to N1 N0 = []); assert (E.enum_from_then_to N0 N1 N3 = [N0;N1;N2;N3]); assert (E.enum_from_then_to N0 N2 N3 = [N0;N2]); assert (E.enum_from_then_to N0 N3 N3 = [N0;N3]); assert (try ignore (E.enum_from_then_to N0 N0 N0); false with Invalid_argument _ -> true); end let poly0 = begin let module E = Enum_poly0 in assert (E.succ `T0 = `T1); assert (E.succ `T1 = `T2); assert (E.succ `T2 = `T3); assert (try ignore (E.succ `T3); false with Invalid_argument "succ" -> true); assert (try ignore (E.pred `T0); false with Invalid_argument "pred" -> true); assert (E.pred `T1 = `T0); assert (E.pred `T2 = `T1); assert (E.pred `T3 = `T2); end let t = begin ListLabels.iter (Enum_int.enum_from_to (-1000) 1000) ~f:(fun i -> assert (Enum_t.succ i = i+1); assert (Enum_t.pred i = i-1); assert (Enum_t.to_enum i = i); assert (Enum_t.from_enum i = i)); end deriving-0.7.1/tests/std/eq_tests.ml000066400000000000000000000163721272135405000174530ustar00rootroot00000000000000open Tests_defs open Deriving_Eq let sum = begin assert (Eq_sum.eq S0 S0); assert (not (Eq_sum.eq S0 (S1 0))); assert (Eq_sum.eq (S1 0) (S1 0)); assert (Eq_sum.eq (Stup (3,0.0)) (Stup (3,0.0))); assert (not (Eq_sum.eq (Stup (0,0.0)) (Stup (1,0.0)))); end let nullsum = begin assert (Eq_nullsum.eq N2 N2) end let r1 = begin assert (Eq_r1.eq { r1_l1 = 10; r1_l2 = 20 } { r1_l1 = 10; r1_l2 = 20 }); assert (not (Eq_r1.eq { r1_l1 = 20; r1_l2 = 10 } { r1_l1 = 10; r1_l2 = 20 })); assert (not (Eq_r1.eq { r1_l1 = 20; r1_l2 = 10 } { r1_l1 = 20; r1_l2 = 20 })); end let r2 = begin let l, r = ({ r2_l1 = 10; r2_l2 = 20}, { r2_l1 = 10; r2_l2 = 20}) in assert (Eq_r2.eq l l); assert (not (Eq_r2.eq l r)); assert (not (Eq_r2.eq r l)); end let r3 = begin let l, r = ({ r3_l1 = 10; r3_l2 = 20}, { r3_l1 = 10; r3_l2 = 20}) in assert (Eq_r3.eq l l); assert (not (Eq_r3.eq l r)); assert (not (Eq_r3.eq r l)); end let intseq = begin assert (Eq_intseq.eq INil INil); assert (Eq_intseq.eq (ICons (1,INil)) (ICons (1,INil))); assert (not (Eq_intseq.eq (ICons (1,INil)) INil)); assert (not (Eq_intseq.eq INil (ICons (1,INil)))); assert (not (Eq_intseq.eq INil (let rec i = ICons(1,i) in i))); end let uses_seqs = begin let eq = Eq_uses_seqs.eq in assert (eq (INil,Cons(1.0,Nil)) (INil,Cons(1.0,Nil))); assert (not (eq (INil,Cons(1.0,Nil)) (INil,Cons(2.0,Nil)))); assert (not (eq (ICons (1,INil),Nil) (INil,Nil))); end let poly0 = begin let eq = Eq_poly0.eq in assert (eq `T0 `T0); assert (not (eq `T1 `T3)); end let poly1 = begin let eq = Eq_poly1.eq in assert (eq `T0 `T0); assert (eq (`T1 10) (`T1 10)); assert (not (eq (`T1 20) (`T1 10))); assert (not (eq (`T1 20) `T0)); end let poly2 = begin let eq = Eq_poly2.eq in assert (eq (P (3, `T0, 0.0)) (P (3, `T0, 0.0))); assert (eq (P (4, `T1 10, 2.0)) (P (4, `T1 10, 2.0))); assert (not (eq (P (5, `T1 10, 2.0)) (P (5, `T0, 2.0)))); assert (not (eq (P (6, `T0, 2.0)) (P (6, `T0, 10.0)))); assert (not (eq (P (0, `T0, 2.0)) (P (7, `T0, 2.0)))); end let poly3 = begin let eq = Eq_poly3.eq in assert (eq `Nil `Nil); assert (eq (`Cons (3,`Nil)) (`Cons (3,`Nil))); assert (eq (`Cons (3,`Cons (4,`Nil))) (`Cons (3,`Cons (4,`Nil)))); assert (not (eq (`Cons (3,`Cons (4,`Nil))) (`Cons (3,`Nil)))); end let poly3b = begin let eq = Eq_poly3b.eq in assert (eq (0,`Nil,`F) (0,`Nil,`F)); assert (not (eq (0,`Cons (1,`Nil),`F) (0,`Nil,`F))); assert (not (eq (1,`Nil,`F) (0,`Nil,`F))); end let poly7_8 = begin let module M7 = Eq_poly7(Eq_int) in let module M8 = Eq_poly8(Eq_int) in assert (M7.eq (Foo (`F 0)) (Foo (`F 0))); assert (not (M7.eq (Foo (`F 0)) (Foo (`F 1)))); assert (M8.eq {x = `G (`H (`I (Foo (`F 0))))} {x = `G (`H (`I (Foo (`F 0))))}); assert (not (M8.eq {x = `G (`H (`I (Foo (`F 0))))} {x = `G (`H (`I (Foo (`F 1))))})); end let poly10 = begin let eq = Eq_poly10.eq in assert (eq `F `F); assert (eq `Nil `Nil); assert (not (eq `Nil `F)); end let mutrec = begin let rec cyclic_1 = S (0, cyclic_2) and cyclic_2 = S (1, cyclic_1) in assert (not (Eq_mutrec_a.eq cyclic_1 cyclic_2)); assert (not (Eq_mutrec_d.eq (`T {l1 = cyclic_1; l2 = cyclic_2}) (`T {l1 = cyclic_2; l2 = cyclic_1}))); end let pmutrec = begin let module M_a = Eq_pmutrec_a(Eq_int)(Eq_bool) in let module M_b = Eq_pmutrec_b(Eq_int)(Eq_bool) in let module M_c = Eq_pmutrec_c(Eq_int)(Eq_bool) in let module M_d = Eq_pmutrec_d(Eq_int)(Eq_bool) in let rec cyclic_1 = SS (0, cyclic_2, true) and cyclic_2 = SS (1, cyclic_1, true) in assert (not (M_a.eq cyclic_1 cyclic_2)); assert (not (M_d.eq (`T {pl1 = cyclic_1; pl2 = cyclic_2}) (`T {pl1 = cyclic_2; pl2 = cyclic_1}))); end let ff1 = begin let module M = Eq_ff1(Eq_bool) in assert (M.eq (F (true,false)) (F (true,false))); assert (M.eq (G (-1)) (G (-1))); assert (not (M.eq (F (false,true)) (F (true,false)))); assert (not (M.eq (G (-1)) (G 0))); assert (not (M.eq (G (-1)) (F (true, true)))); end let ff2 = begin let module M = Eq_ff2(Eq_bool)(Eq_bool) in assert (M.eq (F1 (F2 (Cons (true,Nil), 0, None))) (F1 (F2 (Cons (true,Nil), 0, None)))); assert (not (M.eq (F2 (Nil, 0, None)) (F2 (Cons (true,Nil), 0, None)))); assert (not (M.eq (F2 (Cons (true,Nil), 0, Some true)) (F2 (Cons (true,Nil), 0, Some false)))); assert (not (M.eq (F2 (Cons (true,Nil), 0, None)) (F2 (Cons (true,Nil), 0, Some false)))); end let tup0 = begin assert (Eq_tup0.eq () ()); end let tup2 = begin assert (Eq_tup2.eq (10,5.0) (10,5.0)); assert (not (Eq_tup2.eq (10,5.0) (11,5.0))); assert (not (Eq_tup2.eq (10,5.0) (10,4.0))); end let tup3 = begin assert (Eq_tup3.eq (10,2.5,true) (10,2.5,true)); assert (not (Eq_tup3.eq (10,2.5,true) (11,2.5,true))); assert (not (Eq_tup3.eq (10,2.5,true) (10,2.4,true))); assert (not (Eq_tup3.eq (10,2.5,true) (10,2.5,false))); end let tup4 = begin assert (Eq_tup4.eq (1,2,true,()) (1,2,true,())); assert (not (Eq_tup4.eq (1,2,true,()) (0,2,true,()))); assert (not (Eq_tup4.eq (1,2,true,()) (1,3,true,()))); assert (not (Eq_tup4.eq (1,2,true,()) (1,2,false,()))); end let withref = begin let x = ref 0 in assert (Eq_withref.eq (WR (0,x)) (WR (0,x))); assert (not (Eq_withref.eq (WR (0,x)) (WR (0,ref 0)))); end let t = begin assert (Eq_t.eq 0 0); assert (Eq_t.eq (-10) (-10)); assert (Eq_t.eq 14 14); assert (not (Eq_t.eq 14 0)); assert (not (Eq_t.eq 0 14)); assert (not (Eq_t.eq (-1) 0)); end let ii = begin assert (Eq_ii.eq {int32 = 0l ; int64 = 1L ; nativeint = 2n; } {int32 = 0l ; int64 = 1L ; nativeint = 2n; }); assert (not (Eq_ii.eq {int32 = 0l ; int64 = 1L ; nativeint = 2n; } {int32 = 1l ; int64 = 1L ; nativeint = 2n; })); assert (not (Eq_ii.eq {int32 = 0l ; int64 = 1L ; nativeint = 2n; } {int32 = 0l ; int64 = 2L ; nativeint = 2n; })); assert (not (Eq_ii.eq {int32 = 0l ; int64 = 1L ; nativeint = 2n; } {int32 = 0l ; int64 = 1L ; nativeint = 3n; })); end let ii' = begin assert (Eq_ii'.eq {int32' = 0l ; int64' = 1L ; } {int32' = 0l ; int64' = 1L ; }); assert (not (Eq_ii'.eq {int32' = 0l ; int64' = 1L ; } {int32' = 1l ; int64' = 1L ; })); assert (not (Eq_ii'.eq {int32' = 0l ; int64' = 1L ; } {int32' = 0l ; int64' = 2L ; })); end deriving-0.7.1/tests/std/exp.ml000066400000000000000000000056621272135405000164200ustar00rootroot00000000000000open Deriving_Eq open Deriving_Dump open Deriving_Typeable open Deriving_Pickle module Env = Bimap.Make(String) type name = string deriving (Show, Dump, Typeable) module Eq_string : Eq with type a = name = struct type a = name let eq = (=) end module Pickle_name = Pickle_from_dump(Dump_string)(Eq_string)(Typeable_string) module rec Exp : sig type exp = Var of name | App of exp * exp | Abs of name * exp deriving (Eq,Show,Pickle,Typeable,Dump) end = struct module Eq_exp = struct open Exp type a = exp let eq : exp -> exp -> bool = let rec alpha_eq env l r = match l, r with | Var l, Var r when Env.mem l env -> Env.find l env = r | Var l, Var r -> not (Env.rmem r env) && l = r | App (fl,pl), App (fr,pr) -> alpha_eq env fl fr && alpha_eq env pl pr | Abs (vl,bl), Abs (vr,br) -> alpha_eq (Env.add vl vr env) bl br | _ -> false in alpha_eq Env.empty end type exp = Var of name | App of exp * exp | Abs of name * exp deriving (Show, Typeable, Pickle,Dump) end open Exp (* let args = ref [] *) let discover_sharing : exp -> 'a = let find (next,dynmap) obj = let repr = Obj.repr obj in try List.assq repr dynmap, next, dynmap with Not_found -> next,next+1,(repr,next)::dynmap in let rec discover (next,dynmap) = function | Var s as v -> let (id,next,dynmap) = find (next,dynmap) v in Printf.printf "Var %d\n" id; let (id,next,dynmap) = find (next,dynmap) s in Printf.printf "string: %s %d\n" s id; (next, dynmap) | App (e1,e2) as a -> let (id,next,dynmap) = find (next,dynmap) a in Printf.printf "App %d\n" id; let (next,dynmap) = discover (next,dynmap) e1 in let (next,dynmap) = discover (next,dynmap) e2 in (next,dynmap) | Abs (s,e) as l -> let (id,next,dynmap) = find (next,dynmap) l in Printf.printf "Abs %d\n" id; let (id,next,dynmap) = find (next,dynmap) s in Printf.printf "string: %s %d\n" s id; let (next,dynmap) = discover (next,dynmap) e in (next,dynmap) in fun e -> (discover (1,[]) e) let y = Abs ("a", App (Abs ("b", App (Var "a", Abs ("c", App (App (Var "b", Var "b"), Var "c")))), Abs ("d", App (Var "a", Abs ("e", App (App (Var "d", Var "d"), Var "e")))))) let app e1 e2 = App (e1, e2) let abs (v,e) = Abs (v,e) let freevar x = Var x let rec term_size = function | Var _ -> 1 | App (e1,e2) -> term_size e1 + term_size e2 | Abs (_, body) -> 1 + term_size body deriving-0.7.1/tests/std/functor_tests.ml000066400000000000000000000056651272135405000205310ustar00rootroot00000000000000open Tests_defs let r1 = begin let map : r1 -> r1 = Functor_r1.map in let x = {r1_l1 = 2; r1_l2 = 12} in assert (map x = x); end let intseq = begin let map : intseq -> intseq = Functor_intseq.map in let i = ICons (0, ICons (1, ICons (2, INil))) in assert (map i = i); end let seq = begin let map = let module M : sig val map : ('a -> 'b) -> 'a seq -> 'b seq end = struct let map = Functor_seq.map end in M.map in assert (map ((+)1) (Cons (1, Cons (2, Cons (3, Cons (4, Nil))))) = Cons (2, Cons (3, Cons (4, Cons (5, Nil))))); end let poly7 = begin let map = let module M : sig val map : ('a -> 'b) -> 'a poly7 -> 'b poly7 end = struct let map = Functor_poly7.map end in M.map in assert (map ((+)1) (Foo (`F 0)) = Foo (`F 1)); end let poly8 = begin let map = let module M : sig val map : ('a -> 'b) -> 'a poly8 -> 'b poly8 end = struct let map = Functor_poly8.map end in M.map in assert (map ((+)1) { x = `G (`H (`I (Foo (`F 0))))} = { x = `G (`H (`I (Foo (`F 1))))}); end let poly10 = begin let map : poly10 -> poly10 = Functor_poly10.map in assert (map `F = `F); assert (map (`Cons (1,`Cons (2, `Nil))) = (`Cons (1,`Cons (2, `Nil)))); end let pmutrec = begin let _ = let module M : sig val map : ('a -> 'b) -> ('c -> 'd) -> ('a,'c) pmutrec_a -> ('b,'d) pmutrec_a end = struct let map = Functor_pmutrec_a.map end in M.map in let _ = let module M : sig val map : ('a -> 'b) -> ('c -> 'd) -> ('a,'c) pmutrec_b -> ('b,'d) pmutrec_b end = struct let map = Functor_pmutrec_b.map end in M.map in let _ = let module M : sig val map : ('a -> 'b) -> ('c -> 'd) -> ('a,'c) pmutrec_c -> ('b,'d) pmutrec_c end = struct let map = Functor_pmutrec_c.map end in M.map in let _ = let module M : sig val map : ('a -> 'b) -> ('c -> 'd) -> ('a,'c) pmutrec_d -> ('b,'d) pmutrec_d end = struct let map = Functor_pmutrec_d.map end in M.map in () end let ff1 = begin let map = let module M : sig val map : ('a -> 'b) -> 'a ff1 -> 'b ff1 end = struct let map = Functor_ff1.map end in M.map in assert (map ((+)1) (F (1,2)) = F (2,3)); assert (map ((+)1) (G 3) = G 3); end let ff2 = begin let map f = let module M : sig val map : ('a -> 'b) -> ('c -> 'd) -> ('a,'c) ff2 -> ('b,'d) ff2 end = struct let map = Functor_ff2.map end in M.map f in assert (map ((+)1) not (F1 (F2 (Cons (1,Cons (2, Nil)), 3, Some true))) = (F1 (F2 (Cons (2,Cons (3, Nil)), 3, Some false)))); assert (map not ((+)1) (F1 (F2 (Cons (true,Nil), 3, Some 0))) = (F1 (F2 (Cons (false,Nil), 3, Some 1)))); end (* type 'a constrained = [`F of 'a] constraint 'a = int *) let t = begin let map : int -> int = Functor_t.map in assert (map 12 = 12); end deriving-0.7.1/tests/std/inline.ml000066400000000000000000000014021272135405000170660ustar00rootroot00000000000000let _ = Eq.eq true false let _ = Show.show<(bool * string) list option> (Some ([true, "yes"; false, "no"])) let _ = [Typeable.mk 3; Typeable.mk 3.0; Typeable.mk [1;2;3]] type 'a seq = [`Nil | `Cons of 'a * 'a seq] deriving (Typeable) type nil = [`Nil] deriving (Typeable) type intlist = ([nil| `Cons of int * 'a ] as 'a) deriving (Typeable) let t1 = Lazy.force (Typeable.type_rep) let t2 = Lazy.force (Typeable.type_rep) let _ = Deriving_Typeable.TypeRep.eq t1 t2 let _ = Typeable.throwing_cast (Typeable.mk (`Cons (1, `Cons (2, `Cons (3, `Nil))))) let _ = Eq.eq true (Eq.eq 3 4) let _ = print_endline "Tests succeeded!" deriving-0.7.1/tests/std/notc.ml000066400000000000000000000002711272135405000165560ustar00rootroot00000000000000open Tests_defs open Sigs open Pickle_tests open Typeable_tests open Bounded_tests open Eq_tests open Dump_tests open Enum_tests open Functor_tests open Show_tests open Exp open Inline deriving-0.7.1/tests/std/pickle_tests.ml000066400000000000000000000173651272135405000203200ustar00rootroot00000000000000open Tests_defs open Deriving_Eq open Deriving_Pickle module Test (S : Pickle) = struct let test v = S.Eq.eq (S.from_string (S.to_string v)) v end let sum = begin let test = let module T = Test(Pickle_sum) in T.test in assert (test S0); assert (test (S1 3)); assert (test (S2 (10,2.0))); assert (test (Sunit ())); assert (test (Stup (10,2.0))); assert (test (Stup1 3)); end let nullsum = begin let test = let module T = Test(Pickle_nullsum) in T.test in assert (test N0); assert (test N1); assert (test N2); assert (test N3); end let r1 = begin let test = let module T = Test(Pickle_r1) in T.test in assert (test {r1_l1 = 10; r1_l2 = 20}); assert (test {r1_l1 = min_int; r1_l2 = max_int}); assert (test {r1_l1 = max_int; r1_l2 = min_int}); end let r2 = begin let v = { r2_l1 = 10; r2_l2 = 14 } in assert (not (Eq_r2.eq (Pickle_r2.from_string (Pickle_r2.to_string v)) v)); assert (Pickle_r2.from_string (Pickle_r2.to_string v) = v); end let r3 = begin let v = { r3_l1 = 10; r3_l2 = 14 } in assert (not (Eq_r3.eq (Pickle_r3.from_string (Pickle_r3.to_string v)) v)); assert (Pickle_r3.from_string (Pickle_r3.to_string v) = v); end let intseq = begin let test = let module T = Test(Pickle_intseq) in T.test in assert (test INil); assert (test (ICons (10, ICons (20, ICons (30, ICons (40, INil)))))); assert (test (ICons (max_int, ICons (min_int, INil)))); end let seq = begin let test = let module T = Test(Pickle_seq(Pickle_bool)) in T.test in let test' = let module T = Test(Pickle_seq(Pickle_seq(Pickle_bool))) in T.test in assert (test Nil); assert (test (Cons (false, Cons (true, Cons (false, Nil))))); assert (test' Nil); assert (test' (Cons (Cons (false, Cons (true, Nil)), Cons (Cons (true, Cons (false, Nil)), Nil)))); end let uses_seqs = begin let test = let module T = Test(Pickle_uses_seqs) in T.test in assert (test (INil, Nil)); assert (test (INil, Cons (0.0, Cons(10.0, Nil)))); assert (test (ICons (10, ICons(20, INil)), Nil)); assert (test (ICons (10, ICons(20, INil)), Cons (0.0, Cons(10.0, Nil)))); end type permute0 = [`T3 | `T1 | `T2 | `T0] deriving (Typeable, Eq, Pickle) let poly0 = begin let test v = Eq_permute0.eq (Pickle_permute0.from_string (Pickle_poly0.to_string v)) v in assert (test `T0); assert (test `T1); assert (test `T2); assert (test `T3); end type permute3 = [`Nil | `Cons of int * permute3] deriving (Typeable, Eq, Pickle) let _ = begin let test v = Eq_permute3.eq (Pickle_permute3.from_string (Pickle_poly3.to_string v)) v in assert (test `Nil); assert (test (`Cons (0, `Cons (1, `Cons (2, `Nil))))); end let poly3b = begin let test = let module T = Test(Pickle_poly3b) in T.test in assert (test (10, `Nil, `F)); assert (test (10, `Cons (10, `Cons (-20, `Nil)), `F)); end let _ = begin let test = let module T = Test(Pickle_poly7(Pickle_bool)) in T.test and test' = let module T = Test(Pickle_poly8(Pickle_int)) in T.test in assert (test (Foo (`F true))); assert (test (Foo (`F false))); assert (test' {x = `G (`H (`I (Foo (`F (max_int - 1)))))}); assert (test' {x = `G (`H (`I (Foo (`F (min_int + 1)))))}); end let _ = begin let test = let module T = Test(Pickle_poly10) in T.test in assert (test `F); assert (test `Nil); assert (test (`Cons (12, `Cons (14, `Nil)))); end let mutrec = begin let module A = Test(Pickle_mutrec_a) in let module B = Test(Pickle_mutrec_b) in let module C = Test(Pickle_mutrec_c) in let module D = Test(Pickle_mutrec_d) in let a = N in let b = { l1 = S (3, a); l2 = a } in let c = S (3, S (4, S (5, N))) in let d = `T b in assert (A.test a); assert (B.test b); assert (C.test c); assert (D.test d); end let pmutrec = begin (* type ('a,'b) pmutrec_a = ('a,'b) pmutrec_c and ('a,'b) pmutrec_b = { pl1 : ('a,'b) pmutrec_c ; pl2 : ('a,'b) pmutrec_a } and ('a,'b) pmutrec_c = SS of 'a * ('a,'b) pmutrec_a * 'b and ('a,'b) pmutrec_d = [`T of ('a,'b) pmutrec_b] *) end let ff1 = begin let test = let module T = Test(Pickle_ff1(Pickle_bool)) in T.test in assert (test (F (true,false))); assert (test (G 435)); end let ff2 = begin let test = let module T = Test(Pickle_ff2(Pickle_bool)(Pickle_int)) in T.test in assert (test (F1 (F2 (Nil, 10, None)))); assert (test (F1 (F2 (Cons (true, Cons (false, Nil)), 10, Some 14)))); end let unit = begin let test = let module T = Test(Pickle_unit) in T.test in assert (test ()); end let tup2 = begin let test = let module T = Test(Pickle_tup2) in T.test in assert (test (-10,12e4)); assert (test (max_int,12e4)); end let tup3 = begin let test = let module T = Test(Pickle_tup3) in T.test in assert (test (0,12.3,true)); assert (test (min_int,-12.3,false)); end let tup4 = begin let test = let module T = Test(Pickle_tup4) in T.test in assert (test (0,0,true,())); assert (test (min_int,max_int,false,())); end let withref = begin let v = WR (10, ref 20) in assert (not (Eq_withref.eq (Pickle_withref.from_string (Pickle_withref.to_string v)) v)); assert (Pickle_withref.from_string (Pickle_withref.to_string v) = v); end let t = begin let test v = Eq_int.eq (Pickle_int.from_string (Pickle_t.to_string v)) v in assert (test min_int); assert (test max_int); assert (test 10); end type refobj = A | B of refobj ref deriving (Eq, Typeable, Pickle) let circular = let s = ref A in let r = B s in s := r; r let _ = let v = Pickle_refobj.from_string (Pickle_refobj.to_string circular) in let (B {contents = B {contents = B {contents = B {contents = B {contents = B {contents = B {contents = _ }}}}}}}) = v in () type mut = { mutable x : mut option; mutable y : mut option; z : int; } deriving (Eq, Typeable, Pickle) let circularm = let i = {z = 1; x = None; y = None} in let j = {z = 2; x = None; y = Some i} in i.x <- Some j; i.y <- Some i; j.x <- Some j; i let _ = let v = Pickle_mut.from_string (Pickle_mut.to_string circularm) in let {z = 1; x = Some {z = 2; x = Some {z = 2; x = Some _; y = Some _}; y = Some _}; y = Some {z = 1; x = Some {z = 2; x = Some {z = 2; x = Some {z = 2; x = Some _; y = Some _}; y = Some _}; y = Some _}; y = Some _}} = v in () type t1 = { mutable x : t2 option } and t2 = { y : t1 option } deriving (Eq, Typeable, Pickle) let circular_a = let a = { x = None } in let b = { y = Some a } in a.x <- Some b; a let _ = let {x = Some {y = Some {x = Some {y = Some {x = Some {y = Some {x = Some {y = Some _}}}}}}}} = Pickle_t1.from_string (Pickle_t1.to_string circular_a) in () deriving-0.7.1/tests/std/show_tests.ml000066400000000000000000000005051272135405000200150ustar00rootroot00000000000000module type A = sig type t = private [> `A ] deriving (Show) end module Make(M : A) = struct type truc = Plop of M.t deriving (Show) let chose x = Plop x end module MA = struct type t = [ `A | `B ] deriving (Show) end module M = Make(MA) let _ = print_endline (Show.show(M.chose `B)) deriving-0.7.1/tests/std/sigs.ml000066400000000000000000000163361272135405000165710ustar00rootroot00000000000000(* Deriving a signature with types exposed *) module T : sig 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) deriving (Dump, Eq, Show, Typeable, Pickle) type nullsum = N0 | N1 | N2 | N3 deriving (Enum, Bounded, Eq, Typeable, Pickle) type r1 = { r1_l1 : int; r1_l2 : int; } deriving (Dump, Eq, Show, Typeable, Pickle, Functor) type r2 = { mutable r2_l1 : int; mutable r2_l2 : int; } deriving (Eq, Show, Typeable, Pickle) type r3 = { r3_l1 : int; mutable r3_l2 : int; } deriving (Eq, Show, Typeable, Pickle) type r4 = { r4_l1 : 'a . 'a list } type label = x:int -> int type funct = int -> int type intseq = INil | ICons of int * intseq deriving (Dump, Eq, Show, Typeable, Pickle, Functor) type 'a seq = Nil | Cons of 'a * 'a seq deriving (Dump, Eq, Show, Functor, Typeable, Pickle) type uses_seqs = (intseq * float seq) deriving (Dump, Eq, Show, Typeable, Pickle) type obj = < x : int > type poly0 = [`T0 | `T1 | `T2 | `T3] deriving (Enum, Bounded, Show, Eq, Typeable, Pickle) type poly1 = [`T0 | `T1 of int] deriving (Dump, Eq, Show) type poly2 = P of int * [`T0 | `T1 of int] * float deriving (Dump, Eq, Show) type poly3 = [`Nil | `Cons of int * 'c] as 'c deriving (Dump, Eq, Show, Typeable, Pickle) type poly3b = int * ([`Nil | `Cons of int * 'c] as 'c) * [`F] deriving (Dump, Eq, Show, Typeable, Pickle) type 'a poly7 = Foo of [`F of 'a] and 'a poly8 = { x : [`G of [`H of [`I of 'a poly7]]] } deriving (Dump, Eq, Show, Functor, Typeable, Pickle) type poly10 = [`F | poly3] deriving (Dump, Eq, Show, Functor, Typeable, Pickle) type mutrec_a = mutrec_c and mutrec_b = { l1 : mutrec_c ; l2 : mutrec_a } and mutrec_c = S of int * mutrec_a | N and mutrec_d = [`T of mutrec_b] deriving (Dump, Eq, Show, Typeable, Pickle) type ('a,'b) pmutrec_a = ('a,'b) pmutrec_c and ('a,'b) pmutrec_b = { pl1 : ('a,'b) pmutrec_c ; pl2 : ('a,'b) pmutrec_a } and ('a,'b) pmutrec_c = SS of 'a * ('a,'b) pmutrec_a * 'b and ('a,'b) pmutrec_d = [`T of ('a,'b) pmutrec_b] deriving (Dump, Eq, Show, Functor, Typeable, Pickle) type 'a ff1 = F of 'a * 'a | G of int deriving (Show, Eq, Dump, Functor, Typeable, Pickle) type ('a,'b) ff2 = F1 of ('a,'b) ff2 | F2 of 'a seq * int * 'b option deriving (Dump, Eq, Show, Functor, Typeable, Pickle) type tup0 = unit deriving (Dump, Eq, Show, Typeable, Pickle) type tup2 = int * float deriving (Dump, Eq, Show, Typeable, Pickle) type tup3 = int * float * bool deriving (Dump, Eq, Show, Typeable, Pickle) type tup4 = int * int * bool * unit deriving (Dump, Eq, Show, Typeable, Pickle, Bounded) type withref = WR of int * (int ref) deriving (Eq, Show, Typeable, Pickle) module M : sig type t deriving (Show, Eq, Dump) end module P : sig type 'a t (* deriving (Show) *) end type 'a constrained = [`F of 'a] constraint 'a = int deriving (Functor) type p1 = private P1 deriving (Show, Eq) module Private : sig type p2 = private Q deriving (Show, Eq, Dump) end type t = int deriving (Eq, Enum, Bounded, Dump, Show, Typeable, Pickle, Functor) end = Tests_defs (* Deriving a signature with types made abstract *) module T_opaque : sig type sum deriving (Dump, Eq, Show, Typeable, Pickle) type nullsum deriving (Enum, Bounded, Eq, Typeable, Pickle) type r1 deriving (Dump, Eq, Show, Typeable, Pickle, Functor) type r2 deriving (Eq, Show, Typeable, Pickle) type r3 deriving (Eq, Show, Typeable, Pickle) type r4 type label type funct type intseq deriving (Dump, Eq, Show, Typeable, Pickle, Functor) type 'a seq deriving (Dump, Eq, Show, Functor, Typeable, Pickle) type uses_seqs deriving (Dump, Eq, Show, Typeable, Pickle) type obj type poly0 deriving (Enum, Bounded, Show, Eq, Typeable, Pickle) type poly1 deriving (Dump, Eq, Show) type poly2 deriving (Dump, Eq, Show) type poly3 deriving (Dump, Eq, Show, Typeable, Pickle) type poly3b deriving (Dump, Eq, Show, Typeable, Pickle) type 'a poly7 and 'a poly8 deriving (Dump, Eq, Show, Functor, Typeable, Pickle) type poly10 deriving (Dump, Eq, Show, Functor, Typeable, Pickle) type mutrec_a and mutrec_b and mutrec_c and mutrec_d deriving (Dump, Eq, Show, Typeable, Pickle) type ('a,'b) pmutrec_a and ('a,'b) pmutrec_b and ('a,'b) pmutrec_c and ('a,'b) pmutrec_d deriving (Dump, Eq, Show, Functor, Typeable, Pickle) type 'a ff1 deriving (Show, Eq, Dump, Functor, Typeable, Pickle) type ('a,'b) ff2 deriving (Dump, Eq, Show, Functor, Typeable, Pickle) type tup0 deriving (Dump, Eq, Show, Typeable, Pickle) type tup2 deriving (Dump, Eq, Show, Typeable, Pickle) type tup3 deriving (Dump, Eq, Show, Typeable, Pickle) type tup4 deriving (Dump, Eq, Show, Typeable, Pickle, Bounded) type withref deriving (Eq, Show, Typeable, Pickle) module M : sig type t deriving (Show, Eq, Dump) end module P : sig type 'a t end type 'a constrained constraint 'a = int deriving (Functor) type p1 deriving (Show, Eq) module Private : sig type p2 end type t deriving (Eq, Enum, Bounded, Dump, Show, Typeable, Pickle, Functor) end = Tests_defs (* A signature with no deriving (to make sure that the types are still compatible) *) module T_no_deriving : sig 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) type nullsum = N0 | N1 | N2 | N3 type r1 = { r1_l1 : int; r1_l2 : int; } type r2 = { mutable r2_l1 : int; mutable r2_l2 : int; } type r3 = { r3_l1 : int; mutable r3_l2 : int; } type r4 = { r4_l1 : 'a . 'a list } type label = x:int -> int type funct = int -> int type intseq = INil | ICons of int * intseq type 'a seq = Nil | Cons of 'a * 'a seq type uses_seqs = (intseq * float seq) type obj = < x : int > type poly0 = [`T0 | `T1 | `T2 | `T3] type poly1 = [`T0 | `T1 of int] type poly2 = P of int * [`T0 | `T1 of int] * float type poly3 = [`Nil | `Cons of int * 'c] as 'c type poly3b = int * ([`Nil | `Cons of int * 'c] as 'c) * [`F] type 'a poly7 = Foo of [`F of 'a] and 'a poly8 = { x : [`G of [`H of [`I of 'a poly7]]] } type poly10 = [`F | poly3] type mutrec_a = mutrec_c and mutrec_b = { l1 : mutrec_c ; l2 : mutrec_a } and mutrec_c = S of int * mutrec_a | N and mutrec_d = [`T of mutrec_b] type ('a,'b) pmutrec_a = ('a,'b) pmutrec_c and ('a,'b) pmutrec_b = { pl1 : ('a,'b) pmutrec_c ; pl2 : ('a,'b) pmutrec_a } and ('a,'b) pmutrec_c = SS of 'a * ('a,'b) pmutrec_a * 'b and ('a,'b) pmutrec_d = [`T of ('a,'b) pmutrec_b] type 'a ff1 = F of 'a * 'a | G of int type ('a,'b) ff2 = F1 of ('a,'b) ff2 | F2 of 'a seq * int * 'b option type tup0 = unit type tup2 = int * float type tup3 = int * float * bool type tup4 = int * int * bool * unit type withref = WR of int * (int ref) module M : sig type t end module P : sig type 'a t end type 'a constrained = [`F of 'a] constraint 'a = int type p1 = private P1 module Private : sig type p2 = private Q end type t = int end = Tests_defs deriving-0.7.1/tests/std/tests_defs.ml000066400000000000000000000130051272135405000177550ustar00rootroot00000000000000(* sums (nullary, unary, and n-ary) *) 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) deriving (Dump, Eq, Show, Typeable, Pickle) type nullsum = N0 | N1 | N2 | N3 deriving (Enum, Bounded, Eq, Typeable, Pickle) (* records with mutable and immutable fields (and various combinations) *) type r1 = { r1_l1 : int; r1_l2 : int; } deriving (Dump, Eq, Show, Typeable, Pickle, Functor) type r2 = { mutable r2_l1 : int; mutable r2_l2 : int; } deriving (Eq, Show, Typeable, Pickle) type r3 = { r3_l1 : int; mutable r3_l2 : int; } deriving (Eq, Show, Typeable, Pickle) (* polymorphic records *) type r4 = { r4_l1 : 'a . 'a list } deriving (Dump, Eq, Show) (* label types *) type label = x:int -> int (* deriving (Dump, Eq, Show) *) (* function types *) type funct = int -> int (* deriving (Dump, Eq, Show) *) (* recursive types *) type intseq = INil | ICons of int * intseq deriving (Dump, Eq, Show, Typeable, Pickle, Functor) type 'a seq = Nil | Cons of 'a * 'a seq deriving (Dump, Eq, Show, Functor, Typeable, Pickle) (* applied type constructors (nullary, n-ary) *) type uses_seqs = (intseq * float seq) deriving (Dump, Eq, Show, Typeable, Pickle) (* object and class types *) type obj = < x : int > (* class types *) class c = object end (* polymorphic variants (nullary, unary tags, extending complex type expressions, defined inline) *) type poly0 = [`T0 | `T1 | `T2 | `T3] deriving (Enum, Bounded, Show, Eq, Typeable, Pickle) type poly1 = [`T0 | `T1 of int] deriving (Dump, Eq, Show) type poly2 = P of int * [`T0 | `T1 of int] * float deriving (Dump, Eq, Show) (* `as'-recursion *) type poly3 = [`Nil | `Cons of int * 'c] as 'c deriving (Dump, Eq, Show, Typeable, Pickle) type poly3b = int * ([`Nil | `Cons of int * 'c] as 'c) * [`F] deriving (Dump, Eq, Show, Typeable, Pickle) (* <, >, =, > < polymorphic variants *) type 'a poly7 = Foo of [`F of 'a] and 'a poly8 = { x : [`G of [`H of [`I of 'a poly7]]] } deriving (Dump, Eq, Show, Functor, Typeable, Pickle) (* type poly9 = [`F | [`G]] deriving (Dump, Eq, Show, Typeable, Pickle) currently broken. *) type poly10 = [`F | poly3] deriving (Dump, Eq, Show, Functor, Typeable, Pickle) (* mutually recursive types (monomorphic, polymorphic) *) type mutrec_a = mutrec_c and mutrec_b = { l1 : mutrec_c ; l2 : mutrec_a } and mutrec_c = S of int * mutrec_a | N and mutrec_d = [`T of mutrec_b] deriving (Dump, Eq, Show, Typeable, Pickle) type ('a,'b) pmutrec_a = ('a,'b) pmutrec_c and ('a,'b) pmutrec_b = { pl1 : ('a,'b) pmutrec_c ; pl2 : ('a,'b) pmutrec_a } and ('a,'b) pmutrec_c = SS of 'a * ('a,'b) pmutrec_a * 'b and ('a,'b) pmutrec_d = [`T of ('a,'b) pmutrec_b] deriving (Dump, Eq, Show, Functor, Typeable, Pickle) type 'a pmutrec_a' = ('a,'a) pmutrec_c' and ('a,'b) pmutrec_b' = { pl1' : ('b,'a) pmutrec_c' ; pl2' : 'a pmutrec_a' } and ('a,'b) pmutrec_c' = SS' of 'a * 'b pmutrec_a' * 'b | TT' of ('a * ('a,'b,'a) pmutrec_d' * 'b) and ('a,'b,'c) pmutrec_d' = [ `S of ('a,'b) pmutrec_b' | `T of ('b,'c) pmutrec_b' ] deriving (Dump, Eq, Show, Functor, Typeable, Pickle) (* polymorphic types *) type 'a ff1 = F of 'a * 'a | G of int deriving (Show, Eq, Dump, Functor, Typeable, Pickle) type ('a,'b) ff2 = F1 of ('a,'b) ff2 | F2 of 'a seq * int * 'b option deriving (Dump, Eq, Show, Functor, Typeable, Pickle) (* tuples *) type tup0 = unit deriving (Dump, Eq, Show, Typeable, Pickle) type tup2 = int * float deriving (Dump, Eq, Show, Typeable, Pickle) type tup3 = int * float * bool deriving (Dump, Eq, Show, Typeable, Pickle) type tup4 = int * int * bool * unit deriving (Dump, Eq, Show, Typeable, Pickle, Bounded) (* type equations (replication) *) (* TODO *) (* references *) type withref = WR of int * (int ref) deriving (Eq, Show, Typeable, Pickle) (* through module boundaries *) module rec M : sig type t deriving (Show, Eq, Dump) end = struct type t = [`N|`C of M.t] deriving (Show, Eq, Dump) end (* parameterized types through module boundaries *) module rec P : sig type 'a t (* deriving (Show) *) end = struct type 'a t = [`N|`C of 'a P.t] (*Doesn't work: results in an unsafe module definition *)(* deriving (Show)*) end (* with constraints *) type 'a constrained = [`F of 'a] constraint 'a = int deriving (Functor) (* Show, etc. don't work here *) (* private datatypes *) type p1 = private P1 deriving (Show, Eq) (* check that `private' in the interface is allowed for classes that disallow `private' (e.g. Dump) as long as we don't have `private' in the implementation *) module Private : sig type p2 = private Q deriving (Show, Eq, Dump) end = struct type p2 = Q deriving (Show, Eq, Dump) end (* Reusing existing instances *) type t = int deriving (Eq, Enum, Bounded, Dump, Show, Typeable, Pickle, Functor) (* Int32, etc. *) type ii = { int32: int32; int64: int64; nativeint: nativeint; } deriving (Eq, Dump, Typeable, Pickle, Show) type ii' = { int32': Int32.t; int64': Int64.t; } deriving (Eq, Dump, Typeable, Pickle, Show) #if ocaml_version >= (4, 00) (* GADTs *) type _ g1 = | I : int -> int g1 | C : 'a -> 'a g1 | L : 'a list -> 'a list g1 | R : 'a g1 * 'a -> 'a g1 | B : 'a * 'a * int -> 'a g1 deriving (Show) type (_, _) g2 = | A : 'a -> ('a, 'b) g2 | B : 'b -> ('a, 'b) g2 | R : ('b, 'a) g2 -> ('a, 'b) g2 deriving (Show) type _ g3 = | A : 'a g4 * 'a -> 'a g3 | B : int g3 and _ g4 = | C : 'a g3 * 'a -> 'a g4 | D : float g4 deriving (Show) #endif deriving-0.7.1/tests/std/typeable_tests.ml000066400000000000000000000042661272135405000206520ustar00rootroot00000000000000open Deriving_Typeable type t1 = F deriving (Typeable) type t2 = F deriving (Typeable) let eq_types t1 t2 = TypeRep.eq (Lazy.force t1) (Lazy.force t2) let _ = begin assert (eq_types Typeable.type_rep Typeable.type_rep); assert (eq_types Typeable.type_rep Typeable.type_rep); assert (not (eq_types Typeable.type_rep Typeable.type_rep)); assert (not (eq_types Typeable.type_rep Typeable.type_rep)); end type t3 = int deriving (Typeable) let _ = begin assert (eq_types Typeable.type_rep Typeable.type_rep); end type t4 = [`T of int] deriving (Typeable) type t5 = [`T of t3] deriving (Typeable) let _ = begin assert (eq_types Typeable.type_rep Typeable.type_rep); end type t6 = [`T of t5] deriving (Typeable) let _ = begin assert (not (eq_types Typeable.type_rep Typeable.type_rep)); end type t7 = [`T of t6] deriving (Typeable) let _ = begin assert (not (eq_types Typeable.type_rep Typeable.type_rep)); end type t8 = [`A | `B] deriving (Typeable) type t9 = [`B | `A] deriving (Typeable) let _ = begin assert (eq_types Typeable.type_rep Typeable.type_rep); end type ('a,'r) openr = [`Nil | `Cons of 'a * 'r] deriving (Typeable) type 'a closedr = [`Nil | `Cons of 'a * 'a closedr] deriving (Typeable) type l1 = [ `A of (int, l1) openr ] and l2 = [ `A of int closedr ] deriving (Typeable) (* The following fail without recursive module : *) (* type l3 = (int, l3) openr deriving (Typeable) *) let _ = begin assert (eq_types Typeable.type_rep Typeable.type_rep); end type nil = [`Nil] deriving (Typeable) type t10 = [ `A of ([nil| `Cons of int * 'a ] as 'a)] list deriving (Typeable) type t11 = l2 list deriving (Typeable) let _ = begin assert (eq_types Typeable.type_rep Typeable.type_rep); end deriving-0.7.1/tests/tc/000077500000000000000000000000001272135405000150755ustar00rootroot00000000000000deriving-0.7.1/tests/tc/tc.ml000066400000000000000000000000531272135405000160330ustar00rootroot00000000000000 type t = A of int | B of float with show