├── .gitignore ├── .jenkins.sh ├── CHANGES ├── COPYING ├── Makefile ├── Makefile.dist ├── README.md ├── _oasis ├── _tags ├── configure ├── lib ├── META.ab ├── deriving_Bounded.ml ├── deriving_Bounded.mli ├── deriving_Default.ml ├── deriving_Default.mli ├── deriving_Dump.ml ├── deriving_Dump.mli ├── deriving_Enum.ml ├── deriving_Enum.mli ├── deriving_Eq.ml ├── deriving_Eq.mli ├── deriving_Functor.ml ├── deriving_Functor.mli ├── deriving_Pickle.ml ├── deriving_Pickle.mli ├── deriving_Show.ml ├── deriving_Show.mli ├── deriving_Typeable.ml ├── deriving_Typeable.mli ├── deriving_dynmap.ml ├── deriving_dynmap.mli ├── deriving_interned.ml ├── deriving_interned.mli ├── deriving_monad.ml ├── deriving_monad.mli ├── deriving_num.ml └── deriving_num.mli ├── myocamlbuild.ml ├── opam ├── setup.ml ├── syntax ├── classes │ ├── bounded_class.ml │ ├── default_class.ml │ ├── dump_class.ml │ ├── enum_class.ml │ ├── eq_class.ml │ ├── functor_class.ml │ ├── pickle_class.ml │ ├── show_class.ml │ └── typeable_class.ml ├── common │ ├── base.ml │ ├── base.mli │ ├── clusters.ml │ ├── clusters.mli │ ├── defs.ml │ ├── defs.mli │ ├── extend.ml │ ├── extend.mli │ ├── id.ml.ab │ ├── type.ml │ ├── type.mli │ ├── utils.ml │ └── utils.mli ├── std │ └── pa_deriving_std.ml └── tc │ └── pa_deriving_tc.ml └── tests ├── rejected ├── README ├── a.ml ├── alias.ml ├── dump1.ml ├── dump2.ml ├── enum1.ml ├── enum2.ml ├── enum3.ml ├── enum4.ml ├── eq1.ml ├── eq2.ml ├── eq3.ml ├── eqparams.ml ├── functorf.ml ├── infsup.ml ├── labels.ml ├── polyrec.ml ├── polyrecord.ml ├── privaterows1.ml └── privaterows2.ml ├── std ├── bimap.ml ├── bounded_tests.ml ├── dump_tests.ml ├── enum_tests.ml ├── eq_tests.ml ├── exp.ml ├── functor_tests.ml ├── inline.ml ├── notc.ml ├── pickle_tests.ml ├── show_tests.ml ├── sigs.ml ├── tests_defs.ml └── typeable_tests.ml └── tc └── tc.ml /.gitignore: -------------------------------------------------------------------------------- 1 | ._* 2 | *~ 3 | #* 4 | *# 5 | _build 6 | setup.log 7 | setup.data 8 | *.native 9 | *.byte 10 | syntax/common/id.ml 11 | *.bak 12 | *.ba0 13 | setup.exe 14 | *.mllib 15 | *.mlpack 16 | lib/META 17 | -------------------------------------------------------------------------------- /.jenkins.sh: -------------------------------------------------------------------------------- 1 | 2 | opam pin add --no-action deriving . 3 | opam install type_conv 4 | opam install --deps-only deriving 5 | opam install --verbose deriving 6 | 7 | do_build_doc () { 8 | make wikidoc 9 | cp -Rf doc/manual-wiki/*.wiki ${MANUAL_SRC_DIR} 10 | cp -Rf _build/deriving-api.wikidocdir/*.wiki ${API_DIR} 11 | } 12 | 13 | do_remove () { 14 | opam remove --verbose deriving 15 | } 16 | -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | == 0.8.2 2 | 3 | * improved documentation 4 | 5 | == 0.8.1 6 | 7 | * Declare dependency on 'num'. Fixes build on OS X. 8 | 9 | == 0.8 10 | 11 | * Compatibility with OCaml 4.06 (-safe-string) 12 | * Drop optcomp dependency and compatibility with OCaml < 4.03 13 | 14 | == 0.7.1 15 | 16 | * Compatibility with OCaml 4.03 17 | 18 | == 0.7 19 | 20 | * Compatibility with ocaml-4.02 (Peter Zotoz, Hugo Heuzard) 21 | * Fix toplevel usage (Vincent Bernardoff) 22 | * Class: add equality for sets (Jeremy Yallop) 23 | 24 | == 0.6 25 | 26 | * Added a 'Default' class (Hugo Heuzard) 27 | * Allow private variant in the 'Functor' class (Pierre Chambart) 28 | * Switch build system to oasis and improved META 29 | 30 | == 0.5-ocsigen 31 | 32 | * Experimental minimalistic support of GADT 33 | * Allows to register predefined instances 34 | 35 | == 0.4-ocsigen 36 | 37 | * Compatibility with typeconv >= 108.07.00 38 | 39 | == 0.3-ocsigen 40 | 41 | * Use "lazy first-order module" instead of "recursive module" to be 42 | compatible with {{{js_of_ocaml}}}. 43 | * Be less restrictive with mutually recursive type definition 44 | * Split runtime into deriving.cma and deriving_num.cma 45 | 46 | * Class: 47 | ** Typeable: use OCaml's lazy for {{{type_rep}}} 48 | ** Show: added separators to {{{map}}} and {{{set}}} 49 | ** Show, Dump and Eq: Allow polymorphic type fields. 50 | 51 | == 0.2-ocsigen 52 | 53 | * Add compatibility with ocamlfind 54 | * Add a type-conv compatibility mode 55 | * Simplify the definition of new class 56 | 57 | * Syntax: Add {{{Class}}} in module_expr. 58 | 59 | * Small bug fixes in class: 60 | ** Show: Added parentheses around tuples. 61 | ** Pickle: remove warning in generated code. 62 | 63 | == 0.1.1 64 | 65 | * Renamed serialisation classes: 66 | ** Pickle -> Dump 67 | ** Shelve -> Pickle 68 | * Made Dump and Pickle interface compatible with each other and more 69 | compatible with Marshal. 70 | * Bugfix in the tag hash function on 64-bit platforms. 71 | * Fixed a bug with a functor application quotation that used revised 72 | syntax. 73 | 74 | == 0.1 75 | 76 | * Initial release 77 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2007 Jeremy Yallop 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | THE SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 658582336b0f135eb71fa94307014b50) 3 | 4 | SETUP = ./setup.exe 5 | 6 | build: setup.data $(SETUP) 7 | $(SETUP) -build $(BUILDFLAGS) 8 | 9 | doc: setup.data $(SETUP) build 10 | $(SETUP) -doc $(DOCFLAGS) 11 | 12 | test: setup.data $(SETUP) build 13 | $(SETUP) -test $(TESTFLAGS) 14 | 15 | all: $(SETUP) 16 | $(SETUP) -all $(ALLFLAGS) 17 | 18 | install: setup.data $(SETUP) 19 | $(SETUP) -install $(INSTALLFLAGS) 20 | 21 | uninstall: setup.data $(SETUP) 22 | $(SETUP) -uninstall $(UNINSTALLFLAGS) 23 | 24 | reinstall: setup.data $(SETUP) 25 | $(SETUP) -reinstall $(REINSTALLFLAGS) 26 | 27 | clean: $(SETUP) 28 | $(SETUP) -clean $(CLEANFLAGS) 29 | 30 | distclean: $(SETUP) 31 | $(SETUP) -distclean $(DISTCLEANFLAGS) 32 | $(RM) $(SETUP) 33 | 34 | setup.data: $(SETUP) 35 | $(SETUP) -configure $(CONFIGUREFLAGS) 36 | 37 | configure: $(SETUP) 38 | $(SETUP) -configure $(CONFIGUREFLAGS) 39 | 40 | setup.exe: setup.ml _oasis 41 | ocamlfind ocamlopt -o $@ -linkpkg -package oasis.dynrun setup.ml || ocamlfind ocamlc -o $@ -linkpkg -package oasis.dynrun setup.ml || true 42 | $(RM) setup.cmi setup.cmo setup.cmx setup.o setup.cmt 43 | 44 | .PHONY: build doc test all install uninstall reinstall clean distclean configure 45 | 46 | # OASIS_STOP 47 | 48 | wikidoc: $(SETUP) setup.data build 49 | $(SETUP) -build deriving-api.wikidocdir/index.wiki 50 | -------------------------------------------------------------------------------- /Makefile.dist: -------------------------------------------------------------------------------- 1 | 2 | ## 3 | ## Usage: 4 | ## 5 | ## If the released version is tagged in the main repository, use: 6 | ## 7 | ## make -f Makefile.dist 8 | ## 9 | ## If the tag has not been pushed, use: 10 | ## 11 | ## make -f Makefile.dist REPO=${PWD} 12 | ## 13 | ## otherwise, use: 14 | ## 15 | ## make -f Makefile.dist REPO=${PWD} VERSION=master 16 | ## 17 | 18 | VERSION?=$(shell grep Version: _oasis | cut -d ' ' -f 2) 19 | REPO?=https://github.com/ocsigen/deriving 20 | 21 | all: dist sign 22 | 23 | dist: 24 | @rm -rf deriving-${VERSION} \ 25 | deriving-${VERSION}.tar.gz \ 26 | deriving-${VERSION}.tar.gz.asc 27 | git clone --local -b ${VERSION} ${REPO} deriving-${VERSION} 28 | oasis -C deriving-${VERSION} setup 29 | sed -i "s/SETUP := setup-dev.exe/SETUP := setup.exe/" \ 30 | deriving-${VERSION}/Makefile 31 | cd deriving-${VERSION} && rm -rf .git .gitignore Makefile.dist opam 32 | tar cvzf deriving-${VERSION}.tar.gz deriving-${VERSION} 33 | @rm -rf deriving-${VERSION} 34 | 35 | sign: deriving-${VERSION}.tar.gz.asc 36 | 37 | deriving-${VERSION}.tar.gz.asc: deriving-${VERSION}.tar.gz 38 | gpg --armor -b $^ 39 | 40 | .PHONY: dist sign 41 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Deriving (was Deriving-ocsigen) 2 | =============================== 3 | 4 | This release of deriving is based on the library by Jeremy Yallop. See: 5 | 6 | * http://code.google.com/p/deriving/ 7 | 8 | Compared to the original library, it adds: 9 | 10 | * META file for ocamlfind compatibility 11 | * a type-conv compatibility mode 12 | * the generated code do not rely on recursive modules (this allows compatibility with js_of_ocaml) 13 | * minimalistic support of GADT 14 | 15 | See CHANGES for more details. 16 | 17 | Requirements: 18 | ------------- 19 | 20 | * ocaml and camlp4 (>= 3.12) 21 | * optcomp 22 | * type-conv (optionnal) 23 | 24 | Build intructions: 25 | ------------------ 26 | 27 | ``` 28 | $ ./configure [--disable-tc] 29 | $ make 30 | 31 | # make install 32 | ``` 33 | 34 | Documention and examples of the original library: 35 | ------------------------------------------------- 36 | 37 | * http://code.google.com/p/deriving/wiki/Introduction 38 | * http://code.google.com/p/deriving/wiki/Classes 39 | 40 | Examples: 41 | --------- 42 | 43 | ``` 44 | $ ocaml 45 | Objective Caml version 4.01.0 46 | 47 | # #use "topfind";; 48 | - : unit = () 49 | # #camlp4o;; 50 | Camlp4 Parsing version 4.01.0 51 | 52 | # #require "deriving";; 53 | # type t = A of int | B of t deriving (Show);; 54 | type t = A of int | B of t 55 | module rec Show_t : sig ... end 56 | # Show.show (B (A 4));; 57 | - : string = "B A 4" 58 | ``` 59 | 60 | Examples with type-conv: 61 | ------------------------ 62 | 63 | ``` 64 | $ ocaml 65 | Objective Caml version 4.01.0@ 66 | 67 | # #use "topfind";; 68 | - : unit = () 69 | # #camlp4o;; 70 | Camlp4 Parsing version 4.01.0 71 | 72 | # #require "deriving.tc";; 73 | # type t = A of int | B of t with show;; 74 | type t = A of int | B of t 75 | module rec Show_t : sig ... end 76 | ``` 77 | -------------------------------------------------------------------------------- /_oasis: -------------------------------------------------------------------------------- 1 | OASISFormat: 0.4 2 | Name: deriving 3 | OCamlVersion: >= 4.03.0 4 | Version: 0.8.2 5 | Synopsis: Extension to OCaml for deriving functions from type declarations 6 | Authors: Jeremy Yallop 7 | License: MIT 8 | BuildTools: ocamlbuild 9 | FilesAB: syntax/common/id.ml.ab, 10 | lib/META.ab 11 | Plugins: DevFiles (0.4) 12 | AlphaFeatures: compiled_setup_ml 13 | 14 | Flag tc 15 | Description: type-conv support 16 | Default: false 17 | 18 | Library "deriving" 19 | Path : lib 20 | FindlibName : deriving 21 | Modules : Deriving_Show, Deriving_Eq, Deriving_Bounded, 22 | Deriving_Enum, Deriving_monad, Deriving_Dump, 23 | Deriving_Typeable, Deriving_Pickle, 24 | Deriving_Functor, Deriving_Default 25 | InternalModules : Deriving_interned, Deriving_dynmap 26 | BuildDepends : deriving.syntax 27 | 28 | Library "deriving_num" 29 | Path : lib 30 | FindlibParent : deriving 31 | FindlibName : num 32 | Modules : Deriving_num 33 | BuildDepends : deriving,num 34 | 35 | Library "pa_deriving_classes" 36 | Path : syntax/classes 37 | FindlibParent : deriving 38 | FindlibName : syntax 39 | Modules : Show_class, Dump_class, Enum_class, Bounded_class, 40 | Eq_class, Typeable_class, Pickle_class, 41 | Functor_class, Default_class 42 | BuildDepends : deriving.syntax.std 43 | 44 | Library "pa_deriving_common" 45 | Path : syntax/common 46 | FindlibParent : pa_deriving_classes 47 | FindlibName : common 48 | Pack : true 49 | Modules : Id, Utils, Type, Defs, Clusters, Base, Extend 50 | BuildDepends : camlp4,camlp4.extend,camlp4.quotations.o,bytes 51 | 52 | Library "pa_deriving_std" 53 | Path : syntax/std 54 | FindlibParent : pa_deriving_classes 55 | FindlibName : std 56 | Modules : Pa_deriving_std 57 | BuildDepends : deriving.syntax.common,camlp4.quotations.o 58 | 59 | Library "pa_deriving_tc" 60 | Path : syntax/tc 61 | FindlibParent : pa_deriving_classes 62 | FindlibName : tc 63 | Modules : Pa_deriving_tc 64 | BuildDepends : deriving.syntax.common,type_conv 65 | Build$: flag(tc) 66 | Install$: flag(tc) 67 | 68 | Document "deriving-api" 69 | Title: API reference for Deriving 70 | Type: ocamlbuild (0.3) 71 | Install: true 72 | InstallDir: $htmldir/api 73 | BuildTools: ocamldoc 74 | XOCamlbuildPath: ./ 75 | XOCamlbuildLibraries: 76 | deriving, 77 | deriving.num, 78 | deriving.syntax, 79 | deriving.syntax.common 80 | 81 | Executable test 82 | Path : tests/std 83 | CompiledObject : best 84 | MainIs : notc.ml 85 | BuildDepends : deriving 86 | Install : false 87 | Build$: flag(tests) 88 | 89 | Executable test_tc 90 | Path : tests/tc 91 | Install : false 92 | CompiledObject : best 93 | MainIs : tc.ml 94 | BuildDepends : deriving,type_conv 95 | Build$: flag(tests) && flag(tc) 96 | 97 | Test std 98 | TestTools : test 99 | Command : $test 100 | Run$: flag(tests) 101 | 102 | Test tc 103 | TestTools : test_tc 104 | Command : $test_tc 105 | Run$: flag(tests) && flag(tc) 106 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # OASIS_STOP 3 | <**/*.ml{,i}>:syntax(camlp4o) 4 | :-package(camlp4.quotations.o) 5 | :package(camlp4.quotations.r) 6 | :-use_pa_deriving_std 7 | :use_pa_deriving_tc 8 | ## BUG in oasis: not generated when using 'oasis setup' 9 | "syntax/common/id.cmx": for-pack(Pa_deriving_common) 10 | -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # OASIS_START 4 | # DO NOT EDIT (digest: 43a4c04eb31d237f10fee79d293a406c) 5 | set -e 6 | 7 | FST=true 8 | for i in "$@"; do 9 | if $FST; then 10 | set -- 11 | FST=false 12 | fi 13 | 14 | case $i in 15 | --*=*) 16 | ARG=${i%%=*} 17 | VAL=${i##*=} 18 | set -- "$@" "$ARG" "$VAL" 19 | ;; 20 | *) 21 | set -- "$@" "$i" 22 | ;; 23 | esac 24 | done 25 | 26 | if [ ! -e setup.exe ] || [ _oasis -nt setup.exe ] || [ setup.ml -nt setup.exe ] || [ configure -nt setup.exe ]; then 27 | ocamlfind ocamlopt -o setup.exe -linkpkg -package oasis.dynrun setup.ml || ocamlfind ocamlc -o setup.exe -linkpkg -package oasis.dynrun setup.ml || exit 1 28 | rm -f setup.cmi setup.cmo setup.cmx setup.o setup.cmt 29 | fi 30 | ./setup.exe -configure "$@" 31 | # OASIS_STOP 32 | -------------------------------------------------------------------------------- /lib/META.ab: -------------------------------------------------------------------------------- 1 | version = "$(pkg_version)" 2 | description = "Deriving" 3 | 4 | requires = "$(pkg_name).runtime, $(pkg_name).syntax" 5 | archive(syntax, preprocessor) = "-ignore dummy" 6 | 7 | error(pkg_type_conv, pkg_deriving) = "Could not be loaded together with 'type_conv'. Please use $(pkg_name).tc instead." 8 | 9 | package "runtime" ( 10 | 11 | archive(byte) = "deriving.cma" 12 | archive(native) = "deriving.cmxa" 13 | archive(byte, pkg_num) += "deriving_num.cma" 14 | archive(native, pkg_num) += "deriving_num.cmxa" 15 | 16 | requires = "bytes" 17 | 18 | ) 19 | 20 | package "syntax" ( 21 | 22 | requires(syntax, preprocessor) = "$(pkg_name).syntax.std, $(pkg_name).syntax.classes" 23 | requires(toploop) = "$(pkg_name).syntax.std, $(pkg_name).syntax.classes" 24 | archive(syntax, preprocessor) = "-ignore dummy" 25 | 26 | error(pkg_type_conv, pkg_deriving.syntax, -pkg_deriving) = "Could not be loaded together with 'type_conv'. Please use $(pkg_name).syntax_tc instead." 27 | 28 | package "common" ( 29 | 30 | requires(syntax, preprocessor) = "unix, camlp4" 31 | requires(toploop) = "unix, camlp4" 32 | 33 | archive(syntax, preprocessor) = "pa_deriving_common.cma" 34 | archive(syntax, toploop) = "pa_deriving_common.cma" 35 | 36 | ) 37 | 38 | package "std" ( 39 | 40 | description = "Deriving syntax extension" 41 | version = "$(pkg_version)" 42 | 43 | requires(syntax, preprocessor) = "$(pkg_name).syntax.common" 44 | requires(toploop) = "$(pkg_name).syntax.common" 45 | 46 | error(pkg_type_conv, -pkg_deriving.syntax, -pkg_deriving) = "Could not be loaded together with 'type_conv'. Please use $(pkg_name).syntax.tc instead." 47 | 48 | exists_if = "pa_deriving_std.cma" 49 | 50 | archive(syntax, preprocessor) = "pa_deriving_std.cma" 51 | archive(syntax, toploop) = "pa_deriving_std.cma" 52 | 53 | ) 54 | 55 | package "tc" ( 56 | 57 | description = "Deriving syntax extension (type_conv compatible syntax)" 58 | version = "$(pkg_version)" 59 | 60 | requires(syntax, preprocessor) = "$(pkg_name).syntax.common, type_conv" 61 | requires(toploop) = "$(pkg_name).syntax.common, type_conv" 62 | 63 | exists_if = "pa_deriving_tc.cma" 64 | 65 | archive(syntax, preprocessor) = "pa_deriving_tc.cma" 66 | archive(syntax, toploop) = "pa_deriving_tc.cma" 67 | 68 | ) 69 | 70 | package "classes" ( 71 | 72 | description = "Deriving syntax extension (predefined classes)" 73 | version = "$(pkg_version)" 74 | 75 | requires(syntax, preprocessor) = "$(pkg_name).syntax.common" 76 | requires(toploop) = "$(pkg_name).syntax.common" 77 | 78 | exists_if = "pa_deriving_classes.cma" 79 | 80 | archive(syntax, preprocessor) = "pa_deriving_classes.cma" 81 | archive(syntax, toploop) = "pa_deriving_classes.cma" 82 | 83 | ) 84 | 85 | ) 86 | 87 | package "tc" ( 88 | requires = "$(pkg_name).runtime, $(pkg_name).syntax_tc" 89 | archive(syntax, preprocessor) = "-ignore dummy" 90 | ) 91 | 92 | package "syntax_tc" ( 93 | requires(syntax, preprocessor) = "$(pkg_name).syntax.tc, $(pkg_name).syntax.classes" 94 | requires(toploop) = "$(pkg_name).syntax.tc, $(pkg_name).syntax.classes" 95 | archive(syntax, preprocessor) = "-ignore dummy" 96 | ) 97 | -------------------------------------------------------------------------------- /lib/deriving_Bounded.ml: -------------------------------------------------------------------------------- 1 | (* Copyright Jeremy Yallop 2007. 2 | This file is free software, distributed under the MIT license. 3 | See the file COPYING for details. 4 | *) 5 | 6 | (** Primitive instanecs for bounded **) 7 | module Deriving_Bounded = struct 8 | module type Bounded = sig 9 | type a 10 | val min_bound : a 11 | val max_bound : a 12 | end 13 | 14 | module Bounded_integer(B : sig type t 15 | val max_int : t 16 | val min_int : t 17 | end) : Bounded with type a = B.t = 18 | struct 19 | type a = B.t 20 | let min_bound = B.min_int 21 | let max_bound = B.max_int 22 | end 23 | module Bounded_int32 = Bounded_integer(Int32) 24 | module Bounded_int64 = Bounded_integer(Int64) 25 | module Bounded_nativeint = Bounded_integer(Nativeint) 26 | module Bounded_int = struct 27 | type a = int 28 | let min_bound = Pervasives.min_int 29 | let max_bound = Pervasives.max_int 30 | end 31 | module Bounded_bool = struct 32 | type a = bool 33 | let min_bound = false 34 | let max_bound = true 35 | end 36 | module Bounded_char = struct 37 | type a = char 38 | let min_bound = Char.chr 0 39 | let max_bound = Char.chr 0xff (* Is this guaranteed? *) 40 | end 41 | module Bounded_unit = struct 42 | type a = unit 43 | let min_bound = () 44 | let max_bound = () 45 | end 46 | end 47 | include Deriving_Bounded 48 | type open_flag = Pervasives.open_flag = 49 | | Open_rdonly 50 | | Open_wronly 51 | | Open_append 52 | | Open_creat 53 | | Open_trunc 54 | | Open_excl 55 | | Open_binary 56 | | Open_text 57 | | Open_nonblock 58 | deriving (Bounded) 59 | 60 | type fpclass = Pervasives.fpclass = 61 | | FP_normal 62 | | FP_subnormal 63 | | FP_zero 64 | | FP_infinite 65 | | FP_nan 66 | deriving (Bounded) 67 | -------------------------------------------------------------------------------- /lib/deriving_Bounded.mli: -------------------------------------------------------------------------------- 1 | module type Bounded = 2 | sig 3 | type a 4 | val min_bound : a 5 | val max_bound : a 6 | end 7 | 8 | module Bounded_bool : Bounded with type a = bool 9 | module Bounded_char : Bounded with type a = char 10 | module Bounded_int : Bounded with type a = int 11 | module Bounded_int32 : Bounded with type a = int32 12 | module Bounded_int64 : Bounded with type a = int64 13 | module Bounded_nativeint : Bounded with type a = nativeint 14 | module Bounded_unit : Bounded with type a = unit 15 | module Bounded_open_flag : Bounded with type a = Pervasives.open_flag 16 | module Bounded_fpclass : Bounded with type a = Pervasives.fpclass 17 | -------------------------------------------------------------------------------- /lib/deriving_Default.ml: -------------------------------------------------------------------------------- 1 | module type Default = sig 2 | type a 3 | val default : unit -> a 4 | end 5 | 6 | module Defaults(D : Default) : Default with type a = D.a = struct 7 | include D 8 | end 9 | 10 | module Default_string = Defaults(struct 11 | type a = string 12 | let default () = "" 13 | end) 14 | 15 | module Default_int64 = Defaults(struct 16 | type a = int64 17 | let default () = 0L 18 | end) 19 | 20 | 21 | module Default_int = Defaults(struct 22 | type a = int 23 | let default () = 0 24 | end) 25 | 26 | module Default_bool = Defaults(struct 27 | type a = bool 28 | let default () = true 29 | end) 30 | 31 | module Default_unit = Defaults(struct 32 | type a = unit 33 | let default () = () 34 | end) 35 | 36 | module Default_char = Defaults(struct 37 | type a = char 38 | let default () = '0' 39 | end) 40 | 41 | module Default_float = Defaults(struct 42 | type a = float 43 | let default () = 0.0 44 | end) 45 | 46 | module Default_list (A : Default) = Defaults(struct 47 | type a = A.a list 48 | let default () = [] 49 | end) 50 | 51 | module Default_option (A : Default) = Defaults(struct 52 | type a = A.a option 53 | let default () = None 54 | end) 55 | 56 | module Default_array (A : Default) = Defaults(struct 57 | type a = A.a array 58 | let default () = [||] 59 | end) 60 | 61 | 62 | module Default_ref (A : Default) = Defaults(struct 63 | type a = A.a ref 64 | let default () = ref (A.default ()) 65 | end) 66 | -------------------------------------------------------------------------------- /lib/deriving_Default.mli: -------------------------------------------------------------------------------- 1 | 2 | module type Default = sig 3 | type a 4 | val default : unit -> a 5 | end 6 | 7 | module Defaults(D : Default) : Default with type a = D.a 8 | module Default_string : Default with type a = string 9 | module Default_int64 : Default with type a = int64 10 | module Default_int : Default with type a = int 11 | module Default_bool : Default with type a = bool 12 | module Default_unit : Default with type a = unit 13 | module Default_char : Default with type a = char 14 | module Default_float : Default with type a = float 15 | module Default_list (A : Default) : Default with type a = A.a list 16 | module Default_option (A : Default) : Default with type a = A.a option 17 | module Default_array (A : Default) : Default with type a = A.a array 18 | module Default_ref (A : Default) : Default with type a = A.a ref 19 | -------------------------------------------------------------------------------- /lib/deriving_Dump.ml: -------------------------------------------------------------------------------- 1 | (** Dump **) 2 | 3 | (* Copyright Jeremy Yallop 2007. 4 | This file is free software, distributed under the MIT license. 5 | See the file COPYING for details. 6 | *) 7 | 8 | (* TODO: we could have an additional debugging deserialisation method. *) 9 | module type Dump = sig 10 | type a 11 | val to_buffer : Buffer.t -> a -> unit 12 | val to_string : a -> string 13 | val to_channel : out_channel -> a -> unit 14 | val from_stream : char Stream.t -> a 15 | val from_string : string -> a 16 | val from_channel : in_channel -> a 17 | end 18 | 19 | module type SimpleDump = sig 20 | type a 21 | val to_buffer : Buffer.t -> a -> unit 22 | val from_stream : char Stream.t -> a 23 | end 24 | 25 | exception Dump_error of string 26 | 27 | let bad_tag tag stream typename = 28 | raise (Dump_error 29 | (Printf.sprintf 30 | "Dump: failure during %s deserialisation at character %d; unexpected tag %d" 31 | typename (Stream.count stream) tag)) 32 | 33 | module Defaults (P : sig 34 | type a 35 | val to_buffer : Buffer.t -> a -> unit 36 | val from_stream : char Stream.t -> a 37 | end) : Dump with type a = P.a = 38 | struct 39 | include P 40 | 41 | (* is there a reasonable value to use here? *) 42 | let buffer_size = 128 43 | 44 | let to_string obj = 45 | let buffer = Buffer.create buffer_size in 46 | P.to_buffer buffer obj; 47 | Buffer.contents buffer 48 | (* should we explicitly deallocate the buffer? *) 49 | and from_string string = P.from_stream (Stream.of_string string) 50 | and from_channel in_channel = 51 | from_stream (Stream.of_channel in_channel) 52 | and to_channel out_channel obj = 53 | let buffer = Buffer.create buffer_size in 54 | P.to_buffer buffer obj; 55 | Buffer.output_buffer out_channel buffer 56 | end 57 | 58 | 59 | (* Generic int dumper. This should work for any (fixed-size) integer 60 | type with suitable operations. *) 61 | module Dump_intN (P : sig 62 | type t 63 | val zero : t 64 | val logand : t -> t -> t 65 | val logor : t -> t -> t 66 | val lognot : t -> t 67 | val shift_right_logical : t -> int -> t 68 | val shift_left : t -> int -> t 69 | val of_int : int -> t 70 | val to_int : t -> int 71 | end) = Defaults ( 72 | struct 73 | type a = P.t 74 | (* Format an integer using the following scheme: 75 | 76 | The lower 7 bits of each byte are used to store successive 7-bit 77 | chunks of the integer. 78 | 79 | The highest bit of each byte is used as a flag to indicate 80 | whether the next byte is present. 81 | *) 82 | open Buffer 83 | open Char 84 | open P 85 | 86 | let to_buffer buffer = 87 | let rec aux int = 88 | (* are there more than 7 bits? *) 89 | if logand int (lognot (of_int 0x7f)) <> zero 90 | (* if there are, write the lowest 7 bite plus a high bit (to 91 | indicate that there's more). Then recurse, shifting the value 92 | 7 bits right *) 93 | then begin 94 | add_char buffer (chr (to_int (logor (of_int 0x80) (logand int (of_int 0x7f))))); 95 | aux (shift_right_logical int 7) 96 | end 97 | (* otherwise, write the bottom 7 bits only *) 98 | else add_char buffer (chr (to_int int)) 99 | in aux 100 | 101 | and from_stream stream = 102 | let rec aux (int : t) shift = 103 | let c = of_int (code (Stream.next stream)) in 104 | let int = logor int (shift_left (logand c (of_int 0x7f)) shift) in 105 | if logand c (of_int 0x80) <> zero then aux int (shift + 7) 106 | else int 107 | in aux zero 0 108 | end 109 | ) 110 | 111 | module Dump_int32 = Dump_intN (Int32) 112 | module Dump_int64 = Dump_intN (Int64) 113 | module Dump_nativeint = Dump_intN (Nativeint) 114 | module Dump_int = Defaults ( 115 | struct 116 | type a = int 117 | let to_buffer buffer int = Dump_nativeint.to_buffer buffer (Nativeint.of_int int) 118 | and from_stream stream = Nativeint.to_int (Dump_nativeint.from_stream stream) 119 | end 120 | ) 121 | 122 | module Dump_char = Defaults ( 123 | struct 124 | type a = char 125 | let to_buffer = Buffer.add_char 126 | and from_stream = Stream.next 127 | end 128 | ) 129 | 130 | (* This is questionable; it doesn't preserve sharing *) 131 | module Dump_string = Defaults ( 132 | struct 133 | type a = string 134 | let to_buffer buffer string = 135 | begin 136 | Dump_int.to_buffer buffer (String.length string); 137 | Buffer.add_string buffer string 138 | end 139 | and from_stream stream = 140 | let len = Dump_int.from_stream stream in 141 | let s = Bytes.create len in 142 | for i = 0 to len - 1 do 143 | Bytes.unsafe_set s i (Stream.next stream) 144 | done; 145 | Bytes.to_string s 146 | end 147 | ) 148 | 149 | module Dump_float = Defaults ( 150 | struct 151 | type a = float 152 | let to_buffer buffer f = Dump_int64.to_buffer buffer (Int64.bits_of_float f) 153 | and from_stream stream = Int64.float_of_bits (Dump_int64.from_stream stream) 154 | end 155 | ) 156 | 157 | (* This should end up a bit more compact than the derived version *) 158 | module Dump_list (P : SimpleDump) = Defaults ( 159 | (* This could perhaps be more efficient by serialising the list in 160 | reverse: this would result in only one traversal being needed 161 | during serialisation, and no "reverse" being needed during 162 | deserialisation. (However, dumping would no longer be 163 | tail-recursive) *) 164 | struct 165 | type a = P.a list 166 | let to_buffer buffer items = 167 | begin 168 | Dump_int.to_buffer buffer (List.length items); 169 | List.iter (P.to_buffer buffer) items 170 | end 171 | and from_stream stream = 172 | let rec aux items = function 173 | | 0 -> items 174 | | n -> aux (P.from_stream stream :: items) (n-1) 175 | in List.rev (aux [] (Dump_int.from_stream stream)) 176 | end 177 | ) 178 | 179 | (* Dump_ref and Dump_array cannot preserve sharing, so we don't 180 | provide implementations *) 181 | 182 | module Dump_option (P : SimpleDump) = Defaults ( 183 | struct 184 | type a = P.a option 185 | let to_buffer buffer = function 186 | | None -> Dump_int.to_buffer buffer 0 187 | | Some s -> 188 | begin 189 | Dump_int.to_buffer buffer 1; 190 | P.to_buffer buffer s 191 | end 192 | and from_stream stream = 193 | match Dump_int.from_stream stream with 194 | | 0 -> None 195 | | 1 -> Some (P.from_stream stream) 196 | | i -> bad_tag i stream "option" 197 | end 198 | ) 199 | 200 | 201 | module Dump_bool = Defaults ( 202 | struct 203 | type a = bool 204 | let to_buffer buffer = function 205 | | false -> Buffer.add_char buffer '\000' 206 | | true -> Buffer.add_char buffer '\001' 207 | and from_stream stream = 208 | match Stream.next stream with 209 | | '\000' -> false 210 | | '\001' -> true 211 | | c -> bad_tag (Char.code c) stream "bool" 212 | end 213 | ) 214 | 215 | module Dump_unit = Defaults ( 216 | struct 217 | type a = unit 218 | let to_buffer _ () = () 219 | and from_stream _ = () 220 | end 221 | ) 222 | 223 | module Dump_alpha(P: sig type a end) = Defaults(struct 224 | type a = P.a 225 | let to_buffer _ _ = assert false 226 | let from_stream _ = assert false 227 | end) 228 | 229 | module Dump_undumpable (P : sig type a val tname : string end) = Defaults ( 230 | struct 231 | type a = P.a 232 | let to_buffer _ _ = failwith ("Dump: attempt to serialise a value of unserialisable type : " ^ P.tname) 233 | let from_stream _ = failwith ("Dump: attempt to deserialise a value of unserialisable type : " ^ P.tname) 234 | end 235 | ) 236 | 237 | (* Uses Marshal to serialise the values that the parse-the-declarations 238 | technique can't reach. *) 239 | module Dump_via_marshal (P : sig type a end) = Defaults ( 240 | (* Rather inefficient. *) 241 | struct 242 | include P 243 | let to_buffer buffer obj = Buffer.add_string buffer (Marshal.to_string obj [Marshal.Closures]) 244 | let from_stream stream = 245 | let readn n = 246 | let s = Bytes.create n in 247 | for i = 0 to n - 1 do 248 | Bytes.set s i (Stream.next stream) 249 | done; 250 | s 251 | in 252 | let header = readn Marshal.header_size in 253 | let datasize = Marshal.data_size header 0 in 254 | let datapart = readn datasize in 255 | Marshal.from_bytes (Bytes.cat header datapart) 0 256 | end) 257 | -------------------------------------------------------------------------------- /lib/deriving_Dump.mli: -------------------------------------------------------------------------------- 1 | module type Dump = 2 | sig 3 | type a 4 | val to_buffer : Buffer.t -> a -> unit 5 | val to_string : a -> string 6 | val to_channel : out_channel -> a -> unit 7 | val from_stream : char Stream.t -> a 8 | val from_string : string -> a 9 | val from_channel : in_channel -> a 10 | end 11 | 12 | module Defaults 13 | (P : sig 14 | type a 15 | val to_buffer : Buffer.t -> a -> unit 16 | val from_stream : char Stream.t -> a 17 | end) : Dump with type a = P.a 18 | 19 | exception Dump_error of string 20 | 21 | module Dump_int32 : Dump with type a = Int32.t 22 | module Dump_int64 : Dump with type a = Int64.t 23 | module Dump_nativeint : Dump with type a = Nativeint.t 24 | module Dump_int : Dump with type a = int 25 | module Dump_char : Dump with type a = char 26 | module Dump_string : Dump with type a = string 27 | module Dump_float : Dump with type a = float 28 | module Dump_bool : Dump with type a = bool 29 | module Dump_unit : Dump with type a = unit 30 | module Dump_list (P : Dump) : Dump with type a = P.a list 31 | module Dump_option (P : Dump) : Dump with type a = P.a option 32 | 33 | module Dump_undumpable (P : sig type a val tname : string end) 34 | : Dump with type a = P.a 35 | module Dump_via_marshal (P : sig type a end) 36 | : Dump with type a = P.a 37 | module Dump_alpha (P : sig type a end) 38 | : Dump with type a = P.a 39 | -------------------------------------------------------------------------------- /lib/deriving_Enum.ml: -------------------------------------------------------------------------------- 1 | (* Copyright Jeremy Yallop 2007. 2 | This file is free software, distributed under the MIT license. 3 | See the file COPYING for details. 4 | *) 5 | 6 | open Deriving_Bounded 7 | 8 | let rec rassoc (rkey : 'b) : ('a * 'b) list -> 'a = function 9 | | [] -> raise Not_found 10 | | (a,b)::_ when b = rkey -> a 11 | | _::xs -> rassoc rkey xs 12 | 13 | let rec last : 'a list -> 'a = function 14 | | [] -> raise (Invalid_argument "last") 15 | | [x] -> x 16 | | _::xs -> last xs 17 | 18 | module Deriving_Enum = 19 | struct 20 | (** Enum **) 21 | module type Enum = sig 22 | type a 23 | val succ : a -> a 24 | val pred : a -> a 25 | val to_enum : int -> a 26 | val from_enum : a -> int 27 | val enum_from : a -> a list 28 | val enum_from_then : a -> a -> a list 29 | val enum_from_to : a -> a -> a list 30 | val enum_from_then_to : a -> a -> a -> a list 31 | end 32 | 33 | let startThenTo (start : int) (next : int) (until : int) : int list = 34 | let step = next - start in 35 | if step <= 0 then invalid_arg "startThenTo" 36 | else 37 | let rec upFrom current = 38 | if current > until then [] 39 | else current :: upFrom (current+step) 40 | in 41 | upFrom start 42 | 43 | let range : int -> int -> int list 44 | = fun f t -> startThenTo f (f+1) t 45 | 46 | module Defaults 47 | (E : (sig 48 | type a 49 | val numbering : (a * int) list 50 | end)) : Enum with type a = E.a = 51 | struct 52 | let firstCon = fst (List.hd E.numbering) 53 | let lastCon = fst (last E.numbering) 54 | 55 | type a = E.a 56 | let from_enum a = List.assoc a E.numbering 57 | let to_enum i = try rassoc i E.numbering with Not_found -> raise (Invalid_argument "to_enum") 58 | let succ s = try to_enum ((from_enum s) + 1) with Invalid_argument "to_enum" -> raise (Invalid_argument "succ") 59 | let pred s = try to_enum ((from_enum s) - 1) with Invalid_argument "to_enum" -> raise (Invalid_argument "pred") 60 | let enum_from_to x y = List.map to_enum (range (from_enum x) (from_enum y)) 61 | let enum_from_then_to x y z = List.map to_enum (startThenTo (from_enum x) (from_enum y) (from_enum z)) 62 | let enum_from_then x y = (enum_from_then_to x y 63 | (if from_enum y >= from_enum x then lastCon 64 | else firstCon)) 65 | let enum_from x = enum_from_to x lastCon 66 | end 67 | 68 | 69 | module Defaults' 70 | (E : (sig 71 | type a 72 | val from_enum : a -> int 73 | val to_enum : int -> a 74 | end)) 75 | (B : Bounded with type a = E.a) : Enum with type a = E.a 76 | and type a = B.a = 77 | struct 78 | include E 79 | let firstCon = B.min_bound 80 | let lastCon = B.max_bound 81 | 82 | let succ s = try to_enum ((from_enum s) + 1) with Invalid_argument "to_enum" -> raise (Invalid_argument "succ") 83 | let pred s = try to_enum ((from_enum s) - 1) with Invalid_argument "to_enum" -> raise (Invalid_argument "pred") 84 | let enum_from_to x y = List.map to_enum (range (from_enum x) (from_enum y)) 85 | let enum_from_then_to x y z = List.map to_enum (startThenTo (from_enum x) (from_enum y) (from_enum z)) 86 | let enum_from_then x y = (enum_from_then_to x y 87 | (if from_enum y >= from_enum x then lastCon 88 | else firstCon)) 89 | let enum_from x = enum_from_to x lastCon 90 | end 91 | 92 | module Enum_bool = Defaults(struct 93 | type a = bool 94 | let numbering = [false, 0; true, 1] 95 | end) 96 | 97 | module Enum_char = Defaults'(struct 98 | type a = char 99 | let from_enum = Char.code 100 | let to_enum = Char.chr 101 | end) (Bounded_char) 102 | 103 | module Enum_int = Defaults' (struct 104 | type a = int 105 | let from_enum i = i 106 | let to_enum i = i 107 | end)(Bounded_int) 108 | 109 | (* Can `instance Enum Float' be justified? 110 | For some floats `f' we have `succ f == f'. 111 | Furthermore, float is wider than int, so from_enum will necessarily 112 | give nonsense on many inputs. *) 113 | 114 | module Enum_unit = Defaults' (struct 115 | type a = unit 116 | let from_enum () = 0 117 | let to_enum = function 118 | | 0 -> () 119 | | _ -> raise (Invalid_argument "to_enum") 120 | end) (Bounded_unit) 121 | end 122 | include Deriving_Enum 123 | 124 | type open_flag = Pervasives.open_flag = 125 | | Open_rdonly 126 | | Open_wronly 127 | | Open_append 128 | | Open_creat 129 | | Open_trunc 130 | | Open_excl 131 | | Open_binary 132 | | Open_text 133 | | Open_nonblock 134 | deriving (Bounded,Enum) 135 | 136 | type fpclass = Pervasives.fpclass = 137 | | FP_normal 138 | | FP_subnormal 139 | | FP_zero 140 | | FP_infinite 141 | | FP_nan 142 | deriving (Bounded,Enum) 143 | -------------------------------------------------------------------------------- /lib/deriving_Enum.mli: -------------------------------------------------------------------------------- 1 | module type Enum = 2 | sig 3 | type a 4 | val succ : a -> a 5 | val pred : a -> a 6 | val to_enum : int -> a 7 | val from_enum : a -> int 8 | val enum_from : a -> a list 9 | val enum_from_then : a -> a -> a list 10 | val enum_from_to : a -> a -> a list 11 | val enum_from_then_to : a -> a -> a -> a list 12 | end 13 | 14 | module Defaults 15 | (E : sig type a val numbering : (a * int) list end) 16 | : Enum with type a = E.a 17 | 18 | module Defaults' 19 | (E : sig type a val from_enum : a -> int val to_enum : int -> a end) 20 | (B : Deriving_Bounded.Bounded with type a = E.a) 21 | : Enum with type a = B.a 22 | 23 | module Enum_bool : Enum with type a = bool 24 | module Enum_char : Enum with type a = char 25 | module Enum_int : Enum with type a = int 26 | module Enum_unit : Enum with type a = unit 27 | -------------------------------------------------------------------------------- /lib/deriving_Eq.ml: -------------------------------------------------------------------------------- 1 | (* Copyright Jeremy Yallop 2007. 2 | This file is free software, distributed under the MIT license. 3 | See the file COPYING for details. 4 | *) 5 | 6 | module type Eq = 7 | sig 8 | type a 9 | val eq : a -> a -> bool 10 | end 11 | 12 | module Eq_immutable(S : sig type a end) : 13 | Eq with type a = S.a = 14 | struct 15 | type a = S.a 16 | let eq = (=) 17 | end 18 | 19 | module Eq_mutable(S : sig type a end) : 20 | Eq with type a = S.a = 21 | struct 22 | type a = S.a 23 | let eq = (==) 24 | end 25 | 26 | module Eq_alpha(S : sig type a end) = struct type a = S.a let eq _ _ = assert false end 27 | module Eq_int = Eq_immutable(struct type a = int end) 28 | module Eq_bool = Eq_immutable(struct type a = bool end) 29 | module Eq_float = Eq_immutable(struct type a = float end) 30 | module Eq_unit = Eq_immutable(struct type a = unit end) 31 | module Eq_char = Eq_immutable(struct type a = char end) 32 | module Eq_int32 = Eq_immutable(struct type a = int32 end) 33 | module Eq_int64 = Eq_immutable(struct type a = int64 end) 34 | module Eq_nativeint = Eq_immutable(struct type a = nativeint end) 35 | 36 | module Eq_string = Eq_mutable(struct type a = string end) 37 | module Eq_ref (E : Eq) = Eq_mutable(struct type a = E.a ref end) 38 | module Eq_array (E : Eq) = Eq_mutable(struct type a = E.a array end) 39 | 40 | module Eq_option (E : Eq) 41 | : Eq with type a = E.a option = 42 | struct 43 | type a = E.a option 44 | let eq l r = match l, r with 45 | | None, None -> true 46 | | Some l, Some r -> E.eq l r 47 | | _ -> false 48 | end 49 | 50 | module Eq_map_s_t (E : Eq) (M : Map.S) 51 | : Eq with type a = E.a M.t = 52 | struct 53 | type a = E.a M.t 54 | let eq = M.equal (E.eq) 55 | end 56 | 57 | module Eq_set_s_t (S : Set.S) 58 | : Eq with type a = S.t = 59 | struct 60 | type a = S.t 61 | let eq = S.equal 62 | end 63 | 64 | module Eq_list (E : Eq) : 65 | Eq with type a = E.a list = 66 | struct 67 | type a = E.a list 68 | let rec eq l r = match l, r with 69 | | [], [] -> true 70 | | (lfst::lrst), (rfst::rrst) when E.eq lfst rfst -> eq lrst rrst 71 | | _ -> false 72 | end 73 | 74 | -------------------------------------------------------------------------------- /lib/deriving_Eq.mli: -------------------------------------------------------------------------------- 1 | (* A module for SML-style equality, i.e. where equality of mutables is 2 | physical equality and equality of immutables is structural equality. 3 | *) 4 | 5 | module type Eq = 6 | sig 7 | type a 8 | val eq : a -> a -> bool 9 | end 10 | 11 | module Eq_immutable (S : sig type a end) : Eq with type a = S.a 12 | module Eq_mutable (S : sig type a end) : Eq with type a = S.a 13 | 14 | module Eq_alpha(S : sig type a end) : Eq with type a = S.a 15 | module Eq_int : Eq with type a = int 16 | module Eq_bool : Eq with type a = bool 17 | module Eq_float : Eq with type a = float 18 | module Eq_unit : Eq with type a = unit 19 | module Eq_char : Eq with type a = char 20 | module Eq_string : Eq with type a = string 21 | module Eq_int32 : Eq with type a = int32 22 | module Eq_int64 : Eq with type a = int64 23 | module Eq_nativeint : Eq with type a = nativeint 24 | module Eq_ref (E : Eq) : Eq with type a = E.a ref 25 | module Eq_array (E : Eq) : Eq with type a = E.a array 26 | module Eq_list (E : Eq) : Eq with type a = E.a list 27 | module Eq_option (E : Eq): Eq with type a = E.a option 28 | module Eq_map_s_t (E : Eq) (M : Map.S) : Eq with type a = E.a M.t 29 | module Eq_set_s_t (S : Set.S) : Eq with type a = S.t 30 | -------------------------------------------------------------------------------- /lib/deriving_Functor.ml: -------------------------------------------------------------------------------- 1 | open Deriving_monad 2 | 3 | (* Copyright Jeremy Yallop 2007. 4 | This file is free software, distributed under the MIT license. 5 | See the file COPYING for details. 6 | *) 7 | 8 | module type Functor = 9 | sig 10 | type 'a f 11 | val map : ('a -> 'b) -> 'a f -> 'b f 12 | end 13 | 14 | module MonadFunctor (M : Monad) 15 | : Functor with type 'a f = 'a M.m 16 | = 17 | struct 18 | open M 19 | type 'a f = 'a M.m 20 | let map f x = x >>= (fun x -> return (f x)) 21 | end 22 | 23 | 24 | module Functor_option = MonadFunctor(Monad_option) 25 | module Functor_list = MonadFunctor(Monad_list) 26 | 27 | module Functor_map (O : Map.OrderedType) 28 | : Functor with type 'a f = 'a Map.Make(O).t = 29 | struct 30 | include Map.Make(O) 31 | type 'a f = 'a t 32 | end 33 | 34 | (* 35 | NB: Instances for mutable types (including 36 | 37 | ref 38 | queue 39 | stack 40 | array 41 | stream 42 | buffer) 43 | 44 | are deliberately omitted. Since sharing is detectable for values of 45 | these types we have two distinct design choices: 46 | 47 | 1. Always create a new copy that shares no structure with the 48 | original. 49 | 50 | 2. Always mutate the original copy 51 | 52 | Neither of these seems like the right thing to do, so instead we 53 | simply don't handle mutable types at all. 54 | 55 | (Lazy.t is another example: we'd like map to be total and side-effect 56 | free, which is impossible to guarantee if we handle lazy. 57 | *) 58 | -------------------------------------------------------------------------------- /lib/deriving_Functor.mli: -------------------------------------------------------------------------------- 1 | module type Functor = 2 | sig 3 | type 'a f 4 | val map : ('a -> 'b) -> 'a f -> 'b f 5 | end 6 | module MonadFunctor (M : Deriving_monad.Monad) : Functor with type 'a f = 'a M.m 7 | module Functor_option : Functor with type 'a f = 'a option 8 | module Functor_list : Functor with type 'a f = 'a list 9 | module Functor_map (O : Map.OrderedType) : Functor with type 'a f = 'a Map.Make(O).t 10 | -------------------------------------------------------------------------------- /lib/deriving_Pickle.mli: -------------------------------------------------------------------------------- 1 | open Deriving_Typeable 2 | open Deriving_Eq 3 | open Deriving_Dump 4 | 5 | type id 6 | 7 | (* representation of values of user-defined types *) 8 | module Repr : sig 9 | type t 10 | val make : ?constructor:int -> id list -> t 11 | end 12 | 13 | (* Utilities for serialization *) 14 | module Write : sig 15 | type s 16 | include Deriving_monad.Monad_state_type with type state = s 17 | module Utils (T : Typeable) (E : Eq with type a = T.a) : sig 18 | val allocate : T.a -> (id -> unit m) -> id m 19 | val store_repr : id -> Repr.t -> unit m 20 | end 21 | end 22 | 23 | (* Utilities for deserialization *) 24 | module Read : sig 25 | type s 26 | include Deriving_monad.Monad_state_type with type state = s 27 | module Utils (T : Typeable) : sig 28 | val sum : (int * id list -> T.a m) -> (id -> T.a m) 29 | val tuple : (id list -> T.a m) -> (id -> T.a m) 30 | val record : (T.a -> id list -> T.a m) -> int -> (id -> T.a m) 31 | end 32 | end 33 | 34 | exception UnpicklingError of string 35 | exception UnknownTag of int * string 36 | 37 | module type Pickle = 38 | sig 39 | type a 40 | module Typeable : Typeable with type a = a 41 | module Eq : Eq with type a = a 42 | val pickle : a -> id Write.m 43 | val unpickle : id -> a Read.m 44 | val to_buffer : Buffer.t -> a -> unit 45 | val to_string : a -> string 46 | val to_channel : out_channel -> a -> unit 47 | val from_stream : char Stream.t -> a 48 | val from_string : string -> a 49 | val from_channel : in_channel -> a 50 | end 51 | 52 | module Defaults 53 | (S : sig 54 | type a 55 | module Typeable : Typeable with type a = a 56 | module Eq : Eq with type a = a 57 | val pickle : a -> id Write.m 58 | val unpickle : id -> a Read.m 59 | end) : Pickle with type a = S.a 60 | 61 | module Pickle_unit : Pickle with type a = unit 62 | module Pickle_bool : Pickle with type a = bool 63 | module Pickle_int : Pickle with type a = int 64 | module Pickle_char : Pickle with type a = char 65 | module Pickle_float : Pickle with type a = float 66 | module Pickle_string : Pickle with type a = string 67 | module Pickle_int32 : Pickle with type a = int32 68 | module Pickle_int64 : Pickle with type a = int64 69 | module Pickle_nativeint : Pickle with type a = nativeint 70 | module Pickle_option (V0 : Pickle) : Pickle with type a = V0.a option 71 | module Pickle_list (V0 : Pickle) : Pickle with type a = V0.a list 72 | module Pickle_ref (S : Pickle) : Pickle with type a = S.a ref 73 | 74 | module Pickle_from_dump 75 | (P : Dump) 76 | (E : Eq with type a = P.a) 77 | (T : Typeable with type a = P.a) 78 | : Pickle with type a = P.a 79 | -------------------------------------------------------------------------------- /lib/deriving_Show.ml: -------------------------------------------------------------------------------- 1 | (* Copyright Jeremy Yallop 2007. 2 | This file is free software, distributed under the MIT license. 3 | See the file COPYING for details. 4 | *) 5 | 6 | module Deriving_Show = 7 | struct 8 | (** Show **) 9 | module type Show = sig 10 | type a 11 | val format : Format.formatter -> a -> unit 12 | val format_list : Format.formatter -> a list -> unit 13 | val show : a -> string 14 | val show_list : a list -> string 15 | end 16 | 17 | module type SimpleFormatter = 18 | sig 19 | type a 20 | val format : Format.formatter -> a -> unit 21 | end 22 | 23 | module ShowFormatterDefault (S : SimpleFormatter) = 24 | struct 25 | include S 26 | let format_list formatter items = 27 | let rec writeItems formatter = function 28 | | [] -> () 29 | | [x] -> S.format formatter x; 30 | | x :: xs -> Format.fprintf formatter "%a;@;%a" S.format x writeItems xs 31 | in 32 | Format.fprintf formatter "@[[%a]@]" writeItems items 33 | end 34 | 35 | module ShowDefaults' 36 | (S : (sig 37 | type a 38 | val format : Format.formatter -> a -> unit 39 | val format_list : Format.formatter -> a list -> unit 40 | end)) : Show with type a = S.a = 41 | struct 42 | include S 43 | let showFormatted f item = 44 | let b = Buffer.create 16 in 45 | let formatter = Format.formatter_of_buffer b in 46 | Format.fprintf formatter "@[%a@]@?" f item; 47 | Buffer.sub b 0 (Buffer.length b) 48 | 49 | (* Warning: do not eta-reduce either of the following *) 50 | let show item = showFormatted S.format item 51 | let show_list items = showFormatted S.format_list items 52 | end 53 | 54 | module Defaults (S : SimpleFormatter) : Show with type a = S.a = 55 | ShowDefaults' (ShowFormatterDefault (S)) 56 | 57 | module Show_unprintable (S : sig type a end) (*: Show with type a = S.a *) = 58 | Defaults (struct 59 | type a = S.a 60 | let format formatter _ = Format.pp_print_string formatter "..." 61 | end) 62 | 63 | (* instance Show a => Show [a] *) 64 | module Show_list (S : Show) : Show with type a = S.a list = 65 | Defaults (struct 66 | type a = S.a list 67 | let format = S.format_list 68 | end) 69 | 70 | (* instance Show a => Show (a option) *) 71 | module Show_option (S : Show) : Show with type a = S.a option = 72 | Defaults (struct 73 | type a = S.a option 74 | let format formatter = function 75 | | None -> Format.fprintf formatter "@[None@]" 76 | | Some s -> Format.fprintf formatter "@[Some@;<1 2>(%a)@]" S.format s 77 | end) 78 | 79 | (* instance Show a => Show (a array) *) 80 | module Show_array (S : Show) : Show with type a = S.a array = 81 | Defaults (struct 82 | type a = S.a array 83 | let format formatter obj = 84 | let writeItems formatter items = 85 | let length = Array.length items in 86 | for i = 0 to length - 2 do 87 | Format.fprintf formatter "@[%a;@;@]" S.format (Array.get items i) 88 | done; 89 | if length <> 0 then 90 | S.format formatter (Array.get items (length -1)); 91 | in 92 | Format.fprintf formatter "@[[|%a|]@]" writeItems obj 93 | end) 94 | 95 | module Show_map 96 | (O : Map.OrderedType) 97 | (K : Show with type a = O.t) 98 | (V : Show) 99 | : Show with type a = V.a Map.Make(O).t = 100 | Defaults( 101 | struct 102 | module M = Map.Make(O) 103 | type a = V.a M.t 104 | let format formatter map = 105 | Format.pp_open_box formatter 0; 106 | Format.pp_print_string formatter "{"; 107 | M.iter (fun key value -> 108 | Format.pp_open_box formatter 0; 109 | K.format formatter key; 110 | Format.pp_print_string formatter " => "; 111 | V.format formatter value; 112 | Format.fprintf formatter ";@;"; 113 | Format.pp_close_box formatter (); 114 | ) map; 115 | Format.pp_print_string formatter "}"; 116 | Format.pp_close_box formatter (); 117 | 118 | end) 119 | 120 | module Show_set 121 | (O : Set.OrderedType) 122 | (K : Show with type a = O.t) 123 | : Show with type a = Set.Make(O).t = 124 | Defaults( 125 | struct 126 | module S = Set.Make(O) 127 | type a = S.t 128 | let format formatter set = 129 | Format.pp_open_box formatter 0; 130 | Format.pp_print_string formatter "{"; 131 | S.iter (fun elt -> 132 | Format.pp_open_box formatter 0; 133 | K.format formatter elt; 134 | Format.fprintf formatter ";@;"; 135 | Format.pp_close_box formatter (); 136 | ) set; 137 | Format.pp_print_string formatter "}"; 138 | Format.pp_close_box formatter (); 139 | end) 140 | 141 | module Show_bool = Defaults (struct 142 | type a = bool 143 | let format formatter item = 144 | match item with 145 | | true -> Format.pp_print_string formatter "true" 146 | | false -> Format.pp_print_string formatter "false" 147 | end) 148 | 149 | module Show_integer (S : sig type t val to_string : t -> string end) = Defaults (struct 150 | type a = S.t 151 | let format formatter item = Format.pp_print_string formatter (S.to_string item) 152 | end) 153 | 154 | module Show_int32 = Show_integer(Int32) 155 | module Show_int64 = Show_integer(Int64) 156 | module Show_nativeint = Show_integer(Nativeint) 157 | 158 | module Show_char = Defaults (struct 159 | type a = char 160 | let format formatter item = Format.pp_print_string formatter ("'" ^ Char.escaped item ^ "'") 161 | end) 162 | 163 | module Show_int = Defaults (struct 164 | type a = int 165 | let format formatter item = Format.pp_print_string formatter (string_of_int item) 166 | end) 167 | 168 | module Show_float = Defaults(struct 169 | type a = float 170 | let format formatter item = Format.pp_print_string formatter (string_of_float item) 171 | end) 172 | 173 | module Show_string = Defaults (struct 174 | type a = string 175 | let format formatter item = 176 | Format.pp_print_char formatter '"'; 177 | Format.pp_print_string formatter (String.escaped item); 178 | Format.pp_print_char formatter '"' 179 | end) 180 | 181 | module Show_unit = Defaults(struct 182 | type a = unit 183 | let format formatter () = Format.pp_print_string formatter "()" 184 | end) 185 | 186 | end 187 | include Deriving_Show 188 | 189 | type open_flag = Pervasives.open_flag = 190 | | Open_rdonly 191 | | Open_wronly 192 | | Open_append 193 | | Open_creat 194 | | Open_trunc 195 | | Open_excl 196 | | Open_binary 197 | | Open_text 198 | | Open_nonblock 199 | deriving (Show) 200 | 201 | type fpclass = Pervasives.fpclass = 202 | | FP_normal 203 | | FP_subnormal 204 | | FP_zero 205 | | FP_infinite 206 | | FP_nan 207 | deriving (Show) 208 | 209 | type 'a ref = 'a Pervasives.ref = { mutable contents : 'a; } 210 | deriving (Show) 211 | 212 | -------------------------------------------------------------------------------- /lib/deriving_Show.mli: -------------------------------------------------------------------------------- 1 | module type Show = 2 | sig 3 | type a 4 | val format : Format.formatter -> a -> unit 5 | val format_list : Format.formatter -> a list -> unit 6 | val show : a -> string 7 | val show_list : a list -> string 8 | end 9 | 10 | module Defaults (S : 11 | sig 12 | type a 13 | val format : Format.formatter -> a -> unit 14 | end) : Show with type a = S.a 15 | 16 | module Show_unprintable (S : sig type a end) : Show with type a = S.a 17 | 18 | module Show_char : Show with type a = char 19 | module Show_bool : Show with type a = bool 20 | module Show_unit : Show with type a = unit 21 | module Show_int : Show with type a = int 22 | module Show_int32 : Show with type a = int32 23 | module Show_int64 : Show with type a = int64 24 | module Show_nativeint : Show with type a = nativeint 25 | module Show_float : Show with type a = float 26 | module Show_string : Show with type a = string 27 | 28 | module Show_list (S : Show) : Show with type a = S.a list 29 | module Show_ref (S : Show) : Show with type a = S.a ref 30 | module Show_option (S : Show) : Show with type a = S.a option 31 | module Show_array (S : Show) : Show with type a = S.a array 32 | 33 | module Show_map 34 | (O : Map.OrderedType) 35 | (K : Show with type a = O.t) 36 | (V : Show) 37 | : Show with type a = V.a Map.Make(O).t 38 | 39 | module Show_set 40 | (O : Set.OrderedType) 41 | (K : Show with type a = O.t) 42 | : Show with type a = Set.Make(O).t 43 | -------------------------------------------------------------------------------- /lib/deriving_Typeable.mli: -------------------------------------------------------------------------------- 1 | module TypeRep : 2 | sig 3 | type t 4 | type delayed = t Lazy.t 5 | val compare : t -> t -> int 6 | val eq : t -> t -> bool 7 | val mkFresh : string -> delayed list -> t 8 | val mkTuple : delayed list -> t 9 | val mkPolyv : (string * delayed option) list -> delayed list -> t 10 | end 11 | 12 | exception CastFailure of string 13 | 14 | type dynamic 15 | val tagOf : dynamic -> TypeRep.t 16 | 17 | module type Typeable = 18 | sig 19 | type a 20 | val type_rep : TypeRep.t Lazy.t 21 | val has_type : dynamic -> bool 22 | val cast : dynamic -> a option 23 | val throwing_cast : dynamic -> a 24 | val make_dynamic : a -> dynamic 25 | val mk : a -> dynamic 26 | end 27 | 28 | module Defaults (T : (sig 29 | type a 30 | val type_rep : TypeRep.t Lazy.t 31 | end)) 32 | : Typeable with type a = T.a 33 | 34 | module Typeable_list (A : Typeable) : Typeable with type a = A.a list 35 | module Typeable_option (A : Typeable) : Typeable with type a = A.a option 36 | module Typeable_ref (A : Typeable) : Typeable with type a = A.a ref 37 | 38 | (*module Primitive_typeable (T : sig type t end): Typeable with type a = T.t *) 39 | 40 | module Typeable_unit : Typeable with type a = unit 41 | module Typeable_int : Typeable with type a = int 42 | module Typeable_float : Typeable with type a = float 43 | module Typeable_bool : Typeable with type a = bool 44 | module Typeable_string : Typeable with type a = string 45 | module Typeable_char : Typeable with type a = char 46 | module Typeable_int32 : Typeable with type a = int32 47 | module Typeable_int64 : Typeable with type a = int64 48 | module Typeable_nativeint : Typeable with type a = nativeint 49 | 50 | (**/**) 51 | module Primitive_typeable (T : sig type t val magic : string end) : Typeable with type a = T.t 52 | -------------------------------------------------------------------------------- /lib/deriving_dynmap.ml: -------------------------------------------------------------------------------- 1 | (* Finite maps : t -> dynamic *) 2 | 3 | (* Copyright Jeremy Yallop 2007. 4 | This file is free software, distributed under the MIT license. 5 | See the file COPYING for details. 6 | *) 7 | open Deriving_Typeable 8 | open Deriving_Eq 9 | 10 | module Comp (T : Typeable) (E : Eq with type a = T.a) = 11 | struct 12 | type a = T.a 13 | let adjust_comparator : (T.a -> T.a -> bool) -> dynamic -> dynamic -> bool 14 | = fun comparator d1 d2 -> 15 | match T.cast d1, T.cast d2 with 16 | | Some l, Some r -> comparator l r 17 | | _ -> assert false 18 | let eq = adjust_comparator E.eq 19 | end 20 | 21 | 22 | module DynMap = 23 | struct 24 | module TypeMap = Map.Make(TypeRep) 25 | type comparator = dynamic -> dynamic -> bool 26 | type 'value t = (((dynamic * 'value) list * comparator) TypeMap.t) 27 | 28 | let empty = TypeMap.empty 29 | 30 | let add dynamic value comparator map = 31 | let typeRep = tagOf dynamic in 32 | let monomap = 33 | try (List.filter 34 | (fun (k,_) -> not (comparator k dynamic)) 35 | (fst (TypeMap.find typeRep map))) 36 | with Not_found -> [] 37 | in 38 | TypeMap.add 39 | typeRep 40 | (((dynamic,value)::monomap), comparator) 41 | map 42 | 43 | let mem dynamic map = 44 | try let monomap, comparator = TypeMap.find (tagOf dynamic) map in 45 | (List.exists 46 | (fun (k,_) -> (comparator dynamic k)) 47 | monomap) 48 | with Not_found -> false 49 | 50 | let find dynamic map = 51 | try 52 | let monomap, comparator = TypeMap.find (tagOf dynamic) map in 53 | Some (snd (List.find 54 | (fun (k,_) -> comparator dynamic k) 55 | monomap)) 56 | with Not_found -> None 57 | 58 | let iter : (dynamic -> 'a -> unit) -> 'a t -> unit 59 | = fun f -> 60 | TypeMap.iter 61 | (fun _ (monomap,_) -> List.iter (fun (k, v) -> f k v) monomap) 62 | end 63 | -------------------------------------------------------------------------------- /lib/deriving_dynmap.mli: -------------------------------------------------------------------------------- 1 | (* Finite map : dynamic |-> t *) 2 | 3 | open Deriving_Typeable 4 | open Deriving_Eq 5 | 6 | module Comp (T : Typeable) (E : Eq with type a = T.a) : 7 | sig 8 | type a = T.a 9 | val eq : dynamic -> dynamic -> bool 10 | end 11 | 12 | module DynMap : 13 | sig 14 | type comparator = dynamic -> dynamic -> bool 15 | type 'a t 16 | val empty : 'a t 17 | val add : dynamic -> 'a -> comparator -> 'a t -> 'a t 18 | val mem : dynamic -> 'a t -> bool 19 | val find : dynamic -> 'a t -> 'a option 20 | val iter : (dynamic -> 'a -> unit) -> 'a t -> unit 21 | end 22 | -------------------------------------------------------------------------------- /lib/deriving_interned.ml: -------------------------------------------------------------------------------- 1 | (* Copyright Jeremy Yallop 2007. 2 | This file is free software, distributed under the MIT license. 3 | See the file COPYING for details. 4 | *) 5 | 6 | (* Interned strings *) 7 | module BytesMap = Map.Make(Bytes) 8 | 9 | (* global state *) 10 | let map = ref BytesMap.empty 11 | let counter = ref 0 12 | 13 | type t = int * string 14 | deriving (Show) 15 | 16 | let intern s = 17 | let bs = Bytes.of_string s in 18 | try BytesMap.find bs !map 19 | with Not_found -> 20 | let fresh = (!counter, s) in begin 21 | map := BytesMap.add bs fresh !map; 22 | incr counter; 23 | fresh 24 | end 25 | 26 | let to_string (_,s) = s 27 | let name = snd 28 | let compare (l,_) (r,_) = compare l r 29 | let eq (l,_) (r,_) = l = r 30 | -------------------------------------------------------------------------------- /lib/deriving_interned.mli: -------------------------------------------------------------------------------- 1 | (* Interned strings *) 2 | 3 | type t 4 | val compare : t -> t -> int 5 | val eq : t -> t -> bool 6 | val intern : string -> t 7 | val to_string : t -> string 8 | val name : t -> string 9 | -------------------------------------------------------------------------------- /lib/deriving_monad.ml: -------------------------------------------------------------------------------- 1 | (* Copyright Jeremy Yallop 2007. 2 | This file is free software, distributed under the MIT license. 3 | See the file COPYING for details. 4 | *) 5 | 6 | module type Monad = 7 | sig 8 | type +'a m 9 | val return : 'a -> 'a m 10 | val fail : string -> 'a m 11 | val (>>=) : 'a m -> ('a -> 'b m) -> 'b m 12 | val (>>) : 'a m -> 'b m -> 'b m 13 | end 14 | 15 | module type MonadPlus = 16 | sig 17 | include Monad 18 | val mzero : 'a m 19 | val mplus : 'a m -> 'a m -> 'a m 20 | end 21 | 22 | module MonadDefault 23 | (M : 24 | sig 25 | type +'a m 26 | val return : 'a -> 'a m 27 | val fail : string -> 'a m 28 | val (>>=) : 'a m -> ('a -> 'b m) -> 'b m 29 | end) : Monad with type 'a m = 'a M.m = 30 | struct 31 | include M 32 | let (>>) x y = x >>= (fun _ -> y) 33 | end 34 | 35 | module Monad_option : MonadPlus 36 | with type 'a m = 'a option = 37 | struct 38 | include MonadDefault( 39 | struct 40 | type 'a m = 'a option 41 | let fail _ = None 42 | let return x = Some x 43 | let (>>=) x f = 44 | match x with 45 | | None -> None 46 | | Some x -> f x 47 | 48 | end) 49 | let mzero = None 50 | let mplus l r = match l, r with 51 | | None, r -> r 52 | | l, _ -> l 53 | end 54 | 55 | module Monad_list : MonadPlus 56 | with type 'a m = 'a list = 57 | struct 58 | include MonadDefault( 59 | struct 60 | type 'a m = 'a list 61 | let return x = [x] 62 | let fail _ = [] 63 | let (>>=) m f = List.concat (List.map f m) 64 | end) 65 | let mzero = [] 66 | let mplus = (@) 67 | end 68 | 69 | module IO = 70 | (struct 71 | type 'a m = unit -> 'a 72 | let return a = fun () -> a 73 | let (>>=) m k = 74 | fun () -> 75 | let v = m () in 76 | k v () 77 | let (>>) x y = x >>= (fun _ -> y) 78 | let fail = failwith 79 | let putStr s = fun () -> print_string s 80 | let runIO f = f () 81 | let mkIO (f : unit -> 'b) = return (f ()) 82 | end) 83 | 84 | module type MonadUtilsSig = 85 | sig 86 | include Monad 87 | val liftM : ('a -> 'b) -> 'a m -> 'b m 88 | val liftM2 : ('a -> 'b -> 'c) -> 'a m -> 'b m -> 'c m 89 | val liftM3 : ('a -> 'b -> 'c -> 'd) -> 'a m -> 'b m -> 'c m -> 'd m 90 | val liftM4 : 91 | ('a -> 'b -> 'c -> 'd -> 'e) -> 'a m -> 'b m -> 'c m -> 'd m -> 'e m 92 | val liftM5 : 93 | ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 94 | 'a m -> 'b m -> 'c m -> 'd m -> 'e m -> 'f m 95 | val ap : ('a -> 'b) m -> 'a m -> 'b m 96 | val sequence : 'a m list -> 'a list m 97 | val sequence_ : 'a m list -> unit m 98 | val mapM : ('a -> 'b m) -> 'a list -> 'b list m 99 | val mapM_ : ('a -> 'b m) -> 'a list -> unit m 100 | val ( =<< ) : ('a -> 'b m) -> 'a m -> 'b m 101 | val join : 'a m m -> 'a m 102 | val filterM : ('a -> bool m) -> 'a list -> 'a list m 103 | val mapAndUnzipM : 104 | ('a -> ('b * 'c) m) -> 'a list -> ('b list * 'c list) m 105 | val zipWithM : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> 'c list m 106 | val zipWithM_ : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> unit m 107 | val foldM : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m 108 | val foldM_ : ('a -> 'b -> 'a m) -> 'a -> 'b list -> unit m 109 | val replicateM : int -> 'a m -> 'a list m 110 | val replicateM_ : int -> 'a m -> unit m 111 | val quand : bool -> unit m -> unit m 112 | val unless : bool -> unit m -> unit m 113 | end 114 | 115 | (* Control.Monad *) 116 | module MonadUtils (M : Monad) = 117 | struct 118 | include M 119 | let liftM : ('a1 -> 'r) -> 'a1 m -> 'r m 120 | = fun f m1 -> m1 >>= (fun x1 -> return (f x1)) 121 | let liftM2 : ('a1 -> 'a2 -> 'r) -> 'a1 m -> 'a2 m -> 'r m 122 | = fun f m1 m2 123 | -> m1 >>= (fun x1 124 | -> m2 >>= (fun x2 125 | -> return (f x1 x2))) 126 | let liftM3 : ('a1 -> 'a2 -> 'a3 -> 'r) -> 'a1 m -> 'a2 m -> 'a3 m -> 'r m 127 | = fun f m1 m2 m3 128 | -> m1 >>= (fun x1 129 | -> m2 >>= (fun x2 130 | -> m3 >>= (fun x3 131 | -> return (f x1 x2 x3)))) 132 | let liftM4 : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'r) -> 'a1 m -> 'a2 m -> 'a3 m -> 'a4 m -> 'r m 133 | = fun f m1 m2 m3 m4 134 | -> m1 >>= (fun x1 135 | -> m2 >>= (fun x2 136 | -> m3 >>= (fun x3 137 | -> m4 >>= (fun x4 138 | -> return (f x1 x2 x3 x4))))) 139 | let liftM5 : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'r) -> 'a1 m -> 'a2 m -> 'a3 m -> 'a4 m -> 'a5 m -> 'r m 140 | = fun f m1 m2 m3 m4 m5 141 | -> m1 >>= (fun x1 142 | -> m2 >>= (fun x2 143 | -> m3 >>= (fun x3 144 | -> m4 >>= (fun x4 145 | -> m5 >>= (fun x5 146 | -> return (f x1 x2 x3 x4 x5)))))) 147 | let ap : ('a -> 'b) m -> 'a m -> 'b m 148 | = fun f -> liftM2 (fun x -> x) f 149 | 150 | let sequence : ('a m) list -> ('a list) m 151 | = let mcons p q = p >>= (fun x -> q >>= (fun y -> return (x::y))) 152 | in 153 | fun l -> List.fold_right mcons l (return []) 154 | 155 | let sequence_ : ('a m) list -> unit m 156 | = fun l -> List.fold_right (>>) l (return ()) 157 | 158 | let mapM : ('a -> 'b m) -> 'a list -> ('b list) m 159 | = fun f xs -> sequence (List.map f xs) 160 | 161 | let mapM_ : ('a -> 'b m) -> 'a list -> unit m 162 | = fun f xs -> sequence_ (List.map f xs) 163 | 164 | let (=<<) : ('a -> 'b m) -> 'a m -> 'b m 165 | = fun f x -> x >>= f 166 | 167 | let join : ('a m) m -> 'a m 168 | = fun x -> x >>= (fun x -> x) 169 | 170 | let rec filterM : ('a -> bool m) -> 'a list -> ('a list) m 171 | = fun p -> function 172 | | [] -> return [] 173 | | x::xs -> p x >>= (fun flg -> 174 | filterM p xs >>= (fun ys -> 175 | return (if flg then (x::ys) else ys))) 176 | 177 | let mapAndUnzipM : ('a -> ('b *'c) m) -> 'a list -> ('b list * 'c list) m 178 | = fun f xs -> sequence (List.map f xs) >>= fun x -> return (List.split x) 179 | 180 | let zipWithM : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> ('c list) m 181 | = fun f xs ys -> sequence (List.map2 f xs ys) 182 | 183 | let zipWithM_ : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> unit m 184 | = fun f xs ys -> sequence_ (List.map2 f xs ys) 185 | 186 | let rec foldM : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m 187 | = fun f a -> function 188 | | [] -> return a 189 | | x::xs -> f a x >>= (fun fax -> foldM f fax xs) 190 | 191 | let foldM_ : ('a -> 'b -> 'a m) -> 'a -> 'b list -> unit m 192 | = fun f a xs -> foldM f a xs >> return () 193 | 194 | let ((replicateM : int -> 'a m -> ('a list) m), 195 | (replicateM_ : int -> 'a m -> unit m)) 196 | = let replicate n i = 197 | let rec aux accum = function 198 | | 0 -> accum 199 | | n -> aux (i::accum) (n-1) 200 | in aux [] n 201 | in 202 | ((fun n x -> sequence (replicate n x)), 203 | (fun n x -> sequence_ (replicate n x))) 204 | 205 | let quand (* when *) : bool -> unit m -> unit m 206 | = fun p s -> if p then s else return () 207 | 208 | let unless : bool -> unit m -> unit m 209 | = fun p s -> if p then return () else s 210 | end 211 | 212 | module type MonadPlusUtilsSig = 213 | sig 214 | include MonadUtilsSig 215 | val mzero : 'a m 216 | val mplus : 'a m -> 'a m -> 'a m 217 | val guard : bool -> unit m 218 | val msum : 'a m list -> 'a m 219 | end 220 | 221 | module MonadPlusUtils (M : MonadPlus) = 222 | struct 223 | include MonadUtils(M) 224 | let mzero = M.mzero 225 | let mplus = M.mplus 226 | let guard : bool -> unit M.m 227 | = function 228 | | true -> M.return () 229 | | false -> M.mzero 230 | 231 | let msum : ('a M.m) list -> 'a M.m 232 | = fun l -> List.fold_right M.mplus l M.mzero 233 | end 234 | 235 | module MonadPlusUtils_option = MonadPlusUtils(Monad_option) 236 | module MonadPlusUtils_list = MonadPlusUtils(Monad_list) 237 | module Monad_IO = MonadUtils(MonadDefault (IO)) 238 | 239 | module type Monad_state_type = 240 | sig 241 | include MonadUtilsSig 242 | type state 243 | val get : state m 244 | val put : state -> unit m 245 | val runState : 'a m -> state -> 'a * state 246 | end 247 | 248 | module Monad_state_impl (A : sig type state end) = 249 | struct 250 | type state = A.state 251 | type 'a m = State of (A.state -> ('a * A.state)) 252 | let get = State (fun s -> s,s) 253 | let put s = State (fun _ -> (), s) 254 | let runState (State s) = s 255 | let return a = State (fun state -> (a, state)) 256 | let fail s = failwith ("state monad error " ^ s) 257 | let (>>=) (State x) f = State (fun s -> (let v, s' = x s in 258 | runState (f v) s')) 259 | let (>>) s f = s >>= fun _ -> f 260 | end 261 | 262 | module Monad_state(S : sig type state end) : 263 | Monad_state_type with type state = S.state = 264 | struct 265 | module M = Monad_state_impl(S) 266 | include MonadUtils(M) 267 | type state = M.state 268 | let get = M.get 269 | let put = M.put 270 | let runState = M.runState 271 | end 272 | -------------------------------------------------------------------------------- /lib/deriving_monad.mli: -------------------------------------------------------------------------------- 1 | module type Monad = 2 | sig 3 | type +'a m 4 | val return : 'a -> 'a m 5 | val fail : string -> 'a m 6 | val ( >>= ) : 'a m -> ('a -> 'b m) -> 'b m 7 | val ( >> ) : 'a m -> 'b m -> 'b m 8 | end 9 | 10 | module type MonadPlus = 11 | sig 12 | include Monad 13 | val mzero : 'a m 14 | val mplus : 'a m -> 'a m -> 'a m 15 | end 16 | 17 | module MonadDefault 18 | (M : sig 19 | type +'a m 20 | val return : 'a -> 'a m 21 | val fail : string -> 'a m 22 | val ( >>= ) : 'a m -> ('a -> 'b m) -> 'b m 23 | end) : Monad with type +'a m = 'a M.m 24 | 25 | module Monad_option : MonadPlus with type 'a m = 'a option 26 | module Monad_list : MonadPlus with type 'a m = 'a list 27 | module IO : 28 | sig 29 | include Monad 30 | val putStr : string -> unit m 31 | val runIO : 'a m -> 'a 32 | val mkIO : (unit -> 'b) -> 'b m 33 | end 34 | module type MonadUtilsSig = 35 | sig 36 | include Monad 37 | val liftM : ('a -> 'b) -> 'a m -> 'b m 38 | val liftM2 : ('a -> 'b -> 'c) -> 'a m -> 'b m -> 'c m 39 | val liftM3 : ('a -> 'b -> 'c -> 'd) -> 'a m -> 'b m -> 'c m -> 'd m 40 | val liftM4 : 41 | ('a -> 'b -> 'c -> 'd -> 'e) -> 'a m -> 'b m -> 'c m -> 'd m -> 'e m 42 | val liftM5 : 43 | ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 44 | 'a m -> 'b m -> 'c m -> 'd m -> 'e m -> 'f m 45 | val ap : ('a -> 'b) m -> 'a m -> 'b m 46 | val sequence : 'a m list -> 'a list m 47 | val sequence_ : 'a m list -> unit m 48 | val mapM : ('a -> 'b m) -> 'a list -> 'b list m 49 | val mapM_ : ('a -> 'b m) -> 'a list -> unit m 50 | val ( =<< ) : ('a -> 'b m) -> 'a m -> 'b m 51 | val join : 'a m m -> 'a m 52 | val filterM : ('a -> bool m) -> 'a list -> 'a list m 53 | val mapAndUnzipM : 54 | ('a -> ('b * 'c) m) -> 'a list -> ('b list * 'c list) m 55 | val zipWithM : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> 'c list m 56 | val zipWithM_ : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> unit m 57 | val foldM : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m 58 | val foldM_ : ('a -> 'b -> 'a m) -> 'a -> 'b list -> unit m 59 | val replicateM : int -> 'a m -> 'a list m 60 | val replicateM_ : int -> 'a m -> unit m 61 | val quand : bool -> unit m -> unit m 62 | val unless : bool -> unit m -> unit m 63 | end 64 | 65 | module MonadUtils (M : Monad) : MonadUtilsSig with type 'a m = 'a M.m 66 | module type MonadPlusUtilsSig = 67 | sig 68 | include MonadUtilsSig 69 | val mzero : 'a m 70 | val mplus : 'a m -> 'a m -> 'a m 71 | val guard : bool -> unit m 72 | val msum : 'a m list -> 'a m 73 | end 74 | 75 | module MonadPlusUtils (M : MonadPlus) : MonadPlusUtilsSig with type 'a m = 'a M.m 76 | 77 | module MonadPlusUtils_option : MonadPlusUtilsSig with type 'a m = 'a Monad_option.m 78 | module MonadPlusUtils_list : MonadPlusUtilsSig with type 'a m = 'a Monad_list.m 79 | module Monad_IO : MonadUtilsSig with type 'a m = 'a IO.m 80 | 81 | module type Monad_state_type = 82 | sig 83 | include MonadUtilsSig 84 | type state 85 | val get : state m 86 | val put : state -> unit m 87 | val runState : 'a m -> state -> 'a * state 88 | end 89 | 90 | module Monad_state (S : sig type state end) : 91 | Monad_state_type with type state = S.state 92 | -------------------------------------------------------------------------------- /lib/deriving_num.ml: -------------------------------------------------------------------------------- 1 | 2 | module Show_num = Deriving_Show.Defaults (struct 3 | type a = Num.num 4 | let format formatter item = Format.pp_print_string formatter (Num.string_of_num item) 5 | end) 6 | 7 | module Typeable_num = Deriving_Typeable.Primitive_typeable(struct type t = Num.num let magic = "Primitive.Num.num" end) 8 | 9 | module Eq_num : Deriving_Eq.Eq with type a = Num.num = 10 | struct 11 | type a = Num.num 12 | let eq = Num.eq_num 13 | end 14 | 15 | module Dump_num = Deriving_Dump.Defaults ( 16 | struct 17 | (* TODO: a less wasteful dumper for nums. A good start would be 18 | using half a byte per decimal-coded digit, instead of a whole 19 | byte. *) 20 | type a = Num.num 21 | let to_buffer buffer n = Deriving_Dump.Dump_string.to_buffer buffer (Num.string_of_num n) 22 | and from_stream stream = Num.num_of_string (Deriving_Dump.Dump_string.from_stream stream) 23 | end 24 | ) 25 | 26 | 27 | 28 | module Pickle_num = Deriving_Pickle.Pickle_from_dump(Dump_num)(Eq_num)(Typeable_num) 29 | 30 | 31 | -------------------------------------------------------------------------------- /lib/deriving_num.mli: -------------------------------------------------------------------------------- 1 | 2 | module Show_num : Deriving_Show.Show with type a = Num.num 3 | module Eq_num : Deriving_Eq.Eq with type a = Num.num 4 | module Typeable_num : Deriving_Typeable.Typeable with type a = Num.num 5 | module Dump_num : Deriving_Dump.Dump with type a = Num.num 6 | module Pickle_num : Deriving_Pickle.Pickle with type a = Num.num 7 | 8 | -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | (* OASIS_START *) 2 | (* OASIS_STOP *) 3 | 4 | let _ = 5 | 6 | (* FIX START *) 7 | (* fix needed by ocaml(build) 3.12.1(,4.00.1?) in order to pick the right ocamlfind *) 8 | 9 | (* Fixed in later version with the following commit *) 10 | (* ocamlbuild should look for ocamlfind on the path not in the root directory *) 11 | (* https://github.com/ocaml/ocaml/commit/9d51dccfaebb2c3303ae0bb1d4f28fe6f8d10915 *) 12 | 13 | let _ = Ocamlbuild_pack.Ocamlbuild_where.bindir := "/" in 14 | (* FIX STOP *) 15 | 16 | Ocamlbuild_plugin.dispatch 17 | (fun hook -> 18 | dispatch_default hook; 19 | match hook with 20 | | After_rules -> 21 | (* Internal syntax extension *) 22 | List.iter 23 | (fun dir -> 24 | let tag = "use_pa_deriving_" ^ dir and file = "syntax/" ^ dir ^ "/pa_deriving_" ^ dir ^ ".cma" in 25 | flag ["ocaml"; "compile"; tag] & S[A"-ppopt"; A file]; 26 | flag ["ocaml"; "ocamldep"; tag] & S[A"-ppopt"; A file]; 27 | flag ["ocaml"; "doc"; tag] & S[A"-ppopt"; A file]; 28 | dep ["ocaml"; "ocamldep"; tag] [file]) 29 | ["common"; "std"; "tc"; "classes"]; 30 | 31 | (* Use an introduction page with categories *) 32 | tag_file "deriving-api.docdir/index.html" ["apiref"]; 33 | dep ["apiref"] ["doc/apiref-intro"]; 34 | flag ["apiref"] & S[A "-intro"; P "doc/apiref-intro"; A"-colorize-code"]; 35 | 36 | | _ -> ()) 37 | 38 | 39 | 40 | (* Compile the wiki version of the Ocamldoc. 41 | 42 | Thanks to Till Varoquaux on usenet: 43 | http://www.digipedia.pl/usenet/thread/14273/231/ 44 | 45 | *) 46 | 47 | let ocamldoc_wiki tags deps docout docdir = 48 | let tags = tags -- "extension:html" in 49 | Ocamlbuild_pack.Ocaml_tools.ocamldoc_l_dir tags deps docout docdir 50 | 51 | let () = 52 | try 53 | let wikidoc_dir = 54 | let base = Ocamlbuild_pack.My_unix.run_and_read "ocamlfind query wikidoc" in 55 | String.sub base 0 (String.length base - 1) 56 | in 57 | 58 | Ocamlbuild_pack.Rule.rule 59 | "ocamldoc: document ocaml project odocl & *odoc -> wikidocdir" 60 | ~insert:`top 61 | ~prod:"%.wikidocdir/index.wiki" 62 | ~stamp:"%.wikidocdir/wiki.stamp" 63 | ~dep:"%.odocl" 64 | (Ocamlbuild_pack.Ocaml_tools.document_ocaml_project 65 | ~ocamldoc:ocamldoc_wiki 66 | "%.odocl" "%.wikidocdir/index.wiki" "%.wikidocdir"); 67 | 68 | tag_file "deriving-api.wikidocdir/index.wiki" ["apiref";"wikidoc"]; 69 | flag ["wikidoc"] & S[A"-i";A wikidoc_dir;A"-g";A"odoc_wiki.cma"] 70 | 71 | with Failure e -> () (* Silently fail if the package wikidoc isn't available *) 72 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "deriving" 3 | version: "0.8.2" 4 | synopsis: "Extension to OCaml for deriving functions from type declarations" 5 | maintainer: "dev@ocsigen.org" 6 | authors: "Jeremy Yallop " 7 | homepage: "http://github.com/ocsigen/deriving/" 8 | bug-reports: "https://github.com/ocsigen/deriving/issues/" 9 | license: "MIT" 10 | dev-repo: "git+https://github.com/ocsigen/deriving.git" 11 | build: [ 12 | [make "setup.exe"] 13 | ["./setup.exe" "-configure" "--prefix" prefix "--%{type_conv:enable}%-tc"] 14 | [make] 15 | ] 16 | install: [make "install"] 17 | depends: [ 18 | "ocaml" {>= "4.03.0"} 19 | "ocamlfind" 20 | "camlp4" 21 | "num" 22 | "oasis" {build & >= "0.4.4"} 23 | ] 24 | depopts: "type_conv" 25 | conflicts: [ 26 | "type_conv" {< "108.07.00"} 27 | ] 28 | -------------------------------------------------------------------------------- /setup.ml: -------------------------------------------------------------------------------- 1 | 2 | (* OASIS_START *) 3 | (* DO NOT EDIT (digest: 1bc19e72587da58c1e1f99f847b509aa) *) 4 | (******************************************************************************) 5 | (* OASIS: architecture for building OCaml libraries and applications *) 6 | (* *) 7 | (* Copyright (C) 2011-2016, Sylvain Le Gall *) 8 | (* Copyright (C) 2008-2011, OCamlCore SARL *) 9 | (* *) 10 | (* This library is free software; you can redistribute it and/or modify it *) 11 | (* under the terms of the GNU Lesser General Public License as published by *) 12 | (* the Free Software Foundation; either version 2.1 of the License, or (at *) 13 | (* your option) any later version, with the OCaml static compilation *) 14 | (* exception. *) 15 | (* *) 16 | (* This library is distributed in the hope that it will be useful, but *) 17 | (* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *) 18 | (* or FITNESS FOR A PARTICULAR PURPOSE. See the file COPYING for more *) 19 | (* details. *) 20 | (* *) 21 | (* You should have received a copy of the GNU Lesser General Public License *) 22 | (* along with this library; if not, write to the Free Software Foundation, *) 23 | (* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) 24 | (******************************************************************************) 25 | 26 | open OASISDynRun 27 | 28 | let setup_t = BaseCompat.Compat_0_4.adapt_setup_t setup_t 29 | open BaseCompat.Compat_0_4 30 | (* OASIS_STOP *) 31 | 32 | let () = setup ();; 33 | -------------------------------------------------------------------------------- /syntax/classes/bounded_class.ml: -------------------------------------------------------------------------------- 1 | (* Copyright Jeremy Yallop 2007. 2 | This file is free software, distributed under the MIT license. 3 | See the file COPYING for details. 4 | *) 5 | 6 | open Pa_deriving_common 7 | open Utils 8 | 9 | module Description : Defs.ClassDescription = struct 10 | let classname = "Bounded" 11 | let runtimename = "Deriving_Bounded" 12 | let default_module = None 13 | let alpha = None 14 | let allow_private = false 15 | let predefs = [ 16 | ["unit"], ["Deriving_Bounded";"unit"]; 17 | ["bool"], ["Deriving_Bounded";"bool"]; 18 | ["char"], ["Deriving_Bounded";"char"]; 19 | ["int"], ["Deriving_Bounded";"int"]; 20 | ["int32"], ["Deriving_Bounded";"int32"]; 21 | ["Int32";"t"], ["Deriving_Bounded";"int32"]; 22 | ["int64"], ["Deriving_Bounded";"int64"]; 23 | ["Int64";"t"], ["Deriving_Bounded";"int64"]; 24 | ["nativeint"], ["Deriving_Bounded";"nativeint"]; 25 | ["open_flag"], ["Deriving_Bounded";"open_flag"]; 26 | ["fpclass"], ["Deriving_Bounded";"fpclass"]; 27 | ] 28 | let depends = [] 29 | end 30 | 31 | module Builder(Generator : Defs.Generator) = struct 32 | 33 | open Generator.Loc 34 | open Camlp4.PreCast 35 | open Description 36 | 37 | module Helpers = Generator.AstHelpers 38 | 39 | let wrap min max = 40 | [ <:str_item< let min_bound = $min$ >>; <:str_item< let max_bound = $max$ >> ] 41 | 42 | let generator = (object (self) 43 | 44 | inherit Generator.generator 45 | 46 | method proxy () = 47 | None, [ <:ident< min_bound >>; 48 | <:ident< max_bound >>; ] 49 | 50 | method tuple ctxt ts = 51 | let expr t = 52 | let e = self#expr ctxt t in 53 | <:expr< let module M = $e$ in M.min_bound >>, 54 | <:expr< let module M = $e$ in M.max_bound >> in 55 | let minBounds, maxBounds = List.split (List.map expr ts) in 56 | wrap (Helpers.tuple_expr minBounds) (Helpers.tuple_expr maxBounds) 57 | 58 | method sum ?eq ctxt tname params constraints summands = 59 | let extract_name = function 60 | | (name,[]) -> name 61 | | (name,_) -> 62 | raise (Base.Underivable 63 | (classname ^" cannot be derived for the type " 64 | ^ tname ^ " because the constructor " 65 | ^ name ^ " is not nullary")) in 66 | let names = List.map extract_name summands in 67 | wrap <:expr< $uid:List.hd names$ >> <:expr< $uid:List.last names$ >> 68 | 69 | method variant ctxt tname params constraints (_, tags) = 70 | let extract_name = function 71 | | Type.Tag (name, []) -> name 72 | | Type.Tag (name, _) -> 73 | raise (Base.Underivable 74 | (classname^" cannot be derived because " 75 | ^ "the tag " ^ name^" is not nullary")) 76 | | _ -> 77 | raise (Base.Underivable 78 | (classname^" cannot be derived for this " 79 | ^ "polymorphic variant type")) in 80 | let names = List.map extract_name tags in 81 | wrap <:expr< `$List.hd names$ >> <:expr< `$List.last names$ >> 82 | 83 | (* should perhaps implement this one *) 84 | method record ?eq _ tname params constraints = 85 | raise (Base.Underivable 86 | (classname^" cannot be derived for record types (i.e. " 87 | ^ tname ^ ")")) 88 | 89 | end :> Generator.generator) 90 | 91 | let generate = Generator.generate generator 92 | let generate_sigs = Generator.generate_sigs generator 93 | 94 | end 95 | 96 | include Base.RegisterClass(Description)(Builder) 97 | -------------------------------------------------------------------------------- /syntax/classes/default_class.ml: -------------------------------------------------------------------------------- 1 | open Pa_deriving_common 2 | open Utils 3 | 4 | module Description : Defs.ClassDescription = struct 5 | let classname = "Default" 6 | let default_module = None 7 | let runtimename = "Deriving_Default" 8 | let alpha = None 9 | let allow_private = true 10 | let predefs = [ 11 | ["int" ], ["Deriving_Default";"int"]; 12 | ["bool" ], ["Deriving_Default";"bool"]; 13 | ["unit" ], ["Deriving_Default";"unit"]; 14 | ["char" ], ["Deriving_Default";"char"]; 15 | ["int32" ], ["Deriving_Default";"int32"]; 16 | ["Int32";"t"], ["Deriving_Default";"int32"]; 17 | ["int64" ], ["Deriving_Default";"int64"]; 18 | ["Int64";"t"], ["Deriving_Default";"int64"]; 19 | ["nativeint"], ["Deriving_Default";"nativeint"]; 20 | ["float" ], ["Deriving_Default";"float"]; 21 | ["string" ], ["Deriving_Default";"string"]; 22 | ["list" ], ["Deriving_Default";"list"]; 23 | ["ref" ], ["Deriving_Default";"ref"]; 24 | ["option" ], ["Deriving_Default";"option"]; 25 | ["array" ], ["Deriving_Default";"array"]; 26 | ] 27 | let depends = [] 28 | end 29 | 30 | module Builder(Generator : Defs.Generator) = struct 31 | 32 | open Generator.Loc 33 | open Camlp4.PreCast 34 | open Description 35 | 36 | module Helpers = Generator.AstHelpers 37 | 38 | let wrap expr = [ <:str_item< let default () = $expr$ >> ] 39 | 40 | 41 | let generator = (object (self) 42 | 43 | inherit Generator.generator 44 | 45 | method proxy unit = 46 | None, [ <:ident< default >> ] 47 | 48 | method tuple ctxt args = 49 | let l : Ast.expr list = List.map (fun ty -> <:expr<$self#call_expr ctxt ty "default"$ () >>) args 50 | in 51 | wrap (Helpers.tuple_expr l) 52 | 53 | method case ctxt (name, args) = 54 | match args with 55 | | [] -> <:expr< $uid:name$ >> 56 | | _ -> 57 | let tuple = List.map (fun ty -> <:expr<$self#call_expr ctxt ty "default"$ () >>) args in 58 | <:expr< $uid:name$ $Helpers.tuple_expr tuple$ >> 59 | 60 | method sum ?eq ctxt tname params constraints summands = 61 | wrap (self#case ctxt (List.hd summands)) 62 | 63 | method record ?eq ctxt tname params constraints fields = 64 | let contents = List.map (fun (name, (_,ty), _) -> 65 | name, 66 | <:expr< $ self # call_expr ctxt ty "default"$ ()>> ) fields in 67 | wrap (Helpers.record_expr contents) 68 | 69 | method polycase ctxt = function 70 | | Type.Tag (name, []) -> 71 | <:expr< `$name$ >> 72 | | Type.Tag (name, [ty]) -> 73 | let c = self#call_expr ctxt ty "default" in 74 | <:expr<`$name$ ($c$ ()) >> 75 | | Type.Tag (name, tys) -> 76 | let ty = `Tuple tys in 77 | let c = self#call_expr ctxt ty "default" in 78 | <:expr<`$name$ ($c$ ()) >> 79 | | Type.Extends t -> <:expr< assert false >> 80 | 81 | method variant ctxt tname params constraints (_,tags) = 82 | wrap (self#polycase ctxt (List.hd tags)) 83 | 84 | end :> Generator.generator) 85 | 86 | let classname = Description.classname 87 | let runtimename = Description.runtimename 88 | let generate = Generator.generate generator 89 | let generate_sigs = Generator.generate_sigs generator 90 | let generate_expr = Generator.generate_expr generator 91 | 92 | end 93 | 94 | include Base.RegisterFullClass(Description)(Builder) 95 | -------------------------------------------------------------------------------- /syntax/classes/dump_class.ml: -------------------------------------------------------------------------------- 1 | (* Copyright Jeremy Yallop 2007. 2 | This file is free software, distributed under the MIT license. 3 | See the file COPYING for details. 4 | *) 5 | 6 | open Pa_deriving_common 7 | open Utils 8 | 9 | module Description : Defs.ClassDescription = struct 10 | let classname = "Dump" 11 | let runtimename = "Deriving_Dump" 12 | let default_module = Some "Defaults" 13 | let alpha = Some "Dump_alpha" 14 | let allow_private = false 15 | let predefs = [ 16 | ["unit"], ["Deriving_Dump";"unit"]; 17 | ["bool"], ["Deriving_Dump";"bool"]; 18 | ["char"], ["Deriving_Dump";"char"]; 19 | ["int"], ["Deriving_Dump";"int"]; 20 | ["int32"], ["Deriving_Dump";"int32"]; 21 | ["Int32";"t"], ["Deriving_Dump";"int32"]; 22 | ["int64"], ["Deriving_Dump";"int64"]; 23 | ["Int64";"t"], ["Deriving_Dump";"int64"]; 24 | ["nativeint"], ["Deriving_Dump";"nativeint"]; 25 | ["float"], ["Deriving_Dump";"float"]; 26 | ["num"], ["Deriving_Dump";"num"]; 27 | ["string"], ["Deriving_Dump";"string"]; 28 | ["list"], ["Deriving_Dump";"list"]; 29 | ["option"], ["Deriving_Dump";"option"]; 30 | ] 31 | let depends = [] 32 | end 33 | 34 | module Builder(Generator : Defs.Generator) = struct 35 | 36 | open Generator.Loc 37 | open Camlp4.PreCast 38 | open Description 39 | 40 | module Helpers = Generator.AstHelpers 41 | 42 | let wrap ?(buffer="buffer") ?(stream="stream") to_buffer from_stream = 43 | [ <:str_item< let to_buffer $lid:buffer$ = function $list:to_buffer$ >> ; 44 | <:str_item< let from_stream $lid:stream$ = $from_stream$ >> ] 45 | 46 | let generator = (object (self) 47 | 48 | inherit Generator.generator 49 | 50 | method proxy () = 51 | None, [ <:ident< to_buffer >>; 52 | <:ident< to_string >>; 53 | <:ident< to_channel >>; 54 | <:ident< from_stream >>; 55 | <:ident< from_string >>; 56 | <:ident< from_channel >>; ] 57 | 58 | method dump_int ctxt n = 59 | <:expr< $self#call_expr ctxt (`Constr (["int"],[])) "to_buffer"$ 60 | buffer $`int:n$ >> 61 | 62 | method read_int ctxt = 63 | <:expr< $self#call_expr ctxt (`Constr (["int"],[])) "from_stream"$ stream >> 64 | 65 | 66 | method nargs ctxt tvars args = 67 | let to_buffer id ty = 68 | <:expr< $self#call_expr ctxt ty "to_buffer"$ buffer $lid:id$ >> in 69 | let from_stream id ty e = 70 | <:expr< let $lid:id$ = $self#call_expr ctxt ty "from_stream"$ stream in 71 | $e$ >> in 72 | Helpers.seq_list (List.map2 to_buffer tvars args), 73 | (fun expr -> List.fold_right2 from_stream tvars args expr) 74 | 75 | method tuple ctxt tys = 76 | let tvars, patt, expr = Helpers.tuple (List.length tys) in 77 | let dumper, undump = self#nargs ctxt tvars tys in 78 | wrap [ <:match_case< $patt$ -> $dumper$ >> ] (undump expr) 79 | 80 | method case ctxt (ctor,args) n = 81 | match args with 82 | | [] -> 83 | <:match_case< $uid:ctor$ -> $self#dump_int ctxt n$ >>, 84 | <:match_case< $`int:n$ -> $uid:ctor$ >> 85 | | _ -> 86 | let tvars, patt, expr = Helpers.tuple (List.length args) in 87 | let expr = <:expr< $uid:ctor$ $expr$ >> in 88 | let dumper, undumper = self#nargs ctxt tvars args in 89 | <:match_case< $uid:ctor$ $patt$ -> $self#dump_int ctxt n$; $dumper$ >>, 90 | <:match_case< $`int:n$ -> $undumper expr$ >> 91 | 92 | method sum ?eq ctxt tname params constraints summands = 93 | let msg = "Dump: unexpected tag %d at character %d when deserialising " ^ tname in 94 | let dumpers, undumpers = List.split (List.mapn (self#case ctxt) summands) in 95 | let undumpers = 96 | <:expr< match $self#read_int ctxt$ with 97 | $list:undumpers$ 98 | | n -> raise ($uid:runtimename$.$uid:classname^ "_error"$ 99 | (Printf.sprintf $str:msg$ n (Stream.count stream))) >> 100 | in 101 | wrap dumpers undumpers 102 | 103 | 104 | method field ctxt (name, ty, mut) = 105 | if mut = `Mutable then 106 | raise (Base.Underivable 107 | (classname ^ " cannot be derived for record types " 108 | ^ " with mutable fields (" ^ name ^ ")")); 109 | <:expr< $self#call_poly_expr ctxt ty "to_buffer"$ buffer $lid:name$ >>, 110 | <:binding< $lid:name$ = $self#call_poly_expr ctxt ty "from_stream"$ stream >> 111 | 112 | method record ?eq ctxt tname params constraints fields = 113 | let dumpers, undumpers = List.split (List.map (self#field ctxt) fields) in 114 | let bind b e = <:expr< let $b$ in $e$ >> in 115 | let undump = List.fold_right bind undumpers (Helpers.record_expression fields) in 116 | let dumper = 117 | <:match_case< 118 | $Helpers.record_pattern fields$ 119 | -> $Helpers.seq_list dumpers$ 120 | >> 121 | in 122 | wrap [dumper] undump 123 | 124 | 125 | method polycase ctxt tagspec n : Ast.match_case * Ast.match_case = 126 | match tagspec with 127 | | Type.Tag (name, []) -> 128 | <:match_case< `$name$ -> $self#dump_int ctxt n$ >>, 129 | <:match_case< $`int:n$ -> `$name$ >> 130 | | Type.Tag (name, es) -> 131 | let to_buffer = 132 | <:expr< $self#call_expr ctxt (`Tuple es) "to_buffer"$ buffer x >> in 133 | let from_stream = 134 | <:expr< $self#call_expr ctxt (`Tuple es) "from_stream"$ stream >> in 135 | <:match_case< `$name$ x -> $self#dump_int ctxt n$; $to_buffer$ >>, 136 | <:match_case< $`int:n$ -> `$name$ ($from_stream$) >> 137 | | Type.Extends t -> 138 | let patt, guard, cast = Generator.cast_pattern ctxt t in 139 | let to_buffer = 140 | <:expr< $self#call_expr ctxt t "to_buffer"$ buffer $cast$ >> in 141 | let from_stream = 142 | <:expr< $self#call_expr ctxt t "from_stream"$ stream >> in 143 | <:match_case< $patt$ when $guard$ -> $self#dump_int ctxt n$; $to_buffer$ >>, 144 | <:match_case< $`int:n$ -> ($from_stream$ :> a) >> 145 | 146 | method variant ctxt tname params constraints (_, tags) = 147 | let msg = "Dump: unexpected tag %d at character %d " 148 | ^ "when deserialising polymorphic variant" in 149 | let dumpers, undumpers = List.split (List.mapn (self#polycase ctxt) tags) in 150 | let undumpers = 151 | <:expr< match $self#read_int ctxt$ with 152 | $list:undumpers$ 153 | | n -> raise ($uid:runtimename$.$uid:classname^ "_error"$ 154 | (Printf.sprintf $str:msg$ n (Stream.count stream))) >> 155 | in 156 | wrap (dumpers @ [ <:match_case< _ -> assert false >>]) undumpers 157 | 158 | end :> Generator.generator) 159 | 160 | let generate = Generator.generate generator 161 | let generate_sigs = Generator.generate_sigs generator 162 | 163 | end 164 | 165 | include Base.RegisterClass(Description)(Builder) 166 | -------------------------------------------------------------------------------- /syntax/classes/enum_class.ml: -------------------------------------------------------------------------------- 1 | (* Copyright Jeremy Yallop 2007. 2 | This file is free software, distributed under the MIT license. 3 | See the file COPYING for details. 4 | *) 5 | 6 | open Pa_deriving_common 7 | open Utils 8 | 9 | module Description : Defs.ClassDescription = struct 10 | let classname = "Enum" 11 | let runtimename = "Deriving_Enum" 12 | let default_module = Some "Defaults" 13 | let alpha = None 14 | let allow_private = false 15 | let predefs = [ 16 | ["int"], ["Deriving_Enum";"int"]; 17 | ["bool"], ["Deriving_Enum";"bool"]; 18 | ["unit"], ["Deriving_Enum";"unit"]; 19 | ["char"], ["Deriving_Enum";"char"]; 20 | ] 21 | let depends = [] 22 | end 23 | 24 | module Builder(Generator : Defs.Generator) = struct 25 | 26 | open Generator.Loc 27 | open Camlp4.PreCast 28 | open Description 29 | 30 | module Helpers = Generator.AstHelpers 31 | 32 | let wrap numbering = [ <:str_item< let numbering = $numbering$ >> ] 33 | 34 | let generator = (object(self) 35 | 36 | inherit Generator.generator 37 | 38 | method proxy () = 39 | None, [ <:ident< succ >>; 40 | <:ident< pred >>; 41 | <:ident< to_enum >>; 42 | <:ident< from_enum >>; 43 | <:ident< enum_from >>; 44 | <:ident< enum_from_then >>; 45 | <:ident< enum_from_to >>; 46 | <:ident< enum_from_then_to >>; ] 47 | 48 | method sum ?eq ctxt tname params constraints summands = 49 | let numbering = 50 | List.fold_right2 51 | (fun n ctor rest -> 52 | match ctor with 53 | | (name, []) -> <:expr< ($uid:name$, $`int:n$) :: $rest$ >> 54 | | (name,_) -> 55 | raise (Base.Underivable 56 | (classname ^ " cannot be derived for the type " 57 | ^ tname ^" because the constructor " 58 | ^ name^" is not nullary"))) 59 | (List.range 0 (List.length summands)) 60 | summands 61 | <:expr< [] >> in 62 | wrap numbering 63 | 64 | method variant ctxt tname params constraints (_, tags) = 65 | let numbering = 66 | List.fold_right2 67 | (fun n tagspec rest -> 68 | match tagspec with 69 | | Type.Tag (name, []) -> <:expr< (`$name$, $`int:n$) :: $rest$ >> 70 | | Type.Tag (name, _) -> 71 | raise (Base.Underivable 72 | (classname ^" cannot be derived because the tag " 73 | ^ name^" is not nullary")) 74 | | _ -> raise (Base.Underivable 75 | (classname ^" cannot be derived for this " 76 | ^"polymorphic variant type"))) 77 | (List.range 0 (List.length tags)) 78 | tags 79 | <:expr< [] >> in 80 | wrap numbering 81 | 82 | method tuple ctxt tys = 83 | match tys with 84 | | [ty] -> wrap <:expr< $self#call_expr ctxt ty "numbering"$ >> 85 | | _ -> 86 | raise (Base.Underivable (classname ^" cannot be derived for tuple types")) 87 | 88 | method record ?eq _ tname params constraints = 89 | raise (Base.Underivable 90 | (classname ^" cannot be derived for record types (i.e. "^tname^")")) 91 | 92 | end :> Generator.generator) 93 | 94 | let generate = Generator.generate generator 95 | let generate_sigs = Generator.generate_sigs generator 96 | 97 | end 98 | 99 | include Base.RegisterClass(Description)(Builder) 100 | -------------------------------------------------------------------------------- /syntax/classes/eq_class.ml: -------------------------------------------------------------------------------- 1 | (* Copyright Jeremy Yallop 2007. 2 | This file is free software, distributed under the MIT license. 3 | See the file COPYING for details. 4 | *) 5 | 6 | open Pa_deriving_common 7 | open Utils 8 | 9 | module Description : Defs.ClassDescription = struct 10 | let classname = "Eq" 11 | let runtimename = "Deriving_Eq" 12 | let default_module = None 13 | let alpha = Some "Eq_alpha" 14 | let allow_private = true 15 | let predefs = [ 16 | ["unit"], ["Deriving_Eq";"unit"]; 17 | ["bool"], ["Deriving_Eq";"bool"]; 18 | ["char"], ["Deriving_Eq";"char"]; 19 | ["int"], ["Deriving_Eq";"int"]; 20 | ["int32"], ["Deriving_Eq";"int32"]; 21 | ["Int32";"t"], ["Deriving_Eq";"int32"]; 22 | ["int64"], ["Deriving_Eq";"int64"]; 23 | ["Int64";"t"], ["Deriving_Eq";"int64"]; 24 | ["nativeint"], ["Deriving_Eq";"nativeint"]; 25 | ["float"], ["Deriving_Eq";"float"]; 26 | ["num"], ["Deriving_num";"num"]; 27 | ["list"], ["Deriving_Eq";"list"]; 28 | ["option"], ["Deriving_Eq";"option"]; 29 | ["string"], ["Deriving_Eq";"string"]; 30 | ["ref"], ["Deriving_Eq";"ref"]; 31 | ["array"], ["Deriving_Eq";"array"]; 32 | ] 33 | let depends = [] 34 | end 35 | 36 | module Builder(Generator : Defs.Generator) = struct 37 | 38 | open Generator.Loc 39 | open Camlp4.PreCast 40 | open Description 41 | 42 | module Helpers = Generator.AstHelpers 43 | 44 | let and_guard x y = match x, y with 45 | | <:expr< >>, e | e, <:expr< >> -> e 46 | | x, y -> <:expr< $x$ && $y$ >> 47 | 48 | let lprefix = "l" and rprefix = "r" 49 | 50 | let wrap eq = 51 | [ <:str_item< let eq l r = match l, r with $list:eq$ >>] 52 | 53 | let generator = (object (self) 54 | 55 | method proxy () = 56 | None, [ <:ident< eq >>; ] 57 | 58 | inherit Generator.generator 59 | 60 | method tuple ctxt tys = 61 | let n = List.length tys in 62 | let lnames, lpatt, _ = Helpers.tuple ~param:lprefix n in 63 | let rnames, rpatt, _ = Helpers.tuple ~param:rprefix n in 64 | let test_and ty (lid, rid) e = 65 | <:expr< $self#call_expr ctxt ty "eq"$ $lid:lid$ $lid:rid$ && $e$ >> in 66 | let expr = 67 | List.fold_right2 test_and tys (List.zip lnames rnames) <:expr< true >> in 68 | wrap [ <:match_case< (($lpatt$),($rpatt$)) -> $expr$ >> ] 69 | 70 | 71 | method case ctxt (name,args) = 72 | match args with 73 | | [] -> <:match_case< ($uid:name$, $uid:name$) -> true >> 74 | | _ -> 75 | let nargs = List.length args in 76 | let _, lpatt, lexpr = Helpers.tuple ~param:lprefix nargs 77 | and _, rpatt, rexpr = Helpers.tuple ~param:rprefix nargs in 78 | let patt = <:patt< ($uid:name$ $lpatt$, $uid:name$ $rpatt$) >> in 79 | let eq = 80 | <:expr< $self#call_expr ctxt (`Tuple args) "eq"$ $lexpr$ $rexpr$ >> in 81 | <:match_case< $patt$ -> $eq$ >> 82 | 83 | method sum ?eq ctxt tname params constraints summands = 84 | let wildcard = 85 | match summands with 86 | | [_] -> [] 87 | | _ -> [ <:match_case< _ -> false >>] in 88 | wrap (List.map (self#case ctxt) summands @ wildcard) 89 | 90 | 91 | method field ctxt (name, ty, mut) = 92 | assert(mut <> `Mutable); 93 | <:expr< $self#call_poly_expr ctxt ty "eq"$ $lid:lprefix ^ name$ $lid:rprefix ^ name$ >> 94 | 95 | method record ?eq ctxt tname params constraints fields = 96 | if List.exists (function (_,_,`Mutable) -> true | _ -> false) fields then 97 | wrap [ <:match_case< (l,r) -> l==r >> ] 98 | else 99 | let lpatt = Helpers.record_pattern ~prefix:lprefix fields in 100 | let rpatt = Helpers.record_pattern ~prefix:rprefix fields in 101 | let test_and f e = <:expr< $self#field ctxt f$ && $e$ >> in 102 | let expr = List.fold_right test_and fields <:expr< true >> in 103 | wrap [ <:match_case< (($lpatt$), ($rpatt$)) -> $expr$ >> ] 104 | 105 | 106 | method polycase ctxt : Pa_deriving_common.Type.tagspec -> Ast.match_case = function 107 | | Type.Tag (name, []) -> <:match_case< `$name$, `$name$ -> true >> 108 | | Type.Tag (name, es) -> 109 | <:match_case< `$name$ l, `$name$ r -> $self#call_expr ctxt (`Tuple es) "eq"$ l r >> 110 | | Type.Extends t -> 111 | let lpatt, lguard, lcast = Generator.cast_pattern ctxt ~param:"l" t in 112 | let rpatt, rguard, rcast = Generator.cast_pattern ctxt ~param:"r" t in 113 | let patt = <:patt< ($lpatt$, $rpatt$) >> in 114 | let eq = <:expr< $self#call_expr ctxt t "eq"$ $lcast$ $rcast$ >> in 115 | <:match_case< $patt$ when $and_guard lguard rguard$ -> $eq$ >> 116 | 117 | method variant ctxt tname params constraints (spec, tags) = 118 | wrap (List.map (self#polycase ctxt) tags @ [ <:match_case< _ -> false >> ]) 119 | 120 | end :> Generator.generator) 121 | 122 | let classname = Description.classname 123 | let runtimename = Description.runtimename 124 | let generate = Generator.generate generator 125 | let generate_sigs = Generator.generate_sigs generator 126 | let generate_expr = Generator.generate_expr generator 127 | 128 | end 129 | 130 | include Base.RegisterFullClass(Description)(Builder) 131 | -------------------------------------------------------------------------------- /syntax/classes/functor_class.ml: -------------------------------------------------------------------------------- 1 | (* Copyright Jeremy Yallop 2007. 2 | This file is free software, distributed under the MIT license. 3 | See the file COPYING for details. 4 | *) 5 | 6 | open Pa_deriving_common 7 | open Utils 8 | 9 | module Description : Defs.ClassDescription = struct 10 | let classname = "Functor" 11 | let runtimename = "Deriving_Functor" 12 | let default_module = None 13 | let alpha = None 14 | let allow_private = false 15 | let predefs = [ 16 | ["list"], ["Deriving_Functor";"list"]; 17 | ["ref"], ["Deriving_Functor";"ref"]; 18 | ["option"], ["Deriving_Functor";"option"]; 19 | ] 20 | let depends = [] 21 | end 22 | 23 | module Builder(Generator : Defs.Generator) = struct 24 | 25 | open Generator.Loc 26 | open Camlp4.PreCast 27 | open Description 28 | 29 | module Helpers = Generator.AstHelpers 30 | 31 | type context = { 32 | argmap : Type.qname Type.NameMap.t; 33 | params : Type.param list; 34 | } 35 | 36 | let substitute env = 37 | (object 38 | inherit Type.transform as default 39 | method expr = function 40 | | `Param (p,v) when Type.NameMap.mem p env -> 41 | `Param (Type.NameMap.find p env,v) 42 | | e -> default# expr e 43 | end) # expr 44 | 45 | let setup_context (_,params,_,_,_ : Type.decl) : context = 46 | let argmap = 47 | List.fold_right 48 | (fun (p,_) m -> Type.NameMap.add p [Printf.sprintf "V_%s" p] m) 49 | params 50 | Type.NameMap.empty in 51 | { argmap = argmap; 52 | params = params; 53 | } 54 | 55 | let param_map context : string Type.NameMap.t = 56 | List.fold_right 57 | (fun (name,_) map -> Type.NameMap.add name ("f_" ^ name) map) 58 | context.params 59 | Type.NameMap.empty 60 | 61 | let tdec, sigdec = 62 | let dec context name = 63 | ("f", context.params, 64 | `Expr (`Constr ([name], List.map (fun p -> `Param p) context.params)), [], false) 65 | in 66 | (fun context name -> Helpers.Untranslate.decl (dec context name)), 67 | (fun context name -> Helpers.Untranslate.sigdecl (dec context name)) 68 | 69 | let wrapper context name expr = 70 | let param_map = param_map context in 71 | let patts :Ast.patt list = 72 | List.map 73 | (fun (name,_) -> <:patt< $lid:Type.NameMap.find name param_map$ >>) 74 | context.params in 75 | let rhs = 76 | List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) patts expr in 77 | <:module_expr< struct 78 | type $tdec context name$ 79 | let map = $rhs$ 80 | end >> 81 | (* 82 | prototype: [[t]] : t -> t[b_i/a_i] 83 | 84 | 85 | [[a_i]] = f_i 86 | 87 | [[C1|...CN]] = function [[C1]] ... [[CN]] sum 88 | [[`C1|...`CN]] = function [[`C1]] ... [[`CN]] variant 89 | 90 | [[{t1,...tn}]] = fun (t1,tn) -> ([[t1]],[[tn]]) tuple 91 | [[{l1:t1; ... ln:tn}]] = 92 | fun {l1=t1;...ln=tn} -> {l1=[[t1]];...ln=[[tn]]} record 93 | 94 | [[(t1,...tn) c]] = c_map [[t1]]...[[tn]] constructor 95 | 96 | [[a -> b]] = f . [[a]] (where a_i \notin fv(b)) function 97 | 98 | [[C0]] = C0->C0 nullary constructors 99 | [[C1 (t1...tn)]] = C1 t -> C0 ([[t1]] t1...[[tn]] tn) unary constructor 100 | [[`C0]] = `C0->`C0 nullary tag 101 | [[`C1 t]] = `C1 t->`C0 [[t]] t unary tag 102 | *) 103 | let rec polycase context = function 104 | | Type.Tag (name, []) -> <:match_case< `$name$ -> `$name$ >> 105 | | Type.Tag (name, es) -> <:match_case< `$name$ x -> `$name$ ($expr context (`Tuple es)$ x) >> 106 | | Type.Extends t -> 107 | let patt, guard, exp = Helpers.cast_pattern context.argmap t in 108 | <:match_case< $patt$ when $guard$ -> $expr context t$ $exp$ >> 109 | 110 | and expr context : Pa_deriving_common.Type.expr -> Ast.expr = function 111 | | t when not (Type.contains_tvars t) -> <:expr< fun x -> x >> 112 | | `Param (p,_) -> <:expr< $lid:Type.NameMap.find p (param_map context)$ >> 113 | | `Function (f,t) when not (Type.contains_tvars t) -> 114 | <:expr< fun f x -> f ($expr context f$ x) >> 115 | | `Constr (qname, ts) -> 116 | let qname = 117 | try List.assoc qname predefs 118 | with Not_found -> qname in 119 | List.fold_left 120 | (fun fn arg -> <:expr< $fn$ $expr context arg$ >>) 121 | <:expr< $id:Helpers.modname_from_qname ~qname ~classname$.map >> 122 | ts 123 | | `Tuple ts -> tup context ts 124 | | _ -> raise (Base.Underivable "Functor cannot be derived for this type") 125 | 126 | and tup context = function 127 | | [t] -> expr context t 128 | | ts -> 129 | let args, exps = 130 | (List.fold_right2 131 | (fun t n (p,e) -> 132 | let v = Printf.sprintf "t%d" n in 133 | Ast.PaCom (_loc, <:patt< $lid:v$ >>, p), 134 | Ast.ExCom (_loc, <:expr< $expr context t$ $lid:v$ >>, e)) 135 | ts 136 | (List.range 0 (List.length ts)) 137 | (<:patt< >>, <:expr< >>)) in 138 | let pat, exp = Ast.PaTup (_loc, args), Ast.ExTup (_loc, exps) in 139 | <:expr< fun $pat$ -> $exp$ >> 140 | 141 | and case context = function 142 | | (name, []) -> <:match_case< $uid:name$ -> $uid:name$ >> 143 | | (name, args) -> 144 | let f = tup context args 145 | and _, tpatt, texp = Helpers.tuple (List.length args) in 146 | <:match_case< $uid:name$ $tpatt$ -> let $tpatt$ = ($f$ $texp$) in $uid:name$ ($texp$) >> 147 | 148 | and field context (name, (_,t), _) : Ast.expr = 149 | <:expr< $expr context t$ $lid:name$ >> 150 | 151 | let rhs context : Pa_deriving_common.Type.rhs -> Ast.expr = function 152 | |`Fresh (_, _, `Private) -> raise (Base.Underivable "Functor cannot be derived for private types") 153 | |`Fresh (_, Type.GSum (tname, summands), _) -> 154 | raise (Base.Underivable "Functor cannot be derived for GADT") 155 | |`Fresh (_, Type.Sum summands, _) -> 156 | <:expr< function $list:List.map (case context) summands$ >> 157 | |`Fresh (_, Type.Record fields, _) -> 158 | <:expr< fun $Helpers.record_pattern fields$ -> 159 | $Helpers.record_expr (List.map (fun ((l,_,_) as f) -> (l,field context f)) fields)$ >> 160 | |`Expr e -> expr context e 161 | |`Variant ((_, tags), _) -> 162 | <:expr< function $list:List.map (polycase context) tags$ | _ -> assert false >> 163 | | `Nothing -> raise (Base.Underivable "Cannot generate functor instance for the empty type") 164 | 165 | 166 | let maptype context name = 167 | let param_map = param_map context in 168 | let ctor_in = `Constr ([name], List.map (fun p -> `Param p) context.params) in 169 | let ctor_out = substitute param_map ctor_in (* c[f_i/a_i] *) in 170 | List.fold_right (* (a_i -> f_i) -> ... -> c[a_i] -> c[f_i/a_i] *) 171 | (fun (p,_) out -> 172 | (<:ctyp< ('$lid:p$ -> '$lid:Type.NameMap.find p param_map$) -> $out$>>)) 173 | context.params 174 | (Helpers.Untranslate.expr (`Function (ctor_in, ctor_out))) 175 | 176 | let signature context name : Ast.sig_item list = 177 | [ <:sig_item< type $list:sigdec context name$ >>; 178 | <:sig_item< val map : $maptype context name$ >> ] 179 | 180 | let decl (name, _, r, _, _ as decl) : Camlp4.PreCast.Ast.module_binding = 181 | let context = setup_context decl in 182 | if name = "f" then 183 | raise (Base.Underivable ("deriving: Functor cannot be derived for types called `f'.\n" 184 | ^"Please change the name of your type and try again.")) 185 | else 186 | <:module_binding< 187 | $uid:classname ^ "_" ^ name$ 188 | : sig $list:signature context name$ end 189 | = $wrapper context name (rhs context r)$ >> 190 | 191 | let gen_sig (tname, params, _, _, generated as decl) = 192 | let context = setup_context decl in 193 | if tname = "f" then 194 | raise (Base.Underivable ("deriving: Functor cannot be derived for types called `f'.\n" 195 | ^"Please change the name of your type and try again.")) 196 | else 197 | if generated then 198 | <:sig_item< >> 199 | else 200 | <:sig_item< module $uid:classname ^ "_" ^ tname$ : 201 | sig type $tdec context tname$ val map : $maptype context tname$ end >> 202 | 203 | let generate decls = 204 | <:str_item< module rec $list:List.map decl decls$ >> 205 | 206 | let generate_sigs decls = 207 | <:sig_item< $list:List.map gen_sig decls$>> 208 | 209 | end 210 | 211 | include Base.RegisterClass(Description)(Builder) 212 | -------------------------------------------------------------------------------- /syntax/classes/show_class.ml: -------------------------------------------------------------------------------- 1 | (* Copyright Jeremy Yallop 2007. 2 | This file is free software, distributed under the MIT license. 3 | See the file COPYING for details. 4 | *) 5 | 6 | open Pa_deriving_common 7 | open Utils 8 | 9 | module Description : Defs.ClassDescription = struct 10 | let classname = "Show" 11 | let default_module = Some "Defaults" 12 | let runtimename = "Deriving_Show" 13 | let alpha = Some "Show_unprintable" 14 | let allow_private = true 15 | let predefs = [ 16 | ["int" ], ["Deriving_Show";"int"]; 17 | ["bool" ], ["Deriving_Show";"bool"]; 18 | ["unit" ], ["Deriving_Show";"unit"]; 19 | ["char" ], ["Deriving_Show";"char"]; 20 | ["int32" ], ["Deriving_Show";"int32"]; 21 | ["Int32";"t"], ["Deriving_Show";"int32"]; 22 | ["int64" ], ["Deriving_Show";"int64"]; 23 | ["Int64";"t"], ["Deriving_Show";"int64"]; 24 | ["nativeint"], ["Deriving_Show";"nativeint"]; 25 | ["float" ], ["Deriving_Show";"float"]; 26 | ["num" ], ["Deriving_num" ;"num"]; 27 | ["string" ], ["Deriving_Show";"string"]; 28 | ["list" ], ["Deriving_Show";"list"]; 29 | ["ref" ], ["Deriving_Show";"ref"]; 30 | ["option" ], ["Deriving_Show";"option"]; 31 | ["array" ], ["Deriving_Show";"array"]; 32 | ] 33 | let depends = [] 34 | end 35 | 36 | module Builder(Generator : Defs.Generator) = struct 37 | 38 | open Generator.Loc 39 | open Camlp4.PreCast 40 | open Description 41 | 42 | module Helpers = Generator.AstHelpers 43 | 44 | let wrap formatter = 45 | [ <:str_item< let format formatter : a -> unit = function $list:formatter$ >> ] 46 | 47 | let in_a_box box i e = 48 | <:expr< 49 | Format.$lid:box$ formatter $`int:i$; 50 | $e$; 51 | Format.pp_close_box formatter () >> 52 | 53 | let in_paren e = 54 | <:expr< 55 | Format.pp_print_string formatter "("; 56 | $e$; 57 | Format.pp_print_string formatter ")" >> 58 | 59 | let in_hovbox ?(indent = 0) = in_a_box "pp_open_hovbox" indent 60 | and in_box ?(indent = 0) = in_a_box "pp_open_box" indent 61 | 62 | let generator = (object (self) 63 | 64 | inherit Generator.generator 65 | 66 | method proxy () = 67 | None, [ <:ident< format >>; 68 | <:ident< format_list >>; 69 | <:ident< show >>; 70 | <:ident< show_list >>; ] 71 | 72 | method nargs ctxt tvars args = 73 | match tvars, args with 74 | | [id], [ty] -> 75 | <:expr< $self#call_expr ctxt ty "format"$ formatter $lid:id$ >> 76 | | id::ids, ty::tys -> 77 | let format_expr id ty = 78 | <:expr< $self#call_expr ctxt ty "format"$ formatter $lid:id$ >> in 79 | let format_expr' id ty = 80 | <:expr< Format.pp_print_string formatter ","; 81 | Format.pp_print_space formatter (); 82 | $format_expr id ty$>> in 83 | let exprs = format_expr id ty :: List.map2 format_expr' ids tys in 84 | in_paren (in_hovbox ~indent:1 (Helpers.seq_list exprs)) 85 | | _ -> assert false 86 | 87 | method tuple ctxt args = 88 | let tvars, tpatt, _ = Helpers.tuple (List.length args) in 89 | wrap [ <:match_case< $tpatt$ -> $self#nargs ctxt tvars args$ >> ] 90 | 91 | 92 | method case ctxt (name, args) = 93 | match args with 94 | | [] -> 95 | <:match_case< $uid:name$ -> Format.pp_print_string formatter $str:name$ >> 96 | | _ -> 97 | let tvars, patt, exp = Helpers.tuple (List.length args) in 98 | let format_expr = 99 | <:expr< Format.pp_print_string formatter $str:name$; 100 | Format.pp_print_break formatter 1 2; 101 | $self#nargs ctxt tvars args$ >> in 102 | <:match_case< $uid:name$ $patt$ -> $in_hovbox format_expr$ >> 103 | 104 | method sum ?eq ctxt tname params constraints summands = 105 | wrap (List.map (self#case ctxt) summands) 106 | 107 | method gsum ?eq ctxt tname params constraints gsummands = 108 | let summands = List.map (fun (name, args, _) -> (name, args)) gsummands in 109 | wrap (List.map (self#case ctxt) summands) 110 | 111 | method field ctxt (name, ty, mut) = 112 | <:expr< Format.pp_print_string formatter $str:name ^ " = "$; 113 | $self#call_poly_expr ctxt ty "format"$ formatter $lid:name$ >> 114 | 115 | method record ?eq ctxt tname params constraints fields = 116 | let format_fields = 117 | List.fold_left1 118 | (fun l r -> <:expr< $l$; Format.pp_print_string formatter "; "; $r$ >>) 119 | (List.map (self#field ctxt) fields) in 120 | let format_record = 121 | <:expr< 122 | Format.pp_print_char formatter '{'; 123 | $format_fields$; 124 | Format.pp_print_char formatter '}'; >> in 125 | wrap [ <:match_case< $Helpers.record_pattern fields$ -> $in_hovbox format_record$ >>] 126 | 127 | method polycase ctxt has_guard : Pa_deriving_common.Type.tagspec -> Ast.match_case = function 128 | | Type.Tag (name, []) -> 129 | let format_expr = 130 | <:expr< Format.pp_print_string formatter $str:"`" ^ name ^" "$ >> in 131 | <:match_case< `$uid:name$ -> $format_expr$ >> 132 | | Type.Tag (name, es) -> 133 | let format_expr = 134 | <:expr< Format.pp_print_string formatter $str:"`" ^ name ^" "$; 135 | $self#call_expr ctxt (`Tuple es) "format"$ formatter x >> in 136 | <:match_case< `$uid:name$ x -> $in_hovbox format_expr$ >> 137 | | Type.Extends t -> 138 | let patt, guard, cast = Generator.cast_pattern ctxt t in 139 | let format_expr = 140 | <:expr< $self#call_expr ctxt t "format"$ formatter $cast$ >> in 141 | if guard <> <:expr< >> then has_guard := true; 142 | <:match_case< $patt$ when $guard$ -> $in_hovbox format_expr$ >> 143 | 144 | method variant ctxt tname params constraints (_,tags) = 145 | let has_guard = ref false in 146 | let body = List.map (self#polycase ctxt has_guard) tags in 147 | wrap (if !has_guard 148 | then body @ [ <:match_case< _ -> assert false >> ] 149 | else body) 150 | 151 | end :> Generator.generator) 152 | 153 | let generate = Generator.generate generator 154 | let generate_sigs = Generator.generate_sigs generator 155 | 156 | end 157 | 158 | include Base.RegisterClass(Description)(Builder) 159 | -------------------------------------------------------------------------------- /syntax/classes/typeable_class.ml: -------------------------------------------------------------------------------- 1 | (* Copyright Jeremy Yallop 2007. 2 | This file is free software, distributed under the MIT license. 3 | See the file COPYING for details. 4 | *) 5 | 6 | open Pa_deriving_common 7 | open Utils 8 | 9 | module Description : Defs.ClassDescription = struct 10 | let classname = "Typeable" 11 | let runtimename = "Deriving_Typeable" 12 | let default_module = Some "Defaults" 13 | let alpha = None 14 | let allow_private = true 15 | let predefs = [ 16 | ["int"], ["Deriving_Typeable";"int"]; 17 | ["bool"], ["Deriving_Typeable";"bool"]; 18 | ["unit"], ["Deriving_Typeable";"unit"]; 19 | ["char"], ["Deriving_Typeable";"char"]; 20 | ["int32"], ["Deriving_Typeable";"int32"]; 21 | ["Int32";"t"], ["Deriving_Typeable";"int32"]; 22 | ["int64"], ["Deriving_Typeable";"int64"]; 23 | ["Int64";"t"], ["Deriving_Typeable";"int64"]; 24 | ["nativeint"], ["Deriving_Typeable";"nativeint"]; 25 | ["float"], ["Deriving_Typeable";"float"]; 26 | ["num"], ["Deriving_num";"num"]; 27 | ["string"], ["Deriving_Typeable";"string"]; 28 | ["list"], ["Deriving_Typeable";"list"]; 29 | ["ref"], ["Deriving_Typeable";"ref"]; 30 | ["option"], ["Deriving_Typeable";"option"]; 31 | ] 32 | let depends = [] 33 | end 34 | 35 | module Builder(Generator : Defs.Generator) = struct 36 | 37 | open Generator.Loc 38 | open Camlp4.PreCast 39 | open Description 40 | 41 | module Helpers = Generator.AstHelpers 42 | 43 | let mkName tname = 44 | let file_name, sl, _, _, _, _, _, _ = Loc.to_tuple _loc in 45 | Printf.sprintf "%s_%d_%f_%s" file_name sl (Unix.gettimeofday ()) tname 46 | 47 | let wrap type_rep = [ <:str_item< let type_rep = lazy $type_rep$ >> ] 48 | 49 | let generator = (object(self) 50 | 51 | inherit Generator.generator 52 | 53 | method proxy () = 54 | None, [ <:ident< type_rep >>; 55 | <:ident< has_type >>; 56 | <:ident< cast >>; 57 | <:ident< throwing_cast >>; 58 | <:ident< make_dynamic >>; 59 | <:ident< mk >>; 60 | ] 61 | 62 | method tuple ctxt ts = 63 | let params = 64 | List.map (fun t -> <:expr< $self#call_expr ctxt t "type_rep"$ >>) ts in 65 | wrap <:expr< $uid:runtimename$.TypeRep.mkTuple $Helpers.expr_list params$ >> 66 | 67 | method gen ?eq ctxt tname params constraints = 68 | let paramList = 69 | List.fold_right 70 | (fun p cdr -> 71 | <:expr< $self#call_expr ctxt p "type_rep"$ :: $cdr$ >>) 72 | params 73 | <:expr< [] >> in 74 | wrap <:expr< $uid:runtimename$.TypeRep.mkFresh $str:mkName tname$ $paramList$ >> 75 | 76 | method sum ?eq ctxt tname params constraints _ = 77 | self#gen ~eq ctxt tname params constraints 78 | method record ?eq ctxt tname params constraints _ = 79 | self#gen ~eq ctxt tname params constraints 80 | 81 | method variant ctxt tname params constraints (_,tags) = 82 | let tags, extends = 83 | List.fold_left 84 | (fun (tags, extends) -> function 85 | | Type.Tag (l, []) -> <:expr< ($str:l$, None) :: $tags$ >>, extends 86 | | Type.Tag (l, ts) -> 87 | <:expr< ($str:l$, Some $self#call_expr ctxt (`Tuple ts) "type_rep"$) ::$tags$ >>, 88 | extends 89 | | Type.Extends t -> 90 | tags, 91 | <:expr< $self#call_expr ctxt t "type_rep"$::$extends$ >>) 92 | (<:expr< [] >>, <:expr< [] >>) tags in 93 | wrap <:expr< $uid:runtimename$.TypeRep.mkPolyv $tags$ $extends$ >> 94 | 95 | end :> Generator.generator) 96 | 97 | let classname = Description.classname 98 | let runtimename = Description.runtimename 99 | let generate = Generator.generate generator 100 | let generate_sigs = Generator.generate_sigs generator 101 | let generate_expr = Generator.generate_expr generator 102 | 103 | end 104 | 105 | include Base.RegisterFullClass(Description)(Builder) 106 | -------------------------------------------------------------------------------- /syntax/common/base.mli: -------------------------------------------------------------------------------- 1 | (* Copyright Jeremy Yallop 2007. 2 | Copyright Grégoire Henry 2011. 3 | This file is free software, distributed under the MIT license. 4 | See the file COPYING for details. 5 | *) 6 | 7 | exception Underivable of string 8 | exception NoSuchClass of string 9 | 10 | open Camlp4.PreCast 11 | 12 | val fatal_error : Loc.t -> string -> 'a 13 | val display_errors : Loc.t -> ('a -> 'b) -> 'a -> 'b 14 | 15 | open Defs 16 | 17 | val derive_str : Loc.t -> Type.decl list -> generator -> Ast.str_item 18 | val derive_sig : Loc.t -> Type.decl list -> generator -> Ast.sig_item 19 | 20 | module RegisterClass(Desc : ClassDescription)(MakeClass : ClassBuilder) : sig 21 | val register_predefs : Type.qname -> Type.qname -> unit 22 | end 23 | 24 | module RegisterFullClass(Desc : ClassDescription)(MakeClass : FullBuilder) : sig 25 | val depends : (module DepClassBuilder) 26 | val register_predefs : Type.qname -> Type.qname -> unit 27 | end 28 | 29 | val is_registered : Type.name -> bool 30 | val add_register_hook: 31 | ((module ClassDescription) -> generator -> unit) -> unit 32 | 33 | val find : Type.name -> generator 34 | 35 | (**/**) 36 | 37 | module Register(Desc : ClassDescription)(MakeClass : InnerClassBuilder) : sig 38 | (* Side effects only *) 39 | end 40 | 41 | module Generator(Loc : Loc)(Desc : ClassDescription) : Generator 42 | module AstHelpers(Loc : Loc) : AstHelpers 43 | -------------------------------------------------------------------------------- /syntax/common/clusters.ml: -------------------------------------------------------------------------------- 1 | (* Copyright Grégoire Henry 2011. 2 | This file is free software, distributed under the MIT license. 3 | See the file COPYING for details. 4 | *) 5 | 6 | open Utils 7 | open Type 8 | 9 | (* See cluster.mli for a description of "clusters". *) 10 | 11 | let extract_recursive_calls decls : ESet.t list = 12 | let names = List.map (fun (name,_,_,_,_) -> name) decls in 13 | let obj = (object (self) 14 | inherit [ESet.t] fold as default 15 | method crush sets = List.fold_left ESet.union ESet.empty sets 16 | method expr e = 17 | match e with 18 | | `Constr ([name], args) as e when List.mem name names -> 19 | ESet.add (name, args) (default#expr e) 20 | | e -> default#expr e 21 | method decl d = 22 | match d with 23 | | (tname, params, `Fresh (_, GSum _, _), _, _) -> 24 | (* All GADT are considered recursives... cf. base.ml*) 25 | ESet.add (tname, List.map (fun p -> `Param p) params) (default#decl d) 26 | | _ -> default#decl d 27 | end) in 28 | List.map obj#decl decls 29 | 30 | (** The function [close_decls decls] computes, for the set of type 31 | declarations [decls], the actual instances of these types that are 32 | used in their definitions. It throws an exception if the set is 33 | known to be infinite (a.k.a. non-regural types). *) 34 | let close_decls (decls: Type.decl list) : (Type.decl * ESet.t) list = 35 | 36 | let check_regular_instance name (name', args') = 37 | name <> name' || 38 | List.for_all 39 | (function (`Constr _ | `Tuple _ | `Function _) as e -> not (contains_tvars e) 40 | | _ -> true) args' in 41 | 42 | let expand (tys : (Type.decl * ESet.t) list) name ty_set (name', args') = 43 | let ((_, params',_,_,_), ty_set') = List.find (fun ((n,_,_,_,_),_) -> n = name') tys in 44 | let subst = NameMap.fromList (List.map2 (fun (p, _) a -> p, a) params' args') in 45 | ESet.fold 46 | (fun (name'', args'') acc -> 47 | let new_ty = name'', List.map (substitute_expr subst) args'' in 48 | if not (check_regular_instance name new_ty) then 49 | failwith ("The following types contain non-regular recursion:\n " 50 | ^String.concat ", " (List.map (fun ((n,_,_,_,_),_)->n) tys) 51 | ^"\nderiving does not support non-regular types"); 52 | if ESet.mem new_ty ty_set then acc else ESet.add new_ty acc) 53 | ty_set' ESet.empty in 54 | 55 | let expands (tys : (Type.decl * ESet.t) list) = 56 | List.map 57 | (fun ((name,_,_,_,_),ty_set) -> 58 | ESet.fold 59 | (fun ty acc -> ESet.union (expand tys name ty_set ty) acc) 60 | ty_set ESet.empty) 61 | tys in 62 | 63 | let aggregate_new_tys (tys : (Type.decl * ESet.t) list) new_tys = 64 | List.map2 (fun (d,set) new_set -> d, ESet.union set new_set) tys new_tys in 65 | 66 | let rec loop_close_decls (tys : (Type.decl * ESet.t) list) new_tys = 67 | if List.for_all (fun l -> l = ESet.empty) new_tys then tys 68 | else 69 | let tys = aggregate_new_tys tys new_tys in 70 | let new_tys = expands tys in 71 | loop_close_decls tys new_tys 72 | in 73 | loop_close_decls 74 | (List.map (fun d -> d, ESet.empty) decls) 75 | (extract_recursive_calls decls) 76 | 77 | (** The function [rename_param decl] rename the type parameters with 78 | 'a 'b 'c ... *) 79 | let rename_params (name, params, rhs, constraints, deriving as decl) = 80 | if deriving then decl else 81 | let map = 82 | List.mapn 83 | (fun (o, v) n -> 84 | let n' = 85 | if o.[0] = '_' 86 | then "_" ^ typevar_of_int n 87 | else typevar_of_int n in 88 | (o, (n', v))) 89 | params in 90 | let subst = NameMap.fromList (List.map (fun (o, (n, _)) -> o, n) map) in 91 | ((name, List.map snd map, rename_rhs subst rhs, 92 | List.map (rename_constraint subst) constraints, false)) 93 | 94 | (** Group type declaration (and the associated instances involved in 95 | recursion) by the set of freevars in there "associated recursives 96 | instances". *) 97 | let aggregate_clusters decls = 98 | let add_instances acc (((name,params,_,_,_ : Type.decl) as decl), insts) = 99 | (* Determine types variables involved in recursion. *) 100 | let freevars = ESet.fold 101 | (fun (name, args) acc -> 102 | ParamSet.union (Type.free_tvars (`Constr ([name], args))) acc) 103 | insts ParamSet.empty in 104 | ParamSet.iter (* TODO error message instead of assert (unknown variable) *) 105 | (fun (n, _ as var) -> if not (List.exists (fun p -> var = p) params) then 106 | failwith ("Unkown variable " ^ n) 107 | ) freevars; 108 | assert (ParamSet.for_all (* TODO error message instead of assert (unknown variable) *) 109 | (fun var -> List.exists (fun p -> var = p) params) freevars); 110 | (* Then regroups with instances that shares effective parameters. *) 111 | let rec loop acc = 112 | match acc with 113 | | [] -> [insts, freevars, [decl]] 114 | | (insts', vars, decls) :: acc when ParamSet.equal freevars vars -> 115 | (ESet.union insts insts', vars, decl :: decls) :: acc 116 | | e :: acc -> e :: loop acc 117 | in 118 | loop acc in 119 | List.fold_left add_instances [] decls 120 | 121 | let sort_freevars (fv: ParamSet.t) : param list = 122 | List.sort compare (ParamSet.fold (fun v acc -> v :: acc) fv []) 123 | 124 | type cluster = { 125 | params: Type.param list; 126 | decls: Type.decl list; 127 | instances: (Type.name * Type.expr list) list; 128 | } 129 | 130 | let ( >>> ) x f = f x 131 | 132 | let make decls = 133 | let sets = 134 | List.map rename_params decls 135 | >>> close_decls 136 | >>> aggregate_clusters 137 | in 138 | List.map 139 | (fun (insts, fv, decls) -> { instances = ESet.toList insts; 140 | params = sort_freevars fv; 141 | decls; }) 142 | sets 143 | -------------------------------------------------------------------------------- /syntax/common/clusters.mli: -------------------------------------------------------------------------------- 1 | (* Copyright Grégoire Henry 2011. 2 | This file is free software, distributed under the MIT license. 3 | See the file COPYING for details. 4 | *) 5 | 6 | (* A cluster is the finite set of recursive class instances needed for 7 | deriving a "regular" recursive type declaration. For example: 8 | 9 | type 'a t = A of 'a | B of 'a * 'a t | I of int t 10 | 11 | The corresponding cluster is: 12 | 13 | { 'a t ; int t }. 14 | 15 | For multiple recursives declarations, we may group clusters by the 16 | set of free variables involved in the required instances. For 17 | example: 18 | 19 | type 'a t1 = ('a, int) t2 20 | and ('a, 'b) t2 = A of 'a t1 | B of 'b deriving (Show) 21 | 22 | Types declaration t1 and t2 share the same clusters: 23 | 24 | { 'a t1; ('a, int) t2 }. 25 | 26 | This notion of clusters allows to be less restrictive with 27 | recursive type declaration than previous version of deriving. It's 28 | still not sufficient for handling "non-regular" datatypes like: 29 | 30 | type 'a nested = Z of nested | S of ('a * 'a) nested 31 | 32 | because the set of required instance would be infinite. 33 | 34 | *) 35 | 36 | type cluster = { 37 | params: Type.param list; 38 | decls: Type.decl list; 39 | instances: (Type.name * Type.expr list) list; 40 | } 41 | 42 | val make: Type.decl list -> cluster list 43 | -------------------------------------------------------------------------------- /syntax/common/defs.ml: -------------------------------------------------------------------------------- 1 | defs.mli -------------------------------------------------------------------------------- /syntax/common/defs.mli: -------------------------------------------------------------------------------- 1 | (* Copyright Jeremy Yallop 2007. 2 | Copyright Grégoire Henry 2011. 3 | This file is free software, distributed under the MIT license. 4 | See the file COPYING for details. 5 | *) 6 | 7 | open Camlp4.PreCast 8 | 9 | module type Loc = sig 10 | val _loc : Loc.t (* location of the type definition being derived *) 11 | end 12 | 13 | module type AstHelpers = sig 14 | 15 | module Untranslate : Type.Untranslate 16 | 17 | val seq: Ast.expr -> Ast.expr -> Ast.expr 18 | val seq_list: Ast.expr list -> Ast.expr 19 | 20 | val record_pattern: ?prefix:string -> Type.field list -> Ast.patt 21 | val record_expr: (string * Ast.expr) list -> Ast.expr 22 | val record_expression: ?prefix:string -> Type.field list -> Ast.expr 23 | 24 | val expr_list: Ast.expr list -> Ast.expr 25 | val patt_list: Ast.patt list -> Ast.patt 26 | 27 | val tuple_expr: Ast.expr list -> Ast.expr 28 | val tuple: ?param:string -> int -> string list * Ast.patt * Ast.expr 29 | 30 | val cast_pattern: 31 | Type.qname Type.NameMap.t -> ?param:string -> Type.expr -> 32 | Ast.patt * Ast.expr * Ast.expr 33 | 34 | val modname_from_qname: 35 | qname:string list -> classname:string -> Ast.ident 36 | 37 | end 38 | 39 | 40 | module type Generator = sig 41 | 42 | type context 43 | 44 | module Loc : Loc 45 | module AstHelpers : AstHelpers 46 | 47 | val cast_pattern: 48 | context -> ?param:string -> Type.expr -> 49 | Ast.patt * Ast.expr * Ast.expr 50 | 51 | val instantiate_modargs_repr: context -> Type.repr -> Type.repr 52 | 53 | class virtual generator : object 54 | 55 | method pack: 56 | Type.qname Type.NameMap.t -> Type.expr -> Ast.module_expr -> Ast.expr 57 | method unpack: 58 | Type.qname Type.NameMap.t -> Type.expr -> Ast.expr -> Ast.module_expr 59 | 60 | method class_sig: Type.qname Type.NameMap.t -> Type.expr -> Ast.module_type 61 | 62 | method rhs: context -> Type.subst -> Type.decl -> Ast.module_expr 63 | method expr: context -> Type.expr -> Ast.module_expr 64 | 65 | method constr: context -> Type.qname * Type.expr list -> Ast.module_expr 66 | 67 | method param: context -> Type.param -> Ast.module_expr 68 | method gparam: context -> Type.param * Type.expr -> Ast.module_expr 69 | 70 | method wrap: context -> ?default:Type.name option -> Type.expr -> Ast.str_item list -> Ast.module_expr 71 | 72 | method call_expr: context -> Type.expr -> string -> Ast.expr 73 | method call_poly_expr: context -> Type.poly_expr -> string -> Ast.expr 74 | 75 | method virtual proxy: unit -> Type.name option * Ast.ident list 76 | method virtual sum: 77 | ?eq:Type.expr -> context -> 78 | Type.name -> Type.expr list -> Type.constraint_ list -> 79 | Type.summand list -> Ast.str_item list 80 | method gsum: 81 | ?eq:Type.expr -> context -> 82 | Type.name -> Type.expr list -> Type.constraint_ list -> 83 | Type.gsummand list -> Ast.str_item list 84 | method virtual tuple: context -> Type.expr list -> Ast.str_item list 85 | method virtual variant: 86 | context -> 87 | Type.name -> Type.expr list -> Type.constraint_ list -> 88 | Type.variant -> Ast.str_item list 89 | method virtual record: 90 | ?eq:Type.expr -> context -> 91 | Type.name -> Type.expr list -> Type.constraint_ list -> 92 | Type.field list -> Ast.str_item list 93 | 94 | method class_: context -> [ `NYI ] -> Ast.str_item list 95 | method function_: context -> Type.expr * Type.expr -> Ast.str_item list 96 | method label: 97 | context -> 98 | [ `NonOptional | `Optional ] * Type.name * Type.expr * Type.expr -> 99 | Ast.str_item list 100 | method object_: context -> [ `NYI ] -> Ast.str_item list 101 | 102 | end 103 | 104 | val generate: generator -> Type.decl list -> Ast.str_item 105 | val generate_sigs: generator -> Type.decl list -> Ast.sig_item 106 | val generate_expr: 107 | generator -> 108 | Ast.module_expr Type.EMap.t -> 109 | Type.qname Type.NameMap.t -> 110 | Type.expr -> Ast.module_expr 111 | 112 | end 113 | 114 | (** *) 115 | 116 | module type Class = sig 117 | val generate: Type.decl list -> Ast.str_item 118 | val generate_sigs: Type.decl list -> Ast.sig_item 119 | end 120 | 121 | module type ClassBuilder = functor (Generator : Generator) -> Class 122 | module type InnerClassBuilder = functor (Loc: Loc) -> Class 123 | 124 | module type FullClass = sig 125 | val classname: Type.name 126 | val runtimename: Type.name 127 | include Class 128 | val generate_expr: 129 | Ast.module_expr Type.EMap.t -> 130 | Type.qname Type.NameMap.t -> 131 | Type.expr -> Ast.module_expr 132 | end 133 | 134 | module type FullBuilder = functor (Generator: Generator) -> FullClass 135 | module type DepClassBuilder = functor (Loc: Loc) -> FullClass 136 | 137 | module type ClassDescription = sig 138 | val classname: Type.name 139 | val runtimename: Type.name 140 | val default_module: Type.name option 141 | val alpha: Type.name option 142 | val allow_private: bool 143 | val predefs: (Type.qname * Type.qname) list 144 | val depends: (module DepClassBuilder) list 145 | end 146 | 147 | type generator = (module InnerClassBuilder) 148 | 149 | (**/**) 150 | 151 | (* Compat with <= 0.4-ocsigen *) 152 | 153 | module type FullClassBuilder = functor (Loc: Loc) -> FullClass 154 | 155 | -------------------------------------------------------------------------------- /syntax/common/extend.ml: -------------------------------------------------------------------------------- 1 | (* Copyright Jeremy Yallop 2007. 2 | This file is free software, distributed under the MIT license. 3 | See the file COPYING for details. 4 | *) 5 | 6 | (* Extend the OCaml grammar to include the `deriving' clause after 7 | type declarations in structure and signatures. *) 8 | 9 | open Utils 10 | 11 | open Camlp4.PreCast 12 | 13 | let instantiate _loc t classname = 14 | try 15 | let class_ = Base.find classname in 16 | let module U = Type.Untranslate(struct let _loc = _loc end) in 17 | let binding = Ast.TyDcl (_loc, "inline", [], t, []) in 18 | let decls = Base.display_errors _loc Type.Translate.decls binding in 19 | if List.exists Type.contains_tvars_decl decls then 20 | Base.fatal_error _loc ("deriving: type variables cannot be used in `method' instantiations"); 21 | let tdecls = List.map U.decl decls in 22 | let m = Base.derive_str _loc decls class_ in 23 | <:module_expr< struct 24 | type $list:tdecls$ 25 | $m$ 26 | include $uid:classname ^ "_inline"$ 27 | end >> 28 | with Base.NoSuchClass classname -> 29 | Base.fatal_error _loc ("deriving: " ^ classname ^ " is not a known `class'") 30 | 31 | module Deriving (S : Camlp4.Sig.Camlp4Syntax) = struct 32 | 33 | include Syntax 34 | 35 | let rec drop n l = 36 | if n <= 0 then 37 | l 38 | else 39 | match l with 40 | | [] -> [] 41 | | _ :: l -> drop (n - 1) l 42 | 43 | let test_val_longident_dot_lt = 44 | Gram.Entry.of_parser "test_val_longident_dot_lt" (fun strm -> 45 | let rec test_longident_dot pos tokens = 46 | match tokens with 47 | | (ANTIQUOT ((""|"id"|"anti"|"list"), _), _) :: tokens -> 48 | test_longident_dot (pos+1) tokens 49 | | (UIDENT _, _) :: (KEYWORD ".", _) :: (LIDENT _, _) :: tokens -> 50 | test_longident_dot (pos+3) tokens 51 | | _ :: _ -> 52 | test_delim pos tokens 53 | | [] -> fetch_more test_longident_dot pos 54 | and test_delim pos tokens = 55 | if pos = 0 then 56 | raise Stream.Failure 57 | else 58 | match tokens with 59 | | (KEYWORD ("<"), _) :: _ -> () 60 | | _ :: _ -> raise Stream.Failure 61 | | [] -> fetch_more test_delim pos 62 | and fetch_more k pos = 63 | match drop pos (Stream.npeek (pos + 10) strm) with 64 | | [] -> raise Stream.Failure 65 | | tokens -> k pos tokens 66 | in fetch_more test_longident_dot 0 67 | ) 68 | 69 | open Ast 70 | 71 | EXTEND Gram 72 | expr: LEVEL "simple" 73 | [ 74 | [ TRY[ test_val_longident_dot_lt; e1 = val_longident ; "<" ; t = ctyp; ">" -> 75 | match e1 with 76 | | <:ident< $uid:classname$ . $lid:methodname$ >> -> 77 | let m = instantiate _loc t classname in 78 | <:expr< let module $uid:classname$ = $m$ 79 | in $uid:classname$.$lid:methodname$ >> 80 | | _ -> 81 | Base.fatal_error _loc ("deriving: this looks a bit like a method application, but " 82 | ^"the syntax is not valid"); 83 | ]]]; 84 | 85 | module_expr: LEVEL "simple" 86 | [ 87 | [ TRY[ test_val_longident_dot_lt; e1 = val_longident ; "<" ; t = ctyp; ">" -> 88 | match e1 with 89 | | <:ident< $uid:classname$ >> -> 90 | instantiate _loc t classname 91 | | _ -> 92 | Base.fatal_error _loc ("deriving: this looks a bit like a class instantiation, but " 93 | ^"the syntax is not valid"); 94 | ]]]; 95 | END 96 | 97 | end 98 | 99 | module M = Camlp4.Register.OCamlSyntaxExtension(Id)(Deriving) 100 | -------------------------------------------------------------------------------- /syntax/common/extend.mli: -------------------------------------------------------------------------------- 1 | (* Copyright Jeremy Yallop 2007. 2 | This file is free software, distributed under the MIT license. 3 | See the file COPYING for details. 4 | *) 5 | 6 | (* Extend the OCaml grammar to include the `deriving' clause after 7 | type declarations in structure and signatures. *) 8 | 9 | module Deriving (S : Camlp4.Sig.Camlp4Syntax): Camlp4.Sig.Camlp4Syntax 10 | -------------------------------------------------------------------------------- /syntax/common/id.ml.ab: -------------------------------------------------------------------------------- 1 | let version = "$(pkg_version)" 2 | let name = "$(pkg_name)" 3 | -------------------------------------------------------------------------------- /syntax/common/type.mli: -------------------------------------------------------------------------------- 1 | (* Copyright Jeremy Yallop 2007. 2 | Copyright Grégoire Henry 2011. 3 | This file is free software, distributed under the MIT license. 4 | See the file COPYING for details. 5 | *) 6 | 7 | open Utils 8 | 9 | (* More convenient representation for types, and translation from the 10 | Camlp4 representation *) 11 | 12 | type name = string 13 | type qname = name list 14 | 15 | module NameMap : Map.S with type key = string 16 | module NameSet : Set.S with type elt = string 17 | 18 | (* *) 19 | 20 | type param = name * [ `Minus | `Plus ] option 21 | 22 | type decl = name * param list * rhs * constraint_ list * bool 23 | 24 | and rhs = 25 | [ `Expr of expr 26 | | `Fresh of expr option * repr * [ `Private | `Public ] 27 | | `Nothing 28 | | `Variant of variant * [ `Private | `Public ] ] 29 | 30 | and repr = Sum of summand list | GSum of name * gsummand list | Record of field list 31 | 32 | and field = name * poly_expr * [ `Immutable | `Mutable ] 33 | 34 | and summand = name * expr list 35 | 36 | and gsummand = name * expr list * expr list 37 | 38 | and constraint_ = expr * expr 39 | 40 | and expr = 41 | [ `Class of [ `NYI ] 42 | | `Constr of qname * expr list 43 | | `Function of expr * expr 44 | | `Label of [ `NonOptional | `Optional ] * name * expr * expr 45 | | `Object of [ `NYI ] 46 | | `Param of param 47 | | `GParam of param * expr 48 | | `Tuple of expr list ] 49 | 50 | and poly_expr = param list * expr 51 | 52 | and variant = [ `Eq | `Gt | `Lt ] * tagspec list 53 | 54 | and tagspec = Tag of name * expr list | Extends of expr 55 | 56 | module ParamSet : Set.S with type elt = param 57 | module ParamMap : Map.S with type key = param 58 | module ExprSet : Set.S with type elt = expr 59 | module ExprMap : Map.S with type key = expr 60 | module ESet : Set.S with type elt = name * expr list 61 | module EMap : Map.S with type key = name * expr list 62 | 63 | val free_tvars : expr -> ParamSet.t 64 | val contains_tvars : expr -> bool 65 | val contains_tvars_decl : decl -> bool 66 | 67 | type subst = expr NameMap.t 68 | val build_subst : (name * expr) list -> subst 69 | val substitute_decl : subst -> decl -> decl 70 | val substitute_expr : subst -> expr -> expr 71 | val substitute_rhs : subst -> rhs -> rhs 72 | val substitute_constraint : subst -> constraint_ -> constraint_ 73 | 74 | val rename_rhs : name NameMap.t -> rhs -> rhs 75 | val rename_constraint : name NameMap.t -> constraint_ -> constraint_ 76 | 77 | (** *) 78 | 79 | class virtual ['a] fold : object 80 | method constraint_ : constraint_ -> 'a 81 | method virtual crush : 'a list -> 'a 82 | method decl : decl -> 'a 83 | method expr : expr -> 'a 84 | method field : field -> 'a 85 | method poly_expr : poly_expr -> 'a 86 | method repr : repr -> 'a 87 | method rhs : rhs -> 'a 88 | method summand : summand -> 'a 89 | method gsummand : gsummand -> 'a 90 | method tagspec : tagspec -> 'a 91 | method variant : variant -> 'a 92 | end 93 | 94 | class transform : object 95 | method constraint_ : constraint_ -> constraint_ 96 | method decl : decl -> decl 97 | method expr : expr -> expr 98 | method field : field -> field 99 | method poly_expr : poly_expr -> poly_expr 100 | method repr : repr -> repr 101 | method rhs : rhs -> rhs 102 | method summand : summand -> summand 103 | method gsummand : gsummand -> gsummand 104 | method tagspec : tagspec -> tagspec 105 | method variant : variant -> variant 106 | end 107 | 108 | open Camlp4.PreCast 109 | 110 | module Translate : sig 111 | 112 | val param : Ast.ctyp -> string * [> `Minus | `Plus ] option 113 | val params : Ast.ctyp list -> (string * [> `Minus | `Plus ] option) list 114 | val split_and : Ast.ctyp -> (Ast.ctyp * Ast.ctyp, Ast.ctyp) either 115 | val split_comma : Ast.ctyp -> (Ast.ctyp * Ast.ctyp, Ast.ctyp) either 116 | val split_semi : Ast.ctyp -> (Ast.ctyp * Ast.ctyp, Ast.ctyp) either 117 | val split_or : Ast.ctyp -> (Ast.ctyp * Ast.ctyp, Ast.ctyp) either 118 | val split_amp : Ast.ctyp -> (Ast.ctyp * Ast.ctyp, Ast.ctyp) either 119 | val split_ofamp : Ast.ctyp -> (Ast.ctyp * Ast.ctyp, Ast.ctyp) either 120 | val split_star : Ast.ctyp -> (Ast.ctyp * Ast.ctyp, Ast.ctyp) either 121 | val list : 122 | (Ast.ctyp -> 'a) -> 123 | (Ast.ctyp -> (Ast.ctyp * Ast.ctyp, Ast.ctyp) either) -> 124 | Ast.ctyp -> 'a list 125 | val ident : Ast.ident -> name 126 | val qident : Ast.ident -> qname 127 | 128 | type vmap = (name * variant * name option) list 129 | 130 | val fresh_name : unit -> string 131 | val set_name_prefix : name -> unit 132 | 133 | module WithParams(P : sig val params : param list end) : sig 134 | val params : param list 135 | val apply_t : 'a -> [> `Constr of 'a list * [> `Param of param ] list ] 136 | val expr : Ast.ctyp -> expr * vmap 137 | val tagspec : Ast.ctyp -> tagspec * vmap 138 | val application : Ast.ctyp -> (qname * expr list) * vmap 139 | val variant : Ast.ctyp -> ?alias:name -> [ `Eq | `Gt | `Lt ] -> expr * vmap 140 | val polyexpr : Ast.ctyp -> poly_expr * vmap 141 | val field : Ast.ctyp -> field * vmap 142 | val summand : Ast.ctyp -> summand * vmap 143 | val repr : Ast.ctyp -> repr * (name * variant * name option) list 144 | val toplevel : Ast.ctyp -> rhs * vmap 145 | val constraints : (Ast.ctyp * Ast.ctyp) list -> constraint_ list * vmap 146 | val declify : 147 | (name * variant * name option) list -> 148 | (decl * (name * expr) option) list 149 | end 150 | 151 | type alias_map = expr NameMap.t 152 | 153 | val build_alias_map : (NameMap.key * expr) option list -> alias_map 154 | val split : Ast.ctyp -> Ast.ctyp list 155 | val decl : Ast.ctyp -> decl list * alias_map 156 | val substitute_aliases : alias_map -> decl -> decl 157 | val decls : Ast.ctyp -> decl list 158 | 159 | end 160 | 161 | module type Untranslate = sig 162 | 163 | val param : string * [< `Minus | `Plus ] option -> Ast.ctyp 164 | val qname : string list -> Ast.ident 165 | val qName : string list -> Ast.ident 166 | val expr : expr -> Ast.ctyp 167 | val poly : param list * expr -> Ast.ctyp 168 | val rhs : rhs -> Ast.ctyp 169 | val tagspec : tagspec -> Ast.ctyp 170 | val summand : summand -> Ast.ctyp 171 | val field : field -> Ast.ctyp 172 | val repr : repr -> Ast.ctyp 173 | val constraint_ : expr * expr -> Ast.ctyp * Ast.ctyp 174 | val decl : decl -> Ast.ctyp 175 | val sigdecl : decl -> Ast.ctyp list 176 | 177 | end 178 | 179 | module Untranslate(C : sig val _loc : Ast.Loc.t end) : Untranslate 180 | 181 | (* Debug *) 182 | val print_expr : expr -> string 183 | val print_rhs : rhs -> string 184 | -------------------------------------------------------------------------------- /syntax/common/utils.ml: -------------------------------------------------------------------------------- 1 | (* Copyright Jeremy Yallop 2007. 2 | Copyright Grégoire Henry 2011. 3 | This file is free software, distributed under the MIT license. 4 | See the file COPYING for details. 5 | *) 6 | 7 | type ('a,'b) either = Left of 'a | Right of 'b 8 | 9 | let either_partition (f : 'a -> ('b, 'c) either) (l : 'a list) 10 | : 'b list * 'c list = 11 | let rec aux (lefts, rights) = function 12 | | [] -> (List.rev lefts, List.rev rights) 13 | | x::xs -> 14 | match f x with 15 | | Left l -> aux (l :: lefts, rights) xs 16 | | Right r -> aux (lefts, r :: rights) xs 17 | in aux ([], []) l 18 | 19 | 20 | module List = 21 | struct 22 | include List 23 | 24 | let fold_left1 : ('a -> 'a -> 'a) -> 'a list -> 'a 25 | = fun f l -> match l with 26 | | x::xs -> List.fold_left f x xs 27 | | [] -> invalid_arg "fold_left1" 28 | 29 | let rec fold_right1 : ('a -> 'a -> 'a) -> 'a list -> 'a 30 | = fun f l -> match l with 31 | | [x] -> x 32 | | x::xs -> f x (fold_right1 f xs) 33 | | [] -> invalid_arg "fold_right1" 34 | 35 | let rec range from upto = 36 | let rec aux f t result = 37 | if f = t then result 38 | else aux (f+1) t (f::result) 39 | in if upto < from then raise (Invalid_argument "range") 40 | else List.rev (aux from upto []) 41 | 42 | let rec last : 'a list -> 'a = function 43 | | [] -> invalid_arg "last" 44 | | [x] -> x 45 | | _::xs -> last xs 46 | 47 | let concat_map f l = 48 | let rec aux = function 49 | | _, [] -> [] 50 | | f, x :: xs -> f x @ aux (f, xs) 51 | in aux (f,l) 52 | 53 | let concat_map2 (f : 'a -> 'b -> 'c list) (l1 : 'a list) (l2 : 'b list) : 'c list = 54 | let rec aux = function 55 | | [], [] -> [] 56 | | x::xs, y :: ys -> f x y @ aux (xs, ys) 57 | | _ -> invalid_arg "concat_map2" 58 | in aux (l1, l2) 59 | 60 | let mapn ?(init=0) f = 61 | let rec aux n = function 62 | | [] -> [] 63 | | x::xs -> f x n :: aux (n+1) xs in 64 | aux init 65 | 66 | let rec zip xs ys = match xs, ys with 67 | | [], [] -> [] 68 | | x::xs, y::ys -> (x, y) :: zip xs ys 69 | | _, _ -> invalid_arg "List.zip" 70 | 71 | let rec split3 xyzs = match xyzs with 72 | | [] -> [], [], [] 73 | | (x, y, z) :: xyzs -> 74 | let xs, ys, zs = split3 xyzs in 75 | x :: xs, y :: ys, z :: zs 76 | 77 | end 78 | 79 | module F = 80 | struct 81 | let id x = x 82 | let curry f x y = f (x,y) 83 | let uncurry f (x,y) = f x y 84 | end 85 | 86 | module Option = 87 | struct 88 | let map f = function 89 | | None -> None 90 | | Some x -> Some (f x) 91 | end 92 | 93 | module DumpAst = 94 | struct 95 | open Camlp4.PreCast.Ast 96 | 97 | let rec ident = function 98 | | IdAcc (_, i1, i2) -> "IdAcc ("^ident i1^","^ident i2^")" 99 | | IdApp (_, i1, i2) -> "IdApp ("^ident i1^","^ident i2^")" 100 | | IdLid (_, s) -> "IdLid("^s^")" 101 | | IdUid (_, s) -> "IdUid("^s^")" 102 | | IdAnt (_, s) -> "IdAnt("^s^")" 103 | 104 | let rec ctyp = function 105 | | TyLab (_, s, c) -> "TyLab ("^s ^ "," ^ ctyp c ^")" 106 | | TyDcl (_, s, cs, c2, ccs) -> "TyDcl ("^s ^", [" ^ String.concat ";" (List.map ctyp cs) ^"], "^ctyp c2 ^ ", ["^ 107 | String.concat "," (List.map (fun (c1,c2) -> "(" ^ ctyp c1 ^ ", " ^ ctyp c2 ^ ")") ccs) 108 | ^ "])" 109 | | TyObj (_, c, _) -> "TyObj ("^ ctyp c ^ ", ?)" 110 | | TyOlb (_, s, c) -> "TyOlb ("^s ^ "," ^ ctyp c ^")" 111 | | TyOf (_, c1, c2) -> "TyOf ("^ ctyp c1 ^ ", " ^ ctyp c2 ^ ")" 112 | | TyOr (_, c1, c2) -> "TyOr ("^ ctyp c1 ^ ", " ^ ctyp c2 ^ ")" 113 | | TyRec (_, c) -> "TyRec("^ctyp c^")" 114 | | TySum (_, c) -> "TySum("^ctyp c^")" 115 | | TyPrv (_, c) -> "TyPrv("^ctyp c^")" 116 | | TyMut (_, c) -> "TyMut("^ctyp c^")" 117 | | TyTup (_, c) -> "TyTup("^ctyp c^")" 118 | | TyVrnEq (_, c) -> "TyVrnEq("^ctyp c^")" 119 | | TyVrnSup (_, c) -> "TyVrnSup("^ctyp c^")" 120 | | TyVrnInf (_, c) -> "TyVrnInf("^ctyp c^")" 121 | | TyCls (_, i) -> "TyCls("^ident i^")" 122 | | TyId (_, i) -> "TyId("^ident i^")" 123 | | TyNil (_) -> "TyNil" 124 | | TyAli (_, c1, c2) -> "TyAli ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 125 | | TyAny (_) -> "TyAny" 126 | | TyApp (_, c1, c2) -> "TyApp ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 127 | | TyArr (_, c1, c2) -> "TyArr ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 128 | | TyMan (_, c1, c2) -> "TyMan ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 129 | | TyPol (_, c1, c2) -> "TyPol ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 130 | | TyQuo (_, s) -> "TyQuo("^s^")" 131 | | TyQuP (_, s) -> "TyQuP("^s^")" 132 | | TyQuM (_, s) -> "TyQuM("^s^")" 133 | | TyVrn (_, s) -> "TyVrn("^s^")" 134 | | TyCol (_, c1, c2) -> "TyCol ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 135 | | TySem (_, c1, c2) -> "TySem ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 136 | | TyCom (_, c1, c2) -> "TyCom ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 137 | | TyAnd (_, c1, c2) -> "TyAnd ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 138 | | TySta (_, c1, c2) -> "TySta ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 139 | | TyVrnInfSup (_, c1, c2) -> "TyVrnInfSup ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 140 | | TyAmp (_, c1, c2) -> "TyAmp ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 141 | | TyOfAmp (_, c1, c2) -> "TyOfAmp ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" 142 | | TyPkg (_, mt) -> failwith "first-class modules not supported" 143 | | TyAnt (_, s) -> "TyAnt("^s^")" 144 | | TyTypePol (_, c1, c2) -> "TyTypoPol("^ ctyp c1^ ", "^ ctyp c2 ^")" 145 | | TyAnP _ -> "TyAnP" 146 | | TyAnM _ -> "TyAnM" 147 | | TyAtt (_,name,_,c) -> "TyAtt("^ name ^", "^ ctyp c ^")" 148 | | TyExt (_,name,args,c) -> "TyExt("^ ident name ^", ["^ (String.concat ", " (List.map ctyp args)) ^ "], " ^ ctyp c ^")" 149 | | TyOpn _ -> "TyOpn" 150 | end 151 | 152 | module Map = struct 153 | 154 | module type OrderedType = Map.OrderedType 155 | 156 | module type S = sig 157 | include Map.S 158 | exception Not_found of key 159 | val fromList : (key * 'a) list -> 'a t 160 | val union_disjoint : 'a t list -> 'a t 161 | val union_disjoint2 : 'a t -> 'a t -> 'a t 162 | end 163 | 164 | module Make(Ord: OrderedType) = struct 165 | 166 | let nf = Not_found 167 | exception Not_found of Ord.t 168 | 169 | include Map.Make(Ord) 170 | 171 | let find s m = 172 | try find s m 173 | with e when e = nf -> raise (Not_found s) 174 | 175 | let fromList : (key * 'a) list -> 'a t = fun elems -> 176 | List.fold_right (F.uncurry add) elems empty 177 | 178 | let union_disjoint2 l r = 179 | fold 180 | (fun k v r -> 181 | if mem k r then invalid_arg "union_disjoint" 182 | else add k v r) l r 183 | 184 | let union_disjoint maps = List.fold_right union_disjoint2 maps empty 185 | 186 | end 187 | 188 | end 189 | 190 | module Set = struct 191 | 192 | module type OrderedType = Set.OrderedType 193 | 194 | module type S = sig 195 | include Set.S 196 | val toList : t -> elt list 197 | val fromList : elt list -> t 198 | end 199 | 200 | module Make (Ord : OrderedType) = struct 201 | include Set.Make(Ord) 202 | let toList t = fold (fun x acc -> x :: acc) t [] 203 | let fromList elems = List.fold_right add elems empty 204 | end 205 | 206 | end 207 | 208 | let random_id length = 209 | let idchars = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_'" in 210 | let nidchars = String.length idchars in 211 | let s = Bytes.create length in 212 | for i = 0 to length - 1 do 213 | Bytes.set s i idchars.[Random.int nidchars] 214 | done; 215 | Bytes.to_string s 216 | 217 | (* The function used in OCaml to convert variant labels to their 218 | integer representations. The formula is given in Jacques 219 | Garrigue's 1998 ML workshop paper. 220 | *) 221 | let tag_hash s = 222 | let acc = ref 0 in 223 | let len = String.length s in 224 | for i = 0 to len - 1 do 225 | let c = String.unsafe_get s i in 226 | let n = Char.code c in 227 | acc := (223 * !acc + n); 228 | done; 229 | acc := !acc land (1 lsl 31 - 1); 230 | if !acc > 0x3fffffff then !acc - (1 lsl 31) else !acc 231 | 232 | let _ = 233 | (* Sanity check to make sure the function doesn't change underneath 234 | us *) 235 | assert (tag_hash "premiums" = tag_hash "squigglier"); 236 | assert (tag_hash "deriving" = 398308260); 237 | assert (tag_hash "Candela" = -1019855834) 238 | 239 | 240 | (* For type variable renaming *) 241 | 242 | let c = "abcdefghijklmnopqrstuvwxyz" 243 | 244 | let rec typevar_of_int x = 245 | assert (x >= 0 && x < 26); 246 | String.make 1 (c.[x]) 247 | -------------------------------------------------------------------------------- /syntax/common/utils.mli: -------------------------------------------------------------------------------- 1 | (* Copyright Jeremy Yallop 2007. 2 | Copyright Grégoire Henry 2011. 3 | This file is free software, distributed under the MIT license. 4 | See the file COPYING for details. 5 | *) 6 | 7 | type ('a, 'b) either = Left of 'a | Right of 'b 8 | 9 | val either_partition : 10 | ('a -> ('b, 'c) either) -> 'a list -> 'b list * 'c list 11 | 12 | module List : sig 13 | include module type of List 14 | val fold_left1 : ('a -> 'a -> 'a) -> 'a list -> 'a 15 | val fold_right1 : ('a -> 'a -> 'a) -> 'a list -> 'a 16 | val range : int -> int -> int list 17 | val last : 'a list -> 'a 18 | val concat_map : ('a -> 'b list) -> 'a list -> 'b list 19 | val concat_map2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list 20 | val mapn : ?init:int -> ('a -> int -> 'b) -> 'a list -> 'b list 21 | val zip : 'a list -> 'b list -> ('a * 'b) list 22 | val split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list 23 | end 24 | 25 | module F : sig 26 | val id : 'a -> 'a 27 | val curry : ('a * 'b -> 'c) -> 'a -> 'b -> 'c 28 | val uncurry : ('a -> 'b -> 'c) -> 'a * 'b -> 'c 29 | end 30 | 31 | module Option : sig 32 | val map : ('a -> 'b) -> 'a option -> 'b option 33 | end 34 | 35 | module DumpAst : sig 36 | val ident : Camlp4.PreCast.Ast.ident -> string 37 | val ctyp : Camlp4.PreCast.Ast.ctyp -> string 38 | end 39 | 40 | module Map : sig 41 | 42 | module type OrderedType = Map.OrderedType 43 | 44 | module type S = sig 45 | include Map.S 46 | exception Not_found of key 47 | val fromList : (key * 'a) list -> 'a t 48 | val union_disjoint : 'a t list -> 'a t 49 | val union_disjoint2 : 'a t -> 'a t -> 'a t 50 | end 51 | 52 | module Make (Ord : OrderedType) : S with type key = Ord.t 53 | 54 | end 55 | 56 | module Set : sig 57 | 58 | module type OrderedType = Set.OrderedType 59 | 60 | module type S = sig 61 | include Set.S 62 | val toList : t -> elt list 63 | val fromList : elt list -> t 64 | end 65 | 66 | module Make (Ord : OrderedType) : S with type elt = Ord.t 67 | 68 | end 69 | 70 | val random_id : int -> string 71 | 72 | val tag_hash : string -> int 73 | 74 | val typevar_of_int : int -> string 75 | -------------------------------------------------------------------------------- /syntax/std/pa_deriving_std.ml: -------------------------------------------------------------------------------- 1 | (* Copyright Jeremy Yallop 2007. 2 | Copyright Grégoire Henry 2011. 3 | This file is free software, distributed under the MIT license. 4 | See the file COPYING for details. 5 | *) 6 | 7 | (* Extend the OCaml grammar to include the `deriving' clause after 8 | type declarations in structure and signatures. *) 9 | 10 | open Pa_deriving_common.Utils 11 | 12 | module Deriving (Syntax : Camlp4.Sig.Camlp4Syntax) = 13 | struct 14 | 15 | open Pa_deriving_common.Base 16 | open Pa_deriving_common.Type 17 | open Pa_deriving_common.Extend 18 | open Camlp4.PreCast 19 | include Syntax 20 | 21 | DELETE_RULE Gram str_item: "type"; opt_nonrec; type_declaration END 22 | DELETE_RULE Gram sig_item: "type"; opt_nonrec; type_declaration END 23 | 24 | open Ast 25 | 26 | 27 | EXTEND Gram 28 | str_item: 29 | [[ "type"; types = type_declaration -> <:str_item< type $types$ >> 30 | | "type"; types = type_declaration; "deriving"; "("; cl = LIST0 [x = UIDENT -> x] SEP ","; ")" -> 31 | try 32 | let decls = display_errors _loc Translate.decls types in 33 | let module U = Untranslate(struct let _loc = _loc end) in 34 | let cl = List.map find cl in 35 | let tdecls = List.map U.decl decls in 36 | <:str_item< type $list:tdecls$ $list:List.map (derive_str _loc decls) cl$ >> 37 | with NoSuchClass classname -> 38 | fatal_error _loc ("deriving: " ^ classname ^ " is not a known `class'") 39 | ]] 40 | ; 41 | sig_item: 42 | [[ "type"; types = type_declaration -> <:sig_item< type $types$ >> 43 | | "type"; types = type_declaration; "deriving"; "("; cl = LIST0 [x = UIDENT -> x] SEP "," ; ")" -> 44 | try 45 | let decls = display_errors _loc Translate.decls types in 46 | let module U = Untranslate(struct let _loc = _loc end) in 47 | let tdecls = List.concat_map U.sigdecl decls in 48 | let cl = List.map find cl in 49 | let ms = List.map (derive_sig _loc decls) cl in 50 | <:sig_item< type $list:tdecls$ $list:ms$ >> 51 | with NoSuchClass classname -> 52 | fatal_error _loc ("deriving: " ^ classname ^ " is not a known `class'") 53 | ]] 54 | ; 55 | END 56 | 57 | end 58 | 59 | module M = Camlp4.Register.OCamlSyntaxExtension(Pa_deriving_common.Id)(Deriving) 60 | -------------------------------------------------------------------------------- /syntax/tc/pa_deriving_tc.ml: -------------------------------------------------------------------------------- 1 | (* Copyright Grégoire Henry 2010. 2 | This file is free software, distributed under the MIT license. 3 | See the file COPYING for details. 4 | *) 5 | 6 | (* Registering type derivers into type-conv. *) 7 | 8 | open Camlp4.PreCast 9 | 10 | open Pa_deriving_common 11 | 12 | let translate_str deriver _ types = 13 | let _loc = Ast.loc_of_ctyp types in 14 | let decls = Base.display_errors _loc Type.Translate.decls types in 15 | Base.derive_str _loc decls deriver 16 | 17 | let translate_sig deriver _ types = 18 | let _loc = Ast.loc_of_ctyp types in 19 | let decls = Base.display_errors _loc Type.Translate.decls types in 20 | Base.derive_sig _loc decls deriver 21 | 22 | let register desc class_ = 23 | let module Desc = (val desc : Defs.ClassDescription) in 24 | let name = String.uncapitalize Desc.classname in 25 | Pa_type_conv.add_generator name (translate_str class_); 26 | Pa_type_conv.add_sig_generator name (translate_sig class_) 27 | 28 | let _ = Base.add_register_hook register 29 | -------------------------------------------------------------------------------- /tests/rejected/README: -------------------------------------------------------------------------------- 1 | This directory contains programs that are syntactically correct but 2 | that are rejected by deriving because the types invovled don't meet 3 | the requirements for the classses in the deriving list. They're here 4 | so that it's easy to check the quality of the error messages produced. 5 | -------------------------------------------------------------------------------- /tests/rejected/a.ml: -------------------------------------------------------------------------------- 1 | (* Reject types called 'a' to avoid confusion with the overloaded type parameter *) 2 | 3 | type a = A 4 | deriving (Eq) 5 | -------------------------------------------------------------------------------- /tests/rejected/alias.ml: -------------------------------------------------------------------------------- 1 | (* Alias variable names must be distinct from parameter names *) 2 | type 'a x = [`Foo] as 'a 3 | deriving (Eq) 4 | -------------------------------------------------------------------------------- /tests/rejected/dump1.ml: -------------------------------------------------------------------------------- 1 | (* private datatypes cannot be instances of dump (because Dump.from_string 2 | constructs values *) 3 | 4 | type p = private F 5 | deriving (Dump) 6 | -------------------------------------------------------------------------------- /tests/rejected/dump2.ml: -------------------------------------------------------------------------------- 1 | (* records with mutable fields cannot be instances of Dump 2 | (because it doesn't preserve sharing *) 3 | 4 | type t = { x : int; mutable y : int ; z : int } 5 | deriving (Dump) 6 | -------------------------------------------------------------------------------- /tests/rejected/enum1.ml: -------------------------------------------------------------------------------- 1 | (* enum for records *) 2 | type r = { x : int } deriving (Enum) 3 | -------------------------------------------------------------------------------- /tests/rejected/enum2.ml: -------------------------------------------------------------------------------- 1 | (* Enum for sum types with arguments *) 2 | type t = X of int | Y 3 | deriving (Enum) 4 | -------------------------------------------------------------------------------- /tests/rejected/enum3.ml: -------------------------------------------------------------------------------- 1 | (* Enum for polymorphic variant types with arguments *) 2 | 3 | type t = [`A of int | `B] deriving (Enum) 4 | -------------------------------------------------------------------------------- /tests/rejected/enum4.ml: -------------------------------------------------------------------------------- 1 | (* Enum for extending polymorphic variant types *) 2 | type t1 = [`A] deriving (Enum) 3 | 4 | type t2 = [`B|t1] deriving (Enum) 5 | -------------------------------------------------------------------------------- /tests/rejected/eq1.ml: -------------------------------------------------------------------------------- 1 | (* Eq for functions *) 2 | type t = int -> int deriving (Eq) 3 | -------------------------------------------------------------------------------- /tests/rejected/eq2.ml: -------------------------------------------------------------------------------- 1 | (* Eq for records with polymorphic fields *) 2 | type r4 = { 3 | l1 : 'a . 'a list 4 | } deriving (Eq) 5 | -------------------------------------------------------------------------------- /tests/rejected/eq3.ml: -------------------------------------------------------------------------------- 1 | (* Eq for classes *) 2 | class c = object end deriving (Eq) 3 | -------------------------------------------------------------------------------- /tests/rejected/eqparams.ml: -------------------------------------------------------------------------------- 1 | (* All types in a group must have the same parameters *) 2 | 3 | type 'a t1 = int 4 | and ('a,'b) t2 = int 5 | and t3 = int 6 | deriving (Eq) 7 | -------------------------------------------------------------------------------- /tests/rejected/functorf.ml: -------------------------------------------------------------------------------- 1 | (* Reject types called 'f' to avoid confusion with the overloaded type parameter *) 2 | type f = F deriving (Functor) 3 | -------------------------------------------------------------------------------- /tests/rejected/infsup.ml: -------------------------------------------------------------------------------- 1 | (* < > variant types *) 2 | type poly6 = [< `A > `B] 3 | deriving (Eq) 4 | -------------------------------------------------------------------------------- /tests/rejected/labels.ml: -------------------------------------------------------------------------------- 1 | type label = x:int -> int 2 | deriving (Eq) 3 | -------------------------------------------------------------------------------- /tests/rejected/polyrec.ml: -------------------------------------------------------------------------------- 1 | (* non-regular datatype *) 2 | 3 | type 'a seq = Nil | Cons of 'a * ('a * 'a) seq 4 | deriving (Eq) 5 | -------------------------------------------------------------------------------- /tests/rejected/polyrecord.ml: -------------------------------------------------------------------------------- 1 | (* Polymorphic variant definitions within polymorphic record field 2 | types *) 3 | type r = { 4 | (* I think this could be supported without too much difficulty, but 5 | it doesn't have much benefit *) 6 | x : 'a. [`Foo of 'a] 7 | 8 | } deriving (Eq) 9 | -------------------------------------------------------------------------------- /tests/rejected/privaterows1.ml: -------------------------------------------------------------------------------- 1 | (* Private rows are currently not supported *) 2 | type poly4 = private [< `A] 3 | -------------------------------------------------------------------------------- /tests/rejected/privaterows2.ml: -------------------------------------------------------------------------------- 1 | (* Private rows are currently not supported *) 2 | type poly4 = private [> `A] 3 | deriving (Eq) 4 | -------------------------------------------------------------------------------- /tests/std/bimap.ml: -------------------------------------------------------------------------------- 1 | (* Bidirectional map {t -> t} *) 2 | 3 | module type S = 4 | sig 5 | type item 6 | type t 7 | val empty : t 8 | val add : item -> item -> t -> t 9 | val find : item -> t -> item 10 | val mem : item -> t -> bool 11 | val rmem : item -> t -> bool 12 | end 13 | 14 | module type OrderedType = sig type t val compare : t -> t -> int end 15 | module Make (Ord : OrderedType) = 16 | struct 17 | type item = Ord.t 18 | type t = (item * item) list 19 | let empty = [] 20 | let add l r list = (l,r)::list 21 | let find = List.assoc 22 | let mem = List.mem_assoc 23 | let rmem item = List.exists (fun (_,i) -> i = item) 24 | end 25 | 26 | -------------------------------------------------------------------------------- /tests/std/bounded_tests.ml: -------------------------------------------------------------------------------- 1 | open Tests_defs 2 | 3 | let nullsum = 4 | begin 5 | assert (Bounded_nullsum.min_bound = N0); 6 | assert (Bounded_nullsum.max_bound = N3); 7 | end 8 | 9 | let poly0 = 10 | begin 11 | assert (Bounded_poly0.min_bound = `T0); 12 | assert (Bounded_poly0.max_bound = `T3); 13 | end 14 | 15 | let tup4 = 16 | begin 17 | assert (Bounded_tup4.min_bound = (min_int, min_int, false, ())); 18 | assert (Bounded_tup4.max_bound = (max_int, max_int, true, ())); 19 | end 20 | 21 | let t = 22 | begin 23 | assert (Bounded_t.min_bound = min_int); 24 | assert (Bounded_t.max_bound = max_int); 25 | end 26 | -------------------------------------------------------------------------------- /tests/std/dump_tests.ml: -------------------------------------------------------------------------------- 1 | open Tests_defs 2 | open Deriving_Dump 3 | 4 | module Test (D : Dump) = 5 | struct 6 | let test v = D.from_string (D.to_string v) = v 7 | end 8 | 9 | let sum = begin 10 | let module T = Test (Dump_sum) in 11 | assert (T.test S0); 12 | assert (T.test (S1 max_int)); 13 | assert (T.test (S2 (min_int, 1243.2))); 14 | assert (T.test (S2 (min_int, 1243.2))); 15 | assert (T.test (S3 (12, 0.0, true))); 16 | assert (T.test (Sunit ())); 17 | assert (T.test (Stup (1001, 10.01))); 18 | end 19 | 20 | let r1 = begin 21 | let module T = Test (Dump_r1) in 22 | assert (T.test {r1_l1 = max_int - 10; r1_l2 = min_int + 10}); 23 | end 24 | 25 | let intseq = begin 26 | let module T = Test (Dump_intseq) in 27 | assert (T.test INil); 28 | assert (T.test (ICons (10, ICons (20, ICons (30, INil))))); 29 | end 30 | 31 | let seq = begin 32 | let module T = Test (Dump_seq (Dump_bool)) in 33 | assert (T.test Nil); 34 | assert (T.test (Cons (true, Cons (false, Cons (true, Nil))))); 35 | end 36 | 37 | let uses_seqs = begin 38 | let module T = Test (Dump_uses_seqs) in 39 | assert (T.test (INil, Nil)); 40 | assert (T.test (INil, Cons (0.0, Cons(10.0, Nil)))); 41 | assert (T.test (ICons (10, ICons(20, INil)), Nil)); 42 | assert (T.test (ICons (10, ICons(20, INil)), 43 | Cons (0.0, Cons(10.0, Nil)))); 44 | end 45 | 46 | let poly1 = begin 47 | let module T = Test (Dump_poly1) in 48 | assert (T.test `T0); 49 | assert (T.test (`T1 (-1231))); 50 | end 51 | 52 | let poly2 = begin 53 | let module T = Test (Dump_poly2) in 54 | assert (T.test (P (10, `T1 11, 12.0))); 55 | end 56 | 57 | let poly3 = begin 58 | let module T = Test (Dump_poly3) in 59 | assert (T.test `Nil); 60 | assert (T.test (`Cons (1, `Cons (2, `Cons (3, `Nil))))); 61 | end 62 | 63 | let poly3b = begin 64 | let module T = Test (Dump_poly3b) in 65 | assert (T.test (10, `Nil, `F)); 66 | assert (T.test (0, `Cons (10, `Cons (11, `Cons (12, `Nil))), `F)); 67 | end 68 | 69 | let poly7 = begin 70 | let module T = Test(Dump_poly7(Dump_bool)) in 71 | let module T' = Test(Dump_poly8(Dump_int)) in 72 | assert (T.test (Foo (`F true))); 73 | assert (T.test (Foo (`F false))); 74 | assert (T'.test {x = `G (`H (`I (Foo (`F (max_int - 1)))))}); 75 | assert (T'.test {x = `G (`H (`I (Foo (`F (min_int + 1)))))}); 76 | end 77 | 78 | let poly10 = begin 79 | let module T = Test (Dump_poly10) in 80 | assert (T.test `F); 81 | assert (T.test `Nil); 82 | assert (T.test (`Cons (12, `Cons (14, `Nil)))); 83 | end 84 | 85 | let mutrec = begin 86 | let module A = Test (Dump_mutrec_a) in 87 | let module B = Test (Dump_mutrec_b) in 88 | let module C = Test (Dump_mutrec_c) in 89 | let module D = Test (Dump_mutrec_d) in 90 | let a = N in 91 | let b = { l1 = S (3, a); l2 = a } in 92 | let c = S (3, S (4, S (5, N))) in 93 | let d = `T b in 94 | assert (A.test a); 95 | assert (B.test b); 96 | assert (C.test c); 97 | assert (D.test d); 98 | end 99 | 100 | let pmutrec = begin 101 | (* 102 | type ('a,'b) pmutrec_a = ('a,'b) pmutrec_c 103 | and ('a,'b) pmutrec_b = { pl1 : ('a,'b) pmutrec_c ; pl2 : ('a,'b) pmutrec_a } 104 | and ('a,'b) pmutrec_c = SS of 'a * ('a,'b) pmutrec_a * 'b 105 | and ('a,'b) pmutrec_d = [`T of ('a,'b) pmutrec_b] 106 | *) 107 | end 108 | 109 | let ff1 = begin 110 | let module T = Test(Dump_ff1(Dump_bool)) in 111 | assert (T.test (F (true,false))); 112 | assert (T.test (G 435)); 113 | end 114 | 115 | let ff2 = begin 116 | let module T = Test(Dump_ff2(Dump_bool)(Dump_int)) in 117 | assert (T.test (F1 (F2 (Nil, 10, None)))); 118 | assert (T.test (F1 (F2 (Cons (true, Cons (false, Nil)), 10, Some 14)))); 119 | end 120 | 121 | let tup0 = begin 122 | let module T = Test (Dump_tup0) in 123 | assert (T.test ()); 124 | end 125 | 126 | let tup2 = begin 127 | let module T = Test (Dump_tup2) in 128 | assert (T.test (10, 10.0)); 129 | assert (T.test (max_int, -10.0)); 130 | end 131 | 132 | let tup3 = begin 133 | let module T = Test (Dump_tup3) in 134 | assert (T.test (0,12.3,true)); 135 | assert (T.test (min_int,-12.3,false)); 136 | end 137 | 138 | let tup4 = begin 139 | let module T = Test (Dump_tup4) in 140 | assert (T.test (0,0,true,())); 141 | assert (T.test (min_int,max_int,false,())); 142 | end 143 | 144 | let t = begin 145 | let module T = Test (Dump_t) in 146 | assert (T.test min_int); 147 | assert (T.test max_int); 148 | assert (T.test 10); 149 | end 150 | 151 | let ii = 152 | begin 153 | let module T = Test (Dump_ii) in 154 | assert (T.test 155 | {int32 = 1073741824l ; int64 = 10737418230L ; nativeint = 2n; }); 156 | end 157 | 158 | let iii = 159 | begin 160 | let module T = Test (Dump_ii') in 161 | assert (T.test 162 | {int32' = 1073741824l ; int64' = 10737418230L ; }); 163 | end 164 | -------------------------------------------------------------------------------- /tests/std/enum_tests.ml: -------------------------------------------------------------------------------- 1 | open Tests_defs 2 | open Deriving_Enum 3 | 4 | let nullsum = 5 | begin 6 | let module E = Enum_nullsum in 7 | 8 | assert (E.succ N0 = N1); 9 | assert (E.succ N1 = N2); 10 | assert (E.succ N2 = N3); 11 | assert (try ignore (E.succ N3); false 12 | with Invalid_argument "succ" -> true); 13 | 14 | assert (try ignore (E.pred N0); false 15 | with Invalid_argument "pred" -> true); 16 | assert (E.pred N1 = N0); 17 | assert (E.pred N2 = N1); 18 | assert (E.pred N3 = N2); 19 | 20 | assert (E.from_enum N0 = 0); 21 | assert (E.from_enum N1 = 1); 22 | assert (E.from_enum N2 = 2); 23 | assert (E.from_enum N3 = 3); 24 | 25 | assert (E.to_enum 0 = N0); 26 | assert (E.to_enum 1 = N1); 27 | assert (E.to_enum 2 = N2); 28 | assert (E.to_enum 3 = N3); 29 | assert (try ignore (E.to_enum 4); false 30 | with Invalid_argument "to_enum" -> true); 31 | 32 | assert (E.enum_from N0 = [N0;N1;N2;N3]); 33 | assert (E.enum_from N1 = [N1;N2;N3]); 34 | assert (E.enum_from N2 = [N2;N3]); 35 | assert (E.enum_from N3 = [N3]); 36 | 37 | assert (E.enum_from_then N0 N1 = [N0;N1;N2;N3]); 38 | assert (E.enum_from_then N0 N2 = [N0;N2]); 39 | assert (E.enum_from_then N1 N2 = [N1;N2;N3]); 40 | assert (E.enum_from_then N1 N3 = [N1;N3]); 41 | assert (try ignore (E.enum_from_then N3 N3); false 42 | with Invalid_argument _ -> true); 43 | assert (try ignore (E.enum_from_then N3 N1); false 44 | with Invalid_argument _ -> true); 45 | 46 | assert (E.enum_from_to N0 N1 = [N0;N1]); 47 | assert (E.enum_from_to N1 N3 = [N1;N2;N3]); 48 | assert (E.enum_from_to N1 N1 = [N1]); 49 | assert (E.enum_from_to N1 N0 = []); 50 | 51 | assert (E.enum_from_then_to N0 N1 N3 = [N0;N1;N2;N3]); 52 | assert (E.enum_from_then_to N0 N2 N3 = [N0;N2]); 53 | assert (E.enum_from_then_to N0 N3 N3 = [N0;N3]); 54 | assert (try ignore (E.enum_from_then_to N0 N0 N0); false 55 | with Invalid_argument _ -> true); 56 | end 57 | 58 | let poly0 = 59 | begin 60 | let module E = Enum_poly0 in 61 | 62 | assert (E.succ `T0 = `T1); 63 | assert (E.succ `T1 = `T2); 64 | assert (E.succ `T2 = `T3); 65 | assert (try ignore (E.succ `T3); false 66 | with Invalid_argument "succ" -> true); 67 | 68 | assert (try ignore (E.pred `T0); false 69 | with Invalid_argument "pred" -> true); 70 | assert (E.pred `T1 = `T0); 71 | assert (E.pred `T2 = `T1); 72 | assert (E.pred `T3 = `T2); 73 | 74 | end 75 | 76 | let t = 77 | begin 78 | ListLabels.iter (Enum_int.enum_from_to (-1000) 1000) 79 | ~f:(fun i -> 80 | assert (Enum_t.succ i = i+1); 81 | assert (Enum_t.pred i = i-1); 82 | assert (Enum_t.to_enum i = i); 83 | assert (Enum_t.from_enum i = i)); 84 | end 85 | -------------------------------------------------------------------------------- /tests/std/eq_tests.ml: -------------------------------------------------------------------------------- 1 | open Tests_defs 2 | 3 | open Deriving_Eq 4 | 5 | let sum = 6 | begin 7 | assert (Eq_sum.eq S0 S0); 8 | assert (not (Eq_sum.eq S0 (S1 0))); 9 | assert (Eq_sum.eq (S1 0) (S1 0)); 10 | assert (Eq_sum.eq (Stup (3,0.0)) (Stup (3,0.0))); 11 | assert (not (Eq_sum.eq (Stup (0,0.0)) (Stup (1,0.0)))); 12 | end 13 | 14 | let nullsum = 15 | begin 16 | assert (Eq_nullsum.eq N2 N2) 17 | end 18 | 19 | let r1 = 20 | begin 21 | assert (Eq_r1.eq 22 | { r1_l1 = 10; r1_l2 = 20 } 23 | { r1_l1 = 10; r1_l2 = 20 }); 24 | assert (not (Eq_r1.eq 25 | { r1_l1 = 20; r1_l2 = 10 } 26 | { r1_l1 = 10; r1_l2 = 20 })); 27 | assert (not (Eq_r1.eq 28 | { r1_l1 = 20; r1_l2 = 10 } 29 | { r1_l1 = 20; r1_l2 = 20 })); 30 | end 31 | 32 | let r2 = 33 | begin 34 | let l, r = ({ r2_l1 = 10; r2_l2 = 20}, 35 | { r2_l1 = 10; r2_l2 = 20}) in 36 | assert (Eq_r2.eq l l); 37 | assert (not (Eq_r2.eq l r)); 38 | assert (not (Eq_r2.eq r l)); 39 | end 40 | 41 | let r3 = 42 | begin 43 | let l, r = ({ r3_l1 = 10; r3_l2 = 20}, 44 | { r3_l1 = 10; r3_l2 = 20}) in 45 | assert (Eq_r3.eq l l); 46 | assert (not (Eq_r3.eq l r)); 47 | assert (not (Eq_r3.eq r l)); 48 | end 49 | 50 | let intseq = 51 | begin 52 | assert (Eq_intseq.eq INil INil); 53 | assert (Eq_intseq.eq 54 | (ICons (1,INil)) 55 | (ICons (1,INil))); 56 | assert (not (Eq_intseq.eq 57 | (ICons (1,INil)) 58 | INil)); 59 | assert (not (Eq_intseq.eq 60 | INil 61 | (ICons (1,INil)))); 62 | assert (not (Eq_intseq.eq 63 | INil 64 | (let rec i = ICons(1,i) in i))); 65 | end 66 | 67 | let uses_seqs = 68 | begin 69 | let eq = Eq_uses_seqs.eq in 70 | assert (eq (INil,Cons(1.0,Nil)) (INil,Cons(1.0,Nil))); 71 | assert (not (eq (INil,Cons(1.0,Nil)) (INil,Cons(2.0,Nil)))); 72 | assert (not (eq (ICons (1,INil),Nil) (INil,Nil))); 73 | end 74 | 75 | let poly0 = 76 | begin 77 | let eq = Eq_poly0.eq in 78 | assert (eq `T0 `T0); 79 | assert (not (eq `T1 `T3)); 80 | end 81 | 82 | let poly1 = 83 | begin 84 | let eq = Eq_poly1.eq in 85 | assert (eq `T0 `T0); 86 | assert (eq (`T1 10) (`T1 10)); 87 | assert (not (eq (`T1 20) (`T1 10))); 88 | assert (not (eq (`T1 20) `T0)); 89 | end 90 | 91 | let poly2 = 92 | begin 93 | let eq = Eq_poly2.eq in 94 | assert (eq (P (3, `T0, 0.0)) (P (3, `T0, 0.0))); 95 | assert (eq (P (4, `T1 10, 2.0)) (P (4, `T1 10, 2.0))); 96 | assert (not (eq (P (5, `T1 10, 2.0)) (P (5, `T0, 2.0)))); 97 | assert (not (eq (P (6, `T0, 2.0)) (P (6, `T0, 10.0)))); 98 | assert (not (eq (P (0, `T0, 2.0)) (P (7, `T0, 2.0)))); 99 | end 100 | 101 | 102 | let poly3 = 103 | begin 104 | let eq = Eq_poly3.eq in 105 | assert (eq `Nil `Nil); 106 | assert (eq (`Cons (3,`Nil)) (`Cons (3,`Nil))); 107 | assert (eq (`Cons (3,`Cons (4,`Nil))) (`Cons (3,`Cons (4,`Nil)))); 108 | assert (not (eq (`Cons (3,`Cons (4,`Nil))) (`Cons (3,`Nil)))); 109 | end 110 | 111 | let poly3b = 112 | begin 113 | let eq = Eq_poly3b.eq in 114 | assert (eq (0,`Nil,`F) (0,`Nil,`F)); 115 | assert (not (eq (0,`Cons (1,`Nil),`F) (0,`Nil,`F))); 116 | assert (not (eq (1,`Nil,`F) (0,`Nil,`F))); 117 | end 118 | 119 | 120 | let poly7_8 = 121 | begin 122 | let module M7 = Eq_poly7(Eq_int) in 123 | let module M8 = Eq_poly8(Eq_int) in 124 | assert (M7.eq (Foo (`F 0)) (Foo (`F 0))); 125 | assert (not (M7.eq (Foo (`F 0)) (Foo (`F 1)))); 126 | assert (M8.eq 127 | {x = `G (`H (`I (Foo (`F 0))))} 128 | {x = `G (`H (`I (Foo (`F 0))))}); 129 | assert (not 130 | (M8.eq 131 | {x = `G (`H (`I (Foo (`F 0))))} 132 | {x = `G (`H (`I (Foo (`F 1))))})); 133 | end 134 | 135 | let poly10 = 136 | begin 137 | let eq = Eq_poly10.eq in 138 | assert (eq `F `F); 139 | assert (eq `Nil `Nil); 140 | assert (not (eq `Nil `F)); 141 | end 142 | 143 | let mutrec = 144 | begin 145 | let rec cyclic_1 = S (0, cyclic_2) 146 | and cyclic_2 = S (1, cyclic_1) in 147 | assert (not (Eq_mutrec_a.eq cyclic_1 cyclic_2)); 148 | assert (not 149 | (Eq_mutrec_d.eq 150 | (`T {l1 = cyclic_1; l2 = cyclic_2}) 151 | (`T {l1 = cyclic_2; l2 = cyclic_1}))); 152 | end 153 | 154 | let pmutrec = 155 | begin 156 | let module M_a = Eq_pmutrec_a(Eq_int)(Eq_bool) in 157 | let module M_b = Eq_pmutrec_b(Eq_int)(Eq_bool) in 158 | let module M_c = Eq_pmutrec_c(Eq_int)(Eq_bool) in 159 | let module M_d = Eq_pmutrec_d(Eq_int)(Eq_bool) in 160 | 161 | let rec cyclic_1 = SS (0, cyclic_2, true) 162 | and cyclic_2 = SS (1, cyclic_1, true) in 163 | assert (not (M_a.eq cyclic_1 cyclic_2)); 164 | assert (not 165 | (M_d.eq 166 | (`T {pl1 = cyclic_1; pl2 = cyclic_2}) 167 | (`T {pl1 = cyclic_2; pl2 = cyclic_1}))); 168 | end 169 | 170 | 171 | let ff1 = 172 | begin 173 | let module M = Eq_ff1(Eq_bool) in 174 | assert (M.eq (F (true,false)) (F (true,false))); 175 | assert (M.eq (G (-1)) (G (-1))); 176 | assert (not (M.eq (F (false,true)) (F (true,false)))); 177 | assert (not (M.eq (G (-1)) (G 0))); 178 | assert (not (M.eq (G (-1)) (F (true, true)))); 179 | end 180 | 181 | let ff2 = 182 | begin 183 | let module M = Eq_ff2(Eq_bool)(Eq_bool) in 184 | assert (M.eq 185 | (F1 (F2 (Cons (true,Nil), 0, None))) 186 | (F1 (F2 (Cons (true,Nil), 0, None)))); 187 | 188 | assert (not (M.eq 189 | (F2 (Nil, 0, None)) 190 | (F2 (Cons (true,Nil), 0, None)))); 191 | 192 | assert (not (M.eq 193 | (F2 (Cons (true,Nil), 0, Some true)) 194 | (F2 (Cons (true,Nil), 0, Some false)))); 195 | 196 | assert (not (M.eq 197 | (F2 (Cons (true,Nil), 0, None)) 198 | (F2 (Cons (true,Nil), 0, Some false)))); 199 | end 200 | 201 | let tup0 = 202 | begin 203 | assert (Eq_tup0.eq () ()); 204 | end 205 | 206 | let tup2 = 207 | begin 208 | assert (Eq_tup2.eq (10,5.0) (10,5.0)); 209 | assert (not (Eq_tup2.eq (10,5.0) (11,5.0))); 210 | assert (not (Eq_tup2.eq (10,5.0) (10,4.0))); 211 | end 212 | 213 | let tup3 = 214 | begin 215 | assert (Eq_tup3.eq (10,2.5,true) (10,2.5,true)); 216 | assert (not (Eq_tup3.eq (10,2.5,true) (11,2.5,true))); 217 | assert (not (Eq_tup3.eq (10,2.5,true) (10,2.4,true))); 218 | assert (not (Eq_tup3.eq (10,2.5,true) (10,2.5,false))); 219 | end 220 | 221 | let tup4 = 222 | begin 223 | assert (Eq_tup4.eq (1,2,true,()) (1,2,true,())); 224 | assert (not (Eq_tup4.eq (1,2,true,()) (0,2,true,()))); 225 | assert (not (Eq_tup4.eq (1,2,true,()) (1,3,true,()))); 226 | assert (not (Eq_tup4.eq (1,2,true,()) (1,2,false,()))); 227 | end 228 | 229 | let withref = 230 | begin 231 | let x = ref 0 in 232 | assert (Eq_withref.eq (WR (0,x)) (WR (0,x))); 233 | assert (not (Eq_withref.eq (WR (0,x)) (WR (0,ref 0)))); 234 | end 235 | 236 | let t = 237 | begin 238 | assert (Eq_t.eq 0 0); 239 | assert (Eq_t.eq (-10) (-10)); 240 | assert (Eq_t.eq 14 14); 241 | assert (not (Eq_t.eq 14 0)); 242 | assert (not (Eq_t.eq 0 14)); 243 | assert (not (Eq_t.eq (-1) 0)); 244 | end 245 | 246 | let ii = 247 | begin 248 | assert (Eq_ii.eq 249 | {int32 = 0l ; int64 = 1L ; nativeint = 2n; } 250 | {int32 = 0l ; int64 = 1L ; nativeint = 2n; }); 251 | assert (not (Eq_ii.eq 252 | {int32 = 0l ; int64 = 1L ; nativeint = 2n; } 253 | {int32 = 1l ; int64 = 1L ; nativeint = 2n; })); 254 | assert (not (Eq_ii.eq 255 | {int32 = 0l ; int64 = 1L ; nativeint = 2n; } 256 | {int32 = 0l ; int64 = 2L ; nativeint = 2n; })); 257 | assert (not (Eq_ii.eq 258 | {int32 = 0l ; int64 = 1L ; nativeint = 2n; } 259 | {int32 = 0l ; int64 = 1L ; nativeint = 3n; })); 260 | end 261 | 262 | let ii' = 263 | begin 264 | assert (Eq_ii'.eq 265 | {int32' = 0l ; int64' = 1L ; } 266 | {int32' = 0l ; int64' = 1L ; }); 267 | assert (not (Eq_ii'.eq 268 | {int32' = 0l ; int64' = 1L ; } 269 | {int32' = 1l ; int64' = 1L ; })); 270 | assert (not (Eq_ii'.eq 271 | {int32' = 0l ; int64' = 1L ; } 272 | {int32' = 0l ; int64' = 2L ; })); 273 | end 274 | -------------------------------------------------------------------------------- /tests/std/exp.ml: -------------------------------------------------------------------------------- 1 | open Deriving_Eq 2 | open Deriving_Dump 3 | open Deriving_Typeable 4 | open Deriving_Pickle 5 | 6 | 7 | module Env = Bimap.Make(String) 8 | 9 | type name = string deriving (Show, Dump, Typeable) 10 | module Eq_string : Eq with type a = name = 11 | struct 12 | type a = name 13 | let eq = (=) 14 | end 15 | module Pickle_name 16 | = Pickle_from_dump(Dump_string)(Eq_string)(Typeable_string) 17 | 18 | module rec Exp : 19 | sig 20 | type exp = Var of name 21 | | App of exp * exp 22 | | Abs of name * exp 23 | deriving (Eq,Show,Pickle,Typeable,Dump) 24 | end = 25 | struct 26 | module Eq_exp = struct 27 | open Exp 28 | type a = exp 29 | let eq : exp -> exp -> bool 30 | = let rec alpha_eq env l r = match l, r with 31 | | Var l, Var r when Env.mem l env -> 32 | Env.find l env = r 33 | | Var l, Var r -> 34 | not (Env.rmem r env) && l = r 35 | | App (fl,pl), App (fr,pr) -> 36 | alpha_eq env fl fr && alpha_eq env pl pr 37 | | Abs (vl,bl), Abs (vr,br) -> 38 | alpha_eq (Env.add vl vr env) bl br 39 | | _ -> false 40 | in alpha_eq Env.empty 41 | end 42 | type exp = Var of name 43 | | App of exp * exp 44 | | Abs of name * exp 45 | deriving (Show, Typeable, Pickle,Dump) 46 | end 47 | 48 | open Exp 49 | (* 50 | let args = ref [] 51 | *) 52 | let discover_sharing : exp -> 'a = 53 | let find (next,dynmap) obj = 54 | let repr = Obj.repr obj in 55 | try List.assq repr dynmap, next, dynmap 56 | with Not_found -> next,next+1,(repr,next)::dynmap in 57 | let rec discover (next,dynmap) = function 58 | | Var s as v -> 59 | let (id,next,dynmap) = find (next,dynmap) v in 60 | Printf.printf "Var %d\n" id; 61 | let (id,next,dynmap) = find (next,dynmap) s in 62 | Printf.printf "string: %s %d\n" s id; 63 | (next, dynmap) 64 | 65 | | App (e1,e2) as a -> 66 | let (id,next,dynmap) = find (next,dynmap) a in 67 | Printf.printf "App %d\n" id; 68 | let (next,dynmap) = discover (next,dynmap) e1 in 69 | let (next,dynmap) = discover (next,dynmap) e2 in 70 | (next,dynmap) 71 | 72 | | Abs (s,e) as l -> 73 | let (id,next,dynmap) = find (next,dynmap) l in 74 | Printf.printf "Abs %d\n" id; 75 | let (id,next,dynmap) = find (next,dynmap) s in 76 | Printf.printf "string: %s %d\n" s id; 77 | let (next,dynmap) = discover (next,dynmap) e in 78 | (next,dynmap) 79 | in fun e -> (discover (1,[]) e) 80 | 81 | 82 | 83 | let y = 84 | Abs ("a", 85 | App (Abs ("b", 86 | App (Var "a", 87 | Abs ("c", 88 | App (App (Var "b", 89 | Var "b"), 90 | Var "c")))), 91 | Abs ("d", 92 | App (Var "a", 93 | Abs ("e", 94 | App (App (Var "d", 95 | Var "d"), 96 | Var "e")))))) 97 | let app e1 e2 = App (e1, e2) 98 | 99 | let abs (v,e) = Abs (v,e) 100 | 101 | let freevar x = Var x 102 | 103 | let rec term_size = function 104 | | Var _ -> 1 105 | | App (e1,e2) -> term_size e1 + term_size e2 106 | | Abs (_, body) -> 1 + term_size body 107 | -------------------------------------------------------------------------------- /tests/std/functor_tests.ml: -------------------------------------------------------------------------------- 1 | open Tests_defs 2 | 3 | let r1 = 4 | begin 5 | let map : r1 -> r1 = Functor_r1.map in 6 | let x = {r1_l1 = 2; r1_l2 = 12} in 7 | 8 | assert (map x = x); 9 | end 10 | 11 | let intseq = 12 | begin 13 | let map : intseq -> intseq = Functor_intseq.map in 14 | let i = ICons (0, ICons (1, ICons (2, INil))) in 15 | assert (map i = i); 16 | end 17 | 18 | let seq = 19 | begin 20 | let map = 21 | let module M : sig val map : ('a -> 'b) -> 'a seq -> 'b seq end 22 | = struct let map = Functor_seq.map end in M.map in 23 | assert (map ((+)1) (Cons (1, Cons (2, Cons (3, Cons (4, Nil))))) 24 | = Cons (2, Cons (3, Cons (4, Cons (5, Nil))))); 25 | end 26 | 27 | let poly7 = 28 | begin 29 | let map = 30 | let module M : sig val map : ('a -> 'b) -> 'a poly7 -> 'b poly7 end 31 | = struct let map = Functor_poly7.map end in M.map in 32 | assert (map ((+)1) (Foo (`F 0)) = Foo (`F 1)); 33 | end 34 | 35 | let poly8 = 36 | begin 37 | let map = 38 | let module M : sig val map : ('a -> 'b) -> 'a poly8 -> 'b poly8 end 39 | = struct let map = Functor_poly8.map end in M.map in 40 | assert (map ((+)1) 41 | { x = `G (`H (`I (Foo (`F 0))))} 42 | = { x = `G (`H (`I (Foo (`F 1))))}); 43 | end 44 | 45 | let poly10 = 46 | begin 47 | let map : poly10 -> poly10 = Functor_poly10.map in 48 | assert (map `F = `F); 49 | assert (map (`Cons (1,`Cons (2, `Nil))) = (`Cons (1,`Cons (2, `Nil)))); 50 | end 51 | 52 | let pmutrec = 53 | begin 54 | let _ = 55 | let module M : sig val map : ('a -> 'b) -> ('c -> 'd) -> ('a,'c) pmutrec_a -> ('b,'d) pmutrec_a end 56 | = struct let map = Functor_pmutrec_a.map end in M.map in 57 | let _ = 58 | let module M : sig val map : ('a -> 'b) -> ('c -> 'd) -> ('a,'c) pmutrec_b -> ('b,'d) pmutrec_b end 59 | = struct let map = Functor_pmutrec_b.map end in M.map in 60 | let _ = 61 | let module M : sig val map : ('a -> 'b) -> ('c -> 'd) -> ('a,'c) pmutrec_c -> ('b,'d) pmutrec_c end 62 | = struct let map = Functor_pmutrec_c.map end in M.map in 63 | let _ = 64 | let module M : sig val map : ('a -> 'b) -> ('c -> 'd) -> ('a,'c) pmutrec_d -> ('b,'d) pmutrec_d end 65 | = struct let map = Functor_pmutrec_d.map end in M.map in 66 | () 67 | end 68 | 69 | let ff1 = 70 | begin 71 | let map = 72 | let module M : sig val map : ('a -> 'b) -> 'a ff1 -> 'b ff1 end 73 | = struct let map = Functor_ff1.map end in M.map in 74 | assert (map ((+)1) (F (1,2)) = F (2,3)); 75 | assert (map ((+)1) (G 3) = G 3); 76 | end 77 | 78 | let ff2 = 79 | begin 80 | let map f = 81 | let module M : sig val map : ('a -> 'b) -> ('c -> 'd) -> ('a,'c) ff2 -> ('b,'d) ff2 end 82 | = struct let map = Functor_ff2.map end in M.map f in 83 | assert (map ((+)1) not (F1 (F2 (Cons (1,Cons (2, Nil)), 3, Some true))) 84 | = (F1 (F2 (Cons (2,Cons (3, Nil)), 3, Some false)))); 85 | 86 | assert (map not ((+)1) (F1 (F2 (Cons (true,Nil), 3, Some 0))) 87 | = (F1 (F2 (Cons (false,Nil), 3, Some 1)))); 88 | end 89 | 90 | (* 91 | type 'a constrained = [`F of 'a] constraint 'a = int 92 | *) 93 | 94 | let t = 95 | begin 96 | let map : int -> int = Functor_t.map in 97 | assert (map 12 = 12); 98 | end 99 | -------------------------------------------------------------------------------- /tests/std/inline.ml: -------------------------------------------------------------------------------- 1 | let _ = 2 | Eq.eq true false 3 | 4 | 5 | let _ = 6 | Show.show<(bool * string) list option> 7 | (Some ([true, "yes"; 8 | false, "no"])) 9 | 10 | let _ = 11 | [Typeable.mk 3; 12 | Typeable.mk 3.0; 13 | Typeable.mk [1;2;3]] 14 | 15 | type 'a seq = [`Nil | `Cons of 'a * 'a seq] 16 | deriving (Typeable) 17 | 18 | type nil = [`Nil] 19 | deriving (Typeable) 20 | type intlist = ([nil| `Cons of int * 'a ] as 'a) 21 | deriving (Typeable) 22 | 23 | let t1 = Lazy.force (Typeable.type_rep) 24 | let t2 = Lazy.force (Typeable.type_rep) 25 | let _ = Deriving_Typeable.TypeRep.eq t1 t2 26 | 27 | let _ = 28 | Typeable.throwing_cast 29 | (Typeable.mk (`Cons (1, `Cons (2, `Cons (3, `Nil))))) 30 | 31 | let _ = 32 | Eq.eq true (Eq.eq 3 4) 33 | 34 | let _ = 35 | print_endline "Tests succeeded!" 36 | -------------------------------------------------------------------------------- /tests/std/notc.ml: -------------------------------------------------------------------------------- 1 | open Tests_defs 2 | open Sigs 3 | open Pickle_tests 4 | open Typeable_tests 5 | open Bounded_tests 6 | open Eq_tests 7 | open Dump_tests 8 | open Enum_tests 9 | open Functor_tests 10 | open Show_tests 11 | open Exp 12 | open Inline 13 | -------------------------------------------------------------------------------- /tests/std/pickle_tests.ml: -------------------------------------------------------------------------------- 1 | open Tests_defs 2 | open Deriving_Eq 3 | open Deriving_Pickle 4 | 5 | module Test (S : Pickle) = 6 | struct 7 | let test v = S.Eq.eq (S.from_string (S.to_string v)) v 8 | end 9 | 10 | let sum = 11 | begin 12 | let test = let module T = Test(Pickle_sum) in T.test in 13 | assert (test S0); 14 | assert (test (S1 3)); 15 | assert (test (S2 (10,2.0))); 16 | assert (test (Sunit ())); 17 | assert (test (Stup (10,2.0))); 18 | assert (test (Stup1 3)); 19 | end 20 | 21 | let nullsum = 22 | begin 23 | let test = let module T = Test(Pickle_nullsum) in T.test in 24 | assert (test N0); 25 | assert (test N1); 26 | assert (test N2); 27 | assert (test N3); 28 | end 29 | 30 | let r1 = 31 | begin 32 | let test = let module T = Test(Pickle_r1) in T.test in 33 | assert (test {r1_l1 = 10; r1_l2 = 20}); 34 | assert (test {r1_l1 = min_int; r1_l2 = max_int}); 35 | assert (test {r1_l1 = max_int; r1_l2 = min_int}); 36 | end 37 | 38 | let r2 = 39 | begin 40 | let v = { r2_l1 = 10; 41 | r2_l2 = 14 } in 42 | assert (not (Eq_r2.eq 43 | (Pickle_r2.from_string 44 | (Pickle_r2.to_string v)) v)); 45 | assert (Pickle_r2.from_string 46 | (Pickle_r2.to_string v) = v); 47 | end 48 | 49 | let r3 = 50 | begin 51 | let v = { r3_l1 = 10; 52 | r3_l2 = 14 } in 53 | assert (not (Eq_r3.eq 54 | (Pickle_r3.from_string 55 | (Pickle_r3.to_string v)) v)); 56 | assert (Pickle_r3.from_string 57 | (Pickle_r3.to_string v) = v); 58 | end 59 | 60 | let intseq = 61 | begin 62 | let test = let module T = Test(Pickle_intseq) in T.test in 63 | assert (test INil); 64 | assert (test (ICons (10, ICons (20, ICons (30, ICons (40, INil)))))); 65 | assert (test (ICons (max_int, ICons (min_int, INil)))); 66 | end 67 | 68 | let seq = 69 | begin 70 | let test = let module T = Test(Pickle_seq(Pickle_bool)) in T.test in 71 | let test' = let module T = Test(Pickle_seq(Pickle_seq(Pickle_bool))) in T.test in 72 | 73 | assert (test Nil); 74 | assert (test (Cons (false, Cons (true, Cons (false, Nil))))); 75 | assert (test' Nil); 76 | assert (test' (Cons (Cons (false, Cons (true, Nil)), 77 | Cons (Cons (true, Cons (false, Nil)), 78 | Nil)))); 79 | end 80 | 81 | let uses_seqs = 82 | begin 83 | let test = let module T = Test(Pickle_uses_seqs) in T.test in 84 | assert (test (INil, Nil)); 85 | assert (test (INil, Cons (0.0, Cons(10.0, Nil)))); 86 | assert (test (ICons (10, ICons(20, INil)), Nil)); 87 | assert (test (ICons (10, ICons(20, INil)), 88 | Cons (0.0, Cons(10.0, Nil)))); 89 | end 90 | 91 | type permute0 = [`T3 | `T1 | `T2 | `T0] deriving (Typeable, Eq, Pickle) 92 | let poly0 = 93 | begin 94 | let test v = Eq_permute0.eq (Pickle_permute0.from_string (Pickle_poly0.to_string v)) v in 95 | assert (test `T0); 96 | assert (test `T1); 97 | assert (test `T2); 98 | assert (test `T3); 99 | end 100 | 101 | type permute3 = [`Nil | `Cons of int * permute3] deriving (Typeable, Eq, Pickle) 102 | let _ = 103 | begin 104 | let test v = Eq_permute3.eq (Pickle_permute3.from_string (Pickle_poly3.to_string v)) v in 105 | assert (test `Nil); 106 | assert (test (`Cons (0, `Cons (1, `Cons (2, `Nil))))); 107 | end 108 | 109 | let poly3b = 110 | begin 111 | let test = let module T = Test(Pickle_poly3b) in T.test in 112 | assert (test (10, `Nil, `F)); 113 | assert (test (10, `Cons (10, `Cons (-20, `Nil)), `F)); 114 | end 115 | 116 | let _ = 117 | begin 118 | let test = let module T = Test(Pickle_poly7(Pickle_bool)) in T.test 119 | and test' = let module T = Test(Pickle_poly8(Pickle_int)) in T.test in 120 | assert (test (Foo (`F true))); 121 | assert (test (Foo (`F false))); 122 | assert (test' {x = `G (`H (`I (Foo (`F (max_int - 1)))))}); 123 | assert (test' {x = `G (`H (`I (Foo (`F (min_int + 1)))))}); 124 | end 125 | 126 | let _ = 127 | begin 128 | let test = let module T = Test(Pickle_poly10) in T.test in 129 | assert (test `F); 130 | assert (test `Nil); 131 | assert (test (`Cons (12, `Cons (14, `Nil)))); 132 | end 133 | 134 | let mutrec = 135 | begin 136 | let module A = Test(Pickle_mutrec_a) in 137 | let module B = Test(Pickle_mutrec_b) in 138 | let module C = Test(Pickle_mutrec_c) in 139 | let module D = Test(Pickle_mutrec_d) in 140 | let a = N in 141 | let b = { l1 = S (3, a); l2 = a } in 142 | let c = S (3, S (4, S (5, N))) in 143 | let d = `T b in 144 | assert (A.test a); 145 | assert (B.test b); 146 | assert (C.test c); 147 | assert (D.test d); 148 | end 149 | 150 | let pmutrec = 151 | begin 152 | (* 153 | type ('a,'b) pmutrec_a = ('a,'b) pmutrec_c 154 | and ('a,'b) pmutrec_b = { pl1 : ('a,'b) pmutrec_c ; pl2 : ('a,'b) pmutrec_a } 155 | and ('a,'b) pmutrec_c = SS of 'a * ('a,'b) pmutrec_a * 'b 156 | and ('a,'b) pmutrec_d = [`T of ('a,'b) pmutrec_b] 157 | *) 158 | end 159 | 160 | let ff1 = 161 | begin 162 | let test = let module T = Test(Pickle_ff1(Pickle_bool)) in T.test in 163 | assert (test (F (true,false))); 164 | assert (test (G 435)); 165 | end 166 | 167 | let ff2 = 168 | begin 169 | let test = let module T = Test(Pickle_ff2(Pickle_bool)(Pickle_int)) in T.test in 170 | assert (test (F1 (F2 (Nil, 10, None)))); 171 | assert (test (F1 (F2 (Cons (true, Cons (false, Nil)), 10, Some 14)))); 172 | end 173 | 174 | let unit = 175 | begin 176 | let test = let module T = Test(Pickle_unit) in T.test in 177 | assert (test ()); 178 | end 179 | 180 | let tup2 = 181 | begin 182 | let test = let module T = Test(Pickle_tup2) in T.test in 183 | assert (test (-10,12e4)); 184 | assert (test (max_int,12e4)); 185 | end 186 | 187 | let tup3 = 188 | begin 189 | let test = let module T = Test(Pickle_tup3) in T.test in 190 | assert (test (0,12.3,true)); 191 | assert (test (min_int,-12.3,false)); 192 | end 193 | 194 | let tup4 = 195 | begin 196 | let test = let module T = Test(Pickle_tup4) in T.test in 197 | assert (test (0,0,true,())); 198 | assert (test (min_int,max_int,false,())); 199 | end 200 | 201 | let withref = 202 | begin 203 | let v = WR (10, ref 20) in 204 | assert (not 205 | (Eq_withref.eq (Pickle_withref.from_string 206 | (Pickle_withref.to_string v)) v)); 207 | assert (Pickle_withref.from_string 208 | (Pickle_withref.to_string v) = v); 209 | end 210 | 211 | let t = 212 | begin 213 | let test v = Eq_int.eq (Pickle_int.from_string (Pickle_t.to_string v)) v in 214 | assert (test min_int); 215 | assert (test max_int); 216 | assert (test 10); 217 | end 218 | 219 | type refobj = A | B of refobj ref 220 | deriving (Eq, Typeable, Pickle) 221 | 222 | let circular = 223 | let s = ref A in 224 | let r = B s in 225 | s := r; 226 | r 227 | 228 | let _ = 229 | let v = Pickle_refobj.from_string (Pickle_refobj.to_string circular) in 230 | let (B {contents = 231 | B {contents = 232 | B {contents = 233 | B {contents = 234 | B {contents = 235 | B {contents = 236 | B {contents = _ }}}}}}}) = v in 237 | () 238 | 239 | 240 | type mut = { 241 | mutable x : mut option; 242 | mutable y : mut option; 243 | z : int; 244 | } deriving (Eq, Typeable, Pickle) 245 | 246 | let circularm = 247 | let i = {z = 1; x = None; y = None} in 248 | let j = {z = 2; x = None; y = Some i} in 249 | i.x <- Some j; 250 | i.y <- Some i; 251 | j.x <- Some j; 252 | i 253 | 254 | let _ = 255 | let v = Pickle_mut.from_string (Pickle_mut.to_string circularm) in 256 | let {z = 1; 257 | x = Some {z = 2; x = Some {z = 2; 258 | x = Some _; 259 | y = Some _}; 260 | y = Some _}; 261 | y = Some {z = 1; 262 | x = Some {z = 2; x = Some {z = 2; 263 | x = Some {z = 2; 264 | x = Some _; 265 | y = Some _}; 266 | y = Some _}; 267 | y = Some _}; 268 | y = Some _}} = v in 269 | () 270 | 271 | type t1 = { mutable x : t2 option } 272 | and t2 = { y : t1 option } 273 | deriving (Eq, Typeable, Pickle) 274 | 275 | let circular_a = 276 | let a = { x = None } in 277 | let b = { y = Some a } in 278 | a.x <- Some b; 279 | a 280 | 281 | let _ = 282 | let {x = Some {y = Some 283 | {x = Some {y = Some 284 | {x = Some {y = Some 285 | {x = Some {y = Some _}}}}}}}} = 286 | Pickle_t1.from_string (Pickle_t1.to_string circular_a) in 287 | () 288 | -------------------------------------------------------------------------------- /tests/std/show_tests.ml: -------------------------------------------------------------------------------- 1 | module type A = sig 2 | type t = private [> `A ] 3 | deriving (Show) 4 | end 5 | 6 | module Make(M : A) = struct 7 | type truc = Plop of M.t 8 | deriving (Show) 9 | 10 | let chose x = Plop x 11 | end 12 | 13 | module MA = struct 14 | type t = [ `A | `B ] 15 | deriving (Show) 16 | end 17 | 18 | module M = Make(MA) 19 | 20 | let _ = print_endline (Show.show(M.chose `B)) 21 | -------------------------------------------------------------------------------- /tests/std/sigs.ml: -------------------------------------------------------------------------------- 1 | (* Deriving a signature with types exposed *) 2 | module T : 3 | sig 4 | type sum = S0 | S1 of int | S2 of int * float | S3 of int * float * bool | Sunit of unit | Stup of (int * float) | Stup1 of (int) 5 | deriving (Dump, Eq, Show, Typeable, Pickle) 6 | 7 | type nullsum = N0 | N1 | N2 | N3 8 | deriving (Enum, Bounded, Eq, Typeable, Pickle) 9 | 10 | type r1 = { 11 | r1_l1 : int; 12 | r1_l2 : int; 13 | } deriving (Dump, Eq, Show, Typeable, Pickle, Functor) 14 | 15 | type r2 = { 16 | mutable r2_l1 : int; 17 | mutable r2_l2 : int; 18 | } deriving (Eq, Show, Typeable, Pickle) 19 | 20 | type r3 = { 21 | r3_l1 : int; 22 | mutable r3_l2 : int; 23 | } deriving (Eq, Show, Typeable, Pickle) 24 | 25 | type r4 = { 26 | r4_l1 : 'a . 'a list 27 | } 28 | type label = x:int -> int 29 | 30 | type funct = int -> int 31 | 32 | type intseq = INil | ICons of int * intseq 33 | deriving (Dump, Eq, Show, Typeable, Pickle, Functor) 34 | 35 | type 'a seq = Nil | Cons of 'a * 'a seq 36 | deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 37 | 38 | type uses_seqs = (intseq * float seq) 39 | deriving (Dump, Eq, Show, Typeable, Pickle) 40 | 41 | type obj = < x : int > 42 | 43 | type poly0 = [`T0 | `T1 | `T2 | `T3] 44 | deriving (Enum, Bounded, Show, Eq, Typeable, Pickle) 45 | 46 | type poly1 = [`T0 | `T1 of int] 47 | deriving (Dump, Eq, Show) 48 | 49 | type poly2 = P of int * [`T0 | `T1 of int] * float 50 | deriving (Dump, Eq, Show) 51 | 52 | type poly3 = [`Nil | `Cons of int * 'c] as 'c 53 | deriving (Dump, Eq, Show, Typeable, Pickle) 54 | 55 | type poly3b = int * ([`Nil | `Cons of int * 'c] as 'c) * [`F] 56 | deriving (Dump, Eq, Show, Typeable, Pickle) 57 | 58 | type 'a poly7 = Foo of [`F of 'a] 59 | and 'a poly8 = { x : [`G of [`H of [`I of 'a poly7]]] } 60 | deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 61 | 62 | type poly10 = [`F | poly3] 63 | deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 64 | 65 | type mutrec_a = mutrec_c 66 | and mutrec_b = { l1 : mutrec_c ; l2 : mutrec_a } 67 | and mutrec_c = S of int * mutrec_a | N 68 | and mutrec_d = [`T of mutrec_b] 69 | deriving (Dump, Eq, Show, Typeable, Pickle) 70 | 71 | type ('a,'b) pmutrec_a = ('a,'b) pmutrec_c 72 | and ('a,'b) pmutrec_b = { pl1 : ('a,'b) pmutrec_c ; pl2 : ('a,'b) pmutrec_a } 73 | and ('a,'b) pmutrec_c = SS of 'a * ('a,'b) pmutrec_a * 'b 74 | and ('a,'b) pmutrec_d = [`T of ('a,'b) pmutrec_b] 75 | deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 76 | 77 | type 'a ff1 = F of 'a * 'a | G of int deriving (Show, Eq, Dump, Functor, Typeable, Pickle) 78 | type ('a,'b) ff2 = F1 of ('a,'b) ff2 | F2 of 'a seq * int * 'b option 79 | deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 80 | 81 | type tup0 = unit 82 | deriving (Dump, Eq, Show, Typeable, Pickle) 83 | type tup2 = int * float 84 | deriving (Dump, Eq, Show, Typeable, Pickle) 85 | type tup3 = int * float * bool 86 | deriving (Dump, Eq, Show, Typeable, Pickle) 87 | type tup4 = int * int * bool * unit 88 | deriving (Dump, Eq, Show, Typeable, Pickle, Bounded) 89 | 90 | type withref = WR of int * (int ref) 91 | deriving (Eq, Show, Typeable, Pickle) 92 | 93 | module M : sig 94 | type t deriving (Show, Eq, Dump) 95 | end 96 | 97 | module P : sig 98 | type 'a t (* deriving (Show) *) 99 | end 100 | 101 | type 'a constrained = [`F of 'a] constraint 'a = int 102 | deriving (Functor) 103 | 104 | type p1 = private P1 105 | deriving (Show, Eq) 106 | 107 | module Private : sig 108 | type p2 = private Q deriving (Show, Eq, Dump) 109 | end 110 | 111 | type t = int 112 | deriving (Eq, Enum, Bounded, Dump, Show, Typeable, Pickle, Functor) 113 | end 114 | = Tests_defs 115 | 116 | (* Deriving a signature with types made abstract *) 117 | module T_opaque : 118 | sig 119 | type sum deriving (Dump, Eq, Show, Typeable, Pickle) 120 | type nullsum deriving (Enum, Bounded, Eq, Typeable, Pickle) 121 | type r1 deriving (Dump, Eq, Show, Typeable, Pickle, Functor) 122 | type r2 deriving (Eq, Show, Typeable, Pickle) 123 | type r3 deriving (Eq, Show, Typeable, Pickle) 124 | type r4 125 | type label 126 | type funct 127 | type intseq deriving (Dump, Eq, Show, Typeable, Pickle, Functor) 128 | type 'a seq deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 129 | type uses_seqs deriving (Dump, Eq, Show, Typeable, Pickle) 130 | type obj 131 | type poly0 deriving (Enum, Bounded, Show, Eq, Typeable, Pickle) 132 | type poly1 deriving (Dump, Eq, Show) 133 | type poly2 deriving (Dump, Eq, Show) 134 | type poly3 deriving (Dump, Eq, Show, Typeable, Pickle) 135 | type poly3b deriving (Dump, Eq, Show, Typeable, Pickle) 136 | type 'a poly7 137 | and 'a poly8 deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 138 | type poly10 deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 139 | type mutrec_a 140 | and mutrec_b 141 | and mutrec_c 142 | and mutrec_d deriving (Dump, Eq, Show, Typeable, Pickle) 143 | type ('a,'b) pmutrec_a 144 | and ('a,'b) pmutrec_b 145 | and ('a,'b) pmutrec_c 146 | and ('a,'b) pmutrec_d deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 147 | type 'a ff1 deriving (Show, Eq, Dump, Functor, Typeable, Pickle) 148 | type ('a,'b) ff2 deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 149 | type tup0 deriving (Dump, Eq, Show, Typeable, Pickle) 150 | type tup2 deriving (Dump, Eq, Show, Typeable, Pickle) 151 | type tup3 deriving (Dump, Eq, Show, Typeable, Pickle) 152 | type tup4 deriving (Dump, Eq, Show, Typeable, Pickle, Bounded) 153 | type withref deriving (Eq, Show, Typeable, Pickle) 154 | module M : sig type t deriving (Show, Eq, Dump) end 155 | module P : sig type 'a t end 156 | type 'a constrained constraint 'a = int deriving (Functor) 157 | type p1 deriving (Show, Eq) 158 | module Private : sig type p2 end 159 | type t deriving (Eq, Enum, Bounded, Dump, Show, Typeable, Pickle, Functor) 160 | end 161 | = Tests_defs 162 | 163 | 164 | (* A signature with no deriving (to make sure that the types are still 165 | compatible) *) 166 | module T_no_deriving : 167 | sig 168 | 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) 169 | 170 | type nullsum = N0 | N1 | N2 | N3 171 | 172 | type r1 = { 173 | r1_l1 : int; 174 | r1_l2 : int; 175 | } 176 | 177 | type r2 = { 178 | mutable r2_l1 : int; 179 | mutable r2_l2 : int; 180 | } 181 | 182 | type r3 = { 183 | r3_l1 : int; 184 | mutable r3_l2 : int; 185 | } 186 | 187 | type r4 = { 188 | r4_l1 : 'a . 'a list 189 | } 190 | type label = x:int -> int 191 | 192 | type funct = int -> int 193 | 194 | type intseq = INil | ICons of int * intseq 195 | 196 | type 'a seq = Nil | Cons of 'a * 'a seq 197 | 198 | type uses_seqs = (intseq * float seq) 199 | 200 | type obj = < x : int > 201 | 202 | type poly0 = [`T0 | `T1 | `T2 | `T3] 203 | 204 | type poly1 = [`T0 | `T1 of int] 205 | 206 | type poly2 = P of int * [`T0 | `T1 of int] * float 207 | 208 | type poly3 = [`Nil | `Cons of int * 'c] as 'c 209 | 210 | type poly3b = int * ([`Nil | `Cons of int * 'c] as 'c) * [`F] 211 | 212 | type 'a poly7 = Foo of [`F of 'a] 213 | and 'a poly8 = { x : [`G of [`H of [`I of 'a poly7]]] } 214 | 215 | type poly10 = [`F | poly3] 216 | 217 | type mutrec_a = mutrec_c 218 | and mutrec_b = { l1 : mutrec_c ; l2 : mutrec_a } 219 | and mutrec_c = S of int * mutrec_a | N 220 | and mutrec_d = [`T of mutrec_b] 221 | 222 | type ('a,'b) pmutrec_a = ('a,'b) pmutrec_c 223 | and ('a,'b) pmutrec_b = { pl1 : ('a,'b) pmutrec_c ; pl2 : ('a,'b) pmutrec_a } 224 | and ('a,'b) pmutrec_c = SS of 'a * ('a,'b) pmutrec_a * 'b 225 | and ('a,'b) pmutrec_d = [`T of ('a,'b) pmutrec_b] 226 | 227 | type 'a ff1 = F of 'a * 'a | G of int 228 | type ('a,'b) ff2 = F1 of ('a,'b) ff2 | F2 of 'a seq * int * 'b option 229 | 230 | type tup0 = unit 231 | type tup2 = int * float 232 | type tup3 = int * float * bool 233 | type tup4 = int * int * bool * unit 234 | type withref = WR of int * (int ref) 235 | 236 | module M : sig 237 | type t 238 | end 239 | 240 | module P : sig 241 | type 'a t 242 | end 243 | 244 | type 'a constrained = [`F of 'a] constraint 'a = int 245 | 246 | type p1 = private P1 247 | 248 | module Private : sig 249 | type p2 = private Q 250 | end 251 | 252 | type t = int 253 | end 254 | = Tests_defs 255 | -------------------------------------------------------------------------------- /tests/std/tests_defs.ml: -------------------------------------------------------------------------------- 1 | (* sums (nullary, unary, and n-ary) *) 2 | 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) 3 | deriving (Dump, Eq, Show, Typeable, Pickle) 4 | 5 | type nullsum = N0 | N1 | N2 | N3 6 | deriving (Enum, Bounded, Eq, Typeable, Pickle) 7 | 8 | (* records with mutable and immutable fields (and various combinations) *) 9 | type r1 = { 10 | r1_l1 : int; 11 | r1_l2 : int; 12 | } deriving (Dump, Eq, Show, Typeable, Pickle, Functor) 13 | 14 | type r2 = { 15 | mutable r2_l1 : int; 16 | mutable r2_l2 : int; 17 | } deriving (Eq, Show, Typeable, Pickle) 18 | 19 | type r3 = { 20 | r3_l1 : int; 21 | mutable r3_l2 : int; 22 | } deriving (Eq, Show, Typeable, Pickle) 23 | 24 | (* polymorphic records *) 25 | type r4 = { 26 | r4_l1 : 'a . 'a list 27 | } deriving (Dump, Eq, Show) 28 | 29 | (* label types *) 30 | type label = x:int -> int 31 | (* deriving (Dump, Eq, Show) *) 32 | 33 | (* function types *) 34 | type funct = int -> int 35 | (* deriving (Dump, Eq, Show) *) 36 | 37 | (* recursive types *) 38 | type intseq = INil | ICons of int * intseq 39 | deriving (Dump, Eq, Show, Typeable, Pickle, Functor) 40 | 41 | type 'a seq = Nil | Cons of 'a * 'a seq 42 | deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 43 | 44 | (* applied type constructors (nullary, n-ary) *) 45 | type uses_seqs = (intseq * float seq) 46 | deriving (Dump, Eq, Show, Typeable, Pickle) 47 | 48 | (* object and class types *) 49 | type obj = < x : int > 50 | 51 | (* class types *) 52 | class c = object end 53 | 54 | (* polymorphic variants (nullary, unary tags, extending complex type expressions, defined inline) *) 55 | type poly0 = [`T0 | `T1 | `T2 | `T3] 56 | deriving (Enum, Bounded, Show, Eq, Typeable, Pickle) 57 | 58 | type poly1 = [`T0 | `T1 of int] 59 | deriving (Dump, Eq, Show) 60 | 61 | type poly2 = P of int * [`T0 | `T1 of int] * float 62 | deriving (Dump, Eq, Show) 63 | 64 | (* `as'-recursion *) 65 | type poly3 = [`Nil | `Cons of int * 'c] as 'c 66 | deriving (Dump, Eq, Show, Typeable, Pickle) 67 | 68 | type poly3b = int * ([`Nil | `Cons of int * 'c] as 'c) * [`F] 69 | deriving (Dump, Eq, Show, Typeable, Pickle) 70 | 71 | (* <, >, =, > < polymorphic variants *) 72 | type 'a poly7 = Foo of [`F of 'a] 73 | and 'a poly8 = { x : [`G of [`H of [`I of 'a poly7]]] } 74 | deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 75 | 76 | (* 77 | type poly9 = [`F | [`G]] 78 | deriving (Dump, Eq, Show, Typeable, Pickle) 79 | currently broken. 80 | *) 81 | type poly10 = [`F | poly3] 82 | deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 83 | 84 | (* mutually recursive types (monomorphic, polymorphic) *) 85 | type mutrec_a = mutrec_c 86 | and mutrec_b = { l1 : mutrec_c ; l2 : mutrec_a } 87 | and mutrec_c = S of int * mutrec_a | N 88 | and mutrec_d = [`T of mutrec_b] 89 | deriving (Dump, Eq, Show, Typeable, Pickle) 90 | 91 | type ('a,'b) pmutrec_a = ('a,'b) pmutrec_c 92 | and ('a,'b) pmutrec_b = { pl1 : ('a,'b) pmutrec_c ; pl2 : ('a,'b) pmutrec_a } 93 | and ('a,'b) pmutrec_c = SS of 'a * ('a,'b) pmutrec_a * 'b 94 | and ('a,'b) pmutrec_d = [`T of ('a,'b) pmutrec_b] 95 | deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 96 | 97 | type 'a pmutrec_a' = ('a,'a) pmutrec_c' 98 | and ('a,'b) pmutrec_b' = { pl1' : ('b,'a) pmutrec_c' ; pl2' : 'a pmutrec_a' } 99 | and ('a,'b) pmutrec_c' = SS' of 'a * 'b pmutrec_a' * 'b | TT' of ('a * ('a,'b,'a) pmutrec_d' * 'b) 100 | and ('a,'b,'c) pmutrec_d' = [ `S of ('a,'b) pmutrec_b' | `T of ('b,'c) pmutrec_b' ] 101 | deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 102 | 103 | (* polymorphic types *) 104 | type 'a ff1 = F of 'a * 'a | G of int deriving (Show, Eq, Dump, Functor, Typeable, Pickle) 105 | type ('a,'b) ff2 = F1 of ('a,'b) ff2 | F2 of 'a seq * int * 'b option 106 | deriving (Dump, Eq, Show, Functor, Typeable, Pickle) 107 | 108 | (* tuples *) 109 | type tup0 = unit 110 | deriving (Dump, Eq, Show, Typeable, Pickle) 111 | type tup2 = int * float 112 | deriving (Dump, Eq, Show, Typeable, Pickle) 113 | type tup3 = int * float * bool 114 | deriving (Dump, Eq, Show, Typeable, Pickle) 115 | type tup4 = int * int * bool * unit 116 | deriving (Dump, Eq, Show, Typeable, Pickle, Bounded) 117 | 118 | (* type equations (replication) *) 119 | (* TODO *) 120 | 121 | (* references *) 122 | type withref = WR of int * (int ref) 123 | deriving (Eq, Show, Typeable, Pickle) 124 | 125 | (* through module boundaries *) 126 | module rec M : sig 127 | type t deriving (Show, Eq, Dump) 128 | end = 129 | struct 130 | type t = [`N|`C of M.t] deriving (Show, Eq, Dump) 131 | end 132 | 133 | (* parameterized types through module boundaries *) 134 | module rec P : sig 135 | type 'a t (* deriving (Show) *) 136 | end = 137 | struct 138 | type 'a t = [`N|`C of 'a P.t] 139 | (*Doesn't work: results in an unsafe module definition 140 | *)(* deriving (Show)*) 141 | end 142 | 143 | (* with constraints *) 144 | type 'a constrained = [`F of 'a] constraint 'a = int 145 | deriving (Functor) (* Show, etc. don't work here *) 146 | 147 | (* private datatypes *) 148 | type p1 = private P1 149 | deriving (Show, Eq) 150 | 151 | (* check that `private' in the interface is allowed for classes that 152 | disallow `private' (e.g. Dump) as long as we don't have `private' 153 | in the implementation *) 154 | module Private : sig 155 | type p2 = private Q deriving (Show, Eq, Dump) 156 | end = 157 | struct 158 | type p2 = Q deriving (Show, Eq, Dump) 159 | end 160 | 161 | (* Reusing existing instances *) 162 | type t = int 163 | deriving (Eq, Enum, Bounded, Dump, Show, Typeable, Pickle, Functor) 164 | 165 | (* Int32, etc. *) 166 | 167 | type ii = { 168 | int32: int32; 169 | int64: int64; 170 | nativeint: nativeint; 171 | } deriving (Eq, Dump, Typeable, Pickle, Show) 172 | 173 | type ii' = { 174 | int32': Int32.t; 175 | int64': Int64.t; 176 | } deriving (Eq, Dump, Typeable, Pickle, Show) 177 | 178 | (* GADTs *) 179 | 180 | type _ g1 = 181 | | I : int -> int g1 182 | | C : 'a -> 'a g1 183 | | L : 'a list -> 'a list g1 184 | | R : 'a g1 * 'a -> 'a g1 185 | | B : 'a * 'a * int -> 'a g1 186 | deriving (Show) 187 | 188 | type (_, _) g2 = 189 | | A : 'a -> ('a, 'b) g2 190 | | B : 'b -> ('a, 'b) g2 191 | | R : ('b, 'a) g2 -> ('a, 'b) g2 192 | deriving (Show) 193 | 194 | type _ g3 = 195 | | A : 'a g4 * 'a -> 'a g3 196 | | B : int g3 197 | and _ g4 = 198 | | C : 'a g3 * 'a -> 'a g4 199 | | D : float g4 200 | deriving (Show) 201 | -------------------------------------------------------------------------------- /tests/std/typeable_tests.ml: -------------------------------------------------------------------------------- 1 | open Deriving_Typeable 2 | 3 | type t1 = F deriving (Typeable) 4 | type t2 = F deriving (Typeable) 5 | 6 | let eq_types t1 t2 = TypeRep.eq (Lazy.force t1) (Lazy.force t2) 7 | 8 | let _ = 9 | begin 10 | assert (eq_types 11 | Typeable.type_rep 12 | Typeable.type_rep); 13 | assert (eq_types 14 | Typeable.type_rep 15 | Typeable.type_rep); 16 | assert (not (eq_types 17 | Typeable.type_rep 18 | Typeable.type_rep)); 19 | assert (not (eq_types 20 | Typeable.type_rep 21 | Typeable.type_rep)); 22 | end 23 | 24 | type t3 = int deriving (Typeable) 25 | 26 | let _ = 27 | begin 28 | assert (eq_types 29 | Typeable.type_rep 30 | Typeable.type_rep); 31 | end 32 | 33 | 34 | type t4 = [`T of int] deriving (Typeable) 35 | type t5 = [`T of t3] deriving (Typeable) 36 | 37 | let _ = 38 | begin 39 | assert (eq_types 40 | Typeable.type_rep 41 | Typeable.type_rep); 42 | end 43 | 44 | type t6 = [`T of t5] 45 | deriving (Typeable) 46 | 47 | let _ = 48 | begin 49 | assert (not (eq_types 50 | Typeable.type_rep 51 | Typeable.type_rep)); 52 | 53 | end 54 | 55 | type t7 = [`T of t6] 56 | deriving (Typeable) 57 | 58 | let _ = 59 | begin 60 | assert (not (eq_types 61 | Typeable.type_rep 62 | Typeable.type_rep)); 63 | end 64 | 65 | 66 | type t8 = [`A | `B] deriving (Typeable) 67 | type t9 = [`B | `A] deriving (Typeable) 68 | 69 | let _ = 70 | begin 71 | assert (eq_types 72 | Typeable.type_rep 73 | Typeable.type_rep); 74 | end 75 | 76 | 77 | type ('a,'r) openr = [`Nil | `Cons of 'a * 'r] 78 | deriving (Typeable) 79 | type 'a closedr = [`Nil | `Cons of 'a * 'a closedr] 80 | deriving (Typeable) 81 | type l1 = [ `A of (int, l1) openr ] 82 | and l2 = [ `A of int closedr ] deriving (Typeable) 83 | 84 | (* The following fail without recursive module : *) 85 | (* type l3 = (int, l3) openr deriving (Typeable) *) 86 | 87 | let _ = 88 | begin 89 | assert (eq_types 90 | Typeable.type_rep 91 | Typeable.type_rep); 92 | end 93 | 94 | type nil = [`Nil] deriving (Typeable) 95 | type t10 = [ `A of ([nil| `Cons of int * 'a ] as 'a)] list 96 | deriving (Typeable) 97 | type t11 = l2 list deriving (Typeable) 98 | 99 | let _ = 100 | begin 101 | assert 102 | (eq_types 103 | Typeable.type_rep 104 | Typeable.type_rep); 105 | end 106 | 107 | -------------------------------------------------------------------------------- /tests/tc/tc.ml: -------------------------------------------------------------------------------- 1 | 2 | 3 | type t = A of int | B of float with show 4 | --------------------------------------------------------------------------------