new file mode 100644
@@ -0,0 +1,10 @@
+_build
+_b0
+tmp
+*~
+\.\#*
+\#*#
+*.byte
+*.native
+cmdliner.install
+src/.merlin
new file mode 100644
@@ -0,0 +1 @@
+strict_with=always,match_clause=4,strict_else=never
\ No newline at end of file
new file mode 100644
@@ -0,0 +1,9 @@
+open B0
+
+let cmdliner = "cmdliner"
+let doc = "Declarative definition of command line interfaces for OCaml"
+
+let pkg = Pkg.create cmdliner ~doc
+let lib =
+ let srcs = (`Src_dirs [Fpath.v "src"]) in
+ B0_ocaml.Unit.lib ~pkg cmdliner srcs ~doc
new file mode 100644
@@ -0,0 +1,255 @@
+v1.0.4 2019-06-14 Zagreb
+------------------------
+
+- Change the way `Error (_, e)` term evaluation results
+ are formatted. Instead of treating `e` as text, treat
+ it as formatted lines.
+- Fix 4.08 `Pervasives` deprecation.
+- Fix 4.03 String deprecations.
+- Fix bootstrap build in absence of dynlink.
+- Make the `Makefile` bootstrap build reproducible.
+ Thanks to Thomas Leonard for the patch.
+
+v1.0.3 2018-11-26 Zagreb
+------------------------
+
+- Add `Term.with_used_args`. Thanks to Jeremie Dimino for
+ the patch.
+- Use `Makefile` bootstrap build in opam file.
+- Drop ocamlbuild requirement for `Makefile` bootstrap build.
+- Drop support for ocaml < 4.03.0
+- Dune build support.
+
+v1.0.2 2017-08-07 Zagreb
+------------------------
+
+- Don't remove the `Makefile` from the distribution.
+
+v1.0.1 2017-08-03 Zagreb
+------------------------
+
+- Add a `Makefile` to build and install cmdliner without `topkg` and
+ opam `.install` files. Helps bootstraping opam in OS package
+ managers. Thanks to Hendrik Tews for the patches.
+
+v1.0.0 2017-03-02 La Forclaz (VS)
+---------------------------------
+
+**IMPORTANT** The `Arg.converter` type is deprecated in favor of the
+`Arg.conv` type. For this release both types are equal but the next
+major release will drop the former and make the latter abstract. All
+users are kindly requested to migrate to use the new type and **only**
+via the new `Arg.[p]conv` and `Arg.conv_{parser,printer}` functions.
+
+- Allow terms to be used more than once in terms without tripping out
+ documentation generation (#77). Thanks to François Bobot and Gabriel
+ Radanne.
+- Disallow defining the same option (resp. command) name twice via two
+ different arguments (resp. terms). Raises Invalid_argument, used
+ to be undefined behaviour (in practice, an arbitrary one would be
+ ignored).
+- Improve converter API (see important message above).
+- Add `Term.exit[_status]` and `Term.exit_status_of[_status]_result`.
+ improves composition with `Pervasives.exit`.
+- Add `Term.term_result` and `Term.cli_parse_result` improves composition
+ with terms evaluating to `result` types.
+- Add `Arg.parser_of_kind_of_string`.
+- Change semantics of `Arg.pos_left` (see #76 for details).
+- Deprecate `Term.man_format` in favor of `Arg.man_format`.
+- Reserve the `--cmdliner` option for library use. This is unused for now
+ but will be in the future.
+- Relicense from BSD3 to ISC.
+- Safe-string support.
+- Build depend on topkg.
+
+### End-user visible changes
+
+The following changes affect the end-user behaviour of all binaries using
+cmdliner.
+
+- Required positional arguments. All missing required position
+ arguments are now reported to the end-user, in the correct
+ order (#39). Thanks to Dmitrii Kashin for the report.
+- Optional arguments. All unknown and ambiguous optional argument
+ arguments are now reported to the end-user (instead of only
+ the first one).
+- Change default behaviour of `--help[=FMT]` option. `FMT` no longer
+ defaults to `pager` if unspecified. It defaults to the new value
+ `auto` which prints the help as `pager` or `plain` whenever the
+ `TERM` environment variable is `dumb` or undefined (#43). At the API
+ level this changes the signature of the type `Term.ret` and values
+ `Term.ret`, `Term.man_format` (deprecated) and `Manpage.print` to add the
+ new `` `Auto`` case to manual formats. These are now represented by the
+ `Manpage.format` type rather than inlined polyvars.
+
+### Doc specification improvements and fixes
+
+- Add `?envs` optional argument to `Term.info`. Documents environment
+ variables that influence a term's evaluation and automatically
+ integrate them in the manual.
+- Add `?exits` optional argument to `Term.info`. Documents exit statuses of
+ the program. Use `Term.default_exits` if you are using the new `Term.exit`
+ functions.
+- Add `?man_xrefs` optional argument to `Term.info`. Documents
+ references to other manpages. Automatically formats a `SEE ALSO` section
+ in the manual.
+- Add `Manpage.escape` to escape a string from the documentation markup
+ language.
+- Add `Manpage.s_*` constants for standard man page section names.
+- Add a `` `Blocks`` case to `Manpage.blocks` to allow block splicing
+ (#69). This avoids having to concatenate block lists at the
+ toplevel of your program.
+- `Arg.env_var`, change default environment variable section to the
+ standard `ENVIRONMENT` manual section rather than `ENVIRONMENT
+ VARIABLES`. If you previously manually positioned that section in
+ your man page you will have to change the name. See also next point.
+- Fix automatic placement of default environment variable section (#44)
+ whenever unspecified in the man page.
+- Better automatic insertions of man page sections (#73). See the API
+ docs about manual specification. As a side effect the `NAME` section
+ can now also be overriden manually.
+- Fix repeated environment variable printing for flags (#64). Thanks to
+ Thomas Gazagnaire for the report.
+- Fix rendering of env vars in man pages, bold is standard (#71).
+- Fix plain help formatting for commands with empty
+ description. Thanks to Maciek Starzyk for the patch.
+- Fix (implement really) groff man page escaping (#48).
+- Request `an` macros directly in the man page via `.mso` this
+ makes man pages self-describing and avoids having to call `groff` with
+ the `-man` option.
+- Document required optional arguments as such (#82). Thanks to Isaac Hodes
+ for the report.
+
+### Doc language sanitization
+
+This release tries to bring sanity to the doc language. This may break
+the rendering of some of your man pages. Thanks to Gabriel Scherer,
+Ivan Gotovchits and Nicolás Ojeda Bär for the feedback.
+
+- It is only allowed to use the variables `$(var)` that are mentioned in
+ the docs (`$(docv)`, `$(opt)`, etc.) and the markup directives
+ `$({i,b},text)`. Any other unknown `$(var)` will generate errors
+ on standard error during documentation generation.
+- Markup directives `$({i,b},text)` treat `text` as is, modulo escapes;
+ see next point.
+- Characters `$`, `(`, `)` and `\` can respectively be escaped by `\$`,
+ `\(`, `\)` and `\\`. Escaping `$` and `\` is mandatory everywhere.
+ Escaping `)` is mandatory only in markup directives. Escaping `(`
+ is only here for your symmetric pleasure. Any other sequence of
+ character starting with a `\` is an illegal sequence.
+- Variables `$(mname)` and `$(tname)` are now marked up with bold when
+ substituted. If you used to write `$(b,$(tname))` this will generate
+ an error on standard output, since `$` is not escaped in the markup
+ directive. Simply replace these by `$(tname)`.
+
+v0.9.8 2015-10-11 Cambridge (UK)
+--------------------------------
+
+- Bring back support for OCaml 3.12.0
+- Support for pre-formatted paragraphs in man pages. This adds a
+ ```Pre`` case to the `Manpage.block` type which can break existing
+ programs. Thanks to Guillaume Bury for suggesting and help.
+- Support for environment variables. If an argument is absent from the
+ command line, its value can be read and parsed from an environment
+ variable. This adds an `env` optional argument to the `Arg.info`
+ function which can break existing programs.
+- Support for new variables in option documentation strings. `$(opt)`
+ can be used to refer to the name of the option being documented and
+ `$(env)` for the name of the option's the environment variable.
+- Deprecate `Term.pure` in favor of `Term.const`.
+- Man page generation. Keep undefined variables untouched. Previously
+ a `$(undef)` would be turned into `undef`.
+- Turn a few misterious and spurious `Not_found` exceptions into
+ `Invalid_arg`. These can be triggered by client programming errors
+ (e.g. an unclosed variable in a documentation string).
+- Positional arguments. Invoke the printer on the default (absent)
+ value only if needed. See Optional arguments in the release notes of
+ v0.9.6.
+
+v0.9.7 2015-02-06 La Forclaz (VS)
+---------------------------------
+
+- Build system, don't depend on `ocamlfind`. The package no longer
+ depends on ocamlfind. Thanks to Louis Gesbert for the patch.
+
+v0.9.6 2014-11-18 La Forclaz (VS)
+---------------------------------
+
+- Optional arguments. Invoke the printer on the default (absent) value
+ only if needed, i.e. if help is shown. Strictly speaking an
+ interface breaking change – for example if the absent value was lazy
+ it would be forced on each run. This is no longer the case.
+- Parsed command line syntax: allow short flags to be specified
+ together under a single dash, possibly ending with a short option.
+ This allows to specify e.g. `tar -xvzf archive.tgz` or `tar
+ -xvzfarchive.tgz`. Previously this resulted in an error, all the
+ short flags had to be specified separately. Backward compatible in
+ the sense that only more command lines are parsed. Thanks to Hugo
+ Heuzard for the patch.
+- End user error message improvements using heuristics and edit
+ distance search in the optional argument and sub command name
+ spaces. Thanks to Hugo Heuzard for the patch.
+- Adds `Arg.doc_{quote,alts,alts_enum}`, documentation string
+ helpers.
+- Adds the `Term.eval_peek_opts` function for advanced usage scenarios.
+- The function `Arg.enum` now raises `Invalid_argument` if the
+ enumeration is empty.
+- Improves help paging behaviour on Windows. Thanks to Romain Bardou
+ for the help.
+
+
+v0.9.5 2014-07-04 Cambridge (UK)
+--------------------------------
+
+- Add variance annotation to Term.t. Thanks to Peter Zotov for suggesting.
+- Fix section name formatting in plain text output. Thanks to Mikhail
+ Sobolev for reporting.
+
+
+v0.9.4 2014-02-09 La Forclaz (VS)
+---------------------------------
+
+- Remove temporary files created for paged help. Thanks to Kaustuv Chaudhuri
+ for the suggestion.
+- Avoid linking against `Oo` (was used to get program uuid).
+- Check the environment for `$MANPAGER` aswell. Thanks to Raphaël Proust
+ for the patch.
+- OPAM friendly workflow and drop OASIS support.
+
+
+v0.9.3 2013-01-04 La Forclaz (VS)
+---------------------------------
+
+- Allow user specified `SYNOPSIS` sections.
+
+
+v0.9.2 2012-08-05 Lausanne
+--------------------------
+
+- OASIS 0.3.0 support.
+
+
+v0.9.1 2012-03-17 La Forclaz (VS)
+---------------------------------
+
+- OASIS support.
+- Fixed broken `Arg.pos_right`.
+- Variables `$(tname)` and `$(mname)` can be used in a term's man
+ page to respectively refer to the term's name and the main term
+ name.
+- Support for custom variable substitution in `Manpage.print`.
+- Adds `Term.man_format`, to facilitate the definition of help commands.
+- Rewrote the examples with a better and consistent style.
+
+Incompatible API changes:
+
+- The signature of `Term.eval` and `Term.eval_choice` changed to make
+ it more regular: the given term and its info must be tupled together
+ even for the main term and the tuple order was swapped to make it
+ consistent with the one used for arguments.
+
+
+v0.9.0 2011-05-27 Lausanne
+--------------------------
+
+- First release.
new file mode 100644
@@ -0,0 +1,13 @@
+Copyright (c) 2011 Daniel C. Bünzli
+
+Permission to use, copy, modify, and/or distribute this software for any
+purpose with or without fee is hereby granted, provided that the above
+copyright notice and this permission notice appear in all copies.
+
+THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
new file mode 100644
@@ -0,0 +1,77 @@
+# To be used by system package managers to bootstrap opam. topkg
+# cannot be used as it needs opam-installer which is provided by opam
+# itself.
+
+# Typical usage:
+#
+# make all
+# make install PREFIX=/usr/local
+# make install-doc PREFIX=/usr/local
+
+# Adjust the following on the cli invocation for configuring
+
+-include $(shell ocamlc -where)/Makefile.config
+
+PREFIX=/usr
+LIBDIR=$(DESTDIR)$(PREFIX)/lib/ocaml/cmdliner
+DOCDIR=$(DESTDIR)$(PREFIX)/share/doc/cmdliner
+NATIVE=$(shell ocamlopt -version > /dev/null 2>&1 && echo true)
+# EXT_LIB by default value of OCaml's Makefile.config
+# NATDYNLINK by default value of OCaml's Makefile.config
+
+INSTALL=install
+B=_build
+BASE=$(B)/cmdliner
+
+ifeq ($(NATIVE),true)
+ BUILD-TARGETS=build-byte build-native
+ INSTALL-TARGETS=install-common install-byte install-native
+ ifeq ($(NATDYNLINK),true)
+ BUILD-TARGETS += build-native-dynlink
+ INSTALL-TARGETS += install-native-dynlink
+ endif
+else
+ BUILD-TARGETS=build-byte
+ INSTALL-TARGETS=install-common install-byte
+endif
+
+all: $(BUILD-TARGETS)
+
+install: $(INSTALL-TARGETS)
+
+install-doc:
+ $(INSTALL) -d $(DOCDIR)
+ $(INSTALL) CHANGES.md LICENSE.md README.md $(DOCDIR)
+
+clean:
+ ocaml build.ml clean
+
+build-byte:
+ ocaml build.ml cma
+
+build-native:
+ ocaml build.ml cmxa
+
+build-native-dynlink:
+ ocaml build.ml cmxs
+
+create-libdir:
+ $(INSTALL) -d $(LIBDIR)
+
+install-common: create-libdir
+ $(INSTALL) pkg/META $(BASE).mli $(BASE).cmi $(BASE).cmti $(LIBDIR)
+ $(INSTALL) cmdliner.opam $(LIBDIR)/opam
+
+install-byte: create-libdir
+ $(INSTALL) $(BASE).cma $(LIBDIR)
+
+install-native: create-libdir
+ $(INSTALL) $(BASE).cmxa $(BASE)$(EXT_LIB) $(wildcard $(B)/cmdliner*.cmx) \
+ $(LIBDIR)
+
+install-native-dynlink: create-libdir
+ $(INSTALL) $(BASE).cmxs $(LIBDIR)
+
+.PHONY: all install install-doc clean build-byte build-native \
+ build-native-dynlink create-libdir install-common install-byte \
+ install-native install-dynlink
new file mode 100644
@@ -0,0 +1,51 @@
+Cmdliner — Declarative definition of command line interfaces for OCaml
+-------------------------------------------------------------------------------
+%%VERSION%%
+
+Cmdliner allows the declarative definition of command line interfaces
+for OCaml.
+
+It provides a simple and compositional mechanism to convert command
+line arguments to OCaml values and pass them to your functions. The
+module automatically handles syntax errors, help messages and UNIX man
+page generation. It supports programs with single or multiple commands
+and respects most of the [POSIX][1] and [GNU][2] conventions.
+
+Cmdliner has no dependencies and is distributed under the ISC license.
+
+[1]: http://pubs.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap12.html
+[2]: http://www.gnu.org/software/libc/manual/html_node/Argument-Syntax.html
+
+Home page: http://erratique.ch/software/cmdliner
+Contact: Daniel Bünzli `<daniel.buenzl i@erratique.ch>`
+
+
+## Installation
+
+Cmdliner can be installed with `opam`:
+
+ opam install cmdliner
+
+If you don't use `opam` consult the [`opam`](opam) file for build
+instructions.
+
+
+## Documentation
+
+The documentation and API reference is automatically generated by from
+the source interfaces. It can be consulted [online][doc] or via
+`odig doc cmdliner`.
+
+[doc]: http://erratique.ch/software/cmdliner/doc/Cmdliner
+
+
+## Sample programs
+
+If you installed Cmdliner with `opam` sample programs are located in
+the directory `opam config var cmdliner:doc`. These programs define
+the command line of some classic programs.
+
+In the distribution sample programs are located in the `test`
+directory of the distribution. They can be built and run with:
+
+ topkg build --tests true && topkg test
new file mode 100644
@@ -0,0 +1,3 @@
+true : bin_annot, safe_string
+<src> : include
+<test> : include
\ No newline at end of file
new file mode 100755
@@ -0,0 +1,155 @@
+#!/usr/bin/env ocaml
+
+(* Usage: ocaml build.ml [cma|cmxa|cmxs|clean] *)
+
+let root_dir = Sys.getcwd ()
+let build_dir = "_build"
+let src_dir = "src"
+
+let base_ocaml_opts =
+ [ "-g"; "-bin-annot";
+ "-safe-string"; (* Remove once we require >= 4.06 *) ]
+
+(* Logging *)
+
+let strf = Printf.sprintf
+let err fmt = Printf.kfprintf (fun oc -> flush oc; exit 1) stderr fmt
+let log fmt = Printf.kfprintf (fun oc -> flush oc) stdout fmt
+
+(* The running joke *)
+
+let rev_cut ~sep s = match String.rindex s sep with
+| exception Not_found -> None
+| i -> String.(Some (sub s 0 i, sub s (i + 1) (length s - (i + 1))))
+
+let cuts ~sep s =
+ let rec loop acc = function
+ | "" -> acc
+ | s ->
+ match rev_cut ~sep s with
+ | None -> s :: acc
+ | Some (l, r) -> loop (r :: acc) l
+ in
+ loop [] s
+
+(* Read, write and collect files *)
+
+let fpath ~dir f = String.concat "" [dir; "/"; f]
+
+let string_of_file f =
+ let ic = open_in_bin f in
+ let len = in_channel_length ic in
+ let buf = Bytes.create len in
+ really_input ic buf 0 len;
+ close_in ic;
+ Bytes.unsafe_to_string buf
+
+let string_to_file f s =
+ let oc = open_out_bin f in
+ output_string oc s;
+ close_out oc
+
+let cp src dst = string_to_file dst (string_of_file src)
+
+let ml_srcs dir =
+ let add_file dir acc f = match rev_cut ~sep:'.' f with
+ | Some (m, e) when e = "ml" || e = "mli" -> f :: acc
+ | Some _ | None -> acc
+ in
+ Array.fold_left (add_file dir) [] (Sys.readdir dir)
+
+(* Finding and running commands *)
+
+let find_cmd cmds =
+ let test, null = match Sys.win32 with
+ | true -> "where", " NUL"
+ | false -> "type", "/dev/null"
+ in
+ let cmd c = Sys.command (strf "%s %s 1>%s 2>%s" test c null null) = 0 in
+ try Some (List.find cmd cmds) with Not_found -> None
+
+let err_cmd exit cmd = err "exited with %d: %s\n" exit cmd
+let quote_cmd = match Sys.win32 with
+| false -> fun cmd -> cmd
+| true -> fun cmd -> strf "\"%s\"" cmd
+
+let run_cmd args =
+ let cmd = String.concat " " (List.map Filename.quote args) in
+(* log "[EXEC] %s\n" cmd; *)
+ let exit = Sys.command (quote_cmd cmd) in
+ if exit = 0 then () else err_cmd exit cmd
+
+let read_cmd args =
+ let stdout = Filename.temp_file (Filename.basename Sys.argv.(0)) "b00t" in
+ at_exit (fun () -> try ignore (Sys.remove stdout) with _ -> ());
+ let cmd = String.concat " " (List.map Filename.quote args) in
+ let cmd = quote_cmd @@ strf "%s 1>%s" cmd (Filename.quote stdout) in
+ let exit = Sys.command cmd in
+ if exit = 0 then string_of_file stdout else err_cmd exit cmd
+
+(* Create and delete directories *)
+
+let mkdir dir =
+ try match Sys.file_exists dir with
+ | true -> ()
+ | false -> run_cmd ["mkdir"; dir]
+ with
+ | Sys_error e -> err "%s: %s" dir e
+
+let rmdir dir =
+ try match Sys.file_exists dir with
+ | false -> ()
+ | true ->
+ let rm f = Sys.remove (fpath ~dir f) in
+ Array.iter rm (Sys.readdir dir);
+ run_cmd ["rmdir"; dir]
+ with
+ | Sys_error e -> err "%s: %s" dir e
+
+(* Lookup OCaml compilers and ocamldep *)
+
+let really_find_cmd alts = match find_cmd alts with
+| Some cmd -> cmd
+| None -> err "No %s found in PATH\n" (List.hd @@ List.rev alts)
+
+let ocamlc () = really_find_cmd ["ocamlc.opt"; "ocamlc"]
+let ocamlopt () = really_find_cmd ["ocamlopt.opt"; "ocamlopt"]
+let ocamldep () = really_find_cmd ["ocamldep.opt"; "ocamldep"]
+
+(* Build *)
+
+let sort_srcs srcs =
+ let srcs = List.sort String.compare srcs in
+ read_cmd (ocamldep () :: "-slash" :: "-sort" :: srcs)
+ |> String.trim |> cuts ~sep:' '
+
+let common srcs = base_ocaml_opts @ sort_srcs srcs
+
+let build_cma srcs =
+ run_cmd ([ocamlc ()] @ common srcs @ ["-a"; "-o"; "cmdliner.cma"])
+
+let build_cmxa srcs =
+ run_cmd ([ocamlopt ()] @ common srcs @ ["-a"; "-o"; "cmdliner.cmxa"])
+
+let build_cmxs srcs =
+ run_cmd ([ocamlopt ()] @ common srcs @ ["-shared"; "-o"; "cmdliner.cmxs"])
+
+let clean () = rmdir build_dir
+
+let in_build_dir f =
+ let srcs = ml_srcs src_dir in
+ let cp src = cp (fpath ~dir:src_dir src) (fpath ~dir:build_dir src) in
+ mkdir build_dir;
+ List.iter cp srcs;
+ Sys.chdir build_dir; f srcs; Sys.chdir root_dir
+
+let main () = match Array.to_list Sys.argv with
+| _ :: [ "cma" ] -> in_build_dir build_cma
+| _ :: [ "cmxa" ] -> in_build_dir build_cmxa
+| _ :: [ "cmxs" ] -> in_build_dir build_cmxs
+| _ :: [ "clean" ] -> clean ()
+| [] | [_] -> err "Missing argument: cma, cmxa, cmxs or clean\n";
+| cmd :: args ->
+ err "%s: Unknown argument(s): %s\n" cmd @@ String.concat " " args
+
+let () = main ()
new file mode 100644
@@ -0,0 +1,32 @@
+opam-version: "2.0"
+maintainer: "Daniel Bünzli <daniel.buenzl i@erratique.ch>"
+authors: ["Daniel Bünzli <daniel.buenzl i@erratique.ch>"]
+homepage: "http://erratique.ch/software/cmdliner"
+doc: "http://erratique.ch/software/cmdliner/doc/Cmdliner"
+dev-repo: "git+https://github.com/dune-universe/cmdliner.git"
+bug-reports: "https://github.com/dbuenzli/cmdliner/issues"
+tags: [ "cli" "system" "declarative" "org:erratique" ]
+license: "ISC"
+depends: [
+ "dune" "ocaml" {>= "4.03.0"} ]
+synopsis: """Declarative definition of command line interfaces for OCaml"""
+description: """\
+
+Cmdliner allows the declarative definition of command line interfaces
+for OCaml.
+
+It provides a simple and compositional mechanism to convert command
+line arguments to OCaml values and pass them to your functions. The
+module automatically handles syntax errors, help messages and UNIX man
+page generation. It supports programs with single or multiple commands
+and respects most of the [POSIX][1] and [GNU][2] conventions.
+
+Cmdliner has no dependencies and is distributed under the ISC license.
+
+[1]: http://pubs.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap12.html
+[2]: http://www.gnu.org/software/libc/manual/html_node/Argument-Syntax.html
+"""
+build: [[ "dune" "build" "-p" name ]]
+url {
+ src: "git://github.com/dune-universe/cmdliner.git#duniverse-v1.0.4"
+}
new file mode 100644
@@ -0,0 +1 @@
+Cmdliner
new file mode 100644
@@ -0,0 +1,2 @@
+(lang dune 1.4)
+(name cmdliner)
\ No newline at end of file
new file mode 100644
@@ -0,0 +1,7 @@
+version = "%%VERSION%%"
+description = "Declarative definition of command line interfaces"
+requires = ""
+archive(byte) = "cmdliner.cma"
+archive(native) = "cmdliner.cmxa"
+plugin(byte) = "cmdliner.cma"
+plugin(native) = "cmdliner.cmxs"
\ No newline at end of file
new file mode 100755
@@ -0,0 +1,33 @@
+#!/usr/bin/env ocaml
+#use "topfind"
+#require "topkg"
+open Topkg
+
+let test t = Pkg.flatten [ Pkg.test ~run:false t; Pkg.doc (t ^ ".ml")]
+
+let distrib =
+ let exclude_paths () = Ok [".git";".gitignore";".gitattributes";"_build"] in
+ Pkg.distrib ~exclude_paths ()
+
+let opams =
+ [Pkg.opam_file "cmdliner.opam"]
+
+let () =
+ Pkg.describe ~distrib "cmdliner" ~opams @@ fun c ->
+ Ok [ Pkg.mllib ~api:["Cmdliner"] "src/cmdliner.mllib";
+ test "test/chorus";
+ test "test/cp_ex";
+ test "test/darcs_ex";
+ test "test/revolt";
+ test "test/rm_ex";
+ test "test/tail_ex";
+ Pkg.test ~run:false "test/test_man";
+ Pkg.test ~run:false "test/test_man_utf8";
+ Pkg.test ~run:false "test/test_pos";
+ Pkg.test ~run:false "test/test_pos_rev";
+ Pkg.test ~run:false "test/test_pos_all";
+ Pkg.test ~run:false "test/test_pos_left";
+ Pkg.test ~run:false "test/test_pos_req";
+ Pkg.test ~run:false "test/test_opt_req";
+ Pkg.test ~run:false "test/test_term_dups";
+ Pkg.test ~run:false "test/test_with_used_args"; ]
new file mode 100644
@@ -0,0 +1,309 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+module Manpage = Cmdliner_manpage
+module Arg = Cmdliner_arg
+module Term = struct
+ type ('a, 'b) stdlib_result = ('a, 'b) result
+
+ include Cmdliner_term
+
+ (* Deprecated *)
+
+ let man_format = Cmdliner_arg.man_format
+ let pure = const
+
+ (* Terms *)
+
+ let ( $ ) = app
+
+ type 'a ret = [ `Ok of 'a | term_escape ]
+
+ let ret (al, v) =
+ al, fun ei cl -> match v ei cl with
+ | Ok (`Ok v) -> Ok v
+ | Ok (`Error _ as err) -> Error err
+ | Ok (`Help _ as help) -> Error help
+ | Error _ as e -> e
+
+ let term_result ?(usage = false) (al, v) =
+ al, fun ei cl -> match v ei cl with
+ | Ok (Ok _ as ok) -> ok
+ | Ok (Error (`Msg e)) -> Error (`Error (usage, e))
+ | Error _ as e -> e
+
+ let cli_parse_result (al, v) =
+ al, fun ei cl -> match v ei cl with
+ | Ok (Ok _ as ok) -> ok
+ | Ok (Error (`Msg e)) -> Error (`Parse e)
+ | Error _ as e -> e
+
+ let main_name =
+ Cmdliner_info.Args.empty,
+ (fun ei _ -> Ok (Cmdliner_info.(term_name @@ eval_main ei)))
+
+ let choice_names =
+ let choice_name t = Cmdliner_info.term_name t in
+ Cmdliner_info.Args.empty,
+ (fun ei _ -> Ok (List.rev_map choice_name (Cmdliner_info.eval_choices ei)))
+
+ let with_used_args (al, v) : (_ * string list) t =
+ al, fun ei cl ->
+ match v ei cl with
+ | Ok x ->
+ let actual_args arg_info acc =
+ let args = Cmdliner_cline.actual_args cl arg_info in
+ List.rev_append args acc
+ in
+ let used = List.rev (Cmdliner_info.Args.fold actual_args al []) in
+ Ok (x, used)
+ | Error _ as e -> e
+
+ (* Term information *)
+
+ type exit_info = Cmdliner_info.exit
+ let exit_info = Cmdliner_info.exit
+
+ let exit_status_success = 0
+ let exit_status_cli_error = 124
+ let exit_status_internal_error = 125
+ let default_error_exits =
+ [ exit_info exit_status_cli_error ~doc:"on command line parsing errors.";
+ exit_info exit_status_internal_error
+ ~doc:"on unexpected internal errors (bugs)."; ]
+
+ let default_exits =
+ (exit_info exit_status_success ~doc:"on success.") :: default_error_exits
+
+ type env_info = Cmdliner_info.env
+ let env_info = Cmdliner_info.env
+
+ type info = Cmdliner_info.term
+ let info = Cmdliner_info.term ~args:Cmdliner_info.Args.empty
+ let name ti = Cmdliner_info.term_name ti
+
+ (* Evaluation *)
+
+ let err_help s = "Term error, help requested for unknown command " ^ s
+ let err_argv = "argv array must have at least one element"
+ let err_multi_cmd_def name (a, _) (a', _) =
+ Cmdliner_base.err_multi_def ~kind:"command" name Cmdliner_info.term_doc a a'
+
+ type 'a result =
+ [ `Ok of 'a | `Error of [`Parse | `Term | `Exn ] | `Version | `Help ]
+
+ let add_stdopts ei =
+ let docs = Cmdliner_info.(term_stdopts_docs @@ eval_term ei) in
+ let vargs, vers = match Cmdliner_info.(term_version @@ eval_main ei) with
+ | None -> Cmdliner_info.Args.empty, None
+ | Some _ ->
+ let args, _ as vers = Cmdliner_arg.stdopt_version ~docs in
+ args, Some vers
+ in
+ let help = Cmdliner_arg.stdopt_help ~docs in
+ let args = Cmdliner_info.Args.union vargs (fst help) in
+ let term = Cmdliner_info.(term_add_args (eval_term ei) args) in
+ help, vers, Cmdliner_info.eval_with_term ei term
+
+ type 'a eval_result =
+ ('a, [ term_escape
+ | `Exn of exn * Printexc.raw_backtrace
+ | `Parse of string
+ | `Std_help of Manpage.format | `Std_version ]) stdlib_result
+
+ let run ~catch ei cl f = try (f ei cl :> 'a eval_result) with
+ | exn when catch ->
+ let bt = Printexc.get_raw_backtrace () in
+ Error (`Exn (exn, bt))
+
+ let try_eval_stdopts ~catch ei cl help version =
+ match run ~catch ei cl (snd help) with
+ | Ok (Some fmt) -> Some (Error (`Std_help fmt))
+ | Error _ as err -> Some err
+ | Ok None ->
+ match version with
+ | None -> None
+ | Some version ->
+ match run ~catch ei cl (snd version) with
+ | Ok false -> None
+ | Ok true -> Some (Error (`Std_version))
+ | Error _ as err -> Some err
+
+ let term_eval ~catch ei f args =
+ let help, version, ei = add_stdopts ei in
+ let term_args = Cmdliner_info.(term_args @@ eval_term ei) in
+ let res = match Cmdliner_cline.create term_args args with
+ | Error (e, cl) ->
+ begin match try_eval_stdopts ~catch ei cl help version with
+ | Some e -> e
+ | None -> Error (`Error (true, e))
+ end
+ | Ok cl ->
+ match try_eval_stdopts ~catch ei cl help version with
+ | Some e -> e
+ | None -> run ~catch ei cl f
+ in
+ ei, res
+
+ let term_eval_peek_opts ei f args =
+ let help, version, ei = add_stdopts ei in
+ let term_args = Cmdliner_info.(term_args @@ eval_term ei) in
+ let v, ret = match Cmdliner_cline.create ~peek_opts:true term_args args with
+ | Error (e, cl) ->
+ begin match try_eval_stdopts ~catch:true ei cl help version with
+ | Some e -> None, e
+ | None -> None, Error (`Error (true, e))
+ end
+ | Ok cl ->
+ let ret = run ~catch:true ei cl f in
+ let v = match ret with Ok v -> Some v | Error _ -> None in
+ match try_eval_stdopts ~catch:true ei cl help version with
+ | Some e -> v, e
+ | None -> v, ret
+ in
+ let ret = match ret with
+ | Ok v -> `Ok v
+ | Error `Std_help _ -> `Help
+ | Error `Std_version -> `Version
+ | Error `Parse _ -> `Error `Parse
+ | Error `Help _ -> `Help
+ | Error `Exn _ -> `Error `Exn
+ | Error `Error _ -> `Error `Term
+ in
+ v, ret
+
+ let do_help help_ppf err_ppf ei fmt cmd =
+ let ei = match cmd with
+ | None -> Cmdliner_info.(eval_with_term ei @@ eval_main ei)
+ | Some cmd ->
+ try
+ let is_cmd t = Cmdliner_info.term_name t = cmd in
+ let cmd = List.find is_cmd (Cmdliner_info.eval_choices ei) in
+ Cmdliner_info.eval_with_term ei cmd
+ with Not_found -> invalid_arg (err_help cmd)
+ in
+ let _, _, ei = add_stdopts ei (* may not be the originally eval'd term *) in
+ Cmdliner_docgen.pp_man ~errs:err_ppf fmt help_ppf ei
+
+ let do_result help_ppf err_ppf ei = function
+ | Ok v -> `Ok v
+ | Error res ->
+ match res with
+ | `Std_help fmt -> Cmdliner_docgen.pp_man err_ppf fmt help_ppf ei; `Help
+ | `Std_version -> Cmdliner_msg.pp_version help_ppf ei; `Version
+ | `Parse err ->
+ Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false ~err;
+ `Error `Parse
+ | `Help (fmt, cmd) -> do_help help_ppf err_ppf ei fmt cmd; `Help
+ | `Exn (e, bt) -> Cmdliner_msg.pp_backtrace err_ppf ei e bt; `Error `Exn
+ | `Error (usage, err) ->
+ (if usage
+ then Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:true ~err
+ else Cmdliner_msg.pp_err err_ppf ei ~err);
+ `Error `Term
+
+ (* API *)
+
+ let env_default v = try Some (Sys.getenv v) with Not_found -> None
+ let remove_exec argv =
+ try List.tl (Array.to_list argv) with Failure _ -> invalid_arg err_argv
+
+ let eval
+ ?help:(help_ppf = Format.std_formatter)
+ ?err:(err_ppf = Format.err_formatter)
+ ?(catch = true) ?(env = env_default) ?(argv = Sys.argv) ((al, f), ti) =
+ let term = Cmdliner_info.term_add_args ti al in
+ let ei = Cmdliner_info.eval ~term ~main:term ~choices:[] ~env in
+ let args = remove_exec argv in
+ let ei, res = term_eval ~catch ei f args in
+ do_result help_ppf err_ppf ei res
+
+ let choose_term main choices = function
+ | [] -> Ok (main, [])
+ | maybe :: args' as args ->
+ if String.length maybe > 1 && maybe.[0] = '-' then Ok (main, args) else
+ let index =
+ let add acc (choice, _ as c) =
+ let name = Cmdliner_info.term_name choice in
+ match Cmdliner_trie.add acc name c with
+ | `New t -> t
+ | `Replaced (c', _) -> invalid_arg (err_multi_cmd_def name c c')
+ in
+ List.fold_left add Cmdliner_trie.empty choices
+ in
+ match Cmdliner_trie.find index maybe with
+ | `Ok choice -> Ok (choice, args')
+ | `Not_found ->
+ let all = Cmdliner_trie.ambiguities index "" in
+ let hints = Cmdliner_suggest.value maybe all in
+ Error (Cmdliner_base.err_unknown ~kind:"command" maybe ~hints)
+ | `Ambiguous ->
+ let ambs = Cmdliner_trie.ambiguities index maybe in
+ let ambs = List.sort compare ambs in
+ Error (Cmdliner_base.err_ambiguous ~kind:"command" maybe ~ambs)
+
+ let eval_choice
+ ?help:(help_ppf = Format.std_formatter)
+ ?err:(err_ppf = Format.err_formatter)
+ ?(catch = true) ?(env = env_default) ?(argv = Sys.argv)
+ main choices =
+ let to_term_f ((al, f), ti) = Cmdliner_info.term_add_args ti al, f in
+ let choices_f = List.rev_map to_term_f choices in
+ let main_f = to_term_f main in
+ let choices = List.rev_map fst choices_f in
+ let main = fst main_f in
+ match choose_term main_f choices_f (remove_exec argv) with
+ | Error err ->
+ let ei = Cmdliner_info.eval ~term:main ~main ~choices ~env in
+ Cmdliner_msg.pp_err_usage err_ppf ei ~err_lines:false ~err;
+ `Error `Parse
+ | Ok ((chosen, f), args) ->
+ let ei = Cmdliner_info.eval ~term:chosen ~main ~choices ~env in
+ let ei, res = term_eval ~catch ei f args in
+ do_result help_ppf err_ppf ei res
+
+ let eval_peek_opts
+ ?(version_opt = false) ?(env = env_default) ?(argv = Sys.argv)
+ ((args, f) : 'a t) =
+ let version = if version_opt then Some "dummy" else None in
+ let term = Cmdliner_info.term ~args ?version "dummy" in
+ let ei = Cmdliner_info.eval ~term ~main:term ~choices:[] ~env in
+ (term_eval_peek_opts ei f (remove_exec argv) :> 'a option * 'a result)
+
+ (* Exits *)
+
+ let exit_status_of_result ?(term_err = 1) = function
+ | `Ok _ | `Help | `Version -> exit_status_success
+ | `Error `Term -> term_err
+ | `Error `Exn -> exit_status_internal_error
+ | `Error `Parse -> exit_status_cli_error
+
+ let exit_status_of_status_result ?term_err = function
+ | `Ok n -> n
+ | r -> exit_status_of_result ?term_err r
+
+ let stdlib_exit = exit
+ let exit ?term_err r = stdlib_exit (exit_status_of_result ?term_err r)
+ let exit_status ?term_err r =
+ stdlib_exit (exit_status_of_status_result ?term_err r)
+
+end
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,1624 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+(** Declarative definition of command line interfaces.
+
+ [Cmdliner] provides a simple and compositional mechanism
+ to convert command line arguments to OCaml values and pass them to
+ your functions. The module automatically handles syntax errors,
+ help messages and UNIX man page generation. It supports programs
+ with single or multiple commands
+ (like [darcs] or [git]) and respect most of the
+ {{:http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap12.html}
+ POSIX} and
+ {{:http://www.gnu.org/software/libc/manual/html_node/Argument-Syntax.html}
+ GNU} conventions.
+
+ Consult the {{!basics}basics}, details about the supported
+ {{!cmdline}command line syntax} and {{!examples} examples} of
+ use. Open the module to use it, it defines only three modules in
+ your scope.
+
+ {e %%VERSION%% — {{:%%PKG_HOMEPAGE%% }homepage}} *)
+
+(** {1:top Interface} *)
+
+(** Man page specification.
+
+ Man page generation is automatically handled by [Cmdliner],
+ consult the {{!manual}details}.
+
+ The {!block} type is used to define a man page's content. It's a
+ good idea to follow the {{!standard_sections}standard} manual page
+ structure.
+
+ {b References.}
+ {ul
+ {- [man-pages(7)], {{:http://man7.org/linux/man-pages/man7/man-pages.7.html}
+ {e Conventions for writing Linux man pages}}.}} *)
+module Manpage : sig
+
+ (** {1:man Man pages} *)
+
+ type block =
+ [ `S of string | `P of string | `Pre of string | `I of string * string
+ | `Noblank | `Blocks of block list ]
+ (** The type for a block of man page text.
+
+ {ul
+ {- [`S s] introduces a new section [s], see the
+ {{!standard_sections}standard section names}.}
+ {- [`P t] is a new paragraph with text [t].}
+ {- [`Pre t] is a new preformatted paragraph with text [t].}
+ {- [`I (l,t)] is an indented paragraph with label
+ [l] and text [t].}
+ {- [`Noblank] suppresses the blank line introduced between two blocks.}
+ {- [`Blocks bs] splices the blocks [bs].}}
+
+ Except in [`Pre], whitespace and newlines are not significant
+ and are all collapsed to a single space. All block strings
+ support the {{!doclang}documentation markup language}.*)
+
+ val escape : string -> string
+ (** [escape s] escapes [s] so that it doesn't get interpreted by the
+ {{!doclang}documentation markup language}. *)
+
+ type title = string * int * string * string * string
+ (** The type for man page titles. Describes the man page
+ [title], [section], [center_footer], [left_footer], [center_header]. *)
+
+ type t = title * block list
+ (** The type for a man page. A title and the page text as a list of blocks. *)
+
+ type xref =
+ [ `Main | `Cmd of string | `Tool of string | `Page of string * int ]
+ (** The type for man page cross-references.
+ {ul
+ {- [`Main] refers to the man page of the program itself.}
+ {- [`Cmd cmd] refers to the man page of the program's [cmd]
+ command (which must exist).}
+ {- [`Tool bin] refers to the command line tool named [bin].}
+ {- [`Page (name, sec)] refers to the man page [name(sec)].}} *)
+
+ (** {1:standard_sections Standard section names and content}
+
+ The following are standard man page section names, roughly ordered
+ in the order they conventionally appear. See also
+ {{:http://man7.org/linux/man-pages/man7/man-pages.7.html}[man man-pages]}
+ for more elaborations about what sections should contain. *)
+
+ val s_name : string
+ (** The [NAME] section. This section is automatically created by
+ [Cmdliner] for your. *)
+
+ val s_synopsis : string
+ (** The [SYNOPSIS] section. By default this section is automatically
+ created by [Cmdliner] for you, unless it is the first section of
+ your term's man page, in which case it will replace it with yours. *)
+
+ val s_description : string
+ (** The [DESCRIPTION] section. This should be a description of what
+ the tool does and provide a little bit of usage and
+ documentation guidance. *)
+
+ val s_commands : string
+ (** The [COMMANDS] section. By default subcommands get listed here. *)
+
+ val s_arguments : string
+ (** The [ARGUMENTS] section. By default positional arguments get
+ listed here. *)
+
+ val s_options : string
+ (** The [OPTIONS] section. By default options and flag arguments get
+ listed here. *)
+
+ val s_common_options : string
+ (** The [COMMON OPTIONS] section. For programs with multiple commands
+ a section that can be used to gather options common to all commands. *)
+
+ val s_exit_status : string
+ (** The [EXIT STATUS] section. By default term status exit codes
+ get listed here. *)
+
+ val s_environment : string
+ (** The [ENVIRONMENT] section. By default environment variables get
+ listed here. *)
+
+ val s_environment_intro : block
+ (** [s_environment_intro] is the introduction content used by cmdliner
+ when it creates the {!s_environment} section. *)
+
+ val s_files : string
+ (** The [FILES] section. *)
+
+ val s_bugs : string
+ (** The [BUGS] section. *)
+
+ val s_examples : string
+ (** The [EXAMPLES] section. *)
+
+ val s_authors : string
+ (** The [AUTHORS] section. *)
+
+ val s_see_also : string
+ (** The [SEE ALSO] section. *)
+
+ (** {1:output Output}
+
+ The {!print} function can be useful if the client wants to define
+ other man pages (e.g. to implement a help command). *)
+
+ type format = [ `Auto | `Pager | `Plain | `Groff ]
+ (** The type for man page output specification.
+ {ul
+ {- [`Auto], formats like [`Pager] or [`Plain] whenever the [TERM]
+ environment variable is [dumb] or unset.}
+ {- [`Pager], tries to write to a discovered pager, if that fails
+ uses the [`Plain] format.}
+ {- [`Plain], formats to plain text.}
+ {- [`Groff], formats to groff commands.}} *)
+
+ val print :
+ ?errs:Format.formatter ->
+ ?subst:(string -> string option) -> format -> Format.formatter -> t -> unit
+ (** [print ~errs ~subst fmt ppf page] prints [page] on [ppf] in the
+ format [fmt]. [subst] can be used to perform variable
+ substitution,(defaults to the identity). [errs] is used to print
+ formatting errors, it defaults to {!Format.err_formatter}. *)
+end
+
+(** Terms.
+
+ A term is evaluated by a program to produce a {{!result}result},
+ which can be turned into an {{!exits}exit status}. A term made of terms
+ referring to {{!Arg}command line arguments} implicitly defines a
+ command line syntax. *)
+module Term : sig
+
+ (** {1:terms Terms} *)
+
+ type +'a t
+ (** The type for terms evaluating to values of type 'a. *)
+
+ val const : 'a -> 'a t
+ (** [const v] is a term that evaluates to [v]. *)
+
+ (**/**)
+ val pure : 'a -> 'a t
+ (** @deprecated use {!const} instead. *)
+
+ val man_format : Manpage.format t
+ (** @deprecated Use {!Arg.man_format} instead. *)
+ (**/**)
+
+ val ( $ ) : ('a -> 'b) t -> 'a t -> 'b t
+ (** [f $ v] is a term that evaluates to the result of applying
+ the evaluation of [v] to the one of [f]. *)
+
+ val app : ('a -> 'b) t -> 'a t -> 'b t
+ (** [app] is {!($)}. *)
+
+ (** {1 Interacting with Cmdliner's evaluation} *)
+
+ type 'a ret =
+ [ `Help of Manpage.format * string option
+ | `Error of (bool * string)
+ | `Ok of 'a ]
+ (** The type for command return values. See {!ret}. *)
+
+ val ret : 'a ret t -> 'a t
+ (** [ret v] is a term whose evaluation depends on the case
+ to which [v] evaluates. With :
+ {ul
+ {- [`Ok v], it evaluates to [v].}
+ {- [`Error (usage, e)], the evaluation fails and [Cmdliner] prints
+ the error [e] and the term's usage if [usage] is [true].}
+ {- [`Help (format, name)], the evaluation fails and [Cmdliner] prints the
+ term's man page in the given [format] (or the man page for a
+ specific [name] term in case of multiple term evaluation).}} *)
+
+ val term_result : ?usage:bool -> ('a, [`Msg of string]) result t -> 'a t
+ (** [term_result ~usage t] evaluates to
+ {ul
+ {- [`Ok v] if [t] evaluates to [Ok v]}
+ {- [`Error `Term] with the error message [e] and usage shown according
+ to [usage] (defaults to [false]), if [t] evaluates to
+ [Error (`Msg e)].}} *)
+
+ val cli_parse_result : ('a, [`Msg of string]) result t -> 'a t
+ (** [cli_parse_result t] is a term that evaluates to:
+ {ul
+ {- [`Ok v] if [t] evaluates to [Ok v].}
+ {- [`Error `Parse] with the error message [e]
+ if [t] evaluates to [Error (`Msg e)].}} *)
+
+ val main_name : string t
+ (** [main_name] is a term that evaluates to the "main" term's name. *)
+
+ val choice_names : string list t
+ (** [choice_names] is a term that evaluates to the names of the terms
+ to choose from. *)
+
+ val with_used_args : 'a t -> ('a * string list) t
+ (** [with_used_args t] is a term that evaluates to [t] tupled
+ with the arguments from the command line that where used to
+ evaluate [t]. *)
+
+ (** {1:tinfo Term information}
+
+ Term information defines the name and man page of a term.
+ For simple evaluation this is the name of the program and its
+ man page. For multiple term evaluation, this is
+ the name of a command and its man page. *)
+
+ type exit_info
+ (** The type for exit status information. *)
+
+ val exit_info : ?docs:string -> ?doc:string -> ?max:int -> int -> exit_info
+ (** [exit_info ~docs ~doc min ~max] describe the range of exit
+ statuses from [min] to [max] (defaults to [min]). [doc] is the
+ man page information for the statuses, defaults to ["undocumented"].
+ [docs] is the title of the man page section in which the statuses
+ will be listed, it defaults to {!Manpage.s_exit_status}.
+
+ In [doc] the {{!doclang}documentation markup language} can be
+ used with following variables:
+ {ul
+ {- [$(status)], the value of [min].}
+ {- [$(status_max)], the value of [max].}
+ {- The variables mentioned in {!info}}} *)
+
+ val default_exits : exit_info list
+ (** [default_exits] is information for exit status {!exit_status_success}
+ added to {!default_error_exits}. *)
+
+ val default_error_exits : exit_info list
+ (** [default_error_exits] is information for exit statuses
+ {!exit_status_cli_error} and {!exit_status_internal_error}. *)
+
+ type env_info
+ (** The type for environment variable information. *)
+
+ val env_info : ?docs:string -> ?doc:string -> string -> env_info
+ (** [env_info ~docs ~doc var] describes an environment variable
+ [var]. [doc] is the man page information of the environment
+ variable, defaults to ["undocumented"]. [docs] is the title of
+ the man page section in which the environment variable will be
+ listed, it defaults to {!Manpage.s_environment}.
+
+ In [doc] the {{!doclang}documentation markup language} can be
+ used with following variables:
+ {ul
+ {- [$(env)], the value of [var].}
+ {- The variables mentioned in {!info}}} *)
+
+ type info
+ (** The type for term information. *)
+
+ val info :
+ ?man_xrefs:Manpage.xref list -> ?man:Manpage.block list ->
+ ?envs:env_info list -> ?exits:exit_info list -> ?sdocs:string ->
+ ?docs:string -> ?doc:string -> ?version:string -> string -> info
+ (** [info sdocs man docs doc version name] is a term information
+ such that:
+ {ul
+ {- [name] is the name of the program or the command.}
+ {- [version] is the version string of the program, ignored
+ for commands.}
+ {- [doc] is a one line description of the program or command used
+ for the [NAME] section of the term's man page. For commands this
+ description is also used in the list of commands of the main
+ term's man page.}
+ {- [docs], only for commands, the title of the section of the main
+ term's man page where it should be listed (defaults to
+ {!Manpage.s_commands}).}
+ {- [sdocs] defines the title of the section in which the
+ standard [--help] and [--version] arguments are listed
+ (defaults to {!Manpage.s_options}).}
+ {- [exits] is a list of exit statuses that the term evaluation
+ may produce.}
+ {- [envs] is a list of environment variables that influence
+ the term's evaluation.}
+ {- [man] is the text of the man page for the term.}
+ {- [man_xrefs] are cross-references to other manual pages. These
+ are used to generate a {!Manpage.s_see_also} section.}}
+ [doc], [man], [envs] support the {{!doclang}documentation markup
+ language} in which the following variables are recognized:
+ {ul
+ {- [$(tname)] the term's name.}
+ {- [$(mname)] the main term's name.}} *)
+
+ val name : info -> string
+ (** [name ti] is the name of the term information. *)
+
+ (** {1:evaluation Evaluation} *)
+
+ type 'a result =
+ [ `Ok of 'a | `Error of [`Parse | `Term | `Exn ] | `Version | `Help ]
+ (** The type for evaluation results.
+ {ul
+ {- [`Ok v], the term evaluated successfully and [v] is the result.}
+ {- [`Version], the version string of the main term was printed
+ on the help formatter.}
+ {- [`Help], man page about the term was printed on the help formatter.}
+ {- [`Error `Parse], a command line parse error occurred and was
+ reported on the error formatter.}
+ {- [`Error `Term], a term evaluation error occurred and was reported
+ on the error formatter (see {!Term.ret}).}
+ {- [`Error `Exn], an exception [e] was caught and reported
+ on the error formatter (see the [~catch] parameter of {!eval}).}} *)
+
+ val eval :
+ ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool ->
+ ?env:(string -> string option) -> ?argv:string array -> ('a t * info) ->
+ 'a result
+ (** [eval help err catch argv (t,i)] is the evaluation result
+ of [t] with command line arguments [argv] (defaults to {!Sys.argv}).
+
+ If [catch] is [true] (default) uncaught exceptions
+ are intercepted and their stack trace is written to the [err]
+ formatter.
+
+ [help] is the formatter used to print help or version messages
+ (defaults to {!Format.std_formatter}). [err] is the formatter
+ used to print error messages (defaults to {!Format.err_formatter}).
+
+ [env] is used for environment variable lookup, the default
+ uses {!Sys.getenv}. *)
+
+ val eval_choice :
+ ?help:Format.formatter -> ?err:Format.formatter -> ?catch:bool ->
+ ?env:(string -> string option) -> ?argv:string array ->
+ 'a t * info -> ('a t * info) list -> 'a result
+ (** [eval_choice help err catch argv (t,i) choices] is like {!eval}
+ except that if the first argument on the command line is not an option
+ name it will look in [choices] for a term whose information has this
+ name and evaluate it.
+
+ If the command name is unknown an error is reported. If the name
+ is unspecified the "main" term [t] is evaluated. [i] defines the
+ name and man page of the program. *)
+
+ val eval_peek_opts :
+ ?version_opt:bool -> ?env:(string -> string option) ->
+ ?argv:string array -> 'a t -> 'a option * 'a result
+ (** [eval_peek_opts version_opt argv t] evaluates [t], a term made
+ of optional arguments only, with the command line [argv]
+ (defaults to {!Sys.argv}). In this evaluation, unknown optional
+ arguments and positional arguments are ignored.
+
+ The evaluation returns a pair. The first component is
+ the result of parsing the command line [argv] stripped from
+ any help and version option if [version_opt] is [true] (defaults
+ to [false]). It results in:
+ {ul
+ {- [Some _] if the command line would be parsed correctly given the
+ {e partial} knowledge in [t].}
+ {- [None] if a parse error would occur on the options of [t]}}
+
+ The second component is the result of parsing the command line
+ [argv] without stripping the help and version options. It
+ indicates what the evaluation would result in on [argv] given
+ the partial knowledge in [t] (for example it would return
+ [`Help] if there's a help option in [argv]). However in
+ contrasts to {!eval} and {!eval_choice} no side effects like
+ error reporting or help output occurs.
+
+ {b Note.} Positional arguments can't be peeked without the full
+ specification of the command line: we can't tell apart a
+ positional argument from the value of an unknown optional
+ argument. *)
+
+ (** {1:exits Turning evaluation results into exit codes}
+
+ {b Note.} If you are using the following functions to handle
+ the evaluation result of a term you should add {!default_exits} to
+ the term's information {{!info}[~exits]} argument.
+
+ {b WARNING.} You should avoid status codes strictly greater than 125
+ as those may be used by
+ {{:https://www.gnu.org/software/bash/manual/html_node/Exit-Status.html}
+ some} shells. *)
+
+ val exit_status_success : int
+ (** [exit_status_success] is 0, the exit status for success. *)
+
+ val exit_status_cli_error : int
+ (** [exit_status_cli_error] is 124, an exit status for command line
+ parsing errors. *)
+
+ val exit_status_internal_error : int
+ (** [exit_status_internal_error] is 125, an exit status for unexpected
+ internal errors. *)
+
+ val exit_status_of_result : ?term_err:int -> 'a result -> int
+ (** [exit_status_of_result ~term_err r] is an [exit(3)] status
+ code determined from [r] as follows:
+ {ul
+ {- {!exit_status_success} if [r] is one of [`Ok _], [`Version], [`Help]}
+ {- [term_err] if [r] is [`Error `Term], [term_err] defaults to [1].}
+ {- {!exit_status_cli_error} if [r] is [`Error `Parse]}
+ {- {!exit_status_internal_error} if [r] is [`Error `Exn]}} *)
+
+ val exit_status_of_status_result : ?term_err:int -> int result -> int
+ (** [exit_status_of_status_result] is like {!exit_status_of_result}
+ except for [`Ok n] where [n] is used as the status exit code. *)
+
+ val exit : ?term_err:int -> 'a result -> unit
+ (** [exit ~term_err r] is
+ [Stdlib.exit @@ exit_status_of_result ~term_err r] *)
+
+ val exit_status : ?term_err:int -> int result -> unit
+ (** [exit_status ~term_err r] is
+ [Stdlib.exit @@ exit_status_of_status_result ~term_err r] *)
+end
+
+(** Terms for command line arguments.
+
+ This module provides functions to define terms that evaluate
+ to the arguments provided on the command line.
+
+ Basic constraints, like the argument type or repeatability, are
+ specified by defining a value of type {!t}. Further constraints can
+ be specified during the {{!argterms}conversion} to a term. *)
+module Arg : sig
+
+(** {1:argconv Argument converters}
+
+ An argument converter transforms a string argument of the command
+ line to an OCaml value. {{!converters}Predefined converters}
+ are provided for many types of the standard library. *)
+
+ type 'a parser = string -> [ `Ok of 'a | `Error of string ]
+ (** The type for argument parsers.
+
+ @deprecated Use a parser with [('a, [ `Msg of string]) result] results
+ and {!conv}. *)
+
+ type 'a printer = Format.formatter -> 'a -> unit
+ (** The type for converted argument printers. *)
+
+ type 'a conv = 'a parser * 'a printer
+ (** The type for argument converters.
+
+ {b WARNING.} This type will become abstract in the next
+ major version of cmdliner, use {!val:conv} or {!pconv}
+ to construct values of this type. *)
+
+ type 'a converter = 'a conv
+ (** @deprecated Use the {!type:conv} type via the {!val:conv} and {!pconv}
+ functions. *)
+
+ val conv :
+ ?docv:string -> (string -> ('a, [`Msg of string]) result) * 'a printer ->
+ 'a conv
+ (** [converter ~docv (parse, print)] is an argument converter
+ parsing values with [parse] and printing them with
+ [print]. [docv] is a documentation meta-variable used in the
+ documentation to stand for the argument value, defaults to
+ ["VALUE"]. *)
+
+ val pconv :
+ ?docv:string -> 'a parser * 'a printer -> 'a conv
+ (** [pconv] is like {!converter}, but uses a deprecated {!parser}
+ signature. *)
+
+ val conv_parser : 'a conv -> (string -> ('a, [`Msg of string]) result)
+ (** [conv_parser c] 's [c]'s parser. *)
+
+ val conv_printer : 'a conv -> 'a printer
+ (** [conv_printer c] is [c]'s printer. *)
+
+ val conv_docv : 'a conv -> string
+ (** [conv_docv c] is [c]'s documentation meta-variable.
+
+ {b WARNING.} Currently always returns ["VALUE"] in the future
+ will return the value given to {!conv} or {!pconv}. *)
+
+ val parser_of_kind_of_string :
+ kind:string -> (string -> 'a option) ->
+ (string -> ('a, [`Msg of string]) result)
+ (** [parser_of_kind_of_string ~kind kind_of_string] is an argument
+ parser using the [kind_of_string] function for parsing and [kind]
+ to report errors (e.g. could be ["an integer"] for an [int] parser.). *)
+
+ val some : ?none:string -> 'a conv -> 'a option conv
+ (** [some none c] is like the converter [c] except it returns
+ [Some] value. It is used for command line arguments
+ that default to [None] when absent. [none] is what to print to
+ document the absence (defaults to [""]). *)
+
+(** {1:arginfo Arguments and their information}
+
+ Argument information defines the man page information of an
+ argument and, for optional arguments, its names. An environment
+ variable can also be specified to read the argument value from
+ if the argument is absent from the command line and the variable
+ is defined. *)
+
+ type env = Term.env_info
+ (** The type for environment variables and their documentation. *)
+
+ val env_var : ?docs:string -> ?doc:string -> string -> env
+ (** [env_var docs doc var] is an environment variables [var]. [doc]
+ is the man page information of the environment variable, the
+ {{!doclang}documentation markup language} with the variables
+ mentioned in {!info} be used; it defaults to ["See option
+ $(opt)."]. [docs] is the title of the man page section in which
+ the environment variable will be listed, it defaults to
+ {!Manpage.s_environment}. *)
+
+ type 'a t
+ (** The type for arguments holding data of type ['a]. *)
+
+ type info
+ (** The type for information about command line arguments. *)
+
+ val info :
+ ?docs:string -> ?docv:string -> ?doc:string -> ?env:env -> string list ->
+ info
+ (** [info docs docv doc env names] defines information for
+ an argument.
+ {ul
+ {- [names] defines the names under which an optional argument
+ can be referred to. Strings of length [1] (["c"]) define
+ short option names (["-c"]), longer strings (["count"])
+ define long option names (["--count"]). [names] must be empty
+ for positional arguments.}
+ {- [env] defines the name of an environment variable which is
+ looked up for defining the argument if it is absent from the
+ command line. See {{!envlookup}environment variables} for
+ details.}
+ {- [doc] is the man page information of the argument.
+ The {{!doclang}documentation language} can be used and
+ the following variables are recognized:
+ {ul
+ {- ["$(docv)"] the value of [docv] (see below).}
+ {- ["$(opt)"], one of the options of [names], preference
+ is given to a long one.}
+ {- ["$(env)"], the environment var specified by [env] (if any).}}
+ {{!doc_helpers}These functions} can help with formatting argument
+ values.}
+ {- [docv] is for positional and non-flag optional arguments.
+ It is a variable name used in the man page to stand for their value.}
+ {- [docs] is the title of the man page section in which the argument
+ will be listed. For optional arguments this defaults
+ to {!Manpage.s_options}. For positional arguments this defaults
+ to {!Manpage.s_arguments}. However a positional argument is only
+ listed if it has both a [doc] and [docv] specified.}} *)
+
+ val ( & ) : ('a -> 'b) -> 'a -> 'b
+ (** [f & v] is [f v], a right associative composition operator for
+ specifying argument terms. *)
+
+(** {1:optargs Optional arguments}
+
+ The information of an optional argument must have at least
+ one name or [Invalid_argument] is raised. *)
+
+ val flag : info -> bool t
+ (** [flag i] is a [bool] argument defined by an optional flag
+ that may appear {e at most} once on the command line under one of
+ the names specified by [i]. The argument holds [true] if the
+ flag is present on the command line and [false] otherwise. *)
+
+ val flag_all : info -> bool list t
+ (** [flag_all] is like {!flag} except the flag may appear more than
+ once. The argument holds a list that contains one [true] value per
+ occurrence of the flag. It holds the empty list if the flag
+ is absent from the command line. *)
+
+ val vflag : 'a -> ('a * info) list -> 'a t
+ (** [vflag v \[v]{_0}[,i]{_0}[;...\]] is an ['a] argument defined
+ by an optional flag that may appear {e at most} once on
+ the command line under one of the names specified in the [i]{_k}
+ values. The argument holds [v] if the flag is absent from the
+ command line and the value [v]{_k} if the name under which it appears
+ is in [i]{_k}.
+
+ {b Note.} Environment variable lookup is unsupported for
+ for these arguments. *)
+
+ val vflag_all : 'a list -> ('a * info) list -> 'a list t
+ (** [vflag_all v l] is like {!vflag} except the flag may appear more
+ than once. The argument holds the list [v] if the flag is absent
+ from the command line. Otherwise it holds a list that contains one
+ corresponding value per occurrence of the flag, in the order found on
+ the command line.
+
+ {b Note.} Environment variable lookup is unsupported for
+ for these arguments. *)
+
+ val opt : ?vopt:'a -> 'a conv -> 'a -> info -> 'a t
+ (** [opt vopt c v i] is an ['a] argument defined by the value of
+ an optional argument that may appear {e at most} once on the command
+ line under one of the names specified by [i]. The argument holds
+ [v] if the option is absent from the command line. Otherwise
+ it has the value of the option as converted by [c].
+
+ If [vopt] is provided the value of the optional argument is itself
+ optional, taking the value [vopt] if unspecified on the command line. *)
+
+ val opt_all : ?vopt:'a -> 'a conv -> 'a list -> info -> 'a list t
+ (** [opt_all vopt c v i] is like {!opt} except the optional argument may
+ appear more than once. The argument holds a list that contains one value
+ per occurrence of the flag in the order found on the command line.
+ It holds the list [v] if the flag is absent from the command line. *)
+
+ (** {1:posargs Positional arguments}
+
+ The information of a positional argument must have no name
+ or [Invalid_argument] is raised. Positional arguments indexing
+ is zero-based.
+
+ {b Warning.} The following combinators allow to specify and
+ extract a given positional argument with more than one term.
+ This should not be done as it will likely confuse end users and
+ documentation generation. These over-specifications may be
+ prevented by raising [Invalid_argument] in the future. But for now
+ it is the client's duty to make sure this doesn't happen. *)
+
+ val pos : ?rev:bool -> int -> 'a conv -> 'a -> info -> 'a t
+ (** [pos rev n c v i] is an ['a] argument defined by the [n]th
+ positional argument of the command line as converted by [c].
+ If the positional argument is absent from the command line
+ the argument is [v].
+
+ If [rev] is [true] (defaults to [false]), the computed
+ position is [max-n] where [max] is the position of
+ the last positional argument present on the command line. *)
+
+ val pos_all : 'a conv -> 'a list -> info -> 'a list t
+ (** [pos_all c v i] is an ['a list] argument that holds
+ all the positional arguments of the command line as converted
+ by [c] or [v] if there are none. *)
+
+ val pos_left :
+ ?rev:bool -> int -> 'a conv -> 'a list -> info -> 'a list t
+ (** [pos_left rev n c v i] is an ['a list] argument that holds
+ all the positional arguments as converted by [c] found on the left
+ of the [n]th positional argument or [v] if there are none.
+
+ If [rev] is [true] (defaults to [false]), the computed
+ position is [max-n] where [max] is the position of
+ the last positional argument present on the command line. *)
+
+ val pos_right :
+ ?rev:bool -> int -> 'a conv -> 'a list -> info -> 'a list t
+ (** [pos_right] is like {!pos_left} except it holds all the positional
+ arguments found on the right of the specified positional argument. *)
+
+ (** {1:argterms Arguments as terms} *)
+
+ val value : 'a t -> 'a Term.t
+ (** [value a] is a term that evaluates to [a]'s value. *)
+
+ val required : 'a option t -> 'a Term.t
+ (** [required a] is a term that fails if [a]'s value is [None] and
+ evaluates to the value of [Some] otherwise. Use this for required
+ positional arguments (it can also be used for defining required
+ optional arguments, but from a user interface perspective this
+ shouldn't be done, it is a contradiction in terms). *)
+
+ val non_empty : 'a list t -> 'a list Term.t
+ (** [non_empty a] is term that fails if [a]'s list is empty and
+ evaluates to [a]'s list otherwise. Use this for non empty lists
+ of positional arguments. *)
+
+ val last : 'a list t -> 'a Term.t
+ (** [last a] is a term that fails if [a]'s list is empty and evaluates
+ to the value of the last element of the list otherwise. Use this
+ for lists of flags or options where the last occurrence takes precedence
+ over the others. *)
+
+ (** {1:predef Predefined arguments} *)
+
+ val man_format : Manpage.format Term.t
+ (** [man_format] is a term that defines a [--man-format] option and
+ evaluates to a value that can be used with {!Manpage.print}. *)
+
+ (** {1:converters Predefined converters} *)
+
+ val bool : bool conv
+ (** [bool] converts values with {!bool_of_string}. *)
+
+ val char : char conv
+ (** [char] converts values by ensuring the argument has a single char. *)
+
+ val int : int conv
+ (** [int] converts values with {!int_of_string}. *)
+
+ val nativeint : nativeint conv
+ (** [nativeint] converts values with {!Nativeint.of_string}. *)
+
+ val int32 : int32 conv
+ (** [int32] converts values with {!Int32.of_string}. *)
+
+ val int64 : int64 conv
+ (** [int64] converts values with {!Int64.of_string}. *)
+
+ val float : float conv
+ (** [float] converts values with {!float_of_string}. *)
+
+ val string : string conv
+ (** [string] converts values with the identity function. *)
+
+ val enum : (string * 'a) list -> 'a conv
+ (** [enum l p] converts values such that unambiguous prefixes of string names
+ in [l] map to the corresponding value of type ['a].
+
+ {b Warning.} The type ['a] must be comparable with {!Pervasives.compare}.
+
+ @raise Invalid_argument if [l] is empty. *)
+
+ val file : string conv
+ (** [file] converts a value with the identity function and
+ checks with {!Sys.file_exists} that a file with that name exists. *)
+
+ val dir : string conv
+ (** [dir] converts a value with the identity function and checks
+ with {!Sys.file_exists} and {!Sys.is_directory}
+ that a directory with that name exists. *)
+
+ val non_dir_file : string conv
+ (** [non_dir_file] converts a value with the identity function and checks
+ with {!Sys.file_exists} and {!Sys.is_directory}
+ that a non directory file with that name exists. *)
+
+ val list : ?sep:char -> 'a conv -> 'a list conv
+ (** [list sep c] splits the argument at each [sep] (defaults to [','])
+ character and converts each substrings with [c]. *)
+
+ val array : ?sep:char -> 'a conv -> 'a array conv
+ (** [array sep c] splits the argument at each [sep] (defaults to [','])
+ character and converts each substring with [c]. *)
+
+ val pair : ?sep:char -> 'a conv -> 'b conv -> ('a * 'b) conv
+ (** [pair sep c0 c1] splits the argument at the {e first} [sep] character
+ (defaults to [',']) and respectively converts the substrings with
+ [c0] and [c1]. *)
+
+ val t2 : ?sep:char -> 'a conv -> 'b conv -> ('a * 'b) conv
+ (** {!t2} is {!pair}. *)
+
+ val t3 : ?sep:char -> 'a conv ->'b conv -> 'c conv -> ('a * 'b * 'c) conv
+ (** [t3 sep c0 c1 c2] splits the argument at the {e first} two [sep]
+ characters (defaults to [',']) and respectively converts the
+ substrings with [c0], [c1] and [c2]. *)
+
+ val t4 :
+ ?sep:char -> 'a conv -> 'b conv -> 'c conv -> 'd conv ->
+ ('a * 'b * 'c * 'd) conv
+ (** [t4 sep c0 c1 c2 c3] splits the argument at the {e first} three [sep]
+ characters (defaults to [',']) respectively converts the substrings
+ with [c0], [c1], [c2] and [c3]. *)
+
+ (** {1:doc_helpers Documentation formatting helpers} *)
+
+ val doc_quote : string -> string
+ (** [doc_quote s] quotes the string [s]. *)
+
+ val doc_alts : ?quoted:bool -> string list -> string
+ (** [doc_alts alts] documents the alternative tokens [alts] according
+ the number of alternatives. If [quoted] is [true] (default)
+ the tokens are quoted. The resulting string can be used in
+ sentences of the form ["$(docv) must be %s"].
+
+ @raise Invalid_argument if [alts] is the empty string. *)
+
+ val doc_alts_enum : ?quoted:bool -> (string * 'a) list -> string
+ (** [doc_alts_enum quoted alts] is [doc_alts quoted (List.map fst alts)]. *)
+end
+
+(** {1:basics Basics}
+
+ With [Cmdliner] your program evaluates a term. A {e term} is a value
+ of type {!Term.t}. The type parameter indicates the type of the
+ result of the evaluation.
+
+One way to create terms is by lifting regular OCaml values with
+{!Term.const}. Terms can be applied to terms evaluating to functional
+values with {!Term.( $ )}. For example for the function:
+
+{[
+let revolt () = print_endline "Revolt!"
+]}
+
+the term :
+
+{[
+open Cmdliner
+
+let revolt_t = Term.(const revolt $ const ())
+]}
+
+is a term that evaluates to the result (and effect) of the [revolt]
+function. Terms are evaluated with {!Term.eval}:
+
+{[
+let () = Term.exit @@ Term.eval (revolt_t, Term.info "revolt")
+]}
+
+This defines a command line program named ["revolt"], without command
+line arguments, that just prints ["Revolt!"] on [stdout].
+
+{[
+> ./revolt
+Revolt!
+]}
+
+The combinators in the {!Arg} module allow to extract command line
+argument data as terms. These terms can then be applied to lifted
+OCaml functions to be evaluated by the program.
+
+Terms corresponding to command line argument data that are part of a
+term evaluation implicitly define a command line syntax. We show this
+on an concrete example.
+
+Consider the [chorus] function that prints repeatedly a given message :
+
+{[
+let chorus count msg =
+ for i = 1 to count do print_endline msg done
+]}
+
+we want to make it available from the command line with the synopsis:
+
+{[
+chorus [-c COUNT | --count=COUNT] [MSG]
+]}
+
+where [COUNT] defaults to [10] and [MSG] defaults to ["Revolt!"]. We
+first define a term corresponding to the [--count] option:
+
+{[
+let count =
+ let doc = "Repeat the message $(docv) times." in
+ Arg.(value & opt int 10 & info ["c"; "count"] ~docv:"COUNT" ~doc)
+]}
+
+This says that [count] is a term that evaluates to the value of an
+optional argument of type [int] that defaults to [10] if unspecified
+and whose option name is either [-c] or [--count]. The arguments [doc]
+and [docv] are used to generate the option's man page information.
+
+The term for the positional argument [MSG] is:
+
+{[
+let msg =
+ let doc = "Overrides the default message to print." in
+ let env = Arg.env_var "CHORUS_MSG" ~doc in
+ let doc = "The message to print." in
+ Arg.(value & pos 0 string "Revolt!" & info [] ~env ~docv:"MSG" ~doc)
+]}
+
+which says that [msg] is a term whose value is the positional argument
+at index [0] of type [string] and defaults to ["Revolt!"] or the
+value of the environment variable [CHORUS_MSG] if the argument is
+unspecified on the command line. Here again [doc] and [docv] are used
+for the man page information.
+
+The term for executing [chorus] with these command line arguments is :
+
+{[
+let chorus_t = Term.(const chorus $ count $ msg)
+]}
+
+and we are now ready to define our program:
+
+{[
+let info =
+ let doc = "print a customizable message repeatedly" in
+ let man = [
+ `S Manpage.s_bugs;
+ `P "Email bug reports to <hehey at example.org>." ]
+ in
+ Term.info "chorus" ~version:"%%VERSION%%" ~doc ~exits:Term.default_exits ~man
+
+let () = Term.exit @@ Term.eval (chorus_t, info))
+]}
+
+The [info] value created with {!Term.info} gives more information
+about the term we execute and is used to generate the program's man
+page. Since we provided a [~version] string, the program will
+automatically respond to the [--version] option by printing this
+string.
+
+A program using {!Term.eval} always responds to the [--help] option by
+showing the man page about the program generated using the information
+you provided with {!Term.info} and {!Arg.info}. Here is the output
+generated by our example :
+
+{v
+> ./chorus --help
+NAME
+ chorus - print a customizable message repeatedly
+
+SYNOPSIS
+ chorus [OPTION]... [MSG]
+
+ARGUMENTS
+ MSG (absent=Revolt! or CHORUS_MSG env)
+ The message to print.
+
+OPTIONS
+ -c COUNT, --count=COUNT (absent=10)
+ Repeat the message COUNT times.
+
+ --help[=FMT] (default=auto)
+ Show this help in format FMT. The value FMT must be one of `auto',
+ `pager', `groff' or `plain'. With `auto', the format is `pager` or
+ `plain' whenever the TERM env var is `dumb' or undefined.
+
+ --version
+ Show version information.
+
+EXIT STATUS
+ chorus exits with the following status:
+
+ 0 on success.
+
+ 124 on command line parsing errors.
+
+ 125 on unexpected internal errors (bugs).
+
+ENVIRONMENT
+ These environment variables affect the execution of chorus:
+
+ CHORUS_MSG
+ Overrides the default message to print.
+
+BUGS
+ Email bug reports to <hehey at example.org>.
+v}
+
+If a pager is available, this output is written to a pager. This help
+is also available in plain text or in the
+{{:http://www.gnu.org/software/groff/groff.html}groff} man page format
+by invoking the program with the option [--help=plain] or
+[--help=groff].
+
+For examples of more complex command line definitions look and run
+the {{!examples}examples}.
+
+{2:multiterms Multiple terms}
+
+[Cmdliner] also provides support for programs like [darcs] or [git]
+that have multiple commands each with their own syntax:
+
+{[prog COMMAND [OPTION]... ARG...]}
+
+A command is defined by coupling a term with {{!Term.tinfo}term
+information}. The term information defines the command name and its
+man page. Given a list of commands the function {!Term.eval_choice}
+will execute the term corresponding to the [COMMAND] argument or a
+specific "main" term if there is no [COMMAND] argument.
+
+{2:doclang Documentation markup language}
+
+Manpage {{!Manpage.block}blocks} and doc strings support the following
+markup language.
+
+{ul
+{- Markup directives [$(i,text)] and [$(b,text)], where [text] is raw
+ text respectively rendered in italics and bold.}
+{- Outside markup directives, context dependent variables of the form
+ [$(var)] are substituted by marked up data. For example in a term's
+ man page [$(tname)] is substituted by the term name in bold.}
+{- Characters $, (, ) and \ can respectively be escaped by \$, \(, \)
+ and \\ (in OCaml strings this will be ["\\$"], ["\\("], ["\\)"],
+ ["\\\\"]). Escaping $ and \ is mandatory everywhere. Escaping ) is
+ mandatory only in markup directives. Escaping ( is only here for
+ your symmetric pleasure. Any other sequence of characters starting
+ with a \ is an illegal character sequence.}
+{- Refering to unknown markup directives or variables will generate
+ errors on standard error during documentation generation.}}
+
+{2:manual Manual}
+
+Man page sections for a term are printed in the order specified by the
+term manual as given to {!Term.info}. Unless specified explicitely in
+the term's manual the following sections are automaticaly created and
+populated for you:
+
+{ul
+{- {{!Manpage.s_name}[NAME]} section.}
+{- {{!Manpage.s_synopsis}[SYNOPSIS]} section.}}
+
+The various [doc] documentation strings specified by the term's
+subterms and additional metadata get inserted at the end of the
+documentation section name [docs] they respectively mention, in the
+following order:
+
+{ol
+{- Commands, see {!Term.info}.}
+{- Positional arguments, see {!Arg.info}. Those are listed iff
+ both the [docv] and [doc] string is specified by {!Arg.info}.}
+{- Optional arguments, see {!Arg.info}.}
+{- Exit statuses, see {!Term.exit_info}.}
+{- Environment variables, see {!Arg.env_var} and {!Term.env_info}.}}
+
+If a [docs] section name is mentioned and does not exist in the term's
+manual, an empty section is created for it, after which the [doc] strings
+are inserted, possibly prefixed by boilerplate text (e.g. for
+{!Manpage.s_environment} and {!Manpage.s_exit_status}).
+
+If the created section is:
+{ul
+{- {{!Manpage.standard_sections}standard}, it
+ is inserted at the right place in the order specified
+ {{!Manpage.standard_sections}here}, but after a possible non-standard
+ section explicitely specified by the term since the latter get the
+ order number of the last previously specified standard section
+ or the order of {!Manpage.s_synopsis} if there is no such section.}
+{- non-standard, it is inserted before the {!Manpage.s_commands}
+ section or the first subsequent existing standard section if it
+ doesn't exist. Taking advantage of this behaviour is discouraged,
+ you should declare manually your non standard section in the term's
+ manual.}}
+
+Ideally all manual strings should be UTF-8 encoded. However at the
+moment macOS (until at least 10.12) is stuck with [groff 1.19.2] which
+doesn't support `preconv(1)`. Regarding UTF-8 output, generating the
+man page with [-Tutf8] maps the hyphen-minus [U+002D] to the minus
+sign [U+2212] which makes it difficult to search it in the pager, so
+[-Tascii] is used for now. Conclusion is that it is better to stick
+to the ASCII set for now. Please contact the author if something seems
+wrong in this reasoning or if you know a work around this.
+
+{2:misc Miscellaneous}
+
+{ul
+{- The option name [--cmdliner] is reserved by the library.}
+{- The option name [--help], (and [--version] if you specify a version
+ string) is reserved by the library. Using it as a term or option
+ name may result in undefined behaviour.}
+{- Defining the same option or command name via two different
+ arguments or terms is illegal and raises [Invalid_argument].}}
+
+{1:cmdline Command line syntax}
+
+For programs evaluating a single term the most general form of invocation is:
+
+{[
+prog [OPTION]... [ARG]...
+]}
+
+The program automatically reponds to the [--help] option by printing
+the help. If a version string is provided in the {{!Term.tinfo}term
+information}, it also automatically responds to the [--version] option
+by printing this string.
+
+Command line arguments are either {{!optargs}{e optional}} or
+{{!posargs}{e positional}}. Both can be freely interleaved but since
+[Cmdliner] accepts many optional forms this may result in
+ambiguities. The special {{!posargs} token [--]} can be used to
+resolve them.
+
+Programs evaluating multiple terms also add this form of invocation:
+
+{[
+prog COMMAND [OPTION]... [ARG]...
+]}
+
+Commands automatically respond to the [--help] option by printing
+their help. The [COMMAND] string must be the first string following
+the program name and may be specified by a prefix as long as it is not
+ambiguous.
+
+{2:optargs Optional arguments}
+
+An optional argument is specified on the command line by a {e name}
+possibly followed by a {e value}.
+
+The name of an option can be short or long.
+
+{ul
+{- A {e short} name is a dash followed by a single alphanumeric
+ character: ["-h"], ["-q"], ["-I"].}
+{- A {e long} name is two dashes followed by alphanumeric
+ characters and dashes: ["--help"], ["--silent"], ["--ignore-case"].}}
+
+More than one name may refer to the same optional argument. For
+example in a given program the names ["-q"], ["--quiet"] and
+["--silent"] may all stand for the same boolean argument indicating
+the program to be quiet. Long names can be specified by any non
+ambiguous prefix.
+
+The value of an option can be specified in three different ways.
+
+{ul
+{- As the next token on the command line: ["-o a.out"], ["--output a.out"].}
+{- Glued to a short name: ["-oa.out"].}
+{- Glued to a long name after an equal character: ["--output=a.out"].}}
+
+Glued forms are especially useful if the value itself starts with a
+dash as is the case for negative numbers, ["--min=-10"].
+
+An optional argument without a value is either a {e flag} (see
+{!Arg.flag}, {!Arg.vflag}) or an optional argument with an optional
+value (see the [~vopt] argument of {!Arg.opt}).
+
+Short flags can be grouped together to share a single dash and the
+group can end with a short option. For example assuming ["-v"] and
+["-x"] are flags and ["-f"] is a short option:
+
+{ul
+{- ["-vx"] will be parsed as ["-v -x"].}
+{- ["-vxfopt"] will be parsed as ["-v -x -fopt"].}
+{- ["-vxf opt"] will be parsed as ["-v -x -fopt"].}
+{- ["-fvx"] will be parsed as ["-f=vx"].}}
+
+{2:posargs Positional arguments}
+
+Positional arguments are tokens on the command line that are not
+option names and are not the value of an optional argument. They are
+numbered from left to right starting with zero.
+
+Since positional arguments may be mistaken as the optional value of an
+optional argument or they may need to look like option names, anything
+that follows the special token ["--"] on the command line is
+considered to be a positional argument.
+
+{2:envlookup Environment variables}
+
+Non-required command line arguments can be backed up by an environment
+variable. If the argument is absent from the command line and that
+the environment variable is defined, its value is parsed using the
+argument converter and defines the value of the argument.
+
+For {!Arg.flag} and {!Arg.flag_all} that do not have an argument converter a
+boolean is parsed from the lowercased variable value as follows:
+
+
+{ul
+{- [""], ["false"], ["no"], ["n"] or ["0"] is [false].}
+{- ["true"], ["yes"], ["y"] or ["1"] is [true].}
+{- Any other string is an error.}}
+
+Note that environment variables are not supported for {!Arg.vflag} and
+{!Arg.vflag_all}.
+
+{1:examples Examples}
+
+These examples are in the [test] directory of the distribution.
+
+{2:exrm A [rm] command}
+
+We define the command line interface of a [rm] command with the synopsis:
+
+{[
+rm [OPTION]... FILE...
+]}
+
+The [-f], [-i] and [-I] flags define the prompt behaviour of [rm],
+represented in our program by the [prompt] type. If more than one of
+these flags is present on the command line the last one takes
+precedence.
+
+To implement this behaviour we map the presence of these flags to
+values of the [prompt] type by using {!Arg.vflag_all}. This argument
+will contain all occurrences of the flag on the command line and we
+just take the {!Arg.last} one to define our term value (if there's no
+occurrence the last value of the default list [[Always]] is taken,
+i.e. the default is [Always]).
+
+{[
+(* Implementation of the command, we just print the args. *)
+
+type prompt = Always | Once | Never
+let prompt_str = function
+| Always -> "always" | Once -> "once" | Never -> "never"
+
+let rm prompt recurse files =
+ Printf.printf "prompt = %s\nrecurse = %B\nfiles = %s\n"
+ (prompt_str prompt) recurse (String.concat ", " files)
+
+(* Command line interface *)
+
+open Cmdliner
+
+let files = Arg.(non_empty & pos_all file [] & info [] ~docv:"FILE")
+let prompt =
+ let doc = "Prompt before every removal." in
+ let always = Always, Arg.info ["i"] ~doc in
+ let doc = "Ignore nonexistent files and never prompt." in
+ let never = Never, Arg.info ["f"; "force"] ~doc in
+ let doc = "Prompt once before removing more than three files, or when
+ removing recursively. Less intrusive than $(b,-i), while
+ still giving protection against most mistakes."
+ in
+ let once = Once, Arg.info ["I"] ~doc in
+ Arg.(last & vflag_all [Always] [always; never; once])
+
+let recursive =
+ let doc = "Remove directories and their contents recursively." in
+ Arg.(value & flag & info ["r"; "R"; "recursive"] ~doc)
+
+let cmd =
+ let doc = "remove files or directories" in
+ let man = [
+ `S Manpage.s_description;
+ `P "$(tname) removes each specified $(i,FILE). By default it does not
+ remove directories, to also remove them and their contents, use the
+ option $(b,--recursive) ($(b,-r) or $(b,-R)).";
+ `P "To remove a file whose name starts with a `-', for example
+ `-foo', use one of these commands:";
+ `P "rm -- -foo"; `Noblank;
+ `P "rm ./-foo";
+ `P "$(tname) removes symbolic links, not the files referenced by the
+ links.";
+ `S Manpage.s_bugs; `P "Report bugs to <hehey at example.org>.";
+ `S Manpage.s_see_also; `P "$(b,rmdir)(1), $(b,unlink)(2)" ]
+ in
+ Term.(const rm $ prompt $ recursive $ files),
+ Term.info "rm" ~version:"%%VERSION%%" ~doc ~exits:Term.default_exits ~man
+
+let () = Term.(exit @@ eval cmd)
+]}
+
+{2:excp A [cp] command}
+
+We define the command line interface of a [cp] command with the synopsis:
+{[
+cp [OPTION]... SOURCE... DEST
+]}
+
+The [DEST] argument must be a directory if there is more than one
+[SOURCE]. This constraint is too complex to be expressed by the
+combinators of {!Arg}. Hence we just give it the {!Arg.string} type
+and verify the constraint at the beginning of the [cp]
+implementation. If unsatisfied we return an [`Error] and by using
+{!Term.ret} on the lifted result [cp_t] of [cp], [Cmdliner] handles
+the error reporting.
+
+{[
+(* Implementation, we check the dest argument and print the args *)
+
+let cp verbose recurse force srcs dest =
+ if List.length srcs > 1 &&
+ (not (Sys.file_exists dest) || not (Sys.is_directory dest))
+ then
+ `Error (false, dest ^ " is not a directory")
+ else
+ `Ok (Printf.printf
+ "verbose = %B\nrecurse = %B\nforce = %B\nsrcs = %s\ndest = %s\n"
+ verbose recurse force (String.concat ", " srcs) dest)
+
+(* Command line interface *)
+
+open Cmdliner
+
+let verbose =
+ let doc = "Print file names as they are copied." in
+ Arg.(value & flag & info ["v"; "verbose"] ~doc)
+
+let recurse =
+ let doc = "Copy directories recursively." in
+ Arg.(value & flag & info ["r"; "R"; "recursive"] ~doc)
+
+let force =
+ let doc = "If a destination file cannot be opened, remove it and try again."in
+ Arg.(value & flag & info ["f"; "force"] ~doc)
+
+let srcs =
+ let doc = "Source file(s) to copy." in
+ Arg.(non_empty & pos_left ~rev:true 0 file [] & info [] ~docv:"SOURCE" ~doc)
+
+let dest =
+ let doc = "Destination of the copy. Must be a directory if there is more
+ than one $(i,SOURCE)." in
+ Arg.(required & pos ~rev:true 0 (some string) None & info [] ~docv:"DEST"
+ ~doc)
+
+let cmd =
+ let doc = "copy files" in
+ let man_xrefs =
+ [ `Tool "mv"; `Tool "scp"; `Page (2, "umask"); `Page (7, "symlink") ]
+ in
+ let exits = Term.default_exits in
+ let man =
+ [ `S Manpage.s_bugs;
+ `P "Email them to <hehey at example.org>."; ]
+ in
+ Term.(ret (const cp $ verbose $ recurse $ force $ srcs $ dest)),
+ Term.info "cp" ~version:"%%VERSION%%" ~doc ~exits ~man ~man_xrefs
+
+let () = Term.(exit @@ eval cmd)
+]}
+
+{2:extail A [tail] command}
+
+We define the command line interface of a [tail] command with the
+synopsis:
+
+{[
+tail [OPTION]... [FILE]...
+]}
+
+The [--lines] option whose value specifies the number of last lines to
+print has a special syntax where a [+] prefix indicates to start
+printing from that line number. In the program this is represented by
+the [loc] type. We define a custom [loc] {{!Arg.argconv}argument
+converter} for this option.
+
+The [--follow] option has an optional enumerated value. The argument
+converter [follow], created with {!Arg.enum} parses the option value
+into the enumeration. By using {!Arg.some} and the [~vopt] argument of
+{!Arg.opt}, the term corresponding to the option [--follow] evaluates
+to [None] if [--follow] is absent from the command line, to [Some
+Descriptor] if present but without a value and to [Some v] if present
+with a value [v] specified.
+
+{[
+(* Implementation of the command, we just print the args. *)
+
+type loc = bool * int
+type verb = Verbose | Quiet
+type follow = Name | Descriptor
+
+let str = Printf.sprintf
+let opt_str sv = function None -> "None" | Some v -> str "Some(%s)" (sv v)
+let loc_str (rev, k) = if rev then str "%d" k else str "+%d" k
+let follow_str = function Name -> "name" | Descriptor -> "descriptor"
+let verb_str = function Verbose -> "verbose" | Quiet -> "quiet"
+
+let tail lines follow verb pid files =
+ Printf.printf "lines = %s\nfollow = %s\nverb = %s\npid = %s\nfiles = %s\n"
+ (loc_str lines) (opt_str follow_str follow) (verb_str verb)
+ (opt_str string_of_int pid) (String.concat ", " files)
+
+(* Command line interface *)
+
+open Cmdliner
+
+let lines =
+ let loc =
+ let parse s =
+ try
+ if s <> "" && s.[0] <> '+' then Ok (true, int_of_string s) else
+ Ok (false, int_of_string (String.sub s 1 (String.length s - 1)))
+ with Failure _ -> Error (`Msg "unable to parse integer")
+ in
+ let print ppf p = Format.fprintf ppf "%s" (loc_str p) in
+ Arg.conv ~docv:"N" (parse, print)
+ in
+ Arg.(value & opt loc (true, 10) & info ["n"; "lines"] ~docv:"N"
+ ~doc:"Output the last $(docv) lines or use $(i,+)$(docv) to start
+ output after the $(i,N)-1th line.")
+
+let follow =
+ let doc = "Output appended data as the file grows. $(docv) specifies how the
+ file should be tracked, by its `name' or by its `descriptor'." in
+ let follow = Arg.enum ["name", Name; "descriptor", Descriptor] in
+ Arg.(value & opt (some follow) ~vopt:(Some Descriptor) None &
+ info ["f"; "follow"] ~docv:"ID" ~doc)
+
+let verb =
+ let doc = "Never output headers giving file names." in
+ let quiet = Quiet, Arg.info ["q"; "quiet"; "silent"] ~doc in
+ let doc = "Always output headers giving file names." in
+ let verbose = Verbose, Arg.info ["v"; "verbose"] ~doc in
+ Arg.(last & vflag_all [Quiet] [quiet; verbose])
+
+let pid =
+ let doc = "With -f, terminate after process $(docv) dies." in
+ Arg.(value & opt (some int) None & info ["pid"] ~docv:"PID" ~doc)
+
+let files = Arg.(value & (pos_all non_dir_file []) & info [] ~docv:"FILE")
+
+let cmd =
+ let doc = "display the last part of a file" in
+ let man = [
+ `S Manpage.s_description;
+ `P "$(tname) prints the last lines of each $(i,FILE) to standard output. If
+ no file is specified reads standard input. The number of printed
+ lines can be specified with the $(b,-n) option.";
+ `S Manpage.s_bugs;
+ `P "Report them to <hehey at example.org>.";
+ `S Manpage.s_see_also;
+ `P "$(b,cat)(1), $(b,head)(1)" ]
+ in
+ Term.(const tail $ lines $ follow $ verb $ pid $ files),
+ Term.info "tail" ~version:"%%VERSION%%" ~doc ~exits:Term.default_exits ~man
+
+let () = Term.(exit @@ eval cmd)
+]}
+
+{2:exdarcs A [darcs] command}
+
+We define the command line interface of a [darcs] command with the
+synopsis:
+
+{[
+darcs [COMMAND] ...
+]}
+
+The [--debug], [-q], [-v] and [--prehook] options are available in
+each command. To avoid having to pass them individually to each
+command we gather them in a record of type [copts]. By lifting the
+record constructor [copts] into the term [copts_t] we now have a term
+that we can pass to the commands to stand for an argument of type
+[copts]. These options are documented in a section called [COMMON
+OPTIONS], since we also want to put [--help] and [--version] in this
+section, the term information of commands makes a judicious use of the
+[sdocs] parameter of {!Term.info}.
+
+The [help] command shows help about commands or other topics. The help
+shown for commands is generated by [Cmdliner] by making an appropriate
+use of {!Term.ret} on the lifted [help] function.
+
+If the program is invoked without a command we just want to show the
+help of the program as printed by [Cmdliner] with [--help]. This is
+done by the [default_cmd] term.
+
+{[
+(* Implementations, just print the args. *)
+
+type verb = Normal | Quiet | Verbose
+type copts = { debug : bool; verb : verb; prehook : string option }
+
+let str = Printf.sprintf
+let opt_str sv = function None -> "None" | Some v -> str "Some(%s)" (sv v)
+let opt_str_str = opt_str (fun s -> s)
+let verb_str = function
+ | Normal -> "normal" | Quiet -> "quiet" | Verbose -> "verbose"
+
+let pr_copts oc copts = Printf.fprintf oc
+ "debug = %B\nverbosity = %s\nprehook = %s\n"
+ copts.debug (verb_str copts.verb) (opt_str_str copts.prehook)
+
+let initialize copts repodir = Printf.printf
+ "%arepodir = %s\n" pr_copts copts repodir
+
+let record copts name email all ask_deps files = Printf.printf
+ "%aname = %s\nemail = %s\nall = %B\nask-deps = %B\nfiles = %s\n"
+ pr_copts copts (opt_str_str name) (opt_str_str email) all ask_deps
+ (String.concat ", " files)
+
+let help copts man_format cmds topic = match topic with
+| None -> `Help (`Pager, None) (* help about the program. *)
+| Some topic ->
+ let topics = "topics" :: "patterns" :: "environment" :: cmds in
+ let conv, _ = Cmdliner.Arg.enum (List.rev_map (fun s -> (s, s)) topics) in
+ match conv topic with
+ | `Error e -> `Error (false, e)
+ | `Ok t when t = "topics" -> List.iter print_endline topics; `Ok ()
+ | `Ok t when List.mem t cmds -> `Help (man_format, Some t)
+ | `Ok t ->
+ let page = (topic, 7, "", "", ""), [`S topic; `P "Say something";] in
+ `Ok (Cmdliner.Manpage.print man_format Format.std_formatter page)
+
+open Cmdliner
+
+(* Help sections common to all commands *)
+
+let help_secs = [
+ `S Manpage.s_common_options;
+ `P "These options are common to all commands.";
+ `S "MORE HELP";
+ `P "Use `$(mname) $(i,COMMAND) --help' for help on a single command.";`Noblank;
+ `P "Use `$(mname) help patterns' for help on patch matching."; `Noblank;
+ `P "Use `$(mname) help environment' for help on environment variables.";
+ `S Manpage.s_bugs; `P "Check bug reports at http://bugs.example.org.";]
+
+(* Options common to all commands *)
+
+let copts debug verb prehook = { debug; verb; prehook }
+let copts_t =
+ let docs = Manpage.s_common_options in
+ let debug =
+ let doc = "Give only debug output." in
+ Arg.(value & flag & info ["debug"] ~docs ~doc)
+ in
+ let verb =
+ let doc = "Suppress informational output." in
+ let quiet = Quiet, Arg.info ["q"; "quiet"] ~docs ~doc in
+ let doc = "Give verbose output." in
+ let verbose = Verbose, Arg.info ["v"; "verbose"] ~docs ~doc in
+ Arg.(last & vflag_all [Normal] [quiet; verbose])
+ in
+ let prehook =
+ let doc = "Specify command to run before this $(mname) command." in
+ Arg.(value & opt (some string) None & info ["prehook"] ~docs ~doc)
+ in
+ Term.(const copts $ debug $ verb $ prehook)
+
+(* Commands *)
+
+let initialize_cmd =
+ let repodir =
+ let doc = "Run the program in repository directory $(docv)." in
+ Arg.(value & opt file Filename.current_dir_name & info ["repodir"]
+ ~docv:"DIR" ~doc)
+ in
+ let doc = "make the current directory a repository" in
+ let exits = Term.default_exits in
+ let man = [
+ `S Manpage.s_description;
+ `P "Turns the current directory into a Darcs repository. Any
+ existing files and subdirectories become ...";
+ `Blocks help_secs; ]
+ in
+ Term.(const initialize $ copts_t $ repodir),
+ Term.info "initialize" ~doc ~sdocs:Manpage.s_common_options ~exits ~man
+
+let record_cmd =
+ let pname =
+ let doc = "Name of the patch." in
+ Arg.(value & opt (some string) None & info ["m"; "patch-name"] ~docv:"NAME"
+ ~doc)
+ in
+ let author =
+ let doc = "Specifies the author's identity." in
+ Arg.(value & opt (some string) None & info ["A"; "author"] ~docv:"EMAIL"
+ ~doc)
+ in
+ let all =
+ let doc = "Answer yes to all patches." in
+ Arg.(value & flag & info ["a"; "all"] ~doc)
+ in
+ let ask_deps =
+ let doc = "Ask for extra dependencies." in
+ Arg.(value & flag & info ["ask-deps"] ~doc)
+ in
+ let files = Arg.(value & (pos_all file) [] & info [] ~docv:"FILE or DIR") in
+ let doc = "create a patch from unrecorded changes" in
+ let exits = Term.default_exits in
+ let man =
+ [`S Manpage.s_description;
+ `P "Creates a patch from changes in the working tree. If you specify
+ a set of files ...";
+ `Blocks help_secs; ]
+ in
+ Term.(const record $ copts_t $ pname $ author $ all $ ask_deps $ files),
+ Term.info "record" ~doc ~sdocs:Manpage.s_common_options ~exits ~man
+
+let help_cmd =
+ let topic =
+ let doc = "The topic to get help on. `topics' lists the topics." in
+ Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc)
+ in
+ let doc = "display help about darcs and darcs commands" in
+ let man =
+ [`S Manpage.s_description;
+ `P "Prints help about darcs commands and other subjects...";
+ `Blocks help_secs; ]
+ in
+ Term.(ret
+ (const help $ copts_t $ Arg.man_format $ Term.choice_names $topic)),
+ Term.info "help" ~doc ~exits:Term.default_exits ~man
+
+let default_cmd =
+ let doc = "a revision control system" in
+ let sdocs = Manpage.s_common_options in
+ let exits = Term.default_exits in
+ let man = help_secs in
+ Term.(ret (const (fun _ -> `Help (`Pager, None)) $ copts_t)),
+ Term.info "darcs" ~version:"%%VERSION%%" ~doc ~sdocs ~exits ~man
+
+let cmds = [initialize_cmd; record_cmd; help_cmd]
+
+let () = Term.(exit @@ eval_choice default_cmd cmds)
+]}
+*)
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,11 @@
+Cmdliner_suggest
+Cmdliner_trie
+Cmdliner_base
+Cmdliner_manpage
+Cmdliner_info
+Cmdliner_docgen
+Cmdliner_msg
+Cmdliner_cline
+Cmdliner_arg
+Cmdliner_term
+Cmdliner
new file mode 100644
@@ -0,0 +1,356 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+let rev_compare n0 n1 = compare n1 n0
+
+(* Invalid_argument strings **)
+
+let err_not_opt = "Option argument without name"
+let err_not_pos = "Positional argument with a name"
+
+(* Documentation formatting helpers *)
+
+let strf = Printf.sprintf
+let doc_quote = Cmdliner_base.quote
+let doc_alts = Cmdliner_base.alts_str
+let doc_alts_enum ?quoted enum = doc_alts ?quoted (List.map fst enum)
+
+let str_of_pp pp v = pp Format.str_formatter v; Format.flush_str_formatter ()
+
+(* Argument converters *)
+
+type 'a parser = string -> [ `Ok of 'a | `Error of string ]
+type 'a printer = Format.formatter -> 'a -> unit
+
+type 'a conv = 'a parser * 'a printer
+type 'a converter = 'a conv
+
+let default_docv = "VALUE"
+let conv ?docv (parse, print) =
+ let parse s = match parse s with Ok v -> `Ok v | Error (`Msg e) -> `Error e in
+ parse, print
+
+let pconv ?docv conv = conv
+
+let conv_parser (parse, _) =
+ fun s -> match parse s with `Ok v -> Ok v | `Error e -> Error (`Msg e)
+
+let conv_printer (_, print) = print
+let conv_docv _ = default_docv
+
+let err_invalid s kind = `Msg (strf "invalid value '%s', expected %s" s kind)
+let parser_of_kind_of_string ~kind k_of_string =
+ fun s -> match k_of_string s with
+ | None -> Error (err_invalid s kind)
+ | Some v -> Ok v
+
+let some = Cmdliner_base.some
+
+(* Argument information *)
+
+type env = Cmdliner_info.env
+let env_var = Cmdliner_info.env
+
+type 'a t = 'a Cmdliner_term.t
+type info = Cmdliner_info.arg
+let info = Cmdliner_info.arg
+
+(* Arguments *)
+
+let ( & ) f x = f x
+
+let err e = Error (`Parse e)
+
+let parse_to_list parser s = match parser s with
+| `Ok v -> `Ok [v]
+| `Error _ as e -> e
+
+let try_env ei a parse ~absent = match Cmdliner_info.arg_env a with
+| None -> Ok absent
+| Some env ->
+ let var = Cmdliner_info.env_var env in
+ match Cmdliner_info.(eval_env_var ei var) with
+ | None -> Ok absent
+ | Some v ->
+ match parse v with
+ | `Ok v -> Ok v
+ | `Error e -> err (Cmdliner_msg.err_env_parse env ~err:e)
+
+let arg_to_args = Cmdliner_info.Args.singleton
+let list_to_args f l =
+ let add acc v = Cmdliner_info.Args.add (f v) acc in
+ List.fold_left add Cmdliner_info.Args.empty l
+
+let flag a =
+ if Cmdliner_info.arg_is_pos a then invalid_arg err_not_opt else
+ let convert ei cl = match Cmdliner_cline.opt_arg cl a with
+ | [] -> try_env ei a Cmdliner_base.env_bool_parse ~absent:false
+ | [_, _, None] -> Ok true
+ | [_, f, Some v] -> err (Cmdliner_msg.err_flag_value f v)
+ | (_, f, _) :: (_ ,g, _) :: _ -> err (Cmdliner_msg.err_opt_repeated f g)
+ in
+ arg_to_args a, convert
+
+let flag_all a =
+ if Cmdliner_info.arg_is_pos a then invalid_arg err_not_opt else
+ let a = Cmdliner_info.arg_make_all_opts a in
+ let convert ei cl = match Cmdliner_cline.opt_arg cl a with
+ | [] ->
+ try_env ei a (parse_to_list Cmdliner_base.env_bool_parse) ~absent:[]
+ | l ->
+ try
+ let truth (_, f, v) = match v with
+ | None -> true
+ | Some v -> failwith (Cmdliner_msg.err_flag_value f v)
+ in
+ Ok (List.rev_map truth l)
+ with Failure e -> err e
+ in
+ arg_to_args a, convert
+
+let vflag v l =
+ let convert _ cl =
+ let rec aux fv = function
+ | (v, a) :: rest ->
+ begin match Cmdliner_cline.opt_arg cl a with
+ | [] -> aux fv rest
+ | [_, f, None] ->
+ begin match fv with
+ | None -> aux (Some (f, v)) rest
+ | Some (g, _) -> failwith (Cmdliner_msg.err_opt_repeated g f)
+ end
+ | [_, f, Some v] -> failwith (Cmdliner_msg.err_flag_value f v)
+ | (_, f, _) :: (_, g, _) :: _ ->
+ failwith (Cmdliner_msg.err_opt_repeated g f)
+ end
+ | [] -> match fv with None -> v | Some (_, v) -> v
+ in
+ try Ok (aux None l) with Failure e -> err e
+ in
+ let flag (_, a) =
+ if Cmdliner_info.arg_is_pos a then invalid_arg err_not_opt else a
+ in
+ list_to_args flag l, convert
+
+let vflag_all v l =
+ let convert _ cl =
+ let rec aux acc = function
+ | (fv, a) :: rest ->
+ begin match Cmdliner_cline.opt_arg cl a with
+ | [] -> aux acc rest
+ | l ->
+ let fval (k, f, v) = match v with
+ | None -> (k, fv)
+ | Some v -> failwith (Cmdliner_msg.err_flag_value f v)
+ in
+ aux (List.rev_append (List.rev_map fval l) acc) rest
+ end
+ | [] ->
+ if acc = [] then v else List.rev_map snd (List.sort rev_compare acc)
+ in
+ try Ok (aux [] l) with Failure e -> err e
+ in
+ let flag (_, a) =
+ if Cmdliner_info.arg_is_pos a then invalid_arg err_not_opt else
+ Cmdliner_info.arg_make_all_opts a
+ in
+ list_to_args flag l, convert
+
+let parse_opt_value parse f v = match parse v with
+| `Ok v -> v
+| `Error e -> failwith (Cmdliner_msg.err_opt_parse f e)
+
+let opt ?vopt (parse, print) v a =
+ if Cmdliner_info.arg_is_pos a then invalid_arg err_not_opt else
+ let absent = Cmdliner_info.Val (lazy (str_of_pp print v)) in
+ let kind = match vopt with
+ | None -> Cmdliner_info.Opt
+ | Some dv -> Cmdliner_info.Opt_vopt (str_of_pp print dv)
+ in
+ let a = Cmdliner_info.arg_make_opt ~absent ~kind a in
+ let convert ei cl = match Cmdliner_cline.opt_arg cl a with
+ | [] -> try_env ei a parse ~absent:v
+ | [_, f, Some v] ->
+ (try Ok (parse_opt_value parse f v) with Failure e -> err e)
+ | [_, f, None] ->
+ begin match vopt with
+ | None -> err (Cmdliner_msg.err_opt_value_missing f)
+ | Some optv -> Ok optv
+ end
+ | (_, f, _) :: (_, g, _) :: _ -> err (Cmdliner_msg.err_opt_repeated g f)
+ in
+ arg_to_args a, convert
+
+let opt_all ?vopt (parse, print) v a =
+ if Cmdliner_info.arg_is_pos a then invalid_arg err_not_opt else
+ let absent = Cmdliner_info.Val (lazy "") in
+ let kind = match vopt with
+ | None -> Cmdliner_info.Opt
+ | Some dv -> Cmdliner_info.Opt_vopt (str_of_pp print dv)
+ in
+ let a = Cmdliner_info.arg_make_opt_all ~absent ~kind a in
+ let convert ei cl = match Cmdliner_cline.opt_arg cl a with
+ | [] -> try_env ei a (parse_to_list parse) ~absent:v
+ | l ->
+ let parse (k, f, v) = match v with
+ | Some v -> (k, parse_opt_value parse f v)
+ | None -> match vopt with
+ | None -> failwith (Cmdliner_msg.err_opt_value_missing f)
+ | Some dv -> (k, dv)
+ in
+ try Ok (List.rev_map snd
+ (List.sort rev_compare (List.rev_map parse l))) with
+ | Failure e -> err e
+ in
+ arg_to_args a, convert
+
+(* Positional arguments *)
+
+let parse_pos_value parse a v = match parse v with
+| `Ok v -> v
+| `Error e -> failwith (Cmdliner_msg.err_pos_parse a e)
+
+let pos ?(rev = false) k (parse, print) v a =
+ if Cmdliner_info.arg_is_opt a then invalid_arg err_not_pos else
+ let absent = Cmdliner_info.Val (lazy (str_of_pp print v)) in
+ let pos = Cmdliner_info.pos ~rev ~start:k ~len:(Some 1) in
+ let a = Cmdliner_info.arg_make_pos_abs ~absent ~pos a in
+ let convert ei cl = match Cmdliner_cline.pos_arg cl a with
+ | [] -> try_env ei a parse ~absent:v
+ | [v] ->
+ (try Ok (parse_pos_value parse a v) with Failure e -> err e)
+ | _ -> assert false
+ in
+ arg_to_args a, convert
+
+let pos_list pos (parse, _) v a =
+ if Cmdliner_info.arg_is_opt a then invalid_arg err_not_pos else
+ let a = Cmdliner_info.arg_make_pos pos a in
+ let convert ei cl = match Cmdliner_cline.pos_arg cl a with
+ | [] -> try_env ei a (parse_to_list parse) ~absent:v
+ | l ->
+ try Ok (List.rev (List.rev_map (parse_pos_value parse a) l)) with
+ | Failure e -> err e
+ in
+ arg_to_args a, convert
+
+let all = Cmdliner_info.pos ~rev:false ~start:0 ~len:None
+let pos_all c v a = pos_list all c v a
+
+let pos_left ?(rev = false) k =
+ let start = if rev then k + 1 else 0 in
+ let len = if rev then None else Some k in
+ pos_list (Cmdliner_info.pos ~rev ~start ~len)
+
+let pos_right ?(rev = false) k =
+ let start = if rev then 0 else k + 1 in
+ let len = if rev then Some k else None in
+ pos_list (Cmdliner_info.pos ~rev ~start ~len)
+
+(* Arguments as terms *)
+
+let absent_error args =
+ let make_req a acc =
+ let req_a = Cmdliner_info.arg_make_req a in
+ Cmdliner_info.Args.add req_a acc
+ in
+ Cmdliner_info.Args.fold make_req args Cmdliner_info.Args.empty
+
+let value a = a
+
+let err_arg_missing args =
+ err @@ Cmdliner_msg.err_arg_missing (Cmdliner_info.Args.choose args)
+
+let required (args, convert) =
+ let args = absent_error args in
+ let convert ei cl = match convert ei cl with
+ | Ok (Some v) -> Ok v
+ | Ok None -> err_arg_missing args
+ | Error _ as e -> e
+ in
+ args, convert
+
+let non_empty (al, convert) =
+ let args = absent_error al in
+ let convert ei cl = match convert ei cl with
+ | Ok [] -> err_arg_missing args
+ | Ok l -> Ok l
+ | Error _ as e -> e
+ in
+ args, convert
+
+let last (args, convert) =
+ let convert ei cl = match convert ei cl with
+ | Ok [] -> err_arg_missing args
+ | Ok l -> Ok (List.hd (List.rev l))
+ | Error _ as e -> e
+ in
+ args, convert
+
+(* Predefined arguments *)
+
+let man_fmts =
+ ["auto", `Auto; "pager", `Pager; "groff", `Groff; "plain", `Plain]
+
+let man_fmt_docv = "FMT"
+let man_fmts_enum = Cmdliner_base.enum man_fmts
+let man_fmts_alts = doc_alts_enum man_fmts
+let man_fmts_doc kind =
+ strf "Show %s in format $(docv). The value $(docv) must be %s. With `auto',
+ the format is `pager` or `plain' whenever the $(b,TERM) env var is
+ `dumb' or undefined."
+ kind man_fmts_alts
+
+let man_format =
+ let doc = man_fmts_doc "output" in
+ let docv = man_fmt_docv in
+ value & opt man_fmts_enum `Pager & info ["man-format"] ~docv ~doc
+
+let stdopt_version ~docs =
+ value & flag & info ["version"] ~docs ~doc:"Show version information."
+
+let stdopt_help ~docs =
+ let doc = man_fmts_doc "this help" in
+ let docv = man_fmt_docv in
+ value & opt ~vopt:(Some `Auto) (some man_fmts_enum) None &
+ info ["help"] ~docv ~docs ~doc
+
+(* Predefined converters. *)
+
+let bool = Cmdliner_base.bool
+let char = Cmdliner_base.char
+let int = Cmdliner_base.int
+let nativeint = Cmdliner_base.nativeint
+let int32 = Cmdliner_base.int32
+let int64 = Cmdliner_base.int64
+let float = Cmdliner_base.float
+let string = Cmdliner_base.string
+let enum = Cmdliner_base.enum
+let file = Cmdliner_base.file
+let dir = Cmdliner_base.dir
+let non_dir_file = Cmdliner_base.non_dir_file
+let list = Cmdliner_base.list
+let array = Cmdliner_base.array
+let pair = Cmdliner_base.pair
+let t2 = Cmdliner_base.t2
+let t3 = Cmdliner_base.t3
+let t4 = Cmdliner_base.t4
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,111 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+(** Command line arguments as terms. *)
+
+type 'a parser = string -> [ `Ok of 'a | `Error of string ]
+type 'a printer = Format.formatter -> 'a -> unit
+type 'a conv = 'a parser * 'a printer
+type 'a converter = 'a conv
+
+val conv :
+ ?docv:string -> (string -> ('a, [`Msg of string]) result) * 'a printer ->
+ 'a conv
+
+val pconv : ?docv:string -> 'a parser * 'a printer -> 'a conv
+val conv_parser : 'a conv -> (string -> ('a, [`Msg of string]) result)
+val conv_printer : 'a conv -> 'a printer
+val conv_docv : 'a conv -> string
+
+val parser_of_kind_of_string :
+ kind:string -> (string -> 'a option) ->
+ (string -> ('a, [`Msg of string]) result)
+
+val some : ?none:string -> 'a converter -> 'a option converter
+
+type env = Cmdliner_info.env
+val env_var : ?docs:string -> ?doc:string -> string -> env
+
+type 'a t = 'a Cmdliner_term.t
+
+type info
+val info :
+ ?docs:string -> ?docv:string -> ?doc:string -> ?env:env -> string list -> info
+
+val ( & ) : ('a -> 'b) -> 'a -> 'b
+
+val flag : info -> bool t
+val flag_all : info -> bool list t
+val vflag : 'a -> ('a * info) list -> 'a t
+val vflag_all : 'a list -> ('a * info) list -> 'a list t
+val opt : ?vopt:'a -> 'a converter -> 'a -> info -> 'a t
+val opt_all : ?vopt:'a -> 'a converter -> 'a list -> info -> 'a list t
+
+val pos : ?rev:bool -> int -> 'a converter -> 'a -> info -> 'a t
+val pos_all : 'a converter -> 'a list -> info -> 'a list t
+val pos_left : ?rev:bool -> int -> 'a converter -> 'a list -> info -> 'a list t
+val pos_right : ?rev:bool -> int -> 'a converter -> 'a list -> info -> 'a list t
+
+(** {1 As terms} *)
+
+val value : 'a t -> 'a Cmdliner_term.t
+val required : 'a option t -> 'a Cmdliner_term.t
+val non_empty : 'a list t -> 'a list Cmdliner_term.t
+val last : 'a list t -> 'a Cmdliner_term.t
+
+(** {1 Predefined arguments} *)
+
+val man_format : Cmdliner_manpage.format Cmdliner_term.t
+val stdopt_version : docs:string -> bool Cmdliner_term.t
+val stdopt_help : docs:string -> Cmdliner_manpage.format option Cmdliner_term.t
+
+(** {1 Converters} *)
+
+val bool : bool converter
+val char : char converter
+val int : int converter
+val nativeint : nativeint converter
+val int32 : int32 converter
+val int64 : int64 converter
+val float : float converter
+val string : string converter
+val enum : (string * 'a) list -> 'a converter
+val file : string converter
+val dir : string converter
+val non_dir_file : string converter
+val list : ?sep:char -> 'a converter -> 'a list converter
+val array : ?sep:char -> 'a converter -> 'a array converter
+val pair : ?sep:char -> 'a converter -> 'b converter -> ('a * 'b) converter
+val t2 : ?sep:char -> 'a converter -> 'b converter -> ('a * 'b) converter
+
+val t3 :
+ ?sep:char -> 'a converter ->'b converter -> 'c converter ->
+ ('a * 'b * 'c) converter
+
+val t4 :
+ ?sep:char -> 'a converter ->'b converter -> 'c converter -> 'd converter ->
+ ('a * 'b * 'c * 'd) converter
+
+val doc_quote : string -> string
+val doc_alts : ?quoted:bool -> string list -> string
+val doc_alts_enum : ?quoted:bool -> (string * 'a) list -> string
+
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,302 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+(* Invalid argument strings *)
+
+let err_empty_list = "empty list"
+let err_incomplete_enum = "Incomplete enumeration for the type"
+
+(* Formatting tools *)
+
+let strf = Printf.sprintf
+let pp = Format.fprintf
+let pp_sp = Format.pp_print_space
+let pp_str = Format.pp_print_string
+let pp_char = Format.pp_print_char
+let pp_text = Format.pp_print_text
+let pp_lines ppf s =
+ let rec stop_at sat ~start ~max s =
+ if start > max then start else
+ if sat s.[start] then start else
+ stop_at sat ~start:(start + 1) ~max s
+ in
+ let sub s start stop ~max =
+ if start = stop then "" else
+ if start = 0 && stop > max then s else
+ String.sub s start (stop - start)
+ in
+ let is_nl c = c = '\n' in
+ let max = String.length s - 1 in
+ let rec loop start s = match stop_at is_nl ~start ~max s with
+ | stop when stop > max -> Format.pp_print_string ppf (sub s start stop ~max)
+ | stop ->
+ Format.pp_print_string ppf (sub s start stop ~max);
+ Format.pp_force_newline ppf ();
+ loop (stop + 1) s
+ in
+ loop 0 s
+
+let pp_tokens ~spaces ppf s = (* collapse white and hint spaces (maybe) *)
+ let is_space = function ' ' | '\n' | '\r' | '\t' -> true | _ -> false in
+ let i_max = String.length s - 1 in
+ let flush start stop = pp_str ppf (String.sub s start (stop - start + 1)) in
+ let rec skip_white i =
+ if i > i_max then i else
+ if is_space s.[i] then skip_white (i + 1) else i
+ in
+ let rec loop start i =
+ if i > i_max then flush start i_max else
+ if not (is_space s.[i]) then loop start (i + 1) else
+ let next_start = skip_white i in
+ (flush start (i - 1); if spaces then pp_sp ppf () else pp_char ppf ' ';
+ if next_start > i_max then () else loop next_start next_start)
+ in
+ loop 0 0
+
+(* Converter (end-user) error messages *)
+
+let quote s = strf "`%s'" s
+let alts_str ?(quoted = true) alts =
+ let quote = if quoted then quote else (fun s -> s) in
+ match alts with
+ | [] -> invalid_arg err_empty_list
+ | [a] -> (quote a)
+ | [a; b] -> strf "either %s or %s" (quote a) (quote b)
+ | alts ->
+ let rev_alts = List.rev alts in
+ strf "one of %s or %s"
+ (String.concat ", " (List.rev_map quote (List.tl rev_alts)))
+ (quote (List.hd rev_alts))
+
+let err_multi_def ~kind name doc v v' =
+ strf "%s %s defined twice (doc strings are '%s' and '%s')"
+ kind name (doc v) (doc v')
+
+let err_ambiguous ~kind s ~ambs =
+ strf "%s %s ambiguous and could be %s" kind (quote s) (alts_str ambs)
+
+let err_unknown ?(hints = []) ~kind v =
+ let did_you_mean s = strf ", did you mean %s ?" s in
+ let hints = match hints with [] -> "." | hs -> did_you_mean (alts_str hs) in
+ strf "unknown %s %s%s" kind (quote v) hints
+
+let err_no kind s = strf "no %s %s" (quote s) kind
+let err_not_dir s = strf "%s is not a directory" (quote s)
+let err_is_dir s = strf "%s is a directory" (quote s)
+let err_element kind s exp =
+ strf "invalid element in %s (`%s'): %s" kind s exp
+
+let err_invalid kind s exp = strf "invalid %s %s, %s" kind (quote s) exp
+let err_invalid_val = err_invalid "value"
+let err_sep_miss sep s =
+ err_invalid_val s (strf "missing a `%c' separator" sep)
+
+(* Converters *)
+
+type 'a parser = string -> [ `Ok of 'a | `Error of string ]
+type 'a printer = Format.formatter -> 'a -> unit
+type 'a conv = 'a parser * 'a printer
+
+let some ?(none = "") (parse, print) =
+ let parse s = match parse s with
+ | `Ok v -> `Ok (Some v)
+ | `Error _ as e -> e
+ in
+ let print ppf v = match v with
+ | None -> Format.pp_print_string ppf none
+ | Some v -> print ppf v
+ in
+ parse, print
+
+let bool =
+ let parse s = try `Ok (bool_of_string s) with
+ | Invalid_argument _ ->
+ `Error (err_invalid_val s (alts_str ["true"; "false"]))
+ in
+ parse, Format.pp_print_bool
+
+let char =
+ let parse s = match String.length s = 1 with
+ | true -> `Ok s.[0]
+ | false -> `Error (err_invalid_val s "expected a character")
+ in
+ parse, pp_char
+
+let parse_with t_of_str exp s =
+ try `Ok (t_of_str s) with Failure _ -> `Error (err_invalid_val s exp)
+
+let int =
+ parse_with int_of_string "expected an integer", Format.pp_print_int
+
+let int32 =
+ parse_with Int32.of_string "expected a 32-bit integer",
+ (fun ppf -> pp ppf "%ld")
+
+let int64 =
+ parse_with Int64.of_string "expected a 64-bit integer",
+ (fun ppf -> pp ppf "%Ld")
+
+let nativeint =
+ parse_with Nativeint.of_string "expected a processor-native integer",
+ (fun ppf -> pp ppf "%nd")
+
+let float =
+ parse_with float_of_string "expected a floating point number",
+ Format.pp_print_float
+
+let string = (fun s -> `Ok s), pp_str
+let enum sl =
+ if sl = [] then invalid_arg err_empty_list else
+ let t = Cmdliner_trie.of_list sl in
+ let parse s = match Cmdliner_trie.find t s with
+ | `Ok _ as r -> r
+ | `Ambiguous ->
+ let ambs = List.sort compare (Cmdliner_trie.ambiguities t s) in
+ `Error (err_ambiguous "enum value" s ambs)
+ | `Not_found ->
+ let alts = List.rev (List.rev_map (fun (s, _) -> s) sl) in
+ `Error (err_invalid_val s ("expected " ^ (alts_str alts)))
+ in
+ let print ppf v =
+ let sl_inv = List.rev_map (fun (s,v) -> (v,s)) sl in
+ try pp_str ppf (List.assoc v sl_inv)
+ with Not_found -> invalid_arg err_incomplete_enum
+ in
+ parse, print
+
+let file =
+ let parse s = match Sys.file_exists s with
+ | true -> `Ok s
+ | false -> `Error (err_no "file or directory" s)
+ in
+ parse, pp_str
+
+let dir =
+ let parse s = match Sys.file_exists s with
+ | true -> if Sys.is_directory s then `Ok s else `Error (err_not_dir s)
+ | false -> `Error (err_no "directory" s)
+ in
+ parse, pp_str
+
+let non_dir_file =
+ let parse s = match Sys.file_exists s with
+ | true -> if not (Sys.is_directory s) then `Ok s else `Error (err_is_dir s)
+ | false -> `Error (err_no "file" s)
+ in
+ parse, pp_str
+
+let split_and_parse sep parse s = (* raises [Failure] *)
+ let parse sub = match parse sub with
+ | `Error e -> failwith e | `Ok v -> v
+ in
+ let rec split accum j =
+ let i = try String.rindex_from s j sep with Not_found -> -1 in
+ if (i = -1) then
+ let p = String.sub s 0 (j + 1) in
+ if p <> "" then parse p :: accum else accum
+ else
+ let p = String.sub s (i + 1) (j - i) in
+ let accum' = if p <> "" then parse p :: accum else accum in
+ split accum' (i - 1)
+ in
+ split [] (String.length s - 1)
+
+let list ?(sep = ',') (parse, pp_e) =
+ let parse s = try `Ok (split_and_parse sep parse s) with
+ | Failure e -> `Error (err_element "list" s e)
+ in
+ let rec print ppf = function
+ | v :: l -> pp_e ppf v; if (l <> []) then (pp_char ppf sep; print ppf l)
+ | [] -> ()
+ in
+ parse, print
+
+let array ?(sep = ',') (parse, pp_e) =
+ let parse s = try `Ok (Array.of_list (split_and_parse sep parse s)) with
+ | Failure e -> `Error (err_element "array" s e)
+ in
+ let print ppf v =
+ let max = Array.length v - 1 in
+ for i = 0 to max do pp_e ppf v.(i); if i <> max then pp_char ppf sep done
+ in
+ parse, print
+
+let split_left sep s =
+ try
+ let i = String.index s sep in
+ let len = String.length s in
+ Some ((String.sub s 0 i), (String.sub s (i + 1) (len - i - 1)))
+ with Not_found -> None
+
+let pair ?(sep = ',') (pa0, pr0) (pa1, pr1) =
+ let parser s = match split_left sep s with
+ | None -> `Error (err_sep_miss sep s)
+ | Some (v0, v1) ->
+ match pa0 v0, pa1 v1 with
+ | `Ok v0, `Ok v1 -> `Ok (v0, v1)
+ | `Error e, _ | _, `Error e -> `Error (err_element "pair" s e)
+ in
+ let printer ppf (v0, v1) = pp ppf "%a%c%a" pr0 v0 sep pr1 v1 in
+ parser, printer
+
+let t2 = pair
+let t3 ?(sep = ',') (pa0, pr0) (pa1, pr1) (pa2, pr2) =
+ let parse s = match split_left sep s with
+ | None -> `Error (err_sep_miss sep s)
+ | Some (v0, s) ->
+ match split_left sep s with
+ | None -> `Error (err_sep_miss sep s)
+ | Some (v1, v2) ->
+ match pa0 v0, pa1 v1, pa2 v2 with
+ | `Ok v0, `Ok v1, `Ok v2 -> `Ok (v0, v1, v2)
+ | `Error e, _, _ | _, `Error e, _ | _, _, `Error e ->
+ `Error (err_element "triple" s e)
+ in
+ let print ppf (v0, v1, v2) =
+ pp ppf "%a%c%a%c%a" pr0 v0 sep pr1 v1 sep pr2 v2
+ in
+ parse, print
+
+let t4 ?(sep = ',') (pa0, pr0) (pa1, pr1) (pa2, pr2) (pa3, pr3) =
+ let parse s = match split_left sep s with
+ | None -> `Error (err_sep_miss sep s)
+ | Some(v0, s) ->
+ match split_left sep s with
+ | None -> `Error (err_sep_miss sep s)
+ | Some (v1, s) ->
+ match split_left sep s with
+ | None -> `Error (err_sep_miss sep s)
+ | Some (v2, v3) ->
+ match pa0 v0, pa1 v1, pa2 v2, pa3 v3 with
+ | `Ok v1, `Ok v2, `Ok v3, `Ok v4 -> `Ok (v1, v2, v3, v4)
+ | `Error e, _, _, _ | _, `Error e, _, _ | _, _, `Error e, _
+ | _, _, _, `Error e -> `Error (err_element "quadruple" s e)
+ in
+ let print ppf (v0, v1, v2, v3) =
+ pp ppf "%a%c%a%c%a%c%a" pr0 v0 sep pr1 v1 sep pr2 v2 sep pr3 v3
+ in
+ parse, print
+
+let env_bool_parse s = match String.lowercase_ascii s with
+| "" | "false" | "no" | "n" | "0" -> `Ok false
+| "true" | "yes" | "y" | "1" -> `Ok true
+| s -> `Error (err_invalid_val s (alts_str ["true"; "yes"; "false"; "no" ]))
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,68 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+(** A few helpful base definitions. *)
+
+(** {1:fmt Formatting helpers} *)
+
+val pp_text : Format.formatter -> string -> unit
+val pp_lines : Format.formatter -> string -> unit
+val pp_tokens : spaces:bool -> Format.formatter -> string -> unit
+
+(** {1:err Error message helpers} *)
+
+val quote : string -> string
+val alts_str : ?quoted:bool -> string list -> string
+val err_ambiguous : kind:string -> string -> ambs:string list -> string
+val err_unknown : ?hints:string list -> kind:string -> string -> string
+val err_multi_def :
+ kind:string -> string -> ('b -> string) -> 'b -> 'b -> string
+
+(** {1:conv Textual OCaml value converters} *)
+
+type 'a parser = string -> [ `Ok of 'a | `Error of string ]
+type 'a printer = Format.formatter -> 'a -> unit
+type 'a conv = 'a parser * 'a printer
+
+val some : ?none:string -> 'a conv -> 'a option conv
+val bool : bool conv
+val char : char conv
+val int : int conv
+val nativeint : nativeint conv
+val int32 : int32 conv
+val int64 : int64 conv
+val float : float conv
+val string : string conv
+val enum : (string * 'a) list -> 'a conv
+val file : string conv
+val dir : string conv
+val non_dir_file : string conv
+val list : ?sep:char -> 'a conv -> 'a list conv
+val array : ?sep:char -> 'a conv -> 'a array conv
+val pair : ?sep:char -> 'a conv -> 'b conv -> ('a * 'b) conv
+val t2 : ?sep:char -> 'a conv -> 'b conv -> ('a * 'b) conv
+val t3 : ?sep:char -> 'a conv ->'b conv -> 'c conv -> ('a * 'b * 'c) conv
+val t4 :
+ ?sep:char -> 'a conv -> 'b conv -> 'c conv -> 'd conv ->
+ ('a * 'b * 'c * 'd) conv
+
+val env_bool_parse : bool parser
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,199 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+(* A command line stores pre-parsed information about the command
+ line's arguments in a more structured way. Given the
+ Cmdliner_info.arg values mentioned in a term and Sys.argv
+ (without exec name) we parse the command line into a map of
+ Cmdliner_info.arg values to [arg] values (see below). This map is used by
+ the term's closures to retrieve and convert command line arguments
+ (see the Cmdliner_arg module). *)
+
+let err_multi_opt_name_def name a a' =
+ Cmdliner_base.err_multi_def
+ ~kind:"option name" name Cmdliner_info.arg_doc a a'
+
+module Amap = Map.Make (Cmdliner_info.Arg)
+
+type arg = (* unconverted argument data as found on the command line. *)
+| O of (int * string * (string option)) list (* (pos, name, value) of opt. *)
+| P of string list
+
+type t = arg Amap.t (* command line, maps arg_infos to arg value. *)
+
+let get_arg cl a = try Amap.find a cl with Not_found -> assert false
+let opt_arg cl a = match get_arg cl a with O l -> l | _ -> assert false
+let pos_arg cl a = match get_arg cl a with P l -> l | _ -> assert false
+let actual_args cl a = match get_arg cl a with
+| P args -> args
+| O l ->
+ let extract_args (_pos, name, value) =
+ name :: (match value with None -> [] | Some v -> [v])
+ in
+ List.concat (List.map extract_args l)
+
+let arg_info_indexes args =
+ (* from [args] returns a trie mapping the names of optional arguments to
+ their arg_info, a list with all arg_info for positional arguments and
+ a cmdline mapping each arg_info to an empty [arg]. *)
+ let rec loop optidx posidx cl = function
+ | [] -> optidx, posidx, cl
+ | a :: l ->
+ match Cmdliner_info.arg_is_pos a with
+ | true -> loop optidx (a :: posidx) (Amap.add a (P []) cl) l
+ | false ->
+ let add t name = match Cmdliner_trie.add t name a with
+ | `New t -> t
+ | `Replaced (a', _) -> invalid_arg (err_multi_opt_name_def name a a')
+ in
+ let names = Cmdliner_info.arg_opt_names a in
+ let optidx = List.fold_left add optidx names in
+ loop optidx posidx (Amap.add a (O []) cl) l
+ in
+ loop Cmdliner_trie.empty [] Amap.empty (Cmdliner_info.Args.elements args)
+
+(* Optional argument parsing *)
+
+let is_opt s = String.length s > 1 && s.[0] = '-'
+let is_short_opt s = String.length s = 2 && s.[0] = '-'
+
+let parse_opt_arg s = (* (name, value) of opt arg, assert len > 1. *)
+ let l = String.length s in
+ if s.[1] <> '-' then (* short opt *)
+ if l = 2 then s, None else
+ String.sub s 0 2, Some (String.sub s 2 (l - 2)) (* with glued opt arg *)
+ else try (* long opt *)
+ let i = String.index s '=' in
+ String.sub s 0 i, Some (String.sub s (i + 1) (l - i - 1))
+ with Not_found -> s, None
+
+let hint_matching_opt optidx s =
+ (* hint options that could match [s] in [optidx]. FIXME explain this is
+ a bit obscure. *)
+ if String.length s <= 2 then [] else
+ let short_opt, long_opt =
+ if s.[1] <> '-'
+ then s, Printf.sprintf "-%s" s
+ else String.sub s 1 (String.length s - 1), s
+ in
+ let short_opt, _ = parse_opt_arg short_opt in
+ let long_opt, _ = parse_opt_arg long_opt in
+ let all = Cmdliner_trie.ambiguities optidx "-" in
+ match List.mem short_opt all, Cmdliner_suggest.value long_opt all with
+ | false, [] -> []
+ | false, l -> l
+ | true, [] -> [short_opt]
+ | true, l -> if List.mem short_opt l then l else short_opt :: l
+
+let parse_opt_args ~peek_opts optidx cl args =
+ (* returns an updated [cl] cmdline according to the options found in [args]
+ with the trie index [optidx]. Positional arguments are returned in order
+ in a list. *)
+ let rec loop errs k cl pargs = function
+ | [] -> List.rev errs, cl, List.rev pargs
+ | "--" :: args -> List.rev errs, cl, (List.rev_append pargs args)
+ | s :: args ->
+ if not (is_opt s) then loop errs (k + 1) cl (s :: pargs) args else
+ let name, value = parse_opt_arg s in
+ match Cmdliner_trie.find optidx name with
+ | `Ok a ->
+ let value, args = match value, Cmdliner_info.arg_opt_kind a with
+ | Some v, Cmdliner_info.Flag when is_short_opt name ->
+ None, ("-" ^ v) :: args
+ | Some _, _ -> value, args
+ | None, Cmdliner_info.Flag -> value, args
+ | None, _ ->
+ match args with
+ | [] -> None, args
+ | v :: rest -> if is_opt v then None, args else Some v, rest
+ in
+ let arg = O ((k, name, value) :: opt_arg cl a) in
+ loop errs (k + 1) (Amap.add a arg cl) pargs args
+ | `Not_found when peek_opts -> loop errs (k + 1) cl pargs args
+ | `Not_found ->
+ let hints = hint_matching_opt optidx s in
+ let err = Cmdliner_base.err_unknown ~kind:"option" ~hints name in
+ loop (err :: errs) (k + 1) cl pargs args
+ | `Ambiguous ->
+ let ambs = Cmdliner_trie.ambiguities optidx name in
+ let ambs = List.sort compare ambs in
+ let err = Cmdliner_base.err_ambiguous "option" name ambs in
+ loop (err :: errs) (k + 1) cl pargs args
+ in
+ let errs, cl, pargs = loop [] 0 cl [] args in
+ if errs = [] then Ok (cl, pargs) else
+ let err = String.concat "\n" errs in
+ Error (err, cl, pargs)
+
+let take_range start stop l =
+ let rec loop i acc = function
+ | [] -> List.rev acc
+ | v :: vs ->
+ if i < start then loop (i + 1) acc vs else
+ if i <= stop then loop (i + 1) (v :: acc) vs else
+ List.rev acc
+ in
+ loop 0 [] l
+
+let process_pos_args posidx cl pargs =
+ (* returns an updated [cl] cmdline in which each positional arg mentioned
+ in the list index posidx, is given a value according the list
+ of positional arguments values [pargs]. *)
+ if pargs = [] then
+ let misses = List.filter Cmdliner_info.arg_is_req posidx in
+ if misses = [] then Ok cl else
+ Error (Cmdliner_msg.err_pos_misses misses, cl)
+ else
+ let last = List.length pargs - 1 in
+ let pos rev k = if rev then last - k else k in
+ let rec loop misses cl max_spec = function
+ | [] -> misses, cl, max_spec
+ | a :: al ->
+ let apos = Cmdliner_info.arg_pos a in
+ let rev = Cmdliner_info.pos_rev apos in
+ let start = pos rev (Cmdliner_info.pos_start apos) in
+ let stop = match Cmdliner_info.pos_len apos with
+ | None -> pos rev last
+ | Some n -> pos rev (Cmdliner_info.pos_start apos + n - 1)
+ in
+ let start, stop = if rev then stop, start else start, stop in
+ let args = take_range start stop pargs in
+ let max_spec = max stop max_spec in
+ let cl = Amap.add a (P args) cl in
+ let misses = match Cmdliner_info.arg_is_req a && args = [] with
+ | true -> a :: misses
+ | false -> misses
+ in
+ loop misses cl max_spec al
+ in
+ let misses, cl, max_spec = loop [] cl (-1) posidx in
+ if misses <> [] then Error (Cmdliner_msg.err_pos_misses misses, cl) else
+ if last <= max_spec then Ok cl else
+ let excess = take_range (max_spec + 1) last pargs in
+ Error (Cmdliner_msg.err_pos_excess excess, cl)
+
+let create ?(peek_opts = false) al args =
+ let optidx, posidx, cl = arg_info_indexes al in
+ match parse_opt_args ~peek_opts optidx cl args with
+ | Ok (cl, _) when peek_opts -> Ok cl
+ | Ok (cl, pargs) -> process_pos_args posidx cl pargs
+ | Error (errs, cl, _) -> Error (errs, cl)
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,34 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+(** Command lines. *)
+
+type t
+
+val create :
+ ?peek_opts:bool -> Cmdliner_info.args -> string list ->
+ (t, string * t) result
+
+val opt_arg : t -> Cmdliner_info.arg -> (int * string * (string option)) list
+val pos_arg : t -> Cmdliner_info.arg -> string list
+val actual_args : t -> Cmdliner_info.arg -> string list
+(** Actual command line arguments from the command line *)
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,352 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+let rev_compare n0 n1 = compare n1 n0
+let strf = Printf.sprintf
+
+let esc = Cmdliner_manpage.escape
+let term_name t = esc @@ Cmdliner_info.term_name t
+
+let sorted_items_to_blocks ~boilerplate:b items =
+ (* Items are sorted by section and then rev. sorted by appearance.
+ We gather them by section in correct order in a `Block and prefix
+ them with optional boilerplate *)
+ let boilerplate = match b with None -> (fun _ -> None) | Some b -> b in
+ let mk_block sec acc = match boilerplate sec with
+ | None -> (sec, `Blocks acc)
+ | Some b -> (sec, `Blocks (b :: acc))
+ in
+ let rec loop secs sec acc = function
+ | (sec', it) :: its when sec' = sec -> loop secs sec (it :: acc) its
+ | (sec', it) :: its -> loop (mk_block sec acc :: secs) sec' [it] its
+ | [] -> (mk_block sec acc) :: secs
+ in
+ match items with
+ | [] -> []
+ | (sec, it) :: its -> loop [] sec [it] its
+
+(* Doc string variables substitutions. *)
+
+let env_info_subst ~subst e = function
+| "env" -> Some (strf "$(b,%s)" @@ esc (Cmdliner_info.env_var e))
+| id -> subst id
+
+let exit_info_subst ~subst e = function
+| "status" -> Some (strf "%d" (fst @@ Cmdliner_info.exit_statuses e))
+| "status_max" -> Some (strf "%d" (snd @@ Cmdliner_info.exit_statuses e))
+| id -> subst id
+
+let arg_info_subst ~subst a = function
+| "docv" ->
+ Some (strf "$(i,%s)" @@ esc (Cmdliner_info.arg_docv a))
+| "opt" when Cmdliner_info.arg_is_opt a ->
+ Some (strf "$(b,%s)" @@ esc (Cmdliner_info.arg_opt_name_sample a))
+| "env" as id ->
+ begin match Cmdliner_info.arg_env a with
+ | Some e -> env_info_subst ~subst e id
+ | None -> subst id
+ end
+| id -> subst id
+
+let term_info_subst ei = function
+| "tname" -> Some (strf "$(b,%s)" @@ term_name (Cmdliner_info.eval_term ei))
+| "mname" -> Some (strf "$(b,%s)" @@ term_name (Cmdliner_info.eval_main ei))
+| _ -> None
+
+(* Command docs *)
+
+let invocation ?(sep = ' ') ei = match Cmdliner_info.eval_kind ei with
+| `Simple | `Multiple_main -> term_name (Cmdliner_info.eval_main ei)
+| `Multiple_sub ->
+ strf "%s%c%s"
+ Cmdliner_info.(term_name @@ eval_main ei) sep
+ Cmdliner_info.(term_name @@ eval_term ei)
+
+let plain_invocation ei = invocation ei
+let invocation ?sep ei = esc @@ invocation ?sep ei
+
+let synopsis_pos_arg a =
+ let v = match Cmdliner_info.arg_docv a with "" -> "ARG" | v -> v in
+ let v = strf "$(i,%s)" (esc v) in
+ let v = (if Cmdliner_info.arg_is_req a then strf "%s" else strf "[%s]") v in
+ match Cmdliner_info.(pos_len @@ arg_pos a) with
+ | None -> v ^ "..."
+ | Some 1 -> v
+ | Some n ->
+ let rec loop n acc = if n <= 0 then acc else loop (n - 1) (v :: acc) in
+ String.concat " " (loop n [])
+
+let synopsis ei = match Cmdliner_info.eval_kind ei with
+| `Multiple_main -> strf "$(b,%s) $(i,COMMAND) ..." @@ invocation ei
+| `Simple | `Multiple_sub ->
+ let rev_cli_order (a0, _) (a1, _) =
+ Cmdliner_info.rev_arg_pos_cli_order a0 a1
+ in
+ let add_pos a acc = match Cmdliner_info.arg_is_opt a with
+ | true -> acc
+ | false -> (a, synopsis_pos_arg a) :: acc
+ in
+ let args = Cmdliner_info.(term_args @@ eval_term ei) in
+ let pargs = Cmdliner_info.Args.fold add_pos args [] in
+ let pargs = List.sort rev_cli_order pargs in
+ let pargs = String.concat " " (List.rev_map snd pargs) in
+ strf "$(b,%s) [$(i,OPTION)]... %s" (invocation ei) pargs
+
+let cmd_docs ei = match Cmdliner_info.eval_kind ei with
+| `Simple | `Multiple_sub -> []
+| `Multiple_main ->
+ let add_cmd acc t =
+ let cmd = strf "$(b,%s)" @@ term_name t in
+ (Cmdliner_info.term_docs t, `I (cmd, Cmdliner_info.term_doc t)) :: acc
+ in
+ let by_sec_by_rev_name (s0, `I (c0, _)) (s1, `I (c1, _)) =
+ let c = compare s0 s1 in
+ if c <> 0 then c else compare c1 c0 (* N.B. reverse *)
+ in
+ let cmds = List.fold_left add_cmd [] (Cmdliner_info.eval_choices ei) in
+ let cmds = List.sort by_sec_by_rev_name cmds in
+ let cmds = (cmds :> (string * Cmdliner_manpage.block) list) in
+ sorted_items_to_blocks ~boilerplate:None cmds
+
+(* Argument docs *)
+
+let arg_man_item_label a =
+ if Cmdliner_info.arg_is_pos a
+ then strf "$(i,%s)" (esc @@ Cmdliner_info.arg_docv a) else
+ let fmt_name var = match Cmdliner_info.arg_opt_kind a with
+ | Cmdliner_info.Flag -> fun n -> strf "$(b,%s)" (esc n)
+ | Cmdliner_info.Opt ->
+ fun n ->
+ if String.length n > 2
+ then strf "$(b,%s)=$(i,%s)" (esc n) (esc var)
+ else strf "$(b,%s) $(i,%s)" (esc n) (esc var)
+ | Cmdliner_info.Opt_vopt _ ->
+ fun n ->
+ if String.length n > 2
+ then strf "$(b,%s)[=$(i,%s)]" (esc n) (esc var)
+ else strf "$(b,%s) [$(i,%s)]" (esc n) (esc var)
+ in
+ let var = match Cmdliner_info.arg_docv a with "" -> "VAL" | v -> v in
+ let names = List.sort compare (Cmdliner_info.arg_opt_names a) in
+ let s = String.concat ", " (List.rev_map (fmt_name var) names) in
+ s
+
+let arg_to_man_item ~errs ~subst ~buf a =
+ let or_env ~value a = match Cmdliner_info.arg_env a with
+ | None -> ""
+ | Some e ->
+ let value = if value then " or" else "absent " in
+ strf "%s $(b,%s) env" value (esc @@ Cmdliner_info.env_var e)
+ in
+ let absent = match Cmdliner_info.arg_absent a with
+ | Cmdliner_info.Err -> "required"
+ | Cmdliner_info.Val v ->
+ match Lazy.force v with
+ | "" -> strf "%s" (or_env ~value:false a)
+ | v -> strf "absent=%s%s" v (or_env ~value:true a)
+ in
+ let optvopt = match Cmdliner_info.arg_opt_kind a with
+ | Cmdliner_info.Opt_vopt v -> strf "default=%s" v
+ | _ -> ""
+ in
+ let argvdoc = match optvopt, absent with
+ | "", "" -> ""
+ | s, "" | "", s -> strf " (%s)" s
+ | s, s' -> strf " (%s) (%s)" s s'
+ in
+ let subst = arg_info_subst ~subst a in
+ let doc = Cmdliner_info.arg_doc a in
+ let doc = Cmdliner_manpage.subst_vars ~errs ~subst buf doc in
+ (Cmdliner_info.arg_docs a, `I (arg_man_item_label a ^ argvdoc, doc))
+
+let arg_docs ~errs ~subst ~buf ei =
+ let by_sec_by_arg a0 a1 =
+ let c = compare (Cmdliner_info.arg_docs a0) (Cmdliner_info.arg_docs a1) in
+ if c <> 0 then c else
+ match Cmdliner_info.arg_is_opt a0, Cmdliner_info.arg_is_opt a1 with
+ | true, true -> (* optional by name *)
+ let key names =
+ let k = List.hd (List.sort rev_compare names) in
+ let k = String.lowercase_ascii k in
+ if k.[1] = '-' then String.sub k 1 (String.length k - 1) else k
+ in
+ compare
+ (key @@ Cmdliner_info.arg_opt_names a0)
+ (key @@ Cmdliner_info.arg_opt_names a1)
+ | false, false -> (* positional by variable *)
+ compare
+ (String.lowercase_ascii @@ Cmdliner_info.arg_docv a0)
+ (String.lowercase_ascii @@ Cmdliner_info.arg_docv a1)
+ | true, false -> -1 (* positional first *)
+ | false, true -> 1 (* optional after *)
+ in
+ let keep_arg a acc =
+ if not Cmdliner_info.(arg_is_pos a && (arg_docv a = "" || arg_doc a = ""))
+ then (a :: acc) else acc
+ in
+ let args = Cmdliner_info.(term_args @@ eval_term ei) in
+ let args = Cmdliner_info.Args.fold keep_arg args [] in
+ let args = List.sort by_sec_by_arg args in
+ let args = List.rev_map (arg_to_man_item ~errs ~subst ~buf) args in
+ sorted_items_to_blocks ~boilerplate:None args
+
+(* Exit statuses doc *)
+
+let exit_boilerplate sec = match sec = Cmdliner_manpage.s_exit_status with
+| false -> None
+| true -> Some (Cmdliner_manpage.s_exit_status_intro)
+
+let exit_docs ~errs ~subst ~buf ~has_sexit ei =
+ let by_sec (s0, _) (s1, _) = compare s0 s1 in
+ let add_exit_item acc e =
+ let subst = exit_info_subst ~subst e in
+ let min, max = Cmdliner_info.exit_statuses e in
+ let doc = Cmdliner_info.exit_doc e in
+ let label = if min = max then strf "%d" min else strf "%d-%d" min max in
+ let item = `I (label, Cmdliner_manpage.subst_vars ~errs ~subst buf doc) in
+ Cmdliner_info.(exit_docs e, item) :: acc
+ in
+ let exits = Cmdliner_info.(term_exits @@ eval_term ei) in
+ let exits = List.sort Cmdliner_info.exit_order exits in
+ let exits = List.fold_left add_exit_item [] exits in
+ let exits = List.stable_sort by_sec (* sort by section *) exits in
+ let boilerplate = if has_sexit then None else Some exit_boilerplate in
+ sorted_items_to_blocks ~boilerplate exits
+
+(* Environment doc *)
+
+let env_boilerplate sec = match sec = Cmdliner_manpage.s_environment with
+| false -> None
+| true -> Some (Cmdliner_manpage.s_environment_intro)
+
+let env_docs ~errs ~subst ~buf ~has_senv ei =
+ let add_env_item ~subst (seen, envs as acc) e =
+ if Cmdliner_info.Envs.mem e seen then acc else
+ let seen = Cmdliner_info.Envs.add e seen in
+ let var = strf "$(b,%s)" @@ esc (Cmdliner_info.env_var e) in
+ let doc = Cmdliner_info.env_doc e in
+ let doc = Cmdliner_manpage.subst_vars ~errs ~subst buf doc in
+ let envs = (Cmdliner_info.env_docs e, `I (var, doc)) :: envs in
+ seen, envs
+ in
+ let add_arg_env a acc = match Cmdliner_info.arg_env a with
+ | None -> acc
+ | Some e -> add_env_item ~subst:(arg_info_subst ~subst a) acc e
+ in
+ let add_env acc e = add_env_item ~subst:(env_info_subst ~subst e) acc e in
+ let by_sec_by_rev_name (s0, `I (v0, _)) (s1, `I (v1, _)) =
+ let c = compare s0 s1 in
+ if c <> 0 then c else compare v1 v0 (* N.B. reverse *)
+ in
+ (* Arg envs before term envs is important here: if the same is mentioned
+ both in an arg and in a term the substs of the arg are allowed. *)
+ let args = Cmdliner_info.(term_args @@ eval_term ei) in
+ let tenvs = Cmdliner_info.(term_envs @@ eval_term ei) in
+ let init = Cmdliner_info.Envs.empty, [] in
+ let acc = Cmdliner_info.Args.fold add_arg_env args init in
+ let _, envs = List.fold_left add_env acc tenvs in
+ let envs = List.sort by_sec_by_rev_name envs in
+ let envs = (envs :> (string * Cmdliner_manpage.block) list) in
+ let boilerplate = if has_senv then None else Some env_boilerplate in
+ sorted_items_to_blocks ~boilerplate envs
+
+(* xref doc *)
+
+let xref_docs ~errs ei =
+ let main = Cmdliner_info.(term_name @@ eval_main ei) in
+ let to_xref = function
+ | `Main -> main, 1
+ | `Tool tool -> tool, 1
+ | `Page (name, sec) -> name, sec
+ | `Cmd c ->
+ if Cmdliner_info.eval_has_choice ei c then strf "%s-%s" main c, 1 else
+ (Format.fprintf errs "xref %s: no such term name@." c; "doc-err", 0)
+ in
+ let xref_str (name, sec) = strf "%s(%d)" (esc name) sec in
+ let xrefs = Cmdliner_info.(term_man_xrefs @@ eval_term ei) in
+ let xrefs = List.fold_left (fun acc x -> to_xref x :: acc) [] xrefs in
+ let xrefs = List.(rev_map xref_str (sort rev_compare xrefs)) in
+ if xrefs = [] then [] else
+ [Cmdliner_manpage.s_see_also, `P (String.concat ", " xrefs)]
+
+(* Man page construction *)
+
+let ensure_s_name ei sm =
+ if Cmdliner_manpage.(smap_has_section sm s_name) then sm else
+ let tname = invocation ~sep:'-' ei in
+ let tdoc = Cmdliner_info.(term_doc @@ eval_term ei) in
+ let tagline = if tdoc = "" then "" else strf " - %s" tdoc in
+ let tagline = `P (strf "%s%s" tname tagline) in
+ Cmdliner_manpage.(smap_append_block sm ~sec:s_name tagline)
+
+let ensure_s_synopsis ei sm =
+ if Cmdliner_manpage.(smap_has_section sm ~sec:s_synopsis) then sm else
+ let synopsis = `P (synopsis ei) in
+ Cmdliner_manpage.(smap_append_block sm ~sec:s_synopsis synopsis)
+
+let insert_term_man_docs ~errs ei sm =
+ let buf = Buffer.create 200 in
+ let subst = term_info_subst ei in
+ let ins sm (s, b) = Cmdliner_manpage.smap_append_block sm s b in
+ let has_senv = Cmdliner_manpage.(smap_has_section sm s_environment) in
+ let has_sexit = Cmdliner_manpage.(smap_has_section sm s_exit_status) in
+ let sm = List.fold_left ins sm (cmd_docs ei) in
+ let sm = List.fold_left ins sm (arg_docs ~errs ~subst ~buf ei) in
+ let sm = List.fold_left ins sm (exit_docs ~errs ~subst ~buf ~has_sexit ei)in
+ let sm = List.fold_left ins sm (env_docs ~errs ~subst ~buf ~has_senv ei) in
+ let sm = List.fold_left ins sm (xref_docs ~errs ei) in
+ sm
+
+let text ~errs ei =
+ let man = Cmdliner_info.(term_man @@ eval_term ei) in
+ let sm = Cmdliner_manpage.smap_of_blocks man in
+ let sm = ensure_s_name ei sm in
+ let sm = ensure_s_synopsis ei sm in
+ let sm = insert_term_man_docs ei ~errs sm in
+ Cmdliner_manpage.smap_to_blocks sm
+
+let title ei =
+ let main = Cmdliner_info.eval_main ei in
+ let exec = String.capitalize_ascii (Cmdliner_info.term_name main) in
+ let name = String.uppercase_ascii (invocation ~sep:'-' ei) in
+ let center_header = esc @@ strf "%s Manual" exec in
+ let left_footer =
+ let version = match Cmdliner_info.term_version main with
+ | None -> "" | Some v -> " " ^ v
+ in
+ esc @@ strf "%s%s" exec version
+ in
+ name, 1, "", left_footer, center_header
+
+let man ~errs ei = title ei, text ~errs ei
+
+let pp_man ~errs fmt ppf ei =
+ Cmdliner_manpage.print
+ ~errs ~subst:(term_info_subst ei) fmt ppf (man ~errs ei)
+
+(* Plain synopsis for usage *)
+
+let pp_plain_synopsis ~errs ppf ei =
+ let buf = Buffer.create 100 in
+ let subst = term_info_subst ei in
+ let syn = Cmdliner_manpage.doc_to_plain ~errs ~subst buf (synopsis ei) in
+ Format.fprintf ppf "@[%s@]" syn
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,30 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+val plain_invocation : Cmdliner_info.eval -> string
+
+val pp_man :
+ errs:Format.formatter -> Cmdliner_manpage.format -> Format.formatter ->
+ Cmdliner_info.eval -> unit
+
+val pp_plain_synopsis :
+ errs:Format.formatter -> Format.formatter -> Cmdliner_info.eval -> unit
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,233 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+
+let new_id = (* thread-safe UIDs, Oo.id (object end) was used before. *)
+ let c = ref 0 in
+ fun () ->
+ let id = !c in
+ incr c; if id > !c then assert false (* too many ids *) else id
+
+(* Environments *)
+
+type env = (* information about an environment variable. *)
+ { env_id : int; (* unique id for the env var. *)
+ env_var : string; (* the variable. *)
+ env_doc : string; (* help. *)
+ env_docs : string; } (* title of help section where listed. *)
+
+let env
+ ?docs:(env_docs = Cmdliner_manpage.s_environment)
+ ?doc:(env_doc = "See option $(opt).") env_var =
+ { env_id = new_id (); env_var; env_doc; env_docs }
+
+let env_var e = e.env_var
+let env_doc e = e.env_doc
+let env_docs e = e.env_docs
+
+
+module Env = struct
+ type t = env
+ let compare a0 a1 = (compare : int -> int -> int) a0.env_id a1.env_id
+end
+
+module Envs = Set.Make (Env)
+type envs = Envs.t
+
+(* Arguments *)
+
+type arg_absence = Err | Val of string Lazy.t
+type opt_kind = Flag | Opt | Opt_vopt of string
+
+type pos_kind = (* information about a positional argument. *)
+ { pos_rev : bool; (* if [true] positions are counted from the end. *)
+ pos_start : int; (* start positional argument. *)
+ pos_len : int option } (* number of arguments or [None] if unbounded. *)
+
+let pos ~rev:pos_rev ~start:pos_start ~len:pos_len =
+ { pos_rev; pos_start; pos_len}
+
+let pos_rev p = p.pos_rev
+let pos_start p = p.pos_start
+let pos_len p = p.pos_len
+
+type arg = (* information about a command line argument. *)
+ { id : int; (* unique id for the argument. *)
+ absent : arg_absence; (* behaviour if absent. *)
+ env : env option; (* environment variable. *)
+ doc : string; (* help. *)
+ docv : string; (* variable name for the argument in help. *)
+ docs : string; (* title of help section where listed. *)
+ pos : pos_kind; (* positional arg kind. *)
+ opt_kind : opt_kind; (* optional arg kind. *)
+ opt_names : string list; (* names (for opt args). *)
+ opt_all : bool; } (* repeatable (for opt args). *)
+
+let dumb_pos = pos ~rev:false ~start:(-1) ~len:None
+
+let arg ?docs ?(docv = "") ?(doc = "") ?env names =
+ let dash n = if String.length n = 1 then "-" ^ n else "--" ^ n in
+ let opt_names = List.map dash names in
+ let docs = match docs with
+ | Some s -> s
+ | None ->
+ match names with
+ | [] -> Cmdliner_manpage.s_arguments
+ | _ -> Cmdliner_manpage.s_options
+ in
+ { id = new_id (); absent = Val (lazy ""); env; doc; docv; docs;
+ pos = dumb_pos; opt_kind = Flag; opt_names; opt_all = false; }
+
+let arg_id a = a.id
+let arg_absent a = a.absent
+let arg_env a = a.env
+let arg_doc a = a.doc
+let arg_docv a = a.docv
+let arg_docs a = a.docs
+let arg_pos a = a.pos
+let arg_opt_kind a = a.opt_kind
+let arg_opt_names a = a.opt_names
+let arg_opt_all a = a.opt_all
+let arg_opt_name_sample a =
+ (* First long or short name (in that order) in the list; this
+ allows the client to control which name is shown *)
+ let rec find = function
+ | [] -> List.hd a.opt_names
+ | n :: ns -> if (String.length n) > 2 then n else find ns
+ in
+ find a.opt_names
+
+let arg_make_req a = { a with absent = Err }
+let arg_make_all_opts a = { a with opt_all = true }
+let arg_make_opt ~absent ~kind:opt_kind a = { a with absent; opt_kind }
+let arg_make_opt_all ~absent ~kind:opt_kind a =
+ { a with absent; opt_kind; opt_all = true }
+
+let arg_make_pos ~pos a = { a with pos }
+let arg_make_pos_abs ~absent ~pos a = { a with absent; pos }
+
+let arg_is_opt a = a.opt_names <> []
+let arg_is_pos a = a.opt_names = []
+let arg_is_req a = a.absent = Err
+
+let arg_pos_cli_order a0 a1 = (* best-effort order on the cli. *)
+ let c = compare (a0.pos.pos_rev) (a1.pos.pos_rev) in
+ if c <> 0 then c else
+ if a0.pos.pos_rev
+ then compare a1.pos.pos_start a0.pos.pos_start
+ else compare a0.pos.pos_start a1.pos.pos_start
+
+let rev_arg_pos_cli_order a0 a1 = arg_pos_cli_order a1 a0
+
+module Arg = struct
+ type t = arg
+ let compare a0 a1 = (compare : int -> int -> int) a0.id a1.id
+end
+
+module Args = Set.Make (Arg)
+type args = Args.t
+
+(* Exit info *)
+
+type exit =
+ { exit_statuses : int * int;
+ exit_doc : string;
+ exit_docs : string; }
+
+let exit
+ ?docs:(exit_docs = Cmdliner_manpage.s_exit_status)
+ ?doc:(exit_doc = "undocumented") ?max min =
+ let max = match max with None -> min | Some max -> max in
+ { exit_statuses = (min, max); exit_doc; exit_docs }
+
+let exit_statuses e = e.exit_statuses
+let exit_doc e = e.exit_doc
+let exit_docs e = e.exit_docs
+let exit_order e0 e1 = compare e0.exit_statuses e1.exit_statuses
+
+(* Term info *)
+
+type term_info =
+ { term_name : string; (* name of the term. *)
+ term_version : string option; (* version (for --version). *)
+ term_doc : string; (* one line description of term. *)
+ term_docs : string; (* title of man section where listed (commands). *)
+ term_sdocs : string; (* standard options, title of section where listed. *)
+ term_exits : exit list; (* exit codes for the term. *)
+ term_envs : env list; (* env vars that influence the term. *)
+ term_man : Cmdliner_manpage.block list; (* man page text. *)
+ term_man_xrefs : Cmdliner_manpage.xref list; } (* man cross-refs. *)
+
+type term =
+ { term_info : term_info;
+ term_args : args; }
+
+let term
+ ?args:(term_args = Args.empty) ?man_xrefs:(term_man_xrefs = [])
+ ?man:(term_man = []) ?envs:(term_envs = []) ?exits:(term_exits = [])
+ ?sdocs:(term_sdocs = Cmdliner_manpage.s_options)
+ ?docs:(term_docs = "COMMANDS") ?doc:(term_doc = "") ?version:term_version
+ term_name =
+ let term_info =
+ { term_name; term_version; term_doc; term_docs; term_sdocs; term_exits;
+ term_envs; term_man; term_man_xrefs }
+ in
+ { term_info; term_args }
+
+let term_name t = t.term_info.term_name
+let term_version t = t.term_info.term_version
+let term_doc t = t.term_info.term_doc
+let term_docs t = t.term_info.term_docs
+let term_stdopts_docs t = t.term_info.term_sdocs
+let term_exits t = t.term_info.term_exits
+let term_envs t = t.term_info.term_envs
+let term_man t = t.term_info.term_man
+let term_man_xrefs t = t.term_info.term_man_xrefs
+let term_args t = t.term_args
+
+let term_add_args t args =
+ { t with term_args = Args.union args t.term_args }
+
+(* Eval info *)
+
+type eval = (* information about the evaluation context. *)
+ { term : term; (* term being evaluated. *)
+ main : term; (* main term. *)
+ choices : term list; (* all term choices. *)
+ env : string -> string option } (* environment variable lookup. *)
+
+let eval ~term ~main ~choices ~env = { term; main; choices; env }
+let eval_term e = e.term
+let eval_main e = e.main
+let eval_choices e = e.choices
+let eval_env_var e v = e.env v
+
+let eval_kind ei =
+ if ei.choices = [] then `Simple else
+ if (ei.term.term_info.term_name == ei.main.term_info.term_name)
+ then `Multiple_main else `Multiple_sub
+
+let eval_with_term ei term = { ei with term }
+
+let eval_has_choice e cmd =
+ let is_cmd t = t.term_info.term_name = cmd in
+ List.exists is_cmd e.choices
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,140 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+(** Terms, argument, env vars information.
+
+ The following types keep untyped information about arguments and
+ terms. This data is used to parse the command line, report errors
+ and format man pages. *)
+
+(** {1:env Environment variables} *)
+
+type env
+val env : ?docs:string -> ?doc:string -> string -> env
+val env_var : env -> string
+val env_doc : env -> string
+val env_docs : env -> string
+
+module Env : Set.OrderedType with type t = env
+module Envs : Set.S with type elt = env
+type envs = Envs.t
+
+(** {1:arg Arguments} *)
+
+type arg_absence =
+| Err (** an error is reported. *)
+| Val of string Lazy.t (** if <> "", takes the given default value. *)
+(** The type for what happens if the argument is absent from the cli. *)
+
+type opt_kind =
+| Flag (** without value, just a flag. *)
+| Opt (** with required value. *)
+| Opt_vopt of string (** with optional value, takes given default. *)
+(** The type for optional argument kinds. *)
+
+type pos_kind
+val pos : rev:bool -> start:int -> len:int option -> pos_kind
+val pos_rev : pos_kind -> bool
+val pos_start : pos_kind -> int
+val pos_len : pos_kind -> int option
+
+type arg
+val arg :
+ ?docs:string -> ?docv:string -> ?doc:string -> ?env:env ->
+ string list -> arg
+
+val arg_id : arg -> int
+val arg_absent : arg -> arg_absence
+val arg_env : arg -> env option
+val arg_doc : arg -> string
+val arg_docv : arg -> string
+val arg_docs : arg -> string
+val arg_opt_names : arg -> string list (* has dashes *)
+val arg_opt_name_sample : arg -> string (* warning must be an opt arg *)
+val arg_opt_kind : arg -> opt_kind
+val arg_pos : arg -> pos_kind
+
+val arg_make_req : arg -> arg
+val arg_make_all_opts : arg -> arg
+val arg_make_opt : absent:arg_absence -> kind:opt_kind -> arg -> arg
+val arg_make_opt_all : absent:arg_absence -> kind:opt_kind -> arg -> arg
+val arg_make_pos : pos:pos_kind -> arg -> arg
+val arg_make_pos_abs : absent:arg_absence -> pos:pos_kind -> arg -> arg
+
+val arg_is_opt : arg -> bool
+val arg_is_pos : arg -> bool
+val arg_is_req : arg -> bool
+
+val arg_pos_cli_order : arg -> arg -> int
+val rev_arg_pos_cli_order : arg -> arg -> int
+
+module Arg : Set.OrderedType with type t = arg
+module Args : Set.S with type elt = arg
+type args = Args.t
+
+(** {1:exit Exit status} *)
+
+type exit
+val exit : ?docs:string -> ?doc:string -> ?max:int -> int -> exit
+val exit_statuses : exit -> int * int
+val exit_doc : exit -> string
+val exit_docs : exit -> string
+val exit_order : exit -> exit -> int
+
+(** {1:term Term information} *)
+
+type term
+
+val term :
+ ?args:args -> ?man_xrefs:Cmdliner_manpage.xref list ->
+ ?man:Cmdliner_manpage.block list -> ?envs:env list -> ?exits:exit list ->
+ ?sdocs:string -> ?docs:string -> ?doc:string -> ?version:string ->
+ string -> term
+
+val term_name : term -> string
+val term_version : term -> string option
+val term_doc : term -> string
+val term_docs : term -> string
+val term_stdopts_docs : term -> string
+val term_exits : term -> exit list
+val term_envs : term -> env list
+val term_man : term -> Cmdliner_manpage.block list
+val term_man_xrefs : term -> Cmdliner_manpage.xref list
+val term_args : term -> args
+
+val term_add_args : term -> args -> term
+
+(** {1:eval Evaluation information} *)
+
+type eval
+
+val eval :
+ term:term -> main:term -> choices:term list ->
+ env:(string -> string option) -> eval
+
+val eval_term : eval -> term
+val eval_main : eval -> term
+val eval_choices : eval -> term list
+val eval_env_var : eval -> string -> string option
+val eval_kind : eval -> [> `Multiple_main | `Multiple_sub | `Simple ]
+val eval_with_term : eval -> term -> eval
+val eval_has_choice : eval -> string -> bool
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,502 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+(* Manpages *)
+
+type block =
+ [ `S of string | `P of string | `Pre of string | `I of string * string
+ | `Noblank | `Blocks of block list ]
+
+type title = string * int * string * string * string
+
+type t = title * block list
+
+type xref =
+ [ `Main | `Cmd of string | `Tool of string | `Page of string * int ]
+
+(* Standard sections *)
+
+let s_name = "NAME"
+let s_synopsis = "SYNOPSIS"
+let s_description = "DESCRIPTION"
+let s_commands = "COMMANDS"
+let s_arguments = "ARGUMENTS"
+let s_options = "OPTIONS"
+let s_common_options = "COMMON OPTIONS"
+let s_exit_status = "EXIT STATUS"
+let s_exit_status_intro =
+ `P "$(tname) exits with the following status:"
+
+let s_environment = "ENVIRONMENT"
+let s_environment_intro =
+ `P "These environment variables affect the execution of $(tname):"
+
+let s_files = "FILES"
+let s_examples = "EXAMPLES"
+let s_bugs = "BUGS"
+let s_authors = "AUTHORS"
+let s_see_also = "SEE ALSO"
+
+(* Section order *)
+
+let s_created = ""
+let order =
+ [| s_name; s_synopsis; s_description; s_created; s_commands;
+ s_arguments; s_options; s_common_options; s_exit_status;
+ s_environment; s_files; s_examples; s_bugs; s_authors; s_see_also; |]
+
+let order_synopsis = 1
+let order_created = 3
+
+let section_of_order i = order.(i)
+let section_to_order ~on_unknown s =
+ let max = Array.length order - 1 in
+ let rec loop i = match i > max with
+ | true -> on_unknown
+ | false -> if order.(i) = s then i else loop (i + 1)
+ in
+ loop 0
+
+(* Section maps
+
+ Section maps, maps section names to their section order and reversed
+ content blocks (content is not reversed in `Block blocks). The sections
+ are listed in reversed order. Unknown sections get the order of the last
+ known section. *)
+
+type smap = (string * (int * block list)) list
+
+let smap_of_blocks bs = (* N.B. this flattens `Blocks, not t.r. *)
+ let rec loop s s_o rbs smap = function
+ | [] -> s, s_o, rbs, smap
+ | `S new_sec :: bs ->
+ let new_o = section_to_order ~on_unknown:s_o new_sec in
+ loop new_sec new_o [] ((s, (s_o, rbs)):: smap) bs
+ | `Blocks blist :: bs ->
+ let s, s_o, rbs, rmap = loop s s_o rbs smap blist (* not t.r. *) in
+ loop s s_o rbs rmap bs
+ | (`P _ | `Pre _ | `I _ | `Noblank as c) :: bs ->
+ loop s s_o (c :: rbs) smap bs
+ in
+ let first, (bs : block list) = match bs with
+ | `S s :: bs -> s, bs
+ | `Blocks (`S s :: blist) :: bs -> s, (`Blocks blist) :: bs
+ | _ -> "", bs
+ in
+ let first_o = section_to_order ~on_unknown:order_synopsis first in
+ let s, s_o, rc, smap = loop first first_o [] [] bs in
+ (s, (s_o, rc)) :: smap
+
+let smap_to_blocks smap = (* N.B. this leaves `Blocks content untouched. *)
+ let rec loop acc smap s = function
+ | b :: rbs -> loop (b :: acc) smap s rbs
+ | [] ->
+ let acc = if s = "" then acc else `S s :: acc in
+ match smap with
+ | (s, (_, rbs)) :: smap -> loop acc smap s rbs
+ | [] -> acc
+ in
+ match smap with
+ | [] -> []
+ | (s, (_, rbs)) :: smap -> loop [] smap s rbs
+
+let smap_has_section smap ~sec = List.exists (fun (s, _) -> sec = s) smap
+let smap_append_block smap ~sec b =
+ let o = section_to_order ~on_unknown:order_created sec in
+ let try_insert =
+ let rec loop max_lt_o left = function
+ | (s', (o, rbs)) :: right when s' = sec ->
+ Ok (List.rev_append ((sec, (o, b :: rbs)) :: left) right)
+ | (_, (o', _) as s) :: right ->
+ let max_lt_o = if o' < o then max o' max_lt_o else max_lt_o in
+ loop max_lt_o (s :: left) right
+ | [] ->
+ if max_lt_o <> -1 then Error max_lt_o else
+ Ok (List.rev ((sec, (o, [b])) :: left))
+ in
+ loop (-1) [] smap
+ in
+ match try_insert with
+ | Ok smap -> smap
+ | Error insert_before ->
+ let rec loop left = function
+ | (s', (o', _)) :: _ as right when o' = insert_before ->
+ List.rev_append ((sec, (o, [b])) :: left) right
+ | s :: ss -> loop (s :: left) ss
+ | [] -> assert false
+ in
+ loop [] smap
+
+(* Formatting tools *)
+
+let strf = Printf.sprintf
+let pf = Format.fprintf
+let pp_str = Format.pp_print_string
+let pp_char = Format.pp_print_char
+let pp_indent ppf c = for i = 1 to c do pp_char ppf ' ' done
+let pp_lines = Cmdliner_base.pp_lines
+let pp_tokens = Cmdliner_base.pp_tokens
+
+(* Cmdliner markup handling *)
+
+let err e fmt = pf e ("cmdliner error: " ^^ fmt ^^ "@.")
+let err_unescaped ~errs c s = err errs "unescaped %C in %S" c s
+let err_malformed ~errs s = err errs "Malformed $(...) in %S" s
+let err_unclosed ~errs s = err errs "Unclosed $(...) in %S" s
+let err_undef ~errs id s = err errs "Undefined variable $(%s) in %S" id s
+let err_illegal_esc ~errs c s = err errs "Illegal escape char %C in %S" c s
+let err_markup ~errs dir s =
+ err errs "Unknown cmdliner markup $(%c,...) in %S" dir s
+
+let is_markup_dir = function 'i' | 'b' -> true | _ -> false
+let is_markup_esc = function '$' | '\\' | '(' | ')' -> true | _ -> false
+let markup_need_esc = function '\\' | '$' -> true | _ -> false
+let markup_text_need_esc = function '\\' | '$' | ')' -> true | _ -> false
+
+let escape s = (* escapes [s] from doc language. *)
+ let max_i = String.length s - 1 in
+ let rec escaped_len i l =
+ if i > max_i then l else
+ if markup_text_need_esc s.[i] then escaped_len (i + 1) (l + 2) else
+ escaped_len (i + 1) (l + 1)
+ in
+ let escaped_len = escaped_len 0 0 in
+ if escaped_len = String.length s then s else
+ let b = Bytes.create escaped_len in
+ let rec loop i k =
+ if i > max_i then Bytes.unsafe_to_string b else
+ let c = String.unsafe_get s i in
+ if not (markup_text_need_esc c)
+ then (Bytes.unsafe_set b k c; loop (i + 1) (k + 1))
+ else (Bytes.unsafe_set b k '\\'; Bytes.unsafe_set b (k + 1) c;
+ loop (i + 1) (k + 2))
+ in
+ loop 0 0
+
+let subst_vars ~errs ~subst b s =
+ let max_i = String.length s - 1 in
+ let flush start stop = match start > max_i with
+ | true -> ()
+ | false -> Buffer.add_substring b s start (stop - start + 1)
+ in
+ let skip_escape k start i =
+ if i > max_i then err_unescaped ~errs '\\' s else k start (i + 1)
+ in
+ let rec skip_markup k start i =
+ if i > max_i then (err_unclosed ~errs s; k start i) else
+ match s.[i] with
+ | '\\' -> skip_escape (skip_markup k) start (i + 1)
+ | ')' -> k start (i + 1)
+ | c -> skip_markup k start (i + 1)
+ in
+ let rec add_subst start i =
+ if i > max_i then (err_unclosed ~errs s; loop start i) else
+ if s.[i] <> ')' then add_subst start (i + 1) else
+ let id = String.sub s start (i - start) in
+ let next = i + 1 in
+ begin match subst id with
+ | None -> err_undef ~errs id s; Buffer.add_string b "undefined";
+ | Some v -> Buffer.add_string b v
+ end;
+ loop next next
+ and loop start i =
+ if i > max_i then flush start max_i else
+ let next = i + 1 in
+ match s.[i] with
+ | '\\' -> skip_escape loop start next
+ | '$' ->
+ if next > max_i then err_unescaped ~errs '$' s else
+ begin match s.[next] with
+ | '(' ->
+ let min = next + 2 in
+ if min > max_i then (err_unclosed ~errs s; loop start next) else
+ begin match s.[min] with
+ | ',' -> skip_markup loop start (min + 1)
+ | _ ->
+ let start_id = next + 1 in
+ flush start (i - 1); add_subst start_id start_id
+ end
+ | _ -> err_unescaped ~errs '$' s; loop start next
+ end;
+ | c -> loop start next
+ in
+ (Buffer.clear b; loop 0 0; Buffer.contents b)
+
+let add_markup_esc ~errs k b s start next target_need_escape target_escape =
+ let max_i = String.length s - 1 in
+ if next > max_i then err_unescaped ~errs '\\' s else
+ match s.[next] with
+ | c when not (is_markup_esc s.[next]) ->
+ err_illegal_esc ~errs c s;
+ k (next + 1) (next + 1)
+ | c ->
+ (if target_need_escape c then target_escape b c else Buffer.add_char b c);
+ k (next + 1) (next + 1)
+
+let add_markup_text ~errs k b s start target_need_escape target_escape =
+ let max_i = String.length s - 1 in
+ let flush start stop = match start > max_i with
+ | true -> ()
+ | false -> Buffer.add_substring b s start (stop - start + 1)
+ in
+ let rec loop start i =
+ if i > max_i then (err_unclosed ~errs s; flush start max_i) else
+ let next = i + 1 in
+ match s.[i] with
+ | '\\' -> (* unescape *)
+ flush start (i - 1);
+ add_markup_esc ~errs loop b s start next
+ target_need_escape target_escape
+ | ')' -> flush start (i - 1); k next next
+ | c when markup_text_need_esc c ->
+ err_unescaped ~errs c s; flush start (i - 1); loop next next
+ | c when target_need_escape c ->
+ flush start (i - 1); target_escape b c; loop next next
+ | c -> loop start next
+ in
+ loop start start
+
+(* Plain text output *)
+
+let markup_to_plain ~errs b s =
+ let max_i = String.length s - 1 in
+ let flush start stop = match start > max_i with
+ | true -> ()
+ | false -> Buffer.add_substring b s start (stop - start + 1)
+ in
+ let need_escape _ = false in
+ let escape _ _ = assert false in
+ let rec loop start i =
+ if i > max_i then flush start max_i else
+ let next = i + 1 in
+ match s.[i] with
+ | '\\' ->
+ flush start (i - 1);
+ add_markup_esc ~errs loop b s start next need_escape escape
+ | '$' ->
+ if next > max_i then err_unescaped ~errs '$' s else
+ begin match s.[next] with
+ | '(' ->
+ let min = next + 2 in
+ if min > max_i then (err_unclosed ~errs s; loop start next) else
+ begin match s.[min] with
+ | ',' ->
+ let markup = s.[min - 1] in
+ if not (is_markup_dir markup)
+ then (err_markup ~errs markup s; loop start next) else
+ let start_data = min + 1 in
+ (flush start (i - 1);
+ add_markup_text ~errs loop b s start_data need_escape escape)
+ | _ ->
+ err_malformed ~errs s; loop start next
+ end
+ | _ -> err_unescaped ~errs '$' s; loop start next
+ end
+ | c when markup_need_esc c ->
+ err_unescaped ~errs c s; flush start (i - 1); loop next next
+ | c -> loop start next
+ in
+ (Buffer.clear b; loop 0 0; Buffer.contents b)
+
+let doc_to_plain ~errs ~subst b s =
+ markup_to_plain ~errs b (subst_vars ~errs ~subst b s)
+
+let p_indent = 7 (* paragraph indentation. *)
+let l_indent = 4 (* label indentation. *)
+
+let pp_plain_blocks ~errs subst ppf ts =
+ let b = Buffer.create 1024 in
+ let markup t = doc_to_plain ~errs b ~subst t in
+ let pp_tokens ppf t = pp_tokens ~spaces:true ppf t in
+ let rec loop = function
+ | [] -> ()
+ | t :: ts ->
+ begin match t with
+ | `Noblank -> ()
+ | `Blocks bs -> loop bs (* not T.R. *)
+ | `P s -> pf ppf "%a@[%a@]@," pp_indent p_indent pp_tokens (markup s)
+ | `S s -> pf ppf "@[%a@]" pp_tokens (markup s)
+ | `Pre s -> pf ppf "%a@[%a@]@," pp_indent p_indent pp_lines (markup s)
+ | `I (label, s) ->
+ let label = markup label in
+ let s = markup s in
+ pf ppf "@[%a@[%a@]" pp_indent p_indent pp_tokens label;
+ if s = "" then pf ppf "@]@," else
+ let ll = String.length label in
+ begin match ll < l_indent with
+ | true ->
+ pf ppf "%a@[%a@]@]" pp_indent (l_indent - ll) pp_tokens s
+ | false ->
+ pf ppf "@\n%a@[%a@]@]"
+ pp_indent (p_indent + l_indent) pp_tokens s
+ end;
+ match ts with `I _ :: _ -> pf ppf "@," | _ -> ()
+ end;
+ begin match ts with
+ | `Noblank :: ts -> loop ts
+ | ts -> Format.pp_print_cut ppf (); loop ts
+ end
+ in
+ loop ts
+
+let pp_plain_page ~errs subst ppf (_, text) =
+ pf ppf "@[<v>%a@]" (pp_plain_blocks ~errs subst) text
+
+(* Groff output *)
+
+let markup_to_groff ~errs b s =
+ let max_i = String.length s - 1 in
+ let flush start stop = match start > max_i with
+ | true -> ()
+ | false -> Buffer.add_substring b s start (stop - start + 1)
+ in
+ let need_escape = function '.' | '\'' | '-' | '\\' -> true | _ -> false in
+ let escape b c = Printf.bprintf b "\\N'%d'" (Char.code c) in
+ let rec end_text start i = Buffer.add_string b "\\fR"; loop start i
+ and loop start i =
+ if i > max_i then flush start max_i else
+ let next = i + 1 in
+ match s.[i] with
+ | '\\' ->
+ flush start (i - 1);
+ add_markup_esc ~errs loop b s start next need_escape escape
+ | '$' ->
+ if next > max_i then err_unescaped ~errs '$' s else
+ begin match s.[next] with
+ | '(' ->
+ let min = next + 2 in
+ if min > max_i then (err_unclosed ~errs s; loop start next) else
+ begin match s.[min] with
+ | ',' ->
+ let start_data = min + 1 in
+ flush start (i - 1);
+ begin match s.[min - 1] with
+ | 'i' -> Buffer.add_string b "\\fI"
+ | 'b' -> Buffer.add_string b "\\fB"
+ | markup -> err_markup ~errs markup s
+ end;
+ add_markup_text ~errs end_text b s start_data need_escape escape
+ | _ -> err_malformed ~errs s; loop start next
+ end
+ | _ -> err_unescaped ~errs '$' s; flush start (i - 1); loop next next
+ end
+ | c when markup_need_esc c ->
+ err_unescaped ~errs c s; flush start (i - 1); loop next next
+ | c when need_escape c ->
+ flush start (i - 1); escape b c; loop next next
+ | c -> loop start next
+ in
+ (Buffer.clear b; loop 0 0; Buffer.contents b)
+
+let doc_to_groff ~errs ~subst b s =
+ markup_to_groff ~errs b (subst_vars ~errs ~subst b s)
+
+let pp_groff_blocks ~errs subst ppf text =
+ let buf = Buffer.create 1024 in
+ let markup t = doc_to_groff ~errs ~subst buf t in
+ let pp_tokens ppf t = pp_tokens ~spaces:false ppf t in
+ let rec pp_block = function
+ | `Blocks bs -> List.iter pp_block bs (* not T.R. *)
+ | `P s -> pf ppf "@\n.P@\n%a" pp_tokens (markup s)
+ | `Pre s -> pf ppf "@\n.P@\n.nf@\n%a@\n.fi" pp_lines (markup s)
+ | `S s -> pf ppf "@\n.SH %a" pp_tokens (markup s)
+ | `Noblank -> pf ppf "@\n.sp -1"
+ | `I (l, s) ->
+ pf ppf "@\n.TP 4@\n%a@\n%a" pp_tokens (markup l) pp_tokens (markup s)
+ in
+ List.iter pp_block text
+
+let pp_groff_page ~errs subst ppf ((n, s, a1, a2, a3), t) =
+ pf ppf ".\\\" Pipe this output to groff -Tutf8 | less@\n\
+ .\\\"@\n\
+ .mso an.tmac@\n\
+ .TH \"%s\" %d \"%s\" \"%s\" \"%s\"@\n\
+ .\\\" Disable hyphenation and ragged-right@\n\
+ .nh@\n\
+ .ad l\
+ %a@?"
+ n s a1 a2 a3 (pp_groff_blocks ~errs subst) t
+
+(* Printing to a pager *)
+
+let pp_to_temp_file pp_v v =
+ try
+ let exec = Filename.basename Sys.argv.(0) in
+ let file, oc = Filename.open_temp_file exec "out" in
+ let ppf = Format.formatter_of_out_channel oc in
+ pp_v ppf v; Format.pp_print_flush ppf (); close_out oc;
+ at_exit (fun () -> try Sys.remove file with Sys_error e -> ());
+ Some file
+ with Sys_error _ -> None
+
+let find_cmd cmds =
+ let test, null = match Sys.os_type with
+ | "Win32" -> "where", " NUL"
+ | _ -> "type", "/dev/null"
+ in
+ let cmd c = Sys.command (strf "%s %s 1>%s 2>%s" test c null null) = 0 in
+ try Some (List.find cmd cmds) with Not_found -> None
+
+let pp_to_pager print ppf v =
+ let pager =
+ let cmds = ["less"; "more"] in
+ let cmds = try (Sys.getenv "PAGER") :: cmds with Not_found -> cmds in
+ let cmds = try (Sys.getenv "MANPAGER") :: cmds with Not_found -> cmds in
+ find_cmd cmds
+ in
+ match pager with
+ | None -> print `Plain ppf v
+ | Some pager ->
+ let cmd = match (find_cmd ["groff"; "nroff"]) with
+ | None ->
+ begin match pp_to_temp_file (print `Plain) v with
+ | None -> None
+ | Some f -> Some (strf "%s < %s" pager f)
+ end
+ | Some c ->
+ begin match pp_to_temp_file (print `Groff) v with
+ | None -> None
+ | Some f ->
+ (* TODO use -Tutf8, but annoyingly maps U+002D to U+2212. *)
+ let xroff = if c = "groff" then c ^ " -Tascii -P-c" else c in
+ Some (strf "%s < %s | %s" xroff f pager)
+ end
+ in
+ match cmd with
+ | None -> print `Plain ppf v
+ | Some cmd -> if (Sys.command cmd) <> 0 then print `Plain ppf v
+
+(* Output *)
+
+type format = [ `Auto | `Pager | `Plain | `Groff ]
+
+let rec print
+ ?(errs = Format.err_formatter)
+ ?(subst = fun x -> None) fmt ppf page =
+ match fmt with
+ | `Pager -> pp_to_pager (print ~errs ~subst) ppf page
+ | `Plain -> pp_plain_page ~errs subst ppf page
+ | `Groff -> pp_groff_page ~errs subst ppf page
+ | `Auto ->
+ match try (Some (Sys.getenv "TERM")) with Not_found -> None with
+ | None | Some "dumb" -> print ~errs ~subst `Plain ppf page
+ | Some _ -> print ~errs ~subst `Pager ppf page
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,100 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+(** Manpages.
+
+ See {!Cmdliner.Manpage}. *)
+
+type block =
+ [ `S of string | `P of string | `Pre of string | `I of string * string
+ | `Noblank | `Blocks of block list ]
+
+val escape : string -> string
+(** [escape s] escapes [s] from the doc language. *)
+
+type title = string * int * string * string * string
+
+type t = title * block list
+
+type xref =
+ [ `Main | `Cmd of string | `Tool of string | `Page of string * int ]
+
+(** {1 Standard section names} *)
+
+val s_name : string
+val s_synopsis : string
+val s_description : string
+val s_commands : string
+val s_arguments : string
+val s_options : string
+val s_common_options : string
+val s_exit_status : string
+val s_environment : string
+val s_files : string
+val s_bugs : string
+val s_examples : string
+val s_authors : string
+val s_see_also : string
+
+(** {1 Section maps}
+
+ Used for handling the merging of metadata doc strings. *)
+
+type smap
+val smap_of_blocks : block list -> smap
+val smap_to_blocks : smap -> block list
+val smap_has_section : smap -> sec:string -> bool
+val smap_append_block : smap -> sec:string -> block -> smap
+(** [smap_append_block smap sec b] appends [b] at the end of section
+ [sec] creating it at the right place if needed. *)
+
+(** {1 Content boilerplate} *)
+
+val s_exit_status_intro : block
+val s_environment_intro : block
+
+(** {1 Output} *)
+
+type format = [ `Auto | `Pager | `Plain | `Groff ]
+val print :
+ ?errs:Format.formatter -> ?subst:(string -> string option) -> format ->
+ Format.formatter -> t -> unit
+
+(** {1 Printers and escapes used by Cmdliner module} *)
+
+val subst_vars :
+ errs:Format.formatter -> subst:(string -> string option) -> Buffer.t ->
+ string -> string
+(** [subst b ~subst s], using [b], substitutes in [s] variables of the form
+ "$(doc)" by their [subst] definition. This leaves escapes and markup
+ directives $(markup,...) intact.
+
+ @raise Invalid_argument in case of illegal syntax. *)
+
+val doc_to_plain :
+ errs:Format.formatter -> subst:(string -> string option) -> Buffer.t ->
+ string -> string
+(** [doc_to_plain b ~subst s] using [b], subsitutes in [s] variables by
+ their [subst] definition and renders cmdliner directives to plain
+ text.
+
+ @raise Invalid_argument in case of illegal syntax. *)
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,116 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+let strf = Printf.sprintf
+let quote = Cmdliner_base.quote
+
+let pp = Format.fprintf
+let pp_text = Cmdliner_base.pp_text
+let pp_lines = Cmdliner_base.pp_lines
+
+(* Environment variable errors *)
+
+let err_env_parse env ~err =
+ let var = Cmdliner_info.env_var env in
+ strf "environment variable %s: %s" (quote var) err
+
+(* Positional argument errors *)
+
+let err_pos_excess excess =
+ strf "too many arguments, don't know what to do with %s"
+ (String.concat ", " (List.map quote excess))
+
+let err_pos_miss a = match Cmdliner_info.arg_docv a with
+| "" -> "a required argument is missing"
+| v -> strf "required argument %s is missing" v
+
+let err_pos_misses = function
+| [] -> assert false
+| [a] -> err_pos_miss a
+| args ->
+ let add_arg acc a = match Cmdliner_info.arg_docv a with
+ | "" -> "ARG" :: acc
+ | argv -> argv :: acc
+ in
+ let rev_args = List.sort Cmdliner_info.rev_arg_pos_cli_order args in
+ let args = List.fold_left add_arg [] rev_args in
+ let args = String.concat ", " args in
+ strf "required arguments %s are missing" args
+
+let err_pos_parse a ~err = match Cmdliner_info.arg_docv a with
+| "" -> err
+| argv ->
+ match Cmdliner_info.(pos_len @@ arg_pos a) with
+ | Some 1 -> strf "%s argument: %s" argv err
+ | None | Some _ -> strf "%s... arguments: %s" argv err
+
+(* Optional argument errors *)
+
+let err_flag_value flag v =
+ strf "option %s is a flag, it cannot take the argument %s"
+ (quote flag) (quote v)
+
+let err_opt_value_missing f = strf "option %s needs an argument" (quote f)
+let err_opt_parse f ~err = strf "option %s: %s" (quote f) err
+let err_opt_repeated f f' =
+ if f = f' then strf "option %s cannot be repeated" (quote f) else
+ strf "options %s and %s cannot be present at the same time"
+ (quote f) (quote f')
+
+(* Argument errors *)
+
+let err_arg_missing a =
+ if Cmdliner_info.arg_is_pos a then err_pos_miss a else
+ strf "required option %s is missing" (Cmdliner_info.arg_opt_name_sample a)
+
+(* Other messages *)
+
+let exec_name ei = Cmdliner_info.(term_name @@ eval_main ei)
+
+let pp_version ppf ei = match Cmdliner_info.(term_version @@ eval_main ei) with
+| None -> assert false
+| Some v -> pp ppf "@[%a@]@." Cmdliner_base.pp_text v
+
+let pp_try_help ppf ei = match Cmdliner_info.eval_kind ei with
+| `Simple | `Multiple_main ->
+ pp ppf "@[<2>Try `%s --help' for more information.@]" (exec_name ei)
+| `Multiple_sub ->
+ let exec_cmd = Cmdliner_docgen.plain_invocation ei in
+ pp ppf "@[<2>Try `%s --help' or `%s --help' for more information.@]"
+ exec_cmd (exec_name ei)
+
+let pp_err ppf ei ~err = pp ppf "%s: @[%a@]@." (exec_name ei) pp_lines err
+
+let pp_err_usage ppf ei ~err_lines ~err =
+ let pp_err = if err_lines then pp_lines else pp_text in
+ pp ppf "@[<v>%s: @[%a@]@,@[Usage: @[%a@]@]@,%a@]@."
+ (exec_name ei) pp_err err (Cmdliner_docgen.pp_plain_synopsis ~errs:ppf) ei
+ pp_try_help ei
+
+let pp_backtrace ppf ei e bt =
+ let bt = Printexc.raw_backtrace_to_string bt in
+ let bt =
+ let len = String.length bt in
+ if len > 0 then String.sub bt 0 (len - 1) (* remove final '\n' *) else bt
+ in
+ pp ppf "%s: @[internal error, uncaught exception:@\n%a@]@."
+ (exec_name ei) pp_lines (strf "%s\n%s" (Printexc.to_string e) bt)
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,56 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+(** Messages for the end-user. *)
+
+(** {1:env_err Environment variable errors} *)
+
+val err_env_parse : Cmdliner_info.env -> err:string -> string
+
+(** {1:pos_err Positional argument errors} *)
+
+val err_pos_excess : string list -> string
+val err_pos_misses : Cmdliner_info.arg list -> string
+val err_pos_parse : Cmdliner_info.arg -> err:string -> string
+
+(** {1:opt_err Optional argument errors} *)
+
+val err_flag_value : string -> string -> string
+val err_opt_value_missing : string -> string
+val err_opt_parse : string -> err:string -> string
+val err_opt_repeated : string -> string -> string
+
+(** {1:arg_err Argument errors} *)
+
+val err_arg_missing : Cmdliner_info.arg -> string
+
+(** {1:msgs Other messages} *)
+
+val pp_version : Format.formatter -> Cmdliner_info.eval -> unit
+val pp_try_help : Format.formatter -> Cmdliner_info.eval -> unit
+val pp_err : Format.formatter -> Cmdliner_info.eval -> err:string -> unit
+val pp_err_usage :
+ Format.formatter -> Cmdliner_info.eval -> err_lines:bool -> err:string -> unit
+
+val pp_backtrace :
+ Format.formatter ->
+ Cmdliner_info.eval -> exn -> Printexc.raw_backtrace -> unit
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,54 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+let levenshtein_distance s t =
+ (* As found here http://rosettacode.org/wiki/Levenshtein_distance#OCaml *)
+ let minimum a b c = min a (min b c) in
+ let m = String.length s in
+ let n = String.length t in
+ (* for all i and j, d.(i).(j) will hold the Levenshtein distance between
+ the first i characters of s and the first j characters of t *)
+ let d = Array.make_matrix (m+1) (n+1) 0 in
+ for i = 0 to m do d.(i).(0) <- i done;
+ for j = 0 to n do d.(0).(j) <- j done;
+ for j = 1 to n do
+ for i = 1 to m do
+ if s.[i-1] = t.[j-1] then
+ d.(i).(j) <- d.(i-1).(j-1) (* no operation required *)
+ else
+ d.(i).(j) <- minimum
+ (d.(i-1).(j) + 1) (* a deletion *)
+ (d.(i).(j-1) + 1) (* an insertion *)
+ (d.(i-1).(j-1) + 1) (* a substitution *)
+ done;
+ done;
+ d.(m).(n)
+
+let value s candidates =
+ let add (min, acc) name =
+ let d = levenshtein_distance s name in
+ if d = min then min, (name :: acc) else
+ if d < min then d, [name] else
+ min, acc
+ in
+ let dist, suggs = List.fold_left add (max_int, []) candidates in
+ if dist < 3 (* suggest only if not too far *) then suggs else []
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,25 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+val value : string -> string list -> string list
+(** [value near candidates] suggests values from [candidates]
+ not to far from near. *)
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,41 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+type term_escape =
+ [ `Error of bool * string
+ | `Help of Cmdliner_manpage.format * string option ]
+
+type 'a parser =
+ Cmdliner_info.eval -> Cmdliner_cline.t ->
+ ('a, [ `Parse of string | term_escape ]) result
+
+type 'a t = Cmdliner_info.args * 'a parser
+
+let const v = Cmdliner_info.Args.empty, (fun _ _ -> Ok v)
+let app (args_f, f) (args_v, v) =
+ Cmdliner_info.Args.union args_f args_v,
+ fun ei cl -> match (f ei cl) with
+ | Error _ as e -> e
+ | Ok f ->
+ match v ei cl with
+ | Error _ as e -> e
+ | Ok v -> Ok (f v)
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,40 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+(** Terms *)
+
+type term_escape =
+ [ `Error of bool * string
+ | `Help of Cmdliner_manpage.format * string option ]
+
+type 'a parser =
+ Cmdliner_info.eval -> Cmdliner_cline.t ->
+ ('a, [ `Parse of string | term_escape ]) result
+(** Type type for command line parser. given static information about
+ the command line and a command line to parse returns an OCaml value. *)
+
+type 'a t = Cmdliner_info.args * 'a parser
+(** The type for terms. The list of arguments it can parse and the parsing
+ function that does so. *)
+
+val const : 'a -> 'a t
+val app : ('a -> 'b) t -> 'a t -> 'b t
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,97 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+module Cmap = Map.Make (Char) (* character maps. *)
+
+type 'a value = (* type for holding a bound value. *)
+| Pre of 'a (* value is bound by the prefix of a key. *)
+| Key of 'a (* value is bound by an entire key. *)
+| Amb (* no value bound because of ambiguous prefix. *)
+| Nil (* not bound (only for the empty trie). *)
+
+type 'a t = { v : 'a value; succs : 'a t Cmap.t }
+let empty = { v = Nil; succs = Cmap.empty }
+let is_empty t = t = empty
+
+(* N.B. If we replace a non-ambiguous key, it becomes ambiguous but it's
+ not important for our use. Also the following is not tail recursive but
+ the stack is bounded by key length. *)
+let add t k d =
+ let rec loop t k len i d pre_d = match i = len with
+ | true ->
+ let t' = { v = Key d; succs = t.succs } in
+ begin match t.v with
+ | Key old -> `Replaced (old, t')
+ | _ -> `New t'
+ end
+ | false ->
+ let v = match t.v with
+ | Amb | Pre _ -> Amb | Key _ as v -> v | Nil -> pre_d
+ in
+ let t' = try Cmap.find k.[i] t.succs with Not_found -> empty in
+ match loop t' k len (i + 1) d pre_d with
+ | `New n -> `New { v; succs = Cmap.add k.[i] n t.succs }
+ | `Replaced (o, n) ->
+ `Replaced (o, { v; succs = Cmap.add k.[i] n t.succs })
+ in
+ loop t k (String.length k) 0 d (Pre d (* allocate less *))
+
+let find_node t k =
+ let rec aux t k len i =
+ if i = len then t else
+ aux (Cmap.find k.[i] t.succs) k len (i + 1)
+ in
+ aux t k (String.length k) 0
+
+let find t k =
+ try match (find_node t k).v with
+ | Key v | Pre v -> `Ok v | Amb -> `Ambiguous | Nil -> `Not_found
+ with Not_found -> `Not_found
+
+let ambiguities t p = (* ambiguities of [p] in [t]. *)
+ try
+ let t = find_node t p in
+ match t.v with
+ | Key _ | Pre _ | Nil -> []
+ | Amb ->
+ let add_char s c = s ^ (String.make 1 c) in
+ let rem_char s = String.sub s 0 ((String.length s) - 1) in
+ let to_list m = Cmap.fold (fun k t acc -> (k,t) :: acc) m [] in
+ let rec aux acc p = function
+ | ((c, t) :: succs) :: rest ->
+ let p' = add_char p c in
+ let acc' = match t.v with
+ | Pre _ | Amb -> acc
+ | Key _ -> (p' :: acc)
+ | Nil -> assert false
+ in
+ aux acc' p' ((to_list t.succs) :: succs :: rest)
+ | [] :: [] -> acc
+ | [] :: rest -> aux acc (rem_char p) rest
+ | [] -> assert false
+ in
+ aux [] p (to_list t.succs :: [])
+ with Not_found -> []
+
+let of_list l =
+ let add t (s, v) = match add t s v with `New t -> t | `Replaced (_, t) -> t in
+ List.fold_left add empty l
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,35 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+(** Tries.
+
+ This implementation also maps any non ambiguous prefix of a
+ key to its value. *)
+
+type 'a t
+
+val empty : 'a t
+val is_empty : 'a t -> bool
+val add : 'a t -> string -> 'a -> [ `New of 'a t | `Replaced of 'a * 'a t ]
+val find : 'a t -> string -> [ `Ok of 'a | `Ambiguous | `Not_found ]
+val ambiguities : 'a t -> string -> string list
+val of_list : (string * 'a) list -> 'a t
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2011 Daniel C. Bünzli
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,4 @@
+(library
+ (public_name cmdliner)
+ (flags :standard -w -3-6-27-32-35)
+ (wrapped false))
new file mode 100644
@@ -0,0 +1,31 @@
+(* Example from the documentation, this code is in public domain. *)
+
+(* Implementation of the command *)
+
+let chorus count msg = for i = 1 to count do print_endline msg done
+
+(* Command line interface *)
+
+open Cmdliner
+
+let count =
+ let doc = "Repeat the message $(docv) times." in
+ Arg.(value & opt int 10 & info ["c"; "count"] ~docv:"COUNT" ~doc)
+
+let msg =
+ let doc = "Overrides the default message to print." in
+ let env = Arg.env_var "CHORUS_MSG" ~doc in
+ let doc = "The message to print." in
+ Arg.(value & pos 0 string "Revolt!" & info [] ~env ~docv:"MSG" ~doc)
+
+let chorus_t = Term.(const chorus $ count $ msg)
+
+let info =
+ let doc = "print a customizable message repeatedly" in
+ let man = [
+ `S Manpage.s_bugs;
+ `P "Email bug reports to <hehey at example.org>." ]
+ in
+ Term.info "chorus" ~version:"%%VERSION%%" ~doc ~exits:Term.default_exits ~man
+
+let () = Term.exit @@ Term.eval (chorus_t, info)
new file mode 100644
@@ -0,0 +1,54 @@
+(* Example from the documentation, this code is in public domain. *)
+
+(* Implementation, we check the dest argument and print the args *)
+
+let cp verbose recurse force srcs dest =
+ if List.length srcs > 1 &&
+ (not (Sys.file_exists dest) || not (Sys.is_directory dest))
+ then
+ `Error (false, dest ^ " is not a directory")
+ else
+ `Ok (Printf.printf
+ "verbose = %B\nrecurse = %B\nforce = %B\nsrcs = %s\ndest = %s\n"
+ verbose recurse force (String.concat ", " srcs) dest)
+
+(* Command line interface *)
+
+open Cmdliner
+
+let verbose =
+ let doc = "Print file names as they are copied." in
+ Arg.(value & flag & info ["v"; "verbose"] ~doc)
+
+let recurse =
+ let doc = "Copy directories recursively." in
+ Arg.(value & flag & info ["r"; "R"; "recursive"] ~doc)
+
+let force =
+ let doc = "If a destination file cannot be opened, remove it and try again."in
+ Arg.(value & flag & info ["f"; "force"] ~doc)
+
+let srcs =
+ let doc = "Source file(s) to copy." in
+ Arg.(non_empty & pos_left ~rev:true 0 file [] & info [] ~docv:"SOURCE" ~doc)
+
+let dest =
+ let doc = "Destination of the copy. Must be a directory if there is more
+ than one $(i,SOURCE)." in
+ let docv = "DEST" in
+ Arg.(required & pos ~rev:true 0 (some string) None & info [] ~docv ~doc)
+
+let cmd =
+ let doc = "copy files" in
+ let man_xrefs =
+ [ `Tool "mv"; `Tool "scp"; `Page ("umask", 2); `Page ("symlink", 7) ]
+ in
+ let exits = Term.default_exits in
+ let man =
+ [ `S Manpage.s_bugs;
+ `P "Email them to <hehey at example.org>."; ]
+ in
+ Term.(ret (const cp $ verbose $ recurse $ force $ srcs $ dest)),
+ Term.info "cp" ~version:"%%VERSION%%" ~doc ~exits ~man ~man_xrefs
+
+let () = Term.(exit @@ eval cmd)
new file mode 100644
@@ -0,0 +1,149 @@
+(* Example from the documentation, this code is in public domain. *)
+
+(* Implementations, just print the args. *)
+
+type verb = Normal | Quiet | Verbose
+type copts = { debug : bool; verb : verb; prehook : string option }
+
+let str = Printf.sprintf
+let opt_str sv = function None -> "None" | Some v -> str "Some(%s)" (sv v)
+let opt_str_str = opt_str (fun s -> s)
+let verb_str = function
+ | Normal -> "normal" | Quiet -> "quiet" | Verbose -> "verbose"
+
+let pr_copts oc copts = Printf.fprintf oc
+ "debug = %B\nverbosity = %s\nprehook = %s\n"
+ copts.debug (verb_str copts.verb) (opt_str_str copts.prehook)
+
+let initialize copts repodir = Printf.printf
+ "%arepodir = %s\n" pr_copts copts repodir
+
+let record copts name email all ask_deps files = Printf.printf
+ "%aname = %s\nemail = %s\nall = %B\nask-deps = %B\nfiles = %s\n"
+ pr_copts copts (opt_str_str name) (opt_str_str email) all ask_deps
+ (String.concat ", " files)
+
+let help copts man_format cmds topic = match topic with
+| None -> `Help (`Pager, None) (* help about the program. *)
+| Some topic ->
+ let topics = "topics" :: "patterns" :: "environment" :: cmds in
+ let conv, _ = Cmdliner.Arg.enum (List.rev_map (fun s -> (s, s)) topics) in
+ match conv topic with
+ | `Error e -> `Error (false, e)
+ | `Ok t when t = "topics" -> List.iter print_endline topics; `Ok ()
+ | `Ok t when List.mem t cmds -> `Help (man_format, Some t)
+ | `Ok t ->
+ let page = (topic, 7, "", "", ""), [`S topic; `P "Say something";] in
+ `Ok (Cmdliner.Manpage.print man_format Format.std_formatter page)
+
+open Cmdliner
+
+(* Help sections common to all commands *)
+
+let help_secs = [
+ `S Manpage.s_common_options;
+ `P "These options are common to all commands.";
+ `S "MORE HELP";
+ `P "Use `$(mname) $(i,COMMAND) --help' for help on a single command.";`Noblank;
+ `P "Use `$(mname) help patterns' for help on patch matching."; `Noblank;
+ `P "Use `$(mname) help environment' for help on environment variables.";
+ `S Manpage.s_bugs; `P "Check bug reports at http://bugs.example.org.";]
+
+(* Options common to all commands *)
+
+let copts debug verb prehook = { debug; verb; prehook }
+let copts_t =
+ let docs = Manpage.s_common_options in
+ let debug =
+ let doc = "Give only debug output." in
+ Arg.(value & flag & info ["debug"] ~docs ~doc)
+ in
+ let verb =
+ let doc = "Suppress informational output." in
+ let quiet = Quiet, Arg.info ["q"; "quiet"] ~docs ~doc in
+ let doc = "Give verbose output." in
+ let verbose = Verbose, Arg.info ["v"; "verbose"] ~docs ~doc in
+ Arg.(last & vflag_all [Normal] [quiet; verbose])
+ in
+ let prehook =
+ let doc = "Specify command to run before this $(mname) command." in
+ Arg.(value & opt (some string) None & info ["prehook"] ~docs ~doc)
+ in
+ Term.(const copts $ debug $ verb $ prehook)
+
+(* Commands *)
+
+let initialize_cmd =
+ let repodir =
+ let doc = "Run the program in repository directory $(docv)." in
+ Arg.(value & opt file Filename.current_dir_name & info ["repodir"]
+ ~docv:"DIR" ~doc)
+ in
+ let doc = "make the current directory a repository" in
+ let exits = Term.default_exits in
+ let man = [
+ `S Manpage.s_description;
+ `P "Turns the current directory into a Darcs repository. Any
+ existing files and subdirectories become ...";
+ `Blocks help_secs; ]
+ in
+ Term.(const initialize $ copts_t $ repodir),
+ Term.info "initialize" ~doc ~sdocs:Manpage.s_common_options ~exits ~man
+
+let record_cmd =
+ let pname =
+ let doc = "Name of the patch." in
+ Arg.(value & opt (some string) None & info ["m"; "patch-name"] ~docv:"NAME"
+ ~doc)
+ in
+ let author =
+ let doc = "Specifies the author's identity." in
+ Arg.(value & opt (some string) None & info ["A"; "author"] ~docv:"EMAIL"
+ ~doc)
+ in
+ let all =
+ let doc = "Answer yes to all patches." in
+ Arg.(value & flag & info ["a"; "all"] ~doc)
+ in
+ let ask_deps =
+ let doc = "Ask for extra dependencies." in
+ Arg.(value & flag & info ["ask-deps"] ~doc)
+ in
+ let files = Arg.(value & (pos_all file) [] & info [] ~docv:"FILE or DIR") in
+ let doc = "create a patch from unrecorded changes" in
+ let exits = Term.default_exits in
+ let man =
+ [`S Manpage.s_description;
+ `P "Creates a patch from changes in the working tree. If you specify
+ a set of files ...";
+ `Blocks help_secs; ]
+ in
+ Term.(const record $ copts_t $ pname $ author $ all $ ask_deps $ files),
+ Term.info "record" ~doc ~sdocs:Manpage.s_common_options ~exits ~man
+
+let help_cmd =
+ let topic =
+ let doc = "The topic to get help on. `topics' lists the topics." in
+ Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc)
+ in
+ let doc = "display help about darcs and darcs commands" in
+ let exits = Term.default_exits in
+ let man =
+ [`S Manpage.s_description;
+ `P "Prints help about darcs commands and other subjects...";
+ `Blocks help_secs; ]
+ in
+ Term.(ret (const help $ copts_t $ Arg.man_format $ Term.choice_names $topic)),
+ Term.info "help" ~doc ~exits ~man
+
+let default_cmd =
+ let doc = "a revision control system" in
+ let sdocs = Manpage.s_common_options in
+ let exits = Term.default_exits in
+ let man = help_secs in
+ Term.(ret (const (fun _ -> `Help (`Pager, None)) $ copts_t)),
+ Term.info "darcs" ~version:"%%VERSION%%" ~doc ~sdocs ~exits ~man
+
+let cmds = [initialize_cmd; record_cmd; help_cmd]
+
+let () = Term.(exit @@ eval_choice default_cmd cmds)
new file mode 100644
@@ -0,0 +1,12 @@
+(executables
+ (names test_man
+ test_man_utf8
+ test_pos
+ test_pos_rev
+ test_pos_all
+ test_pos_left
+ test_pos_req
+ test_opt_req
+ test_term_dups
+ test_with_used_args)
+ (libraries cmdliner))
new file mode 100644
@@ -0,0 +1,9 @@
+(* Example from the documentation, this code is in public domain. *)
+
+let revolt () = print_endline "Revolt!"
+
+open Cmdliner
+
+let revolt_t = Term.(const revolt $ const ())
+
+let () = Term.(exit @@ eval (revolt_t, Term.info "revolt"))
new file mode 100644
@@ -0,0 +1,53 @@
+(* Example from the documentation, this code is in public domain. *)
+
+(* Implementation of the command, we just print the args. *)
+
+type prompt = Always | Once | Never
+let prompt_str = function
+| Always -> "always" | Once -> "once" | Never -> "never"
+
+let rm prompt recurse files =
+ Printf.printf "prompt = %s\nrecurse = %B\nfiles = %s\n"
+ (prompt_str prompt) recurse (String.concat ", " files)
+
+(* Command line interface *)
+
+open Cmdliner
+
+let files = Arg.(non_empty & pos_all file [] & info [] ~docv:"FILE")
+let prompt =
+ let doc = "Prompt before every removal." in
+ let always = Always, Arg.info ["i"] ~doc in
+ let doc = "Ignore nonexistent files and never prompt." in
+ let never = Never, Arg.info ["f"; "force"] ~doc in
+ let doc = "Prompt once before removing more than three files, or when
+ removing recursively. Less intrusive than $(b,-i), while
+ still giving protection against most mistakes."
+ in
+ let once = Once, Arg.info ["I"] ~doc in
+ Arg.(last & vflag_all [Always] [always; never; once])
+
+let recursive =
+ let doc = "Remove directories and their contents recursively." in
+ Arg.(value & flag & info ["r"; "R"; "recursive"] ~doc)
+
+let cmd =
+ let doc = "remove files or directories" in
+ let man = [
+ `S Manpage.s_description;
+ `P "$(tname) removes each specified $(i,FILE). By default it does not
+ remove directories, to also remove them and their contents, use the
+ option $(b,--recursive) ($(b,-r) or $(b,-R)).";
+ `P "To remove a file whose name starts with a `-', for example
+ `-foo', use one of these commands:";
+ `Pre "$(mname) -- -foo\n\
+ $(mname) ./-foo";
+ `P "$(tname) removes symbolic links, not the files referenced by the
+ links.";
+ `S Manpage.s_bugs; `P "Report bugs to <hehey at example.org>.";
+ `S Manpage.s_see_also; `P "$(b,rmdir)(1), $(b,unlink)(2)" ]
+ in
+ Term.(const rm $ prompt $ recursive $ files),
+ Term.info "rm" ~version:"%%VERSION%%" ~doc ~exits:Term.default_exits ~man
+
+let () = Term.(exit @@ eval cmd)
new file mode 100644
@@ -0,0 +1,73 @@
+(* Example from the documentation, this code is in public domain. *)
+
+(* Implementation of the command, we just print the args. *)
+
+type loc = bool * int
+type verb = Verbose | Quiet
+type follow = Name | Descriptor
+
+let str = Printf.sprintf
+let opt_str sv = function None -> "None" | Some v -> str "Some(%s)" (sv v)
+let loc_str (rev, k) = if rev then str "%d" k else str "+%d" k
+let follow_str = function Name -> "name" | Descriptor -> "descriptor"
+let verb_str = function Verbose -> "verbose" | Quiet -> "quiet"
+
+let tail lines follow verb pid files =
+ Printf.printf "lines = %s\nfollow = %s\nverb = %s\npid = %s\nfiles = %s\n"
+ (loc_str lines) (opt_str follow_str follow) (verb_str verb)
+ (opt_str string_of_int pid) (String.concat ", " files)
+
+(* Command line interface *)
+
+open Cmdliner
+
+let lines =
+ let loc =
+ let parse s =
+ try
+ if s <> "" && s.[0] <> '+' then Ok (true, int_of_string s) else
+ Ok (false, int_of_string (String.sub s 1 (String.length s - 1)))
+ with Failure _ -> Error (`Msg "unable to parse integer")
+ in
+ let print ppf p = Format.fprintf ppf "%s" (loc_str p) in
+ Arg.conv ~docv:"N" (parse, print)
+ in
+ Arg.(value & opt loc (true, 10) & info ["n"; "lines"] ~docv:"N"
+ ~doc:"Output the last $(docv) lines or use $(i,+)$(docv) to start
+ output after the $(i,N)-1th line.")
+let follow =
+ let doc = "Output appended data as the file grows. $(docv) specifies how the
+ file should be tracked, by its `name' or by its `descriptor'." in
+ let follow = Arg.enum ["name", Name; "descriptor", Descriptor] in
+ Arg.(value & opt (some follow) ~vopt:(Some Descriptor) None &
+ info ["f"; "follow"] ~docv:"ID" ~doc)
+
+let verb =
+ let doc = "Never output headers giving file names." in
+ let quiet = Quiet, Arg.info ["q"; "quiet"; "silent"] ~doc in
+ let doc = "Always output headers giving file names." in
+ let verbose = Verbose, Arg.info ["v"; "verbose"] ~doc in
+ Arg.(last & vflag_all [Quiet] [quiet; verbose])
+
+let pid =
+ let doc = "With -f, terminate after process $(docv) dies." in
+ Arg.(value & opt (some int) None & info ["pid"] ~docv:"PID" ~doc)
+
+let files = Arg.(value & (pos_all non_dir_file []) & info [] ~docv:"FILE")
+
+let cmd =
+ let doc = "display the last part of a file" in
+ let man = [
+ `S Manpage.s_description;
+ `P "$(tname) prints the last lines of each $(i,FILE) to standard output. If
+ no file is specified reads standard input. The number of printed
+ lines can be specified with the $(b,-n) option.";
+ `S Manpage.s_bugs;
+ `P "Report them to <hehey at example.org>.";
+ `S Manpage.s_see_also;
+ `P "$(b,cat)(1), $(b,head)(1)" ]
+ in
+ Term.(const tail $ lines $ follow $ verb $ pid $ files),
+ Term.info "tail" ~version:"%%VERSION%%" ~doc ~exits:Term.default_exits ~man
+
+let () = Term.(exit @@ eval cmd)
new file mode 100644
@@ -0,0 +1,100 @@
+
+open Cmdliner
+
+let hey =
+ let doc = "Equivalent to set $(opt)." in
+ let env = Arg.env_var "TEST_ENV" ~doc in
+ let doc = "Set hey." in
+ Arg.(value & flag & info ["hey"; "y"] ~env ~doc)
+
+let repodir =
+ let doc = "See option $(opt)." in
+ let env = Arg.env_var "TEST_REPODDIR" ~doc in
+ let doc = "Run the program in repository directory $(docv)." in
+ Arg.(value & opt file Filename.current_dir_name & info ["repodir"] ~env
+ ~docv:"DIR" ~doc)
+
+let id =
+ let doc = "See option $(opt)." in
+ let env = Arg.env_var "TEST_ID" ~doc in
+ let doc = "Whatever $(docv) bla $(env) and $(opt)." in
+ Arg.(value & opt int ~vopt:10 0 & info ["id"; "i"] ~env ~docv:"ID)" ~doc)
+
+let miaouw =
+ let doc = "See option $(opt). These are term names $(mname) $(tname)" in
+ let docs = "MIAOUW SECTION (non-standard unpositioned do not do this)" in
+ let env = Arg.env_var "TEST_MIAOUW" ~doc ~docs in
+ let doc = "Whatever this is the doc var $(docv) this is the env var $(env) \
+ this is the opt $(opt) and this is $(i,italic) and this is
+ $(b,bold) and this $(b,\\$(opt\\)) is \\$(opt) in bold and this
+ \\$ is a dollar. $(mname) is the main term name, $(tname) is the
+ term name."
+ in
+ Arg.(value & opt string "miaouw" & info ["m";] ~env ~docv:"MIAOUW" ~doc)
+
+let test hey repodir id miaouw =
+ Format.printf "hey: %B@.repodir: %s@.id: %d@.miaouw: %s@."
+ hey repodir id miaouw
+
+let man_test_t = Term.(const test $ hey $ repodir $ id $ miaouw)
+
+let info =
+ let doc = "print a customizable message repeatedly" in
+ let envs = [ Term.env_info "TEST_IT" ~doc:"This is $(env) for $(tname)" ] in
+ let exits = [ Term.exit_info ~doc:"This is a $(status) for $(tname)" 1;
+ Term.exit_info ~doc:"Ranges from $(status) to $(status_max)"
+ ~max:10 2; ] @ Term.default_exits
+ in
+ let man = [
+ `S "THIS IS A SECTION FOR $(mname)";
+ `P "$(mname) subst at begin and end $(mname)";
+ `P "$(i,italic) and $(b,bold)";
+ `P "\\$ escaped \\$\\$ escaped \\$";
+ `P "This does not fail \\$(a)";
+ `P ". this is a paragraph starting with a dot.";
+ `P "' this is a paragraph starting with a quote.";
+ `P "This: \\\\(rs is a backslash for groff and you should not see a \\\\";
+ `P "This: \\\\N'46' is a quote for groff and you should not see a '";
+ `P "This: \\\\\" is a groff comment and it should not be one.";
+ `P "This is a non preformatted paragraph, filling will occur. This will
+ be properly layout on 80 columns.";
+ `Pre "This is a preformatted paragraph for $(mname) no filling will \
+ occur do the $(i,ASCII) art $(b,here) this will overflow on 80 \
+ columns \n\
+ 01234556789\
+ 01234556789\
+ 01234556789\
+ 01234556789\
+ 01234556789\
+ 01234556789\
+ 01234556789\
+ 01234556789\n\n\
+ ... Should not break\n\
+ a... Should not break\n\
+ +---+\n\
+ | /|\n\
+ | / | ----> Let's swim to the moon.\n\
+ |/ |\n\
+ +---+";
+ `P "These are escapes escaped \\$ \\( \\) \\\\";
+ `P "() does not need to be escaped outside directives.";
+ `Blocks [
+ `P "The following to paragraphs are spliced in.";
+ `P "This dollar needs escape \\$(var) this one aswell $(b,\\$(bla\\))";
+ `P "This is another paragraph \\$(bla) $(i,\\$(bla\\)) $(b,\\$\\(bla\\))";
+ ];
+ `Noblank;
+ `Pre "This is another preformatted paragraph.\n\
+ There should be no blanks before and after it.";
+ `Noblank;
+ `P "Hey ho";
+ `I ("label", "item label");
+ `I ("lebal", "item lebal");
+ `P "The last paragraph";
+ `S Manpage.s_bugs;
+ `P "Email bug reports to <hehey at example.org>.";]
+ in
+ let man_xrefs = [`Page ("ascii", 7); `Main; `Tool "grep";] in
+ Term.info "man_test" ~version:"%%VERSION%%" ~doc ~envs ~exits ~man ~man_xrefs
+
+let () = Term.exit @@ Term.eval (man_test_t, info)
new file mode 100644
@@ -0,0 +1,11 @@
+open Cmdliner
+
+let nop () = print_endline "It's the manual that is of interest."
+
+
+let test_pos =
+ Term.(const nop $ const ()),
+ Term.info "test_pos"
+ ~doc:"UTF-8 test: íöüóőúűéáăîâșț ÍÜÓŐÚŰÉÁĂÎÂȘȚ 雙峰駱駝"
+
+let () = Term.(exit @@ eval test_pos)
new file mode 100644
@@ -0,0 +1,13 @@
+open Cmdliner
+
+let opt o = print_endline o
+
+let test_opt =
+ let req =
+ Arg.(required & opt (some string) None & info ["r"; "req"] ~docv:"ARG")
+ in
+ Term.(const opt $ req),
+ Term.info "test_opt_req"
+ ~doc:"Test optional required arguments (don't do this)"
+
+let () = Term.(exit @@ eval test_opt)
new file mode 100644
@@ -0,0 +1,13 @@
+open Cmdliner
+
+let pos l t r =
+ print_endline (String.concat "\n" (l @ ["--"; t; "--"] @ r))
+
+let test_pos =
+ let l = Arg.(value & pos_left 2 string [] & info [] ~docv:"LEFT") in
+ let t = Arg.(value & pos 2 string "undefined" & info [] ~docv:"TWO") in
+ let r = Arg.(value & pos_right 2 string [] & info [] ~docv:"RIGHT") in
+ Term.(const pos $ l $ t $ r),
+ Term.info "test_pos" ~doc:"Test pos arguments"
+
+let () = Term.(exit @@ eval test_pos)
new file mode 100644
@@ -0,0 +1,11 @@
+open Cmdliner
+
+let pos_all all = print_endline (String.concat "\n" all)
+
+let test_pos_all =
+ let docv = "THEARG" in
+ let all = Arg.(value & pos_all string [] & info [] ~docv) in
+ Term.(const pos_all $ all),
+ Term.info "test_pos_all" ~doc:"Test pos all"
+
+let () = Term.(exit @@ eval test_pos_all)
new file mode 100644
@@ -0,0 +1,11 @@
+open Cmdliner
+
+let pos l =
+ print_endline (String.concat "\n" l)
+
+let test_pos_left =
+ let l = Arg.(value & pos_left 2 string [] & info [] ~docv:"LEFT") in
+ Term.(const pos $ l),
+ Term.info "test_pos" ~doc:"Test pos left"
+
+let () = Term.(exit @@ eval test_pos_left)
new file mode 100644
@@ -0,0 +1,15 @@
+open Cmdliner
+
+let pos r a1 a0 a2 =
+ print_endline (String.concat "\n" ([a0; a1; a2; "--"] @ r))
+
+let test_pos =
+ let req p =
+ let docv = Printf.sprintf "ARG%d" p in
+ Arg.(required & pos p (some string) None & info [] ~docv)
+ in
+ let right = Arg.(non_empty & pos_right 2 string [] & info [] ~docv:"RIGHT") in
+ Term.(const pos $ right $ req 1 $ req 0 $ req 2),
+ Term.info "test_pos_req" ~doc:"Test pos req arguments"
+
+let () = Term.(exit @@ eval test_pos)
new file mode 100644
@@ -0,0 +1,14 @@
+open Cmdliner
+
+let pos l t r =
+ print_endline (String.concat "\n" (l @ ["--"; t; "--"] @ r))
+
+let test_pos =
+ let rev = true in
+ let l = Arg.(value & pos_left ~rev 2 string [] & info [] ~docv:"LEFT") in
+ let t = Arg.(value & pos ~rev 2 string "undefined" & info [] ~docv:"TWO") in
+ let r = Arg.(value & pos_right ~rev 2 string [] & info [] ~docv:"RIGHT") in
+ Term.(const pos $ l $ t $ r),
+ Term.info "test_pos" ~doc:"Test pos rev arguments"
+
+let () = Term.(exit @@ eval test_pos)
new file mode 100644
@@ -0,0 +1,19 @@
+open Cmdliner
+
+let dups p p_dup o o_dup =
+ let b = string_of_bool in
+ print_endline (String.concat "\n" [p; p_dup; b o; b o_dup;])
+
+let test_pos =
+ let p =
+ let doc = "First pos argument should show up only once in the docs" in
+ Arg.(value & pos 0 string "undefined" & info [] ~doc ~docv:"POS")
+ in
+ let o =
+ let doc = "This should show up only once in the docs" in
+ Arg.(value & flag & info ["f"; "flag"] ~doc)
+ in
+ Term.(const dups $ p $ p $ o $ o),
+ Term.info "test_term_dups" ~doc:"Test multiple term usage"
+
+let () = Term.(exit @@ eval test_pos)
new file mode 100644
@@ -0,0 +1,18 @@
+open Cmdliner
+
+let print_args ((), args) _other =
+ print_endline (String.concat " " args)
+
+let test_pos_left =
+ let a = Arg.(value & flag & info ["a"; "aaa"]) in
+ let b = Arg.(value & opt (some string) None & info ["b"; "bbb"]) in
+ let c = Arg.(value & pos_all string [] & info []) in
+ let main =
+ let ignore_values _a _b _c = () in
+ Term.(with_used_args (const ignore_values $ a $ b $ c))
+ in
+ let other = Arg.(value & flag & info ["other"]) in
+ Term.(const print_args $ main $ other),
+ Term.info "test_capture" ~doc:"Test pos left"
+
+let () = Term.(exit @@ eval test_pos_left)
new file mode 100644
@@ -0,0 +1,5 @@
+*~
+_build
+.merlin
+*.install
+.*.swp
new file mode 100644
@@ -0,0 +1,22 @@
+# See https://github.com/OCamlPro/ocp-indent/blob/master/.ocp-indent for more
+
+# Indent for clauses inside a pattern-match (after the arrow):
+# match foo with
+# | _ ->
+# ^^^^bar
+# the default is 2, which aligns the pattern and the expression
+match_clause = 4
+
+# When nesting expressions on the same line, their indentation are in
+# some cases stacked, so that it remains correct if you close them one
+# at a line. This may lead to large indents in complex code though, so
+# this parameter can be used to set a maximum value. Note that it only
+# affects indentation after function arrows and opening parens at end
+# of line.
+#
+# for example (left: `none`; right: `4`)
+# let f = g (h (i (fun x -> # let f = g (h (i (fun x ->
+# x) # x)
+# ) # )
+# ) # )
+max_indent = 2
new file mode 100644
@@ -0,0 +1,16 @@
+language: c
+sudo: required
+install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh
+script: bash -ex .travis-opam.sh
+env:
+ global:
+ - PACKAGE=cppo
+ matrix:
+ - OCAML_VERSION=4.03
+ - OCAML_VERSION=4.04
+ - OCAML_VERSION=4.05
+ - OCAML_VERSION=4.06
+ - OCAML_VERSION=4.07
+os:
+ - linux
+ - osx
new file mode 100644
@@ -0,0 +1,8 @@
+# We're looking for one or more volunteers to take the lead of cppo,
+# with the help of ocaml-community.
+#
+# Call for volunteers: https://github.com/ocaml-community/meta/issues/27
+# About ocaml-community: https://github.com/ocaml-community/meta
+#
+# Interim maintainers who won't be very responsive :-(
+* @mjambon @pmetzger
new file mode 100644
@@ -0,0 +1,85 @@
+## v1.6.7 (2020-12-21)
+- [compat] Treat ~ and - the same in semver in order to parse
+ OCaml 4.12.0 pre-release versions.
+- [compat] Restore 4.02.3 compatibility.
+
+## v1.6.6 (2019-05-27)
+- [pkg] port build system to dune from jbuilder.
+- [pkg] upgrade opam metadata to 2.0 format.
+- [pkg] remove topkg and use dune-release.
+- [compat] Use `String.capitalize_ascii` to remove warning.
+
+## v1.6.5 (2018-09-12)
+- [bug] Fix 'asr' operator (#61)
+
+## v1.6.4 (2018-02-26)
+- [compat] Tests should now work with older versions of jbuilder.
+
+## v1.6.3 (2018-02-21)
+- [compat] Fix tests.
+
+## v1.6.1 (2018-01-25)
+- [compat] Emit line directives always containing the file name,
+ as mandated starting with ocaml 4.07.
+
+## v1.6.0 (2017-08-07)
+- [pkg] BREAKING: cppo and cppo_ocamlbuild are now two distinct opam
+ packages.
+
+## v1.5.0 (2017-04-24)
+- [+ui] Added the `CAPITALIZE()` function.
+
+## v1.4.0 (2016-08-19)
+- [compat] Cppo is now safe-string ready.
+
+## v1.3.2 (2016-04-20)
+- [pkg] Cppo can now be built on MSVC.
+
+## v1.3.1 (2015-09-20)
+- [bug] Possible to have #endif between two matching parenthesis.
+
+## v1.3.0 (2015-09-13)
+- [+ui] Removed the need for escaping commas and parenthesis in macros.
+- [+ui] Blanks is now allowed in argument list in macro definitions.
+- [+ui] #directive with wrong arguments is now giving a proper error.
+- [bug] Fixed expansion of __FILE__ and __LINE__.
+
+## v1.1.2 (2014-11-10)
+- [+ui] Ocamlbuild_cppo: added the ocamlbuild flag `cppo_V(NAME:VERSION)`,
+ equivalent to `-V NAME:VERSION` (for _tags file).
+
+## v1.1.1 (2014-11-10)
+- [+ui] Ocamlbuild_cppo: added the ocamlbuild flag `cppo_V_OCAML`,
+ equivalent to `-V OCAML:VERSION` (for _tags file).
+
+## v1.1.0 (2014-11-04)
+- [+ui] Added the `-V NAME:VERSION` option.
+- [+ui] Support for tuples in comparisons: tuples can be constructed
+ and compared, e.g. `#if (2 + 2, 5) < (4, 5)`.
+
+## v1.0.1 (2014-10-20)
+- [+ui] `#elif` and `#else` can now be used in the same #if-#else statement.
+- [bug] Fixed the Ocamlbuild flag `cppo_n`.
+
+## v1.0.0 (2014-09-06)
+- [bug] OCaml comments are now better parsed. For example, (* '"' *) works.
+
+## v0.9.4 (2014-06-10)
+- [+ui] Added the ocamlbuild_cppo plugin for Ocamlbuild. To use it:
+ `-plugin(cppo_ocamlbuild)`.
+
+## v0.9.3 (2012-02-03)
+- [pkg] New way of building the tar.gz archive.
+
+## v0.9.2 (2011-08-12)
+- [+ui] Added two predefined macros STRINGIFY and CONCAT for making
+ string literals and for building identifiers respectively.
+
+## v0.9.1 (2011-07-20)
+- [+ui] Added support for processing sections of files using external programs
+ (#ext/#endext, -x option)
+- [doc] Moved and extended documentation into the README file.
+
+## v0.9.0 (2009-11-17)
+
+- initial public release
new file mode 100644
@@ -0,0 +1,17 @@
+Installation instructions for cppo
+==================================
+
+Building cppo requires GNU Make and a standard OCaml
+installation. It can be installed with opam or manually as follows:
+
+Build:
+
+```
+make
+```
+
+Install:
+
+```
+make DESTDIR=/some/path install
+```
new file mode 100644
@@ -0,0 +1,24 @@
+Copyright (c) 2009-2011 Martin Jambon
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+3. The name of the author may not be used to endorse or promote products
+ derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
+IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
new file mode 100644
@@ -0,0 +1,18 @@
+all:
+ @dune build
+
+test:
+ @dune runtest
+
+install:
+ @dune install
+
+uninstall:
+ @dune uninstall
+
+check: test
+
+.PHONY: clean all check test install uninstall
+
+clean:
+ dune clean
new file mode 100644
@@ -0,0 +1,521 @@
+[](https://ci.appveyor.com/project/Chris00/cppo-pnjtx)
+
+Cppo: cpp for OCaml
+===================
+
+Cppo is an equivalent of the C preprocessor for OCaml programs.
+It allows the definition of simple macros and file inclusion.
+
+Cppo is:
+
+* more OCaml-friendly than cpp
+* easy to learn without consulting a manual
+* reasonably fast
+* simple to install and to maintain
+
+User guide
+----------
+
+Cppo is a preprocessor for programming languages that follow lexical rules
+compatible with OCaml including OCaml-style comments `(* ... *)`. These include Ocamllex, Ocamlyacc, Menhir, and extensions of OCaml based on Camlp4, Camlp5, or ppx. Cppo should work with Bucklescript as well. It won't work so well with Reason code because Reason uses C-style comment delimiters `/*` and `*/`.
+
+Cppo supports a number of directives. A directive is a `#` sign placed
+at the beginning of a line, possibly preceded by some whitespace, and followed
+by a valid directive name or by a number:
+
+```ocaml
+BLANK* "#" BLANK* ("define"|"undef"
+ |"if"|"ifdef"|"ifndef"|"else"|"elif"|"endif"
+ |"include"
+ |"warning"|"error"
+ |"ext"|"endext") ...
+```
+
+Directives can be split into multiple lines by placing a backslash `\` at
+the end of the line to be continued. In general, any special character
+can used as a normal character by preceding it with backslash.
+
+
+File inclusion
+--------------
+
+```ocaml
+#include "hello.ml"
+```
+
+This is how a source file `hello.ml` can be included.
+Relative paths are searched first in the directory of the current file
+and then in the search paths added on the command line using `-I`, if any.
+
+
+Macros
+------
+
+This is a simple macro that doesn't take an argument ("object-like
+macro" in the cpp jargon):
+
+```ocaml
+#define Ms Mississippi
+
+match state with
+ Ms -> true
+ | _ -> false
+```
+
+After preprocessing by cppo, the code above becomes:
+
+```ocaml
+match state with
+ Mississippi -> true
+ | _ -> false
+```
+
+If needed, defined macros can be undefined. This is required prior to
+redefining a macro:
+
+```ocaml
+#undef X
+```
+
+An important distinction with cpp is that only previously-defined
+macros are accessible. Defining, undefining or redefining a macro has
+no effect on how previous macros will expand.
+
+Macros can take arguments ("function-like macro" in the cpp
+jargon). Both in the definition (`#define`) and in macro application the
+opening parenthesis must stick to the macro's identifier:
+
+```ocaml
+#define debug(args) if !debugging then Printf.eprintf args else ()
+
+debug("Testing %i" (1 + 1))
+```
+
+is expanded into:
+
+```ocaml
+if !debugging then Printf.eprintf "Testing %i" (1 + 1) else ()
+```
+
+Here is a multiline macro definition. Newlines occurring between
+tokens must be protected by a backslash:
+
+```ocaml
+#define repeat_until(action,condition) \
+ action; \
+ while not (condition) do \
+ action \
+ done
+```
+
+All user-definable macros are constant. There are however two
+predefined variable macros: `__FILE__` and `__LINE__` which take the value
+of the position in the source file where the macro is being expanded.
+
+```ocaml
+#define loc (Printf.sprintf "File %S, line %i" __FILE__ __LINE__)
+```
+
+Macros can be defined on the command line as follows:
+
+```ocaml
+# preprocessing only
+cppo -D 'VERSION 1.0' example.ml
+
+# preprocessing and compiling
+ocamlopt -c -pp "cppo -D 'VERSION 1.0'" example.ml
+```
+
+Conditionals
+------------
+
+Here is a quick reference on conditionals available in cppo. If you
+are not familiar with `#ifdef`, `#ifndef`, `#if`, `#else` and `#elif`, please
+refer to the corresponding section in the cpp manual.
+
+```ocaml
+#ifndef VERSION
+#warning "VERSION is undefined"
+#define VERSION "n/a"
+#endif
+#ifndef VERSION
+#error "VERSION is undefined"
+#endif
+#if OCAML_MAJOR >= 3 && OCAML_MINOR >= 10
+...
+#endif
+#ifdef X
+...
+#elif defined Y
+...
+#else
+...
+#endif
+```
+
+The boolean expressions following `#if` and `#elif` may perform arithmetic
+operations and tests over 64-bit ints.
+
+Boolean expressions:
+
+* `defined` ... followed by an identifier, returns true if such a macro exists
+* `true`
+* `false`
+* `(` ... `)`
+* ... `&&` ...
+* ... `||` ...
+* `not` ...
+
+Arithmetic comparisons used in boolean expressions:
+
+* ... `=` ...
+* ... `<` ...
+* ... `>` ...
+* ... `<>` ...
+* ... `<=` ...
+* ... `>=` ...
+
+Arithmetic operators over signed 64-bit ints:
+
+* `(` ... `)`
+* ... `+` ...
+* ... `-` ...
+* ... `*` ...
+* ... `/` ...
+* ... `mod` ...
+* ... `lsl` ...
+* ... `lsr` ...
+* ... `asr` ...
+* ... `land` ...
+* ... `lor` ...
+* ... `lxor` ...
+* `lnot` ...
+
+Macro identifiers can be used in place of ints as long as they expand
+to an int literal or a tuple of int literals, e.g.:
+
+```ocaml
+#define one 1
+
+#if one + one <> 2
+#error "Something's wrong."
+#endif
+
+#define VERSION (1, 0, 5)
+#if VERSION <= (1, 0, 2)
+#error "Version 1.0.2 or greater is required."
+#endif
+```
+
+Version strings (http://semver.org/) can also be passed to cppo on the
+command line. This results in multiple variables being defined, all
+sharing the same prefix. See the output of `cppo -help` (copied at the
+bottom of this page).
+
+```
+$ cppo -V OCAML:`ocamlc -version`
+#if OCAML_VERSION >= (4, 0, 0)
+(* All is well. *)
+#else
+ #error "This version of OCaml is not supported."
+#endif
+```
+
+Output:
+```
+# 2 "<stdin>"
+(* All is well. *)
+```
+
+Source file location
+--------------------
+
+Location directives are the same as in OCaml and are echoed in the
+output. They consist of a line number optionally followed by a file name:
+
+```ocaml
+# 123
+# 456 "source"
+```
+
+Messages
+--------
+
+Warnings and error messages can be produced by the preprocessor:
+
+```ocaml
+#ifndef X
+ #warning "Assuming default value for X"
+ #define X 1
+#elif X = 0
+ #error "X may not be null"
+#endif
+```
+
+Calling an external processor
+-----------------------------
+
+Cppo provides a mechanism for converting sections of a file using
+and external program. Such a section must be placed between `#ext` and
+`#endext` directives.
+
+```bash
+$ cat foo
+ABC
+#ext lowercase
+DEF
+#endext
+GHI
+#ext lowercase
+KLM
+NOP
+#endext
+QRS
+
+$ cppo -x lowercase:'tr "[A-Z]" "[a-z]"' foo
+# 1 "foo"
+ABC
+def
+# 5 "foo"
+GHI
+klm
+nop
+# 10 "foo"
+QRS
+```
+
+In the example above, `lowercase` is the name given on the
+command-line to external command `'tr "[A-Z]" "[a-z]"'` that reads
+input from stdin and writes its output to stdout.
+
+
+Escaping
+--------
+
+The following characters can be escaped by a backslash when needed:
+
+```ocaml
+(
+)
+,
+#
+```
+
+In OCaml `#` is used for method calls. It is usually not a problem
+because in order to be interpreted as a preprocessor directive, it
+must be the first non-blank character of a line and be a known
+directive. If an object has a define method and you want `#` to appear
+first on a line, you would have to use `\#` instead:
+
+```ocaml
+obj
+ \#define
+```
+
+Line directives in the usual format supported by OCaml are correctly
+interpreted by cppo.
+
+Comments and string literals constitute single tokens even when they
+span across multiple lines. Therefore newlines within string literals
+and comments should remain as-is (no preceding backslash) even in a
+macro body:
+
+```ocaml
+#define welcome \
+"**********
+*Welcome!*
+**********
+"
+```
+
+Concatenation
+-------------
+
+`CONCAT()` is a predefined macro that takes two arguments, removes any
+whitespace between and around them and fuses them into a single identifier.
+The result of the concatenation must be a valid identifier of the
+form [A-Za-z_][A-Za-z0-9_]+ or [A-Za-z], or empty.
+
+For example,
+
+```ocaml
+#define x 123
+CONCAT(z, x)
+```
+
+expands into:
+
+```ocaml
+z123
+```
+
+However the following is illegal:
+
+```ocaml
+#define x 123
+CONCAT(x, z)
+```
+
+because 123z does not form a valid identifier.
+
+`CONCAT(a,b)` is roughly equivalent to `a##b` in cpp syntax.
+
+CAPITALIZE
+---------------
+
+`CAPITALIZE()` is a predefined macro that takes one argument,
+removes any leading and trailing whitespace, reduces each internal
+whitespace sequence to a single space character and produces
+a valid OCaml identifer with first character.
+
+For example,
+```ocaml
+#define EVENT(n,ty) external CONCAT(on,CAPITALIZE(n)) : ty = STRINGIFY(n) [@@bs.val]
+EVENT(exit, unit -> unit)
+```
+is expanded into:
+
+```ocaml
+external onExit : unit -> unit = "exit" [@@bs.val]
+```
+
+Stringification
+---------------
+
+`STRINGIFY()` is a predefined macro that takes one argument,
+removes any leading and trailing whitespace, reduces each internal
+whitespace sequence to a single space character and produces
+a valid OCaml string literal.
+
+For example,
+
+```ocaml
+#define TRACE(f) Printf.printf ">>> %s\n" STRINGIFY(f); f
+TRACE(print_endline) "Hello"
+```
+
+is expanded into:
+
+```ocaml
+Printf.printf ">>> %s\n" "print_endline"; print_endline "Hello"
+```
+
+`STRINGIFY(x)` is the equivalent of `#x` in cpp syntax.
+
+
+Ocamlbuild plugin
+------------------
+
+An ocamlbuild plugin is available. To use it, you can call ocamlbuild
+with the argument `-plugin-tag package(cppo_ocamlbuild)` (only since
+ocaml 4.01 and cppo >= 0.9.4).
+
+Starting from **cppo >= 1.6.0**, the `cppo_ocamlbuild` plugin is in a
+separate OPAM package (`opam install cppo_ocamlbuild`).
+
+With Oasis :
+```
+OCamlVersion: >= 4.01
+AlphaFeatures: ocamlbuild_more_args
+XOCamlbuildPluginTags: package(cppo_ocamlbuild)
+```
+
+After that, you need to add in your `myocamlbuild.ml` :
+```ocaml
+let () =
+ Ocamlbuild_plugin.dispatch
+ (fun hook ->
+ Ocamlbuild_cppo.dispatcher hook ;
+ )
+```
+
+By default the plugin will apply cppo on all files ending in `.cppo.ml`
+`cppo.mli`, and `cppo.mlpack`, in order to produce `.ml`, `.mli`,
+and`.mlpack` files. The following tags are available:
+* `cppo_D(X)` ≡ `-D X`
+* `cppo_U(X)` ≡ `-U X`
+* `cppo_q` ≡ `-q`
+* `cppo_s` ≡ `-s`
+* `cppo_n` ≡ `-n`
+* `cppo_x(NAME:CMD_TEMPLATE)` ≡ `-x NAME:CMD_TEMPLATE`
+* The tag `cppo_I(foo)` can behave in two way:
+ * If `foo` is a directory, it's equivalent to `-I foo`.
+ * If `foo` is a file, it adds `foo` as a dependency and apply `-I
+ parent(foo)`.
+* `cppo_V(NAME:VERSION)` ≡ `-V NAME:VERSION`
+* `cppo_V_OCAML` ≡ `-V OCAML:VERSION`, where `VERSION`
+ is the version of OCaml that ocamlbuild uses.
+
+Detailed command-line usage and options
+---------------------------------------
+
+```
+Usage: ./cppo [OPTIONS] [FILE1 [FILE2 ...]]
+Options:
+ -D DEF
+ Equivalent of interpreting '#define DEF' before processing the
+ input
+ -U IDENT
+ Equivalent of interpreting '#undef IDENT' before processing the
+ input
+ -I DIR
+ Add directory DIR to the search path for included files
+ -V VAR:MAJOR.MINOR.PATCH-OPTPRERELEASE+OPTBUILD
+ Define the following variables extracted from a version string
+ (following the Semantic Versioning syntax http://semver.org/):
+
+ VAR_MAJOR must be a non-negative int
+ VAR_MINOR must be a non-negative int
+ VAR_PATCH must be a non-negative int
+ VAR_PRERELEASE if the OPTPRERELEASE part exists
+ VAR_BUILD if the OPTBUILD part exists
+ VAR_VERSION is the tuple (MAJOR, MINOR, PATCH)
+ VAR_VERSION_STRING is the string MAJOR.MINOR.PATCH
+ VAR_VERSION_FULL is the original string
+
+ Example: cppo -V OCAML:4.02.1
+
+ -o FILE
+ Output file
+ -q
+ Identify and preserve camlp4 quotations
+ -s
+ Output line directives pointing to the exact source location of
+ each token, including those coming from the body of macro
+ definitions. This behavior is off by default.
+ -n
+ Do not output any line directive other than those found in the
+ input (overrides -s).
+ -version
+ Print the version of the program and exit.
+ -x NAME:CMD_TEMPLATE
+ Define a custom preprocessor target section starting with:
+ #ext "NAME"
+ and ending with:
+ #endext
+
+ NAME must be a lowercase identifier of the form [a-z][A-Za-z0-9_]*
+
+ CMD_TEMPLATE is a command template supporting the following
+ special sequences:
+ %F file name (unescaped; beware of potential scripting attacks)
+ %B number of the first line
+ %E number of the last line
+ %% a single percent sign
+
+ Filename, first line number and last line number are also
+ available from the following environment variables:
+ CPPO_FILE, CPPO_FIRST_LINE, CPPO_LAST_LINE.
+
+ The command produced is expected to read the data lines from stdin
+ and to write its output to stdout.
+ -help Display this list of options
+ --help Display this list of options
+```
+
+
+Contributing
+------------
+
+See our contribution guidelines at
+https://github.com/mjambon/documents/blob/master/how-to-contribute.md
new file mode 100644
@@ -0,0 +1 @@
+1.6.6
new file mode 100644
@@ -0,0 +1,14 @@
+
+environment:
+ matrix:
+ - OCAML_BRANCH: 4.05
+ - OCAML_BRANCH: 4.06
+
+install:
+ - appveyor DownloadFile "https://raw.githubusercontent.com/Chris00/ocaml-appveyor/master/install_ocaml.cmd" -FileName "C:\install_ocaml.cmd"
+ - C:\install_ocaml.cmd
+
+build_script:
+ - cd "%APPVEYOR_BUILD_FOLDER%"
+ - dune subst
+ - dune build -p cppo
new file mode 100644
@@ -0,0 +1,31 @@
+version: "1.6.7"
+opam-version: "2.0"
+maintainer: "martin@mjambon.com"
+authors: "Martin Jambon"
+license: "BSD-3-Clause"
+homepage: "https://github.com/ocaml-community/cppo"
+doc: "https://ocaml-community.github.io/cppo/"
+bug-reports: "https://github.com/ocaml-community/cppo/issues"
+depends: [
+ "ocaml" {>= "4.02.3"}
+ "dune" {>= "1.0"}
+ "base-unix"
+]
+build: [
+ ["dune" "subst"] {pinned}
+ ["dune" "build" "-p" name "-j" jobs]
+ ["dune" "runtest" "-p" name "-j" jobs] {with-test}
+]
+dev-repo: "git+https://github.com/ocaml-community/cppo.git"
+synopsis: "Code preprocessor like cpp for OCaml"
+description: """
+Cppo is an equivalent of the C preprocessor for OCaml programs.
+It allows the definition of simple macros and file inclusion.
+
+Cppo is:
+
+* more OCaml-friendly than cpp
+* easy to learn without consulting a manual
+* reasonably fast
+* simple to install and to maintain
+"""
\ No newline at end of file
new file mode 100644
@@ -0,0 +1,27 @@
+version: "1.6.7"
+opam-version: "2.0"
+maintainer: "martin@mjambon.com"
+authors: "Martin Jambon"
+license: "BSD-3-Clause"
+homepage: "https://github.com/ocaml-community/cppo"
+doc: "https://ocaml-community.github.io/cppo/"
+bug-reports: "https://github.com/ocaml-community/cppo/issues"
+depends: [
+ "ocaml"
+ "dune" {>= "1.0"}
+ "ocamlbuild"
+ "ocamlfind"
+]
+build: [
+ ["dune" "subst"] {pinned}
+ ["dune" "build" "-p" name "-j" jobs]
+ ["dune" "runtest" "-p" name "-j" jobs] {with-test}
+]
+dev-repo: "git+https://github.com/ocaml-community/cppo.git"
+synopsis: "Plugin to use cppo with ocamlbuild"
+description: """
+This ocamlbuild plugin lets you use cppo in ocamlbuild projects.
+
+To use it, you can call ocamlbuild with the argument `-plugin-tag
+package(cppo_ocamlbuild)` (only since ocaml 4.01 and cppo >= 0.9.4).
+"""
\ No newline at end of file
new file mode 100644
@@ -0,0 +1,3 @@
+(lang dune 1.0)
+(name cppo)
+(version v1.6.7)
new file mode 100644
@@ -0,0 +1,8 @@
+.PHONY: all clean
+all:
+ ../cppo debug.ml > debug.out
+ ../cppo french.ml > french.out
+ ocamllex lexer.mll
+ ../cppo lexer.ml > lexer.out
+clean:
+ rm -f *.out lexer.ml
new file mode 100644
@@ -0,0 +1,7 @@
+#ifdef DEBUG
+#define debug(s) Printf.eprintf "[%S %i] %s\n%!" __FILE__ __LINE__ s
+#else
+#define debug(s) ()
+#endif
+
+debug("test")
new file mode 100644
@@ -0,0 +1,32 @@
+(ocamllex lexer)
+
+(rule
+ (deps
+ (:< debug.ml))
+ (targets debug.out)
+ (action
+ (with-stdout-to
+ %{targets}
+ (run %{bin:cppo} %{<}))))
+
+(rule
+ (deps
+ (:< french.ml))
+ (targets french.out)
+ (action
+ (with-stdout-to
+ %{targets}
+ (run %{bin:cppo} %{<}))))
+
+(rule
+ (deps
+ (:< lexer.ml))
+ (targets lexer.out)
+ (action
+ (with-stdout-to
+ %{targets}
+ (run %{bin:cppo} %{<}))))
+
+(alias
+ (name DEFAULT)
+ (deps debug.out french.out lexer.out))
new file mode 100644
@@ -0,0 +1,34 @@
+#define soit let
+#define fonction function
+#define fon fun
+#define dans in
+#define si if
+#define alors then
+#define sinon else
+
+#define Liste List
+#define Affichef Printf
+#define affichef printf
+
+#define separation split
+#define tri sort
+
+soit rec separation x = fonction
+ y :: l ->
+ soit l1, l2 = separation x l dans
+ si y < x alors (y :: l1), l2
+ sinon l1, (y :: l2)
+ | [] ->
+ [], []
+
+soit rec tri = fonction
+ x :: l ->
+ soit l1, l2 = separation x l dans
+ tri l1 @ [x] @ tri l2
+ | [] ->
+ []
+
+soit () =
+ soit l = tri [ 5; 3; 7; 1; 7; 4; 99; 22 ] dans
+ Liste.iter (fon i -> Affichef.affichef "%i " i) l;
+ Affichef.affichef "\n"
new file mode 100644
@@ -0,0 +1,9 @@
+(* Warning: ocamllex doesn't accept cppo directives
+ within the rules section. *)
+rule token = parse
+ ['a'-'z']+ { `String (Lexing.lexeme lexbuf) }
+{
+#ifndef NOFOO
+ let foo () = ()
+#endif
+}
new file mode 100644
@@ -0,0 +1 @@
+true: package(ocamlbuild)
new file mode 100644
@@ -0,0 +1,6 @@
+(library
+ (name cppo_ocamlbuild)
+ (public_name cppo_ocamlbuild)
+ (wrapped false)
+ (synopsis "Cppo ocamlbuild plugin")
+ (libraries ocamlbuild))
new file mode 100644
@@ -0,0 +1,35 @@
+
+open Ocamlbuild_plugin
+
+let cppo_rules ext =
+ let dep = "%(name).cppo"-.-ext
+ and prod1 = "%(name: <*> and not <*.cppo>)"-.-ext
+ and prod2 = "%(name: <**/*> and not <**/*.cppo>)"-.-ext in
+ let cppo_rule prod env _build =
+ let dep = env dep in
+ let prod = env prod in
+ let tags = tags_of_pathname prod ++ "cppo" in
+ Cmd (S[A "cppo"; T tags; S [A "-o"; P prod]; P dep ])
+ in
+ rule ("cppo: *.cppo."-.-ext^" -> *."-.-ext) ~dep ~prod:prod1 (cppo_rule prod1);
+ rule ("cppo: **/*.cppo."-.-ext^" -> **/*."-.-ext) ~dep ~prod:prod2 (cppo_rule prod2)
+
+let dispatcher = function
+ | After_rules -> begin
+ List.iter cppo_rules ["ml"; "mli"; "mlpack"];
+ pflag ["cppo"] "cppo_D" (fun s -> S [A "-D"; A s]) ;
+ pflag ["cppo"] "cppo_U" (fun s -> S [A "-U"; A s]) ;
+ pflag ["cppo"] "cppo_I" (fun s ->
+ if Pathname.is_directory s then S [A "-I"; P s]
+ else S [A "-I"; P (Pathname.dirname s)]
+ ) ;
+ pdep ["cppo"] "cppo_I" (fun s ->
+ if Pathname.is_directory s then [] else [s]) ;
+ flag ["cppo"; "cppo_q"] (A "-q") ;
+ flag ["cppo"; "cppo_s"] (A "-s") ;
+ flag ["cppo"; "cppo_n"] (A "-n") ;
+ pflag ["cppo"] "cppo_x" (fun s -> S [A "-x"; A s]);
+ pflag ["cppo"] "cppo_V" (fun s -> S [A "-V"; A s]);
+ flag ["cppo"; "cppo_V_OCAML"] & S [A "-V"; A ("OCAML:" ^ Sys.ocaml_version)]
+ end
+ | _ -> ()
new file mode 100644
@@ -0,0 +1,9 @@
+
+(** [cppo_rules extension] will add rules to Ocamlbuild so that
+ cppo is applied to files ending in "cppo.[extension]".
+
+ By default rules are inserted for files ending with "ml", "mli" and
+ "mlpack". *)
+val cppo_rules : string -> unit
+
+val dispatcher : Ocamlbuild_plugin.hook -> unit
new file mode 100644
@@ -0,0 +1,7 @@
+if Filename.check_suffix Sys.argv.(1) ".ml" &&
+ Scanf.sscanf Sys.ocaml_version "%d.%d" (fun a b -> (a, b)) < (4, 03) then
+ print_endline "\
+module String = struct
+ include String
+ let capitalize_ascii = capitalize
+end"
new file mode 100644
@@ -0,0 +1,63 @@
+open Printf
+
+type command_token =
+ [ `Text of string
+ | `Loc_file
+ | `Loc_first_line
+ | `Loc_last_line ]
+
+type command_template = command_token list
+
+let parse s : command_template =
+ let rec loop acc buf s len i =
+ if i >= len then
+ let s = Buffer.contents buf in
+ if s = "" then acc
+ else `Text s :: acc
+ else if i = len - 1 then (
+ Buffer.add_char buf s.[i];
+ `Text (Buffer.contents buf) :: acc
+ )
+ else
+ let c = s.[i] in
+ if c = '%' then
+ let acc =
+ let s = Buffer.contents buf in
+ Buffer.clear buf;
+ if s = "" then acc
+ else
+ `Text s :: acc
+ in
+ let x =
+ match s.[i+1] with
+ 'F' -> `Loc_file
+ | 'B' -> `Loc_first_line
+ | 'E' -> `Loc_last_line
+ | '%' -> `Text "%"
+ | _ ->
+ failwith (
+ sprintf "Invalid escape sequence in command template %S. \
+ Use %%%% for a %% sign." s
+ )
+ in
+ loop (x :: acc) buf s len (i + 2)
+ else (
+ Buffer.add_char buf c;
+ loop acc buf s len (i + 1)
+ )
+ in
+ let len = String.length s in
+ List.rev (loop [] (Buffer.create len) s len 0)
+
+
+let subst (cmd : command_template) file first last =
+ let l =
+ List.map (
+ function
+ `Text s -> s
+ | `Loc_file -> file
+ | `Loc_first_line -> string_of_int first
+ | `Loc_last_line -> string_of_int last
+ ) cmd
+ in
+ String.concat "" l
new file mode 100644
@@ -0,0 +1,11 @@
+type command_token =
+ [ `Text of string
+ | `Loc_file
+ | `Loc_first_line
+ | `Loc_last_line ]
+
+type command_template = command_token list
+
+val subst : command_template -> string -> int -> int -> string
+
+val parse : string -> command_template
new file mode 100644
@@ -0,0 +1,697 @@
+open Printf
+
+open Cppo_types
+
+module S = Set.Make (String)
+module M = Map.Make (String)
+
+let builtins = [
+ "__FILE__", (fun _env -> `Special);
+ "__LINE__", (fun _env -> `Special);
+ "STRINGIFY", (fun env ->
+ `Defun (dummy_loc, "STRINGIFY",
+ ["x"],
+ [`Stringify (`Ident (dummy_loc, "x", None))],
+ env)
+ );
+ "CONCAT", (fun env ->
+ `Defun (dummy_loc, "CONCAT",
+ ["x";"y"],
+ [`Concat (`Ident (dummy_loc, "x", None),
+ `Ident (dummy_loc, "y", None))],
+ env)
+ );
+ "CAPITALIZE", (fun env ->
+ `Defun (dummy_loc, "CAPITALIZE",
+ ["x"],
+ [`Capitalize (`Ident (dummy_loc, "x", None))],
+ env)
+ );
+
+]
+
+let is_reserved s =
+ List.exists (fun (s', _) -> s = s') builtins
+
+let builtin_env =
+ List.fold_left (fun env (s, f) -> M.add s (f env) env) M.empty builtins
+
+let line_directive buf pos =
+ let len = Buffer.length buf in
+ if len > 0 && Buffer.nth buf (len - 1) <> '\n' then
+ Buffer.add_char buf '\n';
+ bprintf buf "# %i %S\n"
+ pos.Lexing.pos_lnum
+ pos.Lexing.pos_fname;
+ bprintf buf "%s" (String.make (pos.Lexing.pos_cnum - pos.Lexing.pos_bol) ' ')
+
+let rec add_sep sep last = function
+ [] -> [ last ]
+ | [x] -> [ x; last ]
+ | x :: l -> x :: sep :: add_sep sep last l
+
+
+let remove_space l =
+ List.filter (function `Text (_, true, _) -> false | _ -> true) l
+
+let trim_and_compact buf s =
+ let started = ref false in
+ let need_space = ref false in
+ for i = 0 to String.length s - 1 do
+ match s.[i] with
+ ' ' | '\t' | '\n' | '\r' ->
+ if !started then
+ need_space := true
+ | c ->
+ if !need_space then
+ Buffer.add_char buf ' ';
+ (match c with
+ '\"' -> Buffer.add_string buf "\\\""
+ | '\\' -> Buffer.add_string buf "\\\\"
+ | c -> Buffer.add_char buf c);
+ started := true;
+ need_space := false
+ done
+
+let stringify buf s =
+ Buffer.add_char buf '\"';
+ trim_and_compact buf s;
+ Buffer.add_char buf '\"'
+
+let trim_and_compact_string s =
+ let buf = Buffer.create (String.length s) in
+ trim_and_compact buf s;
+ Buffer.contents buf
+
+let trim_compact_and_capitalize_string s =
+ let buf = Buffer.create (String.length s) in
+ trim_and_compact buf s;
+ String.capitalize_ascii (Buffer.contents buf)
+
+let is_ident s =
+ let len = String.length s in
+ len > 0
+ &&
+ (match s.[0] with
+ 'A'..'Z' | 'a'..'z' -> true
+ | '_' when len > 1 -> true
+ | _ -> false)
+ &&
+ (try
+ for i = 1 to len - 1 do
+ match s.[i] with
+ 'A'..'Z' | 'a'..'z' | '_' | '0'..'9' -> ()
+ | _ -> raise Exit
+ done;
+ true
+ with Exit ->
+ false)
+
+let concat loc x y =
+ let s = trim_and_compact_string x ^ trim_and_compact_string y in
+ if not (s = "" || is_ident s) then
+ error loc
+ (sprintf "CONCAT() does not expand into a valid identifier nor \
+ into whitespace:\n%S" s)
+ else
+ if s = "" then " "
+ else " " ^ s ^ " "
+
+(*
+ Expand the contents of a variable used in a boolean expression.
+
+ Ideally, we should first completely expand the contents bound
+ to the variable, and then parse the result as an int or an int tuple.
+ This is a bit complicated to do well, and we don't want to implement
+ a full programming language here either.
+
+ Instead we only accept int literals, int tuple literals, and variables that
+ themselves expand into one those.
+
+ In particular:
+ - We do not support arithmetic operations
+ - We do not support tuples containing variables such as (x, y)
+
+ Example of contents that we support:
+ - 123
+ - (1, 2, 3)
+ - x, where x expands into 123.
+*)
+let rec eval_ident env loc name =
+ let l =
+ try
+ match M.find name env with
+ | `Def (_, _, l, _) -> l
+ | `Defun _ ->
+ error loc (sprintf "%S expects arguments" name)
+ | `Special -> assert false
+ with Not_found -> error loc (sprintf "Undefined identifier %S" name)
+ in
+ let expansion_error () =
+ error loc
+ (sprintf "\
+Variable %s found in cppo boolean expression must expand
+into an int literal, into a tuple of int literals,
+or into a variable with the same properties."
+ name)
+ in
+ (try
+ match remove_space l with
+ [ `Ident (loc, name, None) ] ->
+ (* single identifier that we expand recursively *)
+ eval_ident env loc name
+ | _ ->
+ (* int literal or int tuple literal; variables not allowed *)
+ let text =
+ List.map (
+ function
+ `Text (_, _is_space, s) -> s
+ | _ ->
+ expansion_error ()
+ ) (Cppo_types.flatten_nodes l)
+ in
+ let s = String.concat "" text in
+ (match Cppo_lexer.int_tuple_of_string s with
+ Some [i] -> `Int i
+ | Some l -> `Tuple (loc, List.map (fun i -> `Int i) l)
+ | None ->
+ expansion_error ()
+ )
+ with Cppo_error _ ->
+ expansion_error ()
+ )
+
+let rec replace_idents env (x : arith_expr) : arith_expr =
+ match x with
+ | `Ident (loc, name) -> eval_ident env loc name
+
+ | `Int x -> `Int x
+ | `Neg x -> `Neg (replace_idents env x)
+ | `Add (a, b) -> `Add (replace_idents env a, replace_idents env b)
+ | `Sub (a, b) -> `Sub (replace_idents env a, replace_idents env b)
+ | `Mul (a, b) -> `Mul (replace_idents env a, replace_idents env b)
+ | `Div (loc, a, b) -> `Div (loc, replace_idents env a, replace_idents env b)
+ | `Mod (loc, a, b) -> `Mod (loc, replace_idents env a, replace_idents env b)
+ | `Lnot a -> `Lnot (replace_idents env a)
+ | `Lsl (a, b) -> `Lsl (replace_idents env a, replace_idents env b)
+ | `Lsr (a, b) -> `Lsr (replace_idents env a, replace_idents env b)
+ | `Asr (a, b) -> `Asr (replace_idents env a, replace_idents env b)
+ | `Land (a, b) -> `Land (replace_idents env a, replace_idents env b)
+ | `Lor (a, b) -> `Lor (replace_idents env a, replace_idents env b)
+ | `Lxor (a, b) -> `Lxor (replace_idents env a, replace_idents env b)
+ | `Tuple (loc, l) -> `Tuple (loc, List.map (replace_idents env) l)
+
+let rec eval_int env (x : arith_expr) : int64 =
+ match x with
+ | `Ident (loc, name) -> eval_int env (eval_ident env loc name)
+
+ | `Int x -> x
+ | `Neg x -> Int64.neg (eval_int env x)
+ | `Add (a, b) -> Int64.add (eval_int env a) (eval_int env b)
+ | `Sub (a, b) -> Int64.sub (eval_int env a) (eval_int env b)
+ | `Mul (a, b) -> Int64.mul (eval_int env a) (eval_int env b)
+ | `Div (loc, a, b) ->
+ (try Int64.div (eval_int env a) (eval_int env b)
+ with Division_by_zero ->
+ error loc "Division by zero")
+
+ | `Mod (loc, a, b) ->
+ (try Int64.rem (eval_int env a) (eval_int env b)
+ with Division_by_zero ->
+ error loc "Division by zero")
+
+ | `Lnot a -> Int64.lognot (eval_int env a)
+
+ | `Lsl (a, b) ->
+ let n = eval_int env a in
+ let shift = eval_int env b in
+ let shift =
+ if shift >= 64L then 64L
+ else if shift <= -64L then -64L
+ else shift
+ in
+ Int64.shift_left n (Int64.to_int shift)
+
+ | `Lsr (a, b) ->
+ let n = eval_int env a in
+ let shift = eval_int env b in
+ let shift =
+ if shift >= 64L then 64L
+ else if shift <= -64L then -64L
+ else shift
+ in
+ Int64.shift_right_logical n (Int64.to_int shift)
+
+ | `Asr (a, b) ->
+ let n = eval_int env a in
+ let shift = eval_int env b in
+ let shift =
+ if shift >= 64L then 64L
+ else if shift <= -64L then -64L
+ else shift
+ in
+ Int64.shift_right n (Int64.to_int shift)
+
+ | `Land (a, b) -> Int64.logand (eval_int env a) (eval_int env b)
+ | `Lor (a, b) -> Int64.logor (eval_int env a) (eval_int env b)
+ | `Lxor (a, b) -> Int64.logxor (eval_int env a) (eval_int env b)
+ | `Tuple (loc, l) ->
+ assert (List.length l <> 1);
+ error loc "Operation not supported on tuples"
+
+let rec compare_lists al bl =
+ match al, bl with
+ | a :: al, b :: bl ->
+ let c = Int64.compare a b in
+ if c <> 0 then c
+ else compare_lists al bl
+ | [], [] -> 0
+ | [], _ -> -1
+ | _, [] -> 1
+
+let compare_tuples env (a : arith_expr) (b : arith_expr) =
+ (* We replace the identifiers first to get a better error message
+ on such input:
+
+ #define x (1, 2)
+ #if x >= (1, 2)
+
+ since variables must represent a single int, not a tuple.
+ *)
+ let a = replace_idents env a in
+ let b = replace_idents env b in
+ match a, b with
+ | `Tuple (_, al), `Tuple (_, bl) when List.length al = List.length bl ->
+ let eval_list l = List.map (eval_int env) l in
+ compare_lists (eval_list al) (eval_list bl)
+
+ | `Tuple (_loc1, al), `Tuple (loc2, bl) ->
+ error loc2
+ (sprintf "Tuple of length %i cannot be compared to a tuple of length %i"
+ (List.length bl) (List.length al)
+ )
+
+ | `Tuple (loc, _), _
+ | _, `Tuple (loc, _) ->
+ error loc "Tuple cannot be compared to an int"
+
+ | a, b ->
+ Int64.compare (eval_int env a) (eval_int env b)
+
+let rec eval_bool env (x : bool_expr) =
+ match x with
+ `True -> true
+ | `False -> false
+ | `Defined s -> M.mem s env
+ | `Not x -> not (eval_bool env x)
+ | `And (a, b) -> eval_bool env a && eval_bool env b
+ | `Or (a, b) -> eval_bool env a || eval_bool env b
+ | `Eq (a, b) -> compare_tuples env a b = 0
+ | `Lt (a, b) -> compare_tuples env a b < 0
+ | `Gt (a, b) -> compare_tuples env a b > 0
+
+
+type globals = {
+ call_loc : Cppo_types.loc;
+ (* location used to set the value of
+ __FILE__ and __LINE__ global variables *)
+
+ mutable buf : Buffer.t;
+ (* buffer where the output is written *)
+
+ included : S.t;
+ (* set of already-included files *)
+
+ require_location : bool ref;
+ (* whether a line directive should be printed before outputting the next
+ token *)
+
+ show_exact_locations : bool;
+ (* whether line directives should be printed even for expanded macro
+ bodies *)
+
+ enable_loc : bool ref;
+ (* whether line directives should be printed *)
+
+ g_preserve_quotations : bool;
+ (* identify and preserve camlp4 quotations *)
+
+ incdirs : string list;
+ (* directories for finding included files *)
+
+ current_directory : string;
+ (* directory containing the current file *)
+
+ extensions : (string, Cppo_command.command_template) Hashtbl.t;
+ (* mapping from extension ID to pipeline command *)
+}
+
+
+
+let parse ~preserve_quotations file lexbuf =
+ let lexer_env = Cppo_lexer.init ~preserve_quotations file lexbuf in
+ try
+ Cppo_parser.main (Cppo_lexer.line lexer_env) lexbuf
+ with
+ Parsing.Parse_error ->
+ error (Cppo_lexer.loc lexbuf) "syntax error"
+ | Cppo_types.Cppo_error _ as e ->
+ raise e
+ | e ->
+ error (Cppo_lexer.loc lexbuf) (Printexc.to_string e)
+
+let plural n =
+ if abs n <= 1 then ""
+ else "s"
+
+
+let maybe_print_location g pos =
+ if !(g.enable_loc) then
+ if !(g.require_location) then (
+ line_directive g.buf pos
+ )
+
+let expand_ext g loc id data =
+ let cmd_tpl =
+ try Hashtbl.find g.extensions id
+ with Not_found ->
+ error loc (sprintf "Undefined extension %s" id)
+ in
+ let p1, p2 = loc in
+ let file = p1.Lexing.pos_fname in
+ let first = p1.Lexing.pos_lnum in
+ let last = p2.Lexing.pos_lnum in
+ let cmd = Cppo_command.subst cmd_tpl file first last in
+ Unix.putenv "CPPO_FILE" file;
+ Unix.putenv "CPPO_FIRST_LINE" (string_of_int first);
+ Unix.putenv "CPPO_LAST_LINE" (string_of_int last);
+ let (ic, oc) as p = Unix.open_process cmd in
+ output_string oc data;
+ close_out oc;
+ (try
+ while true do
+ bprintf g.buf "%s\n" (input_line ic)
+ done
+ with End_of_file -> ()
+ );
+ match Unix.close_process p with
+ Unix.WEXITED 0 -> ()
+ | Unix.WEXITED n ->
+ failwith (sprintf "Command %S exited with status %i" cmd n)
+ | _ ->
+ failwith (sprintf "Command %S failed" cmd)
+
+let rec include_file g loc rel_file env =
+ let file =
+ if not (Filename.is_relative rel_file) then
+ if Sys.file_exists rel_file then
+ rel_file
+ else
+ error loc (sprintf "Included file %S does not exist" rel_file)
+ else
+ try
+ let dir =
+ List.find (
+ fun dir ->
+ let file = Filename.concat dir rel_file in
+ Sys.file_exists file
+ ) (g.current_directory :: g.incdirs)
+ in
+ if dir = Filename.current_dir_name then
+ rel_file
+ else
+ Filename.concat dir rel_file
+ with Not_found ->
+ error loc (sprintf "Cannot find included file %S" rel_file)
+ in
+ if S.mem file g.included then
+ failwith (sprintf "Cyclic inclusion of file %S" file)
+ else
+ let ic = open_in file in
+ let lexbuf = Lexing.from_channel ic in
+ let l = parse ~preserve_quotations:g.g_preserve_quotations file lexbuf in
+ close_in ic;
+ expand_list { g with
+ included = S.add file g.included;
+ current_directory = Filename.dirname file
+ } env l
+
+and expand_list ?(top = false) g env l =
+ List.fold_left (expand_node ~top g) env l
+
+and expand_node ?(top = false) g env0 (x : node) =
+ match x with
+ `Ident (loc, name, opt_args) ->
+
+ let def =
+ try Some (M.find name env0)
+ with Not_found -> None
+ in
+ let g =
+ if top && def <> None || g.call_loc == dummy_loc then
+ { g with call_loc = loc }
+ else g
+ in
+
+ let enable_loc0 = !(g.enable_loc) in
+
+ if def <> None then (
+ g.require_location := true;
+
+ if not g.show_exact_locations then (
+ (* error reports will point more or less to the point
+ where the code is included rather than the source location
+ of the macro definition *)
+ maybe_print_location g (fst loc);
+ g.enable_loc := false
+ )
+ );
+
+ let env =
+ match def, opt_args with
+ None, None ->
+ expand_node g env0 (`Text (loc, false, name))
+ | None, Some args ->
+ let with_sep =
+ add_sep
+ [`Text (loc, false, ",")]
+ [`Text (loc, false, ")")]
+ args in
+ let l =
+ `Text (loc, false, name ^ "(") :: List.flatten with_sep in
+ expand_list g env0 l
+
+ | Some (`Defun (_, _, arg_names, _, _)), None ->
+ error loc
+ (sprintf "%S expects %i arguments but is applied to none."
+ name (List.length arg_names))
+
+ | Some (`Def _), Some _ ->
+ error loc
+ (sprintf "%S expects no arguments" name)
+
+ | Some (`Def (_, _, l, env)), None ->
+ ignore (expand_list g env l);
+ env0
+
+ | Some (`Defun (_, _, arg_names, l, env)), Some args ->
+ let argc = List.length arg_names in
+ let n = List.length args in
+ let args =
+ (* it's ok to pass an empty arg if one arg
+ is expected *)
+ if n = 0 && argc = 1 then [[]]
+ else args
+ in
+ if argc <> n then
+ error loc
+ (sprintf "%S expects %i argument%s but is applied to \
+ %i argument%s."
+ name argc (plural argc) n (plural n))
+ else
+ let app_env =
+ List.fold_left2 (
+ fun env name l ->
+ M.add name (`Def (loc, name, l, env0)) env
+ ) env arg_names args
+ in
+ ignore (expand_list g app_env l);
+ env0
+
+ | Some `Special, _ -> assert false
+ in
+
+ if def = None then
+ g.require_location := false
+ else
+ g.require_location := true;
+
+ (* restore initial setting *)
+ g.enable_loc := enable_loc0;
+
+ env
+
+
+ | `Def (loc, name, body)->
+ g.require_location := true;
+ if M.mem name env0 then
+ error loc (sprintf "%S is already defined" name)
+ else
+ M.add name (`Def (loc, name, body, env0)) env0
+
+ | `Defun (loc, name, arg_names, body) ->
+ g.require_location := true;
+ if M.mem name env0 then
+ error loc (sprintf "%S is already defined" name)
+ else
+ M.add name (`Defun (loc, name, arg_names, body, env0)) env0
+
+ | `Undef (loc, name) ->
+ g.require_location := true;
+ if is_reserved name then
+ error loc
+ (sprintf "%S is a built-in variable that cannot be undefined" name)
+ else
+ M.remove name env0
+
+ | `Include (loc, file) ->
+ g.require_location := true;
+ let env = include_file g loc file env0 in
+ g.require_location := true;
+ env
+
+ | `Ext (loc, id, data) ->
+ g.require_location := true;
+ expand_ext g loc id data;
+ g.require_location := true;
+ env0
+
+ | `Cond (_loc, test, if_true, if_false) ->
+ let l =
+ if eval_bool env0 test then if_true
+ else if_false
+ in
+ g.require_location := true;
+ let env = expand_list g env0 l in
+ g.require_location := true;
+ env
+
+ | `Error (loc, msg) ->
+ error loc msg
+
+ | `Warning (loc, msg) ->
+ warning loc msg;
+ env0
+
+ | `Text (loc, is_space, s) ->
+ if not is_space then (
+ maybe_print_location g (fst loc);
+ g.require_location := false
+ );
+ Buffer.add_string g.buf s;
+ env0
+
+ | `Seq l ->
+ expand_list g env0 l
+
+ | `Stringify x ->
+ let enable_loc0 = !(g.enable_loc) in
+ g.enable_loc := false;
+ let buf0 = g.buf in
+ let local_buf = Buffer.create 100 in
+ g.buf <- local_buf;
+ ignore (expand_node g env0 x);
+ stringify buf0 (Buffer.contents local_buf);
+ g.buf <- buf0;
+ g.enable_loc := enable_loc0;
+ env0
+
+ | `Capitalize (x : node) ->
+ let enable_loc0 = !(g.enable_loc) in
+ g.enable_loc := false;
+ let buf0 = g.buf in
+ let local_buf = Buffer.create 100 in
+ g.buf <- local_buf;
+ ignore (expand_node g env0 x);
+ let xs = Buffer.contents local_buf in
+ let s = trim_compact_and_capitalize_string xs in
+ (* stringify buf0 (Buffer.contents local_buf); *)
+ Buffer.add_string buf0 s ;
+ g.buf <- buf0;
+ g.enable_loc := enable_loc0;
+ env0
+ | `Concat (x, y) ->
+ let enable_loc0 = !(g.enable_loc) in
+ g.enable_loc := false;
+ let buf0 = g.buf in
+ let local_buf = Buffer.create 100 in
+ g.buf <- local_buf;
+ ignore (expand_node g env0 x);
+ let xs = Buffer.contents local_buf in
+ Buffer.clear local_buf;
+ ignore (expand_node g env0 y);
+ let ys = Buffer.contents local_buf in
+ let s = concat g.call_loc xs ys in
+ Buffer.add_string buf0 s;
+ g.buf <- buf0;
+ g.enable_loc := enable_loc0;
+ env0
+
+ | `Line (loc, opt_file, n) ->
+ (* printing a line directive is not strictly needed *)
+ (match opt_file with
+ None ->
+ maybe_print_location g (fst loc);
+ bprintf g.buf "\n# %i\n" n
+ | Some file ->
+ bprintf g.buf "\n# %i %S\n" n file
+ );
+ (* printing the location next time is needed because it just changed *)
+ g.require_location := true;
+ env0
+
+ | `Current_line loc ->
+ maybe_print_location g (fst loc);
+ g.require_location := true;
+ let pos, _ = g.call_loc in
+ bprintf g.buf " %i " pos.Lexing.pos_lnum;
+ env0
+
+ | `Current_file loc ->
+ maybe_print_location g (fst loc);
+ g.require_location := true;
+ let pos, _ = g.call_loc in
+ bprintf g.buf " %S " pos.Lexing.pos_fname;
+ env0
+
+
+
+
+let include_inputs
+ ~extensions
+ ~preserve_quotations
+ ~incdirs
+ ~show_exact_locations
+ ~show_no_locations
+ buf env l =
+
+ let enable_loc = not show_no_locations in
+ List.fold_left (
+ fun env (dir, file, open_, close) ->
+ let l = parse ~preserve_quotations file (open_ ()) in
+ close ();
+ let g = {
+ call_loc = dummy_loc;
+ buf = buf;
+ included = S.empty;
+ require_location = ref true;
+ show_exact_locations = show_exact_locations;
+ enable_loc = ref enable_loc;
+ g_preserve_quotations = preserve_quotations;
+ incdirs = incdirs;
+ current_directory = dir;
+ extensions = extensions;
+ }
+ in
+ expand_list ~top:true { g with included = S.add file g.included } env l
+ ) env l
new file mode 100644
@@ -0,0 +1,29 @@
+(** The type signatures in this module are not yet for public consumption.
+
+ Please don't rely on them in any way.*)
+
+module S : Set.S with type elt = string
+module M : Map.S with type key = string
+
+val builtin_env
+ : [> `Defun of
+ Cppo_types.loc * string * string list *
+ [> `Capitalize of Cppo_types.node
+ | `Concat of (Cppo_types.node * Cppo_types.node)
+ | `Stringify of Cppo_types.node ] list * 'a
+ | `Special ] M.t as 'a
+
+val include_inputs
+ : extensions:(string, Cppo_command.command_template) Hashtbl.t
+ -> preserve_quotations:bool
+ -> incdirs:string list
+ -> show_exact_locations:bool
+ -> show_no_locations:bool
+ -> Buffer.t
+ -> (([< `Def of Cppo_types.loc * string * Cppo_types.node list * 'a
+ | `Defun of Cppo_types.loc * string * string list * Cppo_types.node list * 'a
+ | `Special
+ > `Def `Defun ]
+ as 'b)
+ M.t as 'a)
+ -> (string * string * (unit -> Lexing.lexbuf) * (unit -> unit)) list -> 'a
new file mode 100644
@@ -0,0 +1,721 @@
+{
+open Printf
+open Lexing
+
+open Cppo_types
+open Cppo_parser
+
+let pos1 lexbuf = lexbuf.lex_start_p
+let pos2 lexbuf = lexbuf.lex_curr_p
+let loc lexbuf = (pos1 lexbuf, pos2 lexbuf)
+
+let lexer_error lexbuf descr =
+ error (loc lexbuf) descr
+
+let new_file lb name =
+ lb.lex_curr_p <- { lb.lex_curr_p with pos_fname = name }
+
+let lex_new_lines lb =
+ let n = ref 0 in
+ let s = lb.lex_buffer in
+ for i = lb.lex_start_pos to lb.lex_curr_pos do
+ if Bytes.get s i = '\n' then
+ incr n
+ done;
+ let p = lb.lex_curr_p in
+ lb.lex_curr_p <-
+ { p with
+ pos_lnum = p.pos_lnum + !n;
+ pos_bol = p.pos_cnum
+ }
+
+let count_new_lines lb n =
+ let p = lb.lex_curr_p in
+ lb.lex_curr_p <-
+ { p with
+ pos_lnum = p.pos_lnum + n;
+ pos_bol = p.pos_cnum
+ }
+
+(* must start a new line *)
+let update_pos lb p added_chars added_breaks =
+ let cnum = p.pos_cnum + added_chars in
+ lb.lex_curr_p <-
+ { pos_fname = p.pos_fname;
+ pos_lnum = p.pos_lnum + added_breaks;
+ pos_bol = cnum;
+ pos_cnum = cnum }
+
+let set_lnum lb opt_file lnum =
+ let p = lb.lex_curr_p in
+ let cnum = p.pos_cnum in
+ let fname =
+ match opt_file with
+ None -> p.pos_fname
+ | Some file -> file
+ in
+ lb.lex_curr_p <-
+ { pos_fname = fname;
+ pos_bol = cnum;
+ pos_cnum = cnum;
+ pos_lnum = lnum }
+
+let shift lb n =
+ let p = lb.lex_curr_p in
+ lb.lex_curr_p <- { p with pos_cnum = p.pos_cnum + n }
+
+let read_hexdigit c =
+ match c with
+ '0'..'9' -> Char.code c - 48
+ | 'A'..'F' -> Char.code c - 55
+ | 'a'..'z' -> Char.code c - 87
+ | _ -> invalid_arg "read_hexdigit"
+
+let read_hex2 c1 c2 =
+ Char.chr (read_hexdigit c1 * 16 + read_hexdigit c2)
+
+type env = {
+ preserve_quotations : bool;
+ mutable lexer : [ `Ocaml | `Test ];
+ mutable line_start : bool;
+ mutable in_directive : bool; (* true while processing a directive, until the
+ final newline *)
+ buf : Buffer.t;
+ mutable token_start : Lexing.position;
+ lexbuf : Lexing.lexbuf;
+}
+
+let new_line env =
+ env.line_start <- true;
+ count_new_lines env.lexbuf 1
+
+let clear env = Buffer.clear env.buf
+
+let add env s =
+ env.line_start <- false;
+ Buffer.add_string env.buf s
+
+let add_char env c =
+ env.line_start <- false;
+ Buffer.add_char env.buf c
+
+let get env = Buffer.contents env.buf
+
+let long_loc e = (e.token_start, pos2 e.lexbuf)
+
+let cppo_directives = [
+ "define";
+ "elif";
+ "else";
+ "endif";
+ "error";
+ "if";
+ "ifdef";
+ "ifndef";
+ "include";
+ "undef";
+ "warning";
+]
+
+let is_reserved_directive =
+ let tbl = Hashtbl.create 20 in
+ List.iter (fun s -> Hashtbl.add tbl s ()) cppo_directives;
+ fun s -> Hashtbl.mem tbl s
+
+}
+
+(* standard character classes used for macro identifiers *)
+let upper = ['A'-'Z']
+let lower = ['a'-'z']
+let digit = ['0'-'9']
+
+let identchar = upper | lower | digit | [ '_' '\'' ]
+
+
+(* iso-8859-1 upper and lower characters used for ocaml identifiers *)
+let oc_upper = ['A'-'Z' '\192'-'\214' '\216'-'\222']
+let oc_lower = ['a'-'z' '\223'-'\246' '\248'-'\255']
+let oc_identchar = oc_upper | oc_lower | digit | ['_' '\'']
+
+(*
+ Identifiers: ident is used for macro names and is a subset of oc_ident
+*)
+let ident = (lower | '_' identchar | upper) identchar*
+let oc_ident = (oc_lower | '_' oc_identchar | oc_upper) oc_identchar*
+
+
+
+let hex = ['0'-'9' 'a'-'f' 'A'-'F']
+let oct = ['0'-'7']
+let bin = ['0'-'1']
+
+let operator_char =
+ [ '!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
+let infix_symbol =
+ ['=' '<' '>' '@' '^' '|' '&' '+' '-' '*' '/' '$' '%'] operator_char*
+let prefix_symbol = ['!' '?' '~'] operator_char*
+
+let blank = [ ' ' '\t' ]
+let space = [ ' ' '\t' '\r' '\n' ]
+
+let line = ( [^'\n'] | '\\' ('\r'? '\n') )* ('\n' | eof)
+
+let dblank0 = (blank | '\\' '\r'? '\n')*
+let dblank1 = blank (blank | '\\' '\r'? '\n')*
+
+rule token e = parse
+ ""
+ {
+ (*
+ We use two different lexers for boolean expressions in #if directives
+ and for regular OCaml tokens.
+ *)
+ match e.lexer with
+ `Ocaml -> ocaml_token e lexbuf
+ | `Test -> test_token e lexbuf
+ }
+
+and line e = parse
+ blank* "#" as s
+ {
+ match e.lexer with
+ `Test -> lexer_error lexbuf "Syntax error in boolean expression"
+ | `Ocaml ->
+ if e.line_start then (
+ e.in_directive <- true;
+ clear e;
+ add e s;
+ e.token_start <- pos1 lexbuf;
+ e.line_start <- false;
+ directive e lexbuf
+ )
+ else (
+ e.line_start <- false;
+ clear e;
+ TEXT (loc lexbuf, false, s)
+ )
+ }
+
+ | "" { clear e;
+ token e lexbuf }
+
+and directive e = parse
+ blank* "define" dblank1 (ident as id) "("
+ { DEFUN (long_loc e, id) }
+
+ | blank* "define" dblank1 (ident as id)
+ { assert e.in_directive;
+ DEF (long_loc e, id) }
+
+ | blank* "undef" dblank1 (ident as id)
+ { blank_until_eol e lexbuf;
+ UNDEF (long_loc e, id) }
+
+ | blank* "if" dblank1 { e.lexer <- `Test;
+ IF (long_loc e) }
+ | blank* "elif" dblank1 { e.lexer <- `Test;
+ ELIF (long_loc e) }
+
+ | blank* "ifdef" dblank1 (ident as id)
+ { blank_until_eol e lexbuf;
+ IFDEF (long_loc e, `Defined id) }
+
+ | blank* "ifndef" dblank1 (ident as id)
+ { blank_until_eol e lexbuf;
+ IFDEF (long_loc e, `Not (`Defined id)) }
+
+ | blank* "ext" dblank1 (ident as id)
+ { blank_until_eol e lexbuf;
+ clear e;
+ let s = read_ext e lexbuf in
+ EXT (long_loc e, id, s) }
+
+ | blank* "define" dblank1 oc_ident
+ | blank* "undef" dblank1 oc_ident
+ | blank* "ifdef" dblank1 oc_ident
+ | blank* "ifndef" dblank1 oc_ident
+ | blank* "ext" dblank1 oc_ident
+ { error (loc lexbuf)
+ "Identifiers containing non-ASCII characters \
+ may not be used as macro identifiers" }
+
+ | blank* "else"
+ { blank_until_eol e lexbuf;
+ ELSE (long_loc e) }
+
+ | blank* "endif"
+ { blank_until_eol e lexbuf;
+ ENDIF (long_loc e) }
+
+ | blank* "include" dblank0 '"'
+ { clear e;
+ eval_string e lexbuf;
+ blank_until_eol e lexbuf;
+ INCLUDE (long_loc e, get e) }
+
+ | blank* "error" dblank0 '"'
+ { clear e;
+ eval_string e lexbuf;
+ blank_until_eol e lexbuf;
+ ERROR (long_loc e, get e) }
+
+ | blank* "warning" dblank0 '"'
+ { clear e;
+ eval_string e lexbuf;
+ blank_until_eol e lexbuf;
+ WARNING (long_loc e, get e) }
+
+ | blank* (['0'-'9']+ as lnum) dblank0 '\r'? '\n'
+ { e.in_directive <- false;
+ new_line e;
+ let here = long_loc e in
+ let fname = None in
+ let lnum = int_of_string lnum in
+ (* Apply line directive regardless of possible #if condition. *)
+ set_lnum lexbuf fname lnum;
+ LINE (here, None, lnum) }
+
+ | blank* (['0'-'9']+ as lnum) dblank0 '"'
+ { clear e;
+ eval_string e lexbuf;
+ blank_until_eol e lexbuf;
+ let here = long_loc e in
+ let fname = Some (get e) in
+ let lnum = int_of_string lnum in
+ (* Apply line directive regardless of possible #if condition. *)
+ set_lnum lexbuf fname lnum;
+ LINE (here, fname, lnum) }
+
+ | blank*
+ { e.in_directive <- false;
+ add e (lexeme lexbuf);
+ TEXT (long_loc e, true, get e) }
+
+ | blank* (['a'-'z']+ as s)
+ { if is_reserved_directive s then
+ error (loc lexbuf) "cppo directive with missing or wrong arguments";
+ e.in_directive <- false;
+ add e (lexeme lexbuf);
+ TEXT (long_loc e, false, get e) }
+
+
+and blank_until_eol e = parse
+ blank* eof
+ | blank* '\r'? '\n' { new_line e;
+ e.in_directive <- false }
+ | "" { lexer_error lexbuf "syntax error in directive" }
+
+and read_ext e = parse
+ blank* "#" blank* "endext" blank* ('\r'? '\n' | eof)
+ { let s = get e in
+ clear e;
+ new_line e;
+ e.in_directive <- false;
+ s }
+
+ | (blank* as a) "\\" ("#" blank* "endext" blank* '\r'? '\n' as b)
+ { add e a;
+ add e b;
+ new_line e;
+ read_ext e lexbuf }
+
+ | [^'\n']* '\n' as x
+ { add e x;
+ new_line e;
+ read_ext e lexbuf }
+
+ | eof
+ { lexer_error lexbuf "End of file within #ext ... #endext" }
+
+and ocaml_token e = parse
+ "__LINE__"
+ { e.line_start <- false;
+ CURRENT_LINE (loc lexbuf) }
+
+ | "__FILE__"
+ { e.line_start <- false;
+ CURRENT_FILE (loc lexbuf) }
+
+ | ident as s
+ { e.line_start <- false;
+ IDENT (loc lexbuf, s) }
+
+ | oc_ident as s
+ { e.line_start <- false;
+ TEXT (loc lexbuf, false, s) }
+
+ | ident as s "("
+ { e.line_start <- false;
+ FUNIDENT (loc lexbuf, s) }
+
+ | "'\n'"
+ | "'\r\n'"
+ { new_line e;
+ TEXT (loc lexbuf, false, lexeme lexbuf) }
+
+ | "(" { e.line_start <- false; OP_PAREN (loc lexbuf) }
+ | ")" { e.line_start <- false; CL_PAREN (loc lexbuf) }
+ | "," { e.line_start <- false; COMMA (loc lexbuf) }
+
+ | "\\)" { e.line_start <- false; TEXT (loc lexbuf, false, " )") }
+ | "\\," { e.line_start <- false; TEXT (loc lexbuf, false, " ,") }
+ | "\\(" { e.line_start <- false; TEXT (loc lexbuf, false, " (") }
+ | "\\#" { e.line_start <- false; TEXT (loc lexbuf, false, " #") }
+
+ | '`'
+ | "!=" | "#" | "&" | "&&" | "(" | "*" | "+" | "-"
+ | "-." | "->" | "." | ".. :" | "::" | ":=" | ":>" | ";" | ";;" | "<"
+ | "<-" | "=" | ">" | ">]" | ">}" | "?" | "??" | "[" | "[<" | "[>" | "[|"
+ | "]" | "_" | "`" | "{" | "{<" | "|" | "|]" | "}" | "~"
+ | ">>"
+ | prefix_symbol
+ | infix_symbol
+ | "'" ([^ '\'' '\\']
+ | '\\' (_ | digit digit digit | 'x' hex hex)) "'"
+
+ { e.line_start <- false;
+ TEXT (loc lexbuf, false, lexeme lexbuf) }
+
+ | blank+
+ { TEXT (loc lexbuf, true, lexeme lexbuf) }
+
+ | '\\' ('\r'? '\n' as nl)
+
+ {
+ new_line e;
+ if e.in_directive then
+ TEXT (loc lexbuf, true, nl)
+ else
+ TEXT (loc lexbuf, false, lexeme lexbuf)
+ }
+
+ | '\r'? '\n'
+ {
+ new_line e;
+ if e.in_directive then (
+ e.in_directive <- false;
+ ENDEF (loc lexbuf)
+ )
+ else
+ TEXT (loc lexbuf, true, lexeme lexbuf)
+ }
+
+ | "(*"
+ { clear e;
+ add e "(*";
+ e.token_start <- pos1 lexbuf;
+ comment (loc lexbuf) e 1 lexbuf }
+
+ | '"'
+ { clear e;
+ add e "\"";
+ e.token_start <- pos1 lexbuf;
+ string e lexbuf;
+ e.line_start <- false;
+ TEXT (long_loc e, false, get e) }
+
+ | "<:"
+ | "<<"
+ { if e.preserve_quotations then (
+ clear e;
+ add e (lexeme lexbuf);
+ e.token_start <- pos1 lexbuf;
+ quotation e lexbuf;
+ e.line_start <- false;
+ TEXT (long_loc e, false, get e)
+ )
+ else (
+ e.line_start <- false;
+ TEXT (loc lexbuf, false, lexeme lexbuf)
+ )
+ }
+
+
+ | '-'? ( digit (digit | '_')*
+ | ("0x"| "0X") hex (hex | '_')*
+ | ("0o"| "0O") oct (oct | '_')*
+ | ("0b"| "0B") bin (bin | '_')* )
+
+ | '-'? digit (digit | '_')* ('.' (digit | '_')* )?
+ (['e' 'E'] ['+' '-']? digit (digit | '_')* )?
+ { e.line_start <- false;
+ TEXT (loc lexbuf, false, lexeme lexbuf) }
+
+ | blank+
+ { TEXT (loc lexbuf, true, lexeme lexbuf) }
+
+ | _
+ { e.line_start <- false;
+ TEXT (loc lexbuf, false, lexeme lexbuf) }
+
+ | eof
+ { EOF }
+
+
+and comment startloc e depth = parse
+ "(*"
+ { add e "(*";
+ comment startloc e (depth + 1) lexbuf }
+
+ | "*)"
+ { let depth = depth - 1 in
+ add e "*)";
+ if depth > 0 then
+ comment startloc e depth lexbuf
+ else (
+ e.line_start <- false;
+ TEXT (long_loc e, false, get e)
+ )
+ }
+ | '"'
+ { add_char e '"';
+ string e lexbuf;
+ comment startloc e depth lexbuf }
+
+ | "'\n'"
+ | "'\r\n'"
+ { new_line e;
+ add e (lexeme lexbuf);
+ comment startloc e depth lexbuf }
+
+ | "'" ([^ '\'' '\\']
+ | '\\' (_ | digit digit digit | 'x' hex hex)) "'"
+ { add e (lexeme lexbuf);
+ comment startloc e depth lexbuf }
+
+ | '\r'? '\n'
+ {
+ new_line e;
+ add e (lexeme lexbuf);
+ comment startloc e depth lexbuf
+ }
+
+ | [^'(' '*' '"' '\'' '\r' '\n']+
+ {
+ add e (lexeme lexbuf);
+ comment startloc e depth lexbuf
+ }
+
+ | _
+ { add e (lexeme lexbuf);
+ comment startloc e depth lexbuf }
+
+ | eof
+ { error startloc "Unterminated comment reaching the end of file" }
+
+
+and string e = parse
+ '"'
+ { add_char e '"' }
+
+ | "\\\\"
+ | '\\' '"'
+ { add e (lexeme lexbuf);
+ string e lexbuf }
+
+ | '\\' '\r'? '\n'
+ {
+ add e (lexeme lexbuf);
+ new_line e;
+ string e lexbuf
+ }
+
+ | '\r'? '\n'
+ {
+ if e.in_directive then
+ lexer_error lexbuf "Unterminated string literal"
+ else (
+ add e (lexeme lexbuf);
+ new_line e;
+ string e lexbuf
+ )
+ }
+
+ | _ as c
+ { add_char e c;
+ string e lexbuf }
+
+ | eof
+ { }
+
+
+and eval_string e = parse
+ '"'
+ { }
+
+ | '\\' (['\'' '\"' '\\'] as c)
+ { add_char e c;
+ eval_string e lexbuf }
+
+ | '\\' '\r'? '\n'
+ { assert e.in_directive;
+ eval_string e lexbuf }
+
+ | '\r'? '\n'
+ { assert e.in_directive;
+ lexer_error lexbuf "Unterminated string literal" }
+
+ | '\\' (digit digit digit as s)
+ { add_char e (Char.chr (int_of_string s));
+ eval_string e lexbuf }
+
+ | '\\' 'x' (hex as c1) (hex as c2)
+ { add_char e (read_hex2 c1 c2);
+ eval_string e lexbuf }
+
+ | '\\' 'b'
+ { add_char e '\b';
+ eval_string e lexbuf }
+
+ | '\\' 'n'
+ { add_char e '\n';
+ eval_string e lexbuf }
+
+ | '\\' 'r'
+ { add_char e '\r';
+ eval_string e lexbuf }
+
+ | '\\' 't'
+ { add_char e '\t';
+ eval_string e lexbuf }
+
+ | [^ '\"' '\\']+
+ { add e (lexeme lexbuf);
+ eval_string e lexbuf }
+
+ | eof
+ { lexer_error lexbuf "Unterminated string literal" }
+
+
+and quotation e = parse
+ ">>"
+ { add e ">>" }
+
+ | "\\>>"
+ { add e "\\>>";
+ quotation e lexbuf }
+
+ | '\\' '\r'? '\n'
+ {
+ if e.in_directive then (
+ new_line e;
+ quotation e lexbuf
+ )
+ else (
+ add e (lexeme lexbuf);
+ new_line e;
+ quotation e lexbuf
+ )
+ }
+
+ | '\r'? '\n'
+ {
+ if e.in_directive then
+ lexer_error lexbuf "Unterminated quotation"
+ else (
+ add e (lexeme lexbuf);
+ new_line e;
+ quotation e lexbuf
+ )
+ }
+
+ | [^'>' '\\' '\r' '\n']+
+ { add e (lexeme lexbuf);
+ quotation e lexbuf }
+
+ | eof
+ { lexer_error lexbuf "Unterminated quotation" }
+
+and test_token e = parse
+ "true" { TRUE }
+ | "false" { FALSE }
+ | "defined" { DEFINED }
+ | "(" { OP_PAREN (loc lexbuf) }
+ | ")" { CL_PAREN (loc lexbuf) }
+ | "&&" { AND }
+ | "||" { OR }
+ | "not" { NOT }
+ | "=" { EQ }
+ | "<" { LT }
+ | ">" { GT }
+ | "<>" { NE }
+ | "<=" { LE }
+ | ">=" { GE }
+
+ | '-'? ( digit (digit | '_')*
+ | ("0x"| "0X") hex (hex | '_')*
+ | ("0o"| "0O") oct (oct | '_')*
+ | ("0b"| "0B") bin (bin | '_')* )
+ { let s = Lexing.lexeme lexbuf in
+ try INT (Int64.of_string s)
+ with _ ->
+ error (loc lexbuf)
+ (sprintf "Integer constant %s is out the valid range for int64" s)
+ }
+
+ | "+" { PLUS }
+ | "-" { MINUS }
+ | "*" { STAR }
+ | "/" { SLASH (loc lexbuf) }
+ | "mod" { MOD (loc lexbuf) }
+ | "lsl" { LSL }
+ | "lsr" { LSR }
+ | "asr" { ASR }
+ | "land" { LAND }
+ | "lor" { LOR }
+ | "lxor" { LXOR }
+ | "lnot" { LNOT }
+
+ | "," { COMMA (loc lexbuf) }
+
+ | ident
+ { IDENT (loc lexbuf, lexeme lexbuf) }
+
+ | blank+ { test_token e lexbuf }
+ | '\\' '\r'? '\n' { new_line e;
+ test_token e lexbuf }
+ | '\r'? '\n'
+ | eof { assert e.in_directive;
+ e.in_directive <- false;
+ new_line e;
+ e.lexer <- `Ocaml;
+ ENDTEST (loc lexbuf) }
+ | _ { error (loc lexbuf)
+ (sprintf "Invalid token %s" (Lexing.lexeme lexbuf)) }
+
+
+(* Parse just an int or a tuple of ints *)
+and int_tuple = parse
+ | space* (([^'(']#space)+ as s) space* eof
+ { [Int64.of_string s] }
+
+ | space* "(" { int_tuple_content lexbuf }
+
+ | eof | _ { failwith "Not an int nor a tuple" }
+
+and int_tuple_content = parse
+ | space* (([^',' ')']#space)+ as s) space* ","
+ { let x = Int64.of_string s in
+ x :: int_tuple_content lexbuf }
+
+ | space* (([^',' ')']#space)+ as s) space* ")" space* eof
+ { [Int64.of_string s] }
+
+
+{
+ let init ~preserve_quotations file lexbuf =
+ new_file lexbuf file;
+ {
+ preserve_quotations = preserve_quotations;
+ lexer = `Ocaml;
+ line_start = true;
+ in_directive = false;
+ buf = Buffer.create 200;
+ token_start = Lexing.dummy_pos;
+ lexbuf = lexbuf;
+ }
+
+ let int_tuple_of_string s =
+ try Some (int_tuple (Lexing.from_string s))
+ with _ -> None
+}
new file mode 100644
@@ -0,0 +1,230 @@
+open Printf
+
+let add_extension tbl s =
+ let i =
+ try String.index s ':'
+ with Not_found ->
+ failwith "Invalid -x argument"
+ in
+ let id = String.sub s 0 i in
+ let raw_tpl = String.sub s (i+1) (String.length s - i - 1) in
+ let cmd_tpl = Cppo_command.parse raw_tpl in
+ if Hashtbl.mem tbl id then
+ failwith ("Multiple definitions for extension " ^ id)
+ else
+ Hashtbl.add tbl id cmd_tpl
+
+let semver_re = Str.regexp "\
+\\([0-9]+\\)\
+\\.\\([0-9]+\\)\
+\\.\\([0-9]+\\)\
+\\([~-]\\([^+]*\\)\\)?\
+\\(\\+\\(.*\\)\\)?\
+\r?$"
+
+let parse_semver s =
+ if not (Str.string_match semver_re s 0) then
+ None
+ else
+ let major = Str.matched_group 1 s in
+ let minor = Str.matched_group 2 s in
+ let patch = Str.matched_group 3 s in
+ let prerelease = try Some (Str.matched_group 5 s) with Not_found -> None in
+ let build = try Some (Str.matched_group 7 s) with Not_found -> None in
+ Some (major, minor, patch, prerelease, build)
+
+let define var s =
+ [sprintf "#define %s %s\n" var s]
+
+let opt_define var o =
+ match o with
+ | None -> []
+ | Some s -> define var s
+
+let parse_version_spec s =
+ let error () =
+ failwith (sprintf "Invalid version specification: %S" s)
+ in
+ let prefix, version_full =
+ try
+ let len = String.index s ':' in
+ String.sub s 0 len, String.sub s (len+1) (String.length s - (len+1))
+ with Not_found ->
+ error ()
+ in
+ match parse_semver version_full with
+ | None ->
+ error ()
+ | Some (major, minor, patch, opt_prerelease, opt_build) ->
+ let version = sprintf "(%s, %s, %s)" major minor patch in
+ let version_string = sprintf "%s.%s.%s" major minor patch in
+ List.flatten [
+ define (prefix ^ "_MAJOR") major;
+ define (prefix ^ "_MINOR") minor;
+ define (prefix ^ "_PATCH") patch;
+ opt_define (prefix ^ "_PRERELEASE") opt_prerelease;
+ opt_define (prefix ^ "_BUILD") opt_build;
+ define (prefix ^ "_VERSION") version;
+ define (prefix ^ "_VERSION_STRING") version_string;
+ define (prefix ^ "_VERSION_FULL") s;
+ ]
+
+let main () =
+ let extensions = Hashtbl.create 10 in
+ let files = ref [] in
+ let header = ref [] in
+ let incdirs = ref [] in
+ let out_file = ref None in
+ let preserve_quotations = ref false in
+ let show_exact_locations = ref false in
+ let show_no_locations = ref false in
+ let options = [
+ "-D", Arg.String (fun s -> header := ("#define " ^ s ^ "\n") :: !header),
+ "DEF
+ Equivalent of interpreting '#define DEF' before processing the
+ input, e.g. `cppo -D 'VERSION \"1.2.3\"'` (no equal sign)";
+
+ "-U", Arg.String (fun s -> header := ("#undef " ^ s ^ "\n") :: !header),
+ "IDENT
+ Equivalent of interpreting '#undef IDENT' before processing the
+ input";
+
+ "-I", Arg.String (fun s -> incdirs := s :: !incdirs),
+ "DIR
+ Add directory DIR to the search path for included files";
+
+ "-V", Arg.String (fun s -> header := parse_version_spec s @ !header),
+ "VAR:MAJOR.MINOR.PATCH-OPTPRERELEASE+OPTBUILD
+ Define the following variables extracted from a version string
+ (following the Semantic Versioning syntax http://semver.org/):
+
+ VAR_MAJOR must be a non-negative int
+ VAR_MINOR must be a non-negative int
+ VAR_PATCH must be a non-negative int
+ VAR_PRERELEASE if the OPTPRERELEASE part exists
+ VAR_BUILD if the OPTBUILD part exists
+ VAR_VERSION is the tuple (MAJOR, MINOR, PATCH)
+ VAR_VERSION_STRING is the string MAJOR.MINOR.PATCH
+ VAR_VERSION_FULL is the original string
+
+ Example: cppo -V OCAML:4.02.1
+
+ Note that cppo recognises both '-' and '~' preceding the pre-release
+ meaning -V OCAML:4.11.0+alpha1 sets OCAML_BUILD to alpha1 but
+ -V OCAML:4.12.0~alpha1 sets OCAML_PRERELEASE to alpha1.
+";
+
+ "-o", Arg.String (fun s -> out_file := Some s),
+ "FILE
+ Output file";
+
+ "-q", Arg.Set preserve_quotations,
+ "
+ Identify and preserve camlp4 quotations";
+
+ "-s", Arg.Set show_exact_locations,
+ "
+ Output line directives pointing to the exact source location of
+ each token, including those coming from the body of macro
+ definitions. This behavior is off by default.";
+
+ "-n", Arg.Set show_no_locations,
+ "
+ Do not output any line directive other than those found in the
+ input (overrides -s).";
+
+ "-version", Arg.Unit (fun () ->
+ print_endline Cppo_version.cppo_version;
+ exit 0),
+ "
+ Print the version of the program and exit.";
+
+ "-x", Arg.String (fun s -> add_extension extensions s),
+ "NAME:CMD_TEMPLATE
+ Define a custom preprocessor target section starting with:
+ #ext \"NAME\"
+ and ending with:
+ #endext
+
+ NAME must be a lowercase identifier of the form [a-z][A-Za-z0-9_]*
+
+ CMD_TEMPLATE is a command template supporting the following
+ special sequences:
+ %F file name (unescaped; beware of potential scripting attacks)
+ %B number of the first line
+ %E number of the last line
+ %% a single percent sign
+
+ Filename, first line number and last line number are also
+ available from the following environment variables:
+ CPPO_FILE, CPPO_FIRST_LINE, CPPO_LAST_LINE.
+
+ The command produced is expected to read the data lines from stdin
+ and to write its output to stdout."
+ ]
+ in
+ let msg = sprintf "\
+Usage: %s [OPTIONS] [FILE1 [FILE2 ...]]
+Options:" Sys.argv.(0) in
+ let add_file s = files := s :: !files in
+ Arg.parse options add_file msg;
+
+ let inputs =
+ let preliminaries =
+ match List.rev !header with
+ [] -> []
+ | l ->
+ let s = String.concat "" l in
+ [ Sys.getcwd (),
+ "<command line>",
+ (fun () -> Lexing.from_string s),
+ (fun () -> ()) ]
+ in
+ let main =
+ match List.rev !files with
+ [] -> [ Sys.getcwd (),
+ "<stdin>",
+ (fun () -> Lexing.from_channel stdin),
+ (fun () -> ()) ]
+ | l ->
+ List.map (
+ fun file ->
+ let ic = lazy (open_in file) in
+ Filename.dirname file,
+ file,
+ (fun () -> Lexing.from_channel (Lazy.force ic)),
+ (fun () -> close_in (Lazy.force ic))
+ ) l
+ in
+ preliminaries @ main
+ in
+
+ let env = Cppo_eval.builtin_env in
+ let buf = Buffer.create 10_000 in
+ let _env =
+ Cppo_eval.include_inputs
+ ~extensions
+ ~preserve_quotations: !preserve_quotations
+ ~incdirs: (List.rev !incdirs)
+ ~show_exact_locations: !show_exact_locations
+ ~show_no_locations: !show_no_locations
+ buf env inputs
+ in
+ match !out_file with
+ None ->
+ print_string (Buffer.contents buf);
+ flush stdout
+ | Some file ->
+ let oc = open_out file in
+ output_string oc (Buffer.contents buf);
+ close_out oc
+
+let () =
+ if not !Sys.interactive then
+ try
+ main ()
+ with
+ | Cppo_types.Cppo_error msg
+ | Failure msg ->
+ eprintf "Error: %s\n%!" msg;
+ exit 1
new file mode 100644
@@ -0,0 +1,266 @@
+%{
+ open Cppo_types
+%}
+
+/* Directives */
+%token < Cppo_types.loc * string > DEF DEFUN UNDEF INCLUDE WARNING ERROR
+%token < Cppo_types.loc * string option * int > LINE
+%token < Cppo_types.loc * Cppo_types.bool_expr > IFDEF
+%token < Cppo_types.loc * string * string > EXT
+%token < Cppo_types.loc > ENDEF IF ELIF ELSE ENDIF ENDTEST
+
+/* Boolean expressions in #if/#elif directives */
+%token TRUE FALSE DEFINED NOT AND OR EQ LT GT NE LE GE
+ PLUS MINUS STAR LNOT LSL LSR ASR LAND LOR LXOR
+%token < Cppo_types.loc > OP_PAREN SLASH MOD
+%token < int64 > INT
+
+
+/* Regular program and shared terminals */
+%token < Cppo_types.loc > CL_PAREN COMMA CURRENT_LINE CURRENT_FILE
+%token < Cppo_types.loc * string > IDENT FUNIDENT
+%token < Cppo_types.loc * bool * string > TEXT /* bool means "is space" */
+%token EOF
+
+/* Priorities for boolean expressions */
+%left OR
+%left AND
+
+/* Priorities for arithmetics */
+%left PLUS MINUS
+%left STAR SLASH
+%left MOD LSL LSR ASR LAND LOR LXOR
+%nonassoc NOT
+%nonassoc LNOT
+%nonassoc UMINUS
+
+%start main
+%type < Cppo_types.node list > main
+%%
+
+main:
+| unode main { $1 :: $2 }
+| EOF { [] }
+;
+
+unode_list0:
+| unode unode_list0 { $1 :: $2 }
+| { [] }
+;
+
+pnode_list0:
+| pnode pnode_list0 { $1 :: $2 }
+| { [] }
+;
+
+/* node in which opening and closing parentheses don't need to match */
+unode:
+| node { $1 }
+| OP_PAREN { `Text ($1, false, "(") }
+| CL_PAREN { `Text ($1, false, ")") }
+| COMMA { `Text ($1, false, ",") }
+;
+
+/* node in which parentheses must be closed */
+pnode:
+| node { $1 }
+| OP_PAREN pnode_or_comma_list0 CL_PAREN
+ { `Seq [`Text ($1, false, "(");
+ `Seq $2;
+ `Text ($3, false, ")")] }
+;
+
+/* node without parentheses handling (need to use unode or pnode) */
+node:
+| TEXT { `Text $1 }
+
+| IDENT { let loc, name = $1 in
+ `Ident (loc, name, None) }
+
+| FUNIDENT args1 CL_PAREN
+ {
+ (* macro application that receives at least one argument,
+ possibly empty. We cannot distinguish syntactically between
+ zero argument and one empty argument.
+ *)
+ let (pos1, _), name = $1 in
+ let _, pos2 = $3 in
+ `Ident ((pos1, pos2), name, Some $2) }
+| FUNIDENT error
+ { error (fst $1) "Invalid macro application" }
+
+| CURRENT_LINE { `Current_line $1 }
+| CURRENT_FILE { `Current_file $1 }
+
+| DEF unode_list0 ENDEF
+ { let (pos1, _), name = $1 in
+
+ (* Additional spacing is needed for cases like '+foo+'
+ expanding into '++' instead of '+ +'. *)
+ let safe_space = `Text ($3, true, " ") in
+
+ let body = $2 @ [safe_space] in
+ let _, pos2 = $3 in
+ `Def ((pos1, pos2), name, body) }
+
+| DEFUN def_args1 CL_PAREN unode_list0 ENDEF
+ { let (pos1, _), name = $1 in
+ let args = $2 in
+
+ (* Additional spacing is needed for cases like 'foo()bar'
+ where 'foo()' expands into 'abc', giving 'abcbar'
+ instead of 'abc bar';
+ Also needed for '+foo()+' expanding into '++' instead
+ of '+ +'. *)
+ let safe_space = `Text ($5, true, " ") in
+
+ let body = $4 @ [safe_space] in
+ let _, pos2 = $5 in
+ `Defun ((pos1, pos2), name, args, body) }
+
+| DEFUN CL_PAREN
+ { error (fst (fst $1), snd $2)
+ "At least one argument is required" }
+
+| UNDEF
+ { `Undef $1 }
+| WARNING
+ { `Warning $1 }
+| ERROR
+ { `Error $1 }
+
+| INCLUDE
+ { `Include $1 }
+
+| EXT
+ { `Ext $1 }
+
+| IF test unode_list0 elif_list ENDIF
+ { let pos1, _ = $1 in
+ let _, pos2 = $5 in
+ let loc = (pos1, pos2) in
+ let test = $2 in
+ let if_true = $3 in
+ let if_false =
+ List.fold_right (
+ fun (loc, test, if_true) if_false ->
+ [`Cond (loc, test, if_true, if_false) ]
+ ) $4 []
+ in
+ `Cond (loc, test, if_true, if_false)
+ }
+
+| IF test unode_list0 elif_list error
+ { (* BUG? ocamlyacc fails to reduce that rule but not menhir *)
+ error $1 "missing #endif" }
+
+| IFDEF unode_list0 elif_list ENDIF
+ { let (pos1, _), test = $1 in
+ let _, pos2 = $4 in
+ let loc = (pos1, pos2) in
+ let if_true = $2 in
+ let if_false =
+ List.fold_right (
+ fun (loc, test, if_true) if_false ->
+ [`Cond (loc, test, if_true, if_false) ]
+ ) $3 []
+ in
+ `Cond (loc, test, if_true, if_false)
+ }
+
+| IFDEF unode_list0 elif_list error
+ { error (fst $1) "missing #endif" }
+
+| LINE { `Line $1 }
+;
+
+
+elif_list:
+ ELIF test unode_list0 elif_list
+ { let pos1, _ = $1 in
+ let pos2 = Parsing.rhs_end_pos 4 in
+ ((pos1, pos2), $2, $3) :: $4 }
+| ELSE unode_list0
+ { let pos1, _ = $1 in
+ let pos2 = Parsing.rhs_end_pos 2 in
+ [ ((pos1, pos2), `True, $2) ] }
+| { [] }
+;
+
+args1:
+ pnode_list0 COMMA args1 { $1 :: $3 }
+| pnode_list0 { [ $1 ] }
+;
+
+pnode_or_comma_list0:
+| pnode pnode_or_comma_list0 { $1 :: $2 }
+| COMMA pnode_or_comma_list0 { `Text ($1, false, ",") :: $2 }
+| { [] }
+;
+
+def_args1:
+| arg_blank IDENT COMMA def_args1
+ { (snd $2) :: $4 }
+| arg_blank IDENT { [ snd $2 ] }
+;
+
+arg_blank:
+| TEXT arg_blank { let loc, is_space, _s = $1 in
+ if not is_space then
+ error loc "Invalid argument list"
+ }
+| { () }
+;
+
+test:
+ bexpr ENDTEST { $1 }
+;
+
+/* Boolean expressions after #if or #elif */
+bexpr:
+ | TRUE { `True }
+ | FALSE { `False }
+ | DEFINED IDENT { `Defined (snd $2) }
+ | OP_PAREN bexpr CL_PAREN { $2 }
+ | NOT bexpr { `Not $2 }
+ | bexpr AND bexpr { `And ($1, $3) }
+ | bexpr OR bexpr { `Or ($1, $3) }
+ | aexpr EQ aexpr { `Eq ($1, $3) }
+ | aexpr LT aexpr { `Lt ($1, $3) }
+ | aexpr GT aexpr { `Gt ($1, $3) }
+ | aexpr NE aexpr { `Not (`Eq ($1, $3)) }
+ | aexpr LE aexpr { `Not (`Gt ($1, $3)) }
+ | aexpr GE aexpr { `Not (`Lt ($1, $3)) }
+;
+
+/* Arithmetic expressions within boolean expressions */
+aexpr:
+ | INT { `Int $1 }
+ | IDENT { `Ident $1 }
+ | OP_PAREN aexpr_list CL_PAREN
+ { match $2 with
+ | [x] -> x
+ | l ->
+ let pos1, _ = $1 in
+ let _, pos2 = $3 in
+ `Tuple ((pos1, pos2), l)
+ }
+ | aexpr PLUS aexpr { `Add ($1, $3) }
+ | aexpr MINUS aexpr { `Sub ($1, $3) }
+ | aexpr STAR aexpr { `Mul ($1, $3) }
+ | aexpr SLASH aexpr { `Div ($2, $1, $3) }
+ | aexpr MOD aexpr { `Mod ($2, $1, $3) }
+ | aexpr LSL aexpr { `Lsl ($1, $3) }
+ | aexpr LSR aexpr { `Lsr ($1, $3) }
+ | aexpr ASR aexpr { `Asr ($1, $3) }
+ | aexpr LAND aexpr { `Land ($1, $3) }
+ | aexpr LOR aexpr { `Lor ($1, $3) }
+ | aexpr LXOR aexpr { `Lxor ($1, $3) }
+ | LNOT aexpr { `Lnot $2 }
+ | MINUS aexpr %prec UMINUS { `Neg $2 }
+;
+
+aexpr_list:
+ | aexpr COMMA aexpr_list { $1 :: $3 }
+ | aexpr { [$1] }
+;
new file mode 100644
@@ -0,0 +1,98 @@
+open Printf
+open Lexing
+
+module String_set = Set.Make (String)
+module String_map = Map.Make (String)
+
+type loc = position * position
+
+type bool_expr =
+ [ `True
+ | `False
+ | `Defined of string
+ | `Not of bool_expr (* not *)
+ | `And of (bool_expr * bool_expr) (* && *)
+ | `Or of (bool_expr * bool_expr) (* || *)
+ | `Eq of (arith_expr * arith_expr) (* = *)
+ | `Lt of (arith_expr * arith_expr) (* < *)
+ | `Gt of (arith_expr * arith_expr) (* > *)
+ (* syntax for additional operators: <>, <=, >= *)
+ ]
+
+and arith_expr = (* signed int64 *)
+ [ `Int of int64
+ | `Ident of (loc * string)
+ (* must be bound to a valid int literal.
+ Expansion of macro functions is not supported. *)
+
+ | `Tuple of (loc * arith_expr list)
+ (* tuple of 2 or more elements guaranteed by the syntax *)
+
+ | `Neg of arith_expr (* - *)
+ | `Add of (arith_expr * arith_expr) (* + *)
+ | `Sub of (arith_expr * arith_expr) (* - *)
+ | `Mul of (arith_expr * arith_expr) (* * *)
+ | `Div of (loc * arith_expr * arith_expr) (* / *)
+ | `Mod of (loc * arith_expr * arith_expr) (* mod *)
+
+ (* Bitwise operations on 64 bits *)
+ | `Lnot of arith_expr (* lnot *)
+ | `Lsl of (arith_expr * arith_expr) (* lsl *)
+ | `Lsr of (arith_expr * arith_expr) (* lsr *)
+ | `Asr of (arith_expr * arith_expr) (* asr *)
+ | `Land of (arith_expr * arith_expr) (* land *)
+ | `Lor of (arith_expr * arith_expr) (* lor *)
+ | `Lxor of (arith_expr * arith_expr) (* lxor *)
+ ]
+
+and node =
+ [ `Ident of (loc * string * node list list option)
+ | `Def of (loc * string * node list)
+ | `Defun of (loc * string * string list * node list)
+ | `Undef of (loc * string)
+ | `Include of (loc * string)
+ | `Ext of (loc * string * string)
+ | `Cond of (loc * bool_expr * node list * node list)
+ | `Error of (loc * string)
+ | `Warning of (loc * string)
+ | `Text of (loc * bool * string) (* bool is true for space tokens *)
+ | `Seq of node list
+ | `Stringify of node
+ | `Capitalize of node
+ | `Concat of (node * node)
+ | `Line of (loc * string option * int)
+ | `Current_line of loc
+ | `Current_file of loc ]
+
+
+
+let string_of_loc (pos1, pos2) =
+ let line1 = pos1.pos_lnum
+ and start1 = pos1.pos_bol in
+ Printf.sprintf "File %S, line %i, characters %i-%i"
+ pos1.pos_fname line1
+ (pos1.pos_cnum - start1)
+ (pos2.pos_cnum - start1)
+
+
+exception Cppo_error of string
+
+let error loc s =
+ let msg =
+ sprintf "%s\nError: %s" (string_of_loc loc) s in
+ raise (Cppo_error msg)
+
+let warning loc s =
+ let msg =
+ sprintf "%s\nWarning: %s" (string_of_loc loc) s in
+ eprintf "%s\n%!" msg
+
+let dummy_loc = (Lexing.dummy_pos, Lexing.dummy_pos)
+
+let rec flatten_nodes (l: node list): node list =
+ List.flatten (List.map flatten_node l)
+
+and flatten_node (node: node): node list =
+ match node with
+ | `Seq l -> flatten_nodes l
+ | x -> [x]
new file mode 100644
@@ -0,0 +1,70 @@
+type loc = Lexing.position * Lexing.position
+
+exception Cppo_error of string
+
+type bool_expr =
+ [ `True
+ | `False
+ | `Defined of string
+ | `Not of bool_expr (* not *)
+ | `And of (bool_expr * bool_expr) (* && *)
+ | `Or of (bool_expr * bool_expr) (* || *)
+ | `Eq of (arith_expr * arith_expr) (* = *)
+ | `Lt of (arith_expr * arith_expr) (* < *)
+ | `Gt of (arith_expr * arith_expr) (* > *)
+ (* syntax for additional operators: <>, <=, >= *)
+ ]
+
+and arith_expr = (* signed int64 *)
+ [ `Int of int64
+ | `Ident of (loc * string)
+ (* must be bound to a valid int literal.
+ Expansion of macro functions is not supported. *)
+
+ | `Tuple of (loc * arith_expr list)
+ (* tuple of 2 or more elements guaranteed by the syntax *)
+
+ | `Neg of arith_expr (* - *)
+ | `Add of (arith_expr * arith_expr) (* + *)
+ | `Sub of (arith_expr * arith_expr) (* - *)
+ | `Mul of (arith_expr * arith_expr) (* * *)
+ | `Div of (loc * arith_expr * arith_expr) (* / *)
+ | `Mod of (loc * arith_expr * arith_expr) (* mod *)
+
+ (* Bitwise operations on 64 bits *)
+ | `Lnot of arith_expr (* lnot *)
+ | `Lsl of (arith_expr * arith_expr) (* lsl *)
+ | `Lsr of (arith_expr * arith_expr) (* lsr *)
+ | `Asr of (arith_expr * arith_expr) (* asr *)
+ | `Land of (arith_expr * arith_expr) (* land *)
+ | `Lor of (arith_expr * arith_expr) (* lor *)
+ | `Lxor of (arith_expr * arith_expr) (* lxor *)
+ ]
+
+and node =
+ [ `Ident of (loc * string * node list list option)
+ | `Def of (loc * string * node list)
+ | `Defun of (loc * string * string list * node list)
+ | `Undef of (loc * string)
+ | `Include of (loc * string)
+ | `Ext of (loc * string * string)
+ | `Cond of (loc * bool_expr * node list * node list)
+ | `Error of (loc * string)
+ | `Warning of (loc * string)
+ | `Text of (loc * bool * string) (* bool is true for space tokens *)
+ | `Seq of node list
+ | `Stringify of node
+ | `Capitalize of node
+ | `Concat of (node * node)
+ | `Line of (loc * string option * int)
+ | `Current_line of loc
+ | `Current_file of loc ]
+
+val dummy_loc : loc
+
+val error : loc -> string -> _
+
+val warning : loc -> string -> unit
+
+val flatten_nodes : node list -> node list
+
new file mode 100644
@@ -0,0 +1 @@
+val cppo_version : string
new file mode 100644
@@ -0,0 +1,21 @@
+(ocamllex cppo_lexer)
+
+(ocamlyacc cppo_parser)
+
+(rule
+ (targets cppo_version.ml)
+ (action
+ (with-stdout-to
+ %{targets}
+ (echo "let cppo_version = \"%{version:cppo}\""))))
+
+(executable
+ (name cppo_main)
+ (package cppo)
+ (public_name cppo)
+ (modules :standard \ compat)
+ (preprocess (per_module
+ ((action (progn
+ (run ocaml %{dep:compat.ml} %{input-file})
+ (cat %{input-file}))) cppo_eval)))
+ (libraries unix str))
new file mode 100644
@@ -0,0 +1,6 @@
+
+
+#define EVENT(n,ty) external CONCAT(on,CAPITALIZE(n)) : ty = STRINGIFY(n) [@@bs.val]
+
+
+EVENT(exit, unit -> unit)
\ No newline at end of file
new file mode 100644
@@ -0,0 +1,6 @@
+
+
+
+
+# 6 "capital.cppo"
+ external onExit : unit -> unit = "exit" [@@bs.val]
\ No newline at end of file
new file mode 100644
@@ -0,0 +1,7 @@
+(* '"' *)
+
+#define BE_GONE
+
+(* "*)"
+#define DONT_TOUCH_THIS
+*)
new file mode 100644
@@ -0,0 +1,8 @@
+# 1 "comments.cppo"
+(* '"' *)
+
+
+# 5 "comments.cppo"
+(* "*)"
+#define DONT_TOUCH_THIS
+*)
new file mode 100644
@@ -0,0 +1,47 @@
+#if 1 = 1
+#else
+#error "ignored #else (?)"
+#endif
+
+#if true
+ banana
+#elif false
+ apple
+ #error "ignored #elif (?)"
+#endif
+
+#if false
+ earthworm
+ #error ""
+#elif true
+ apricot
+#endif
+
+#if false
+ cuckoo
+ #error ""
+#else
+ #if false
+ egg
+ #error ""
+ #else
+ nest
+ #endif
+#endif
+
+#define X 3
+
+#if false
+ helicopter
+ #error ""
+#elif false
+ ocean
+ #error ""
+#else
+ #if X = 12
+ sand
+ #error ""
+ #elif 4 * X = 12
+ sea urchin
+ #endif
+#endif
new file mode 100644
@@ -0,0 +1,17 @@
+
+
+# 7 "cond.cppo"
+ banana
+
+
+# 17 "cond.cppo"
+ apricot
+
+
+# 28 "cond.cppo"
+ nest
+
+
+
+# 45 "cond.cppo"
+ sea urchin
new file mode 100644
@@ -0,0 +1,130 @@
+(rule
+ (targets ext.out)
+ (deps
+ (:< ext.cppo)
+ source.sh)
+ (action
+ (with-stdout-to
+ %{targets}
+ (run %{bin:cppo} -x "rot13:tr '[a-z]' '[n-za-m]'" -x
+ "source:sh source.sh '%F' %B %E" %{<}))))
+
+(rule
+ (targets comments.out)
+ (deps
+ (:< comments.cppo))
+ (action
+ (with-stdout-to
+ %{targets}
+ (run %{bin:cppo} %{<}))))
+
+(rule
+ (targets cond.out)
+ (deps
+ (:< cond.cppo))
+ (action
+ (with-stdout-to
+ %{targets}
+ (run %{bin:cppo} %{<}))))
+
+(rule
+ (targets tuple.out)
+ (deps
+ (:< tuple.cppo))
+ (action
+ (with-stdout-to
+ %{targets}
+ (run %{bin:cppo} %{<}))))
+
+(rule
+ (targets loc.out)
+ (deps
+ (:< loc.cppo))
+ (action
+ (with-stdout-to
+ %{targets}
+ (run %{bin:cppo} %{<}))))
+
+(rule
+ (targets paren_arg.out)
+ (deps
+ (:< paren_arg.cppo))
+ (action
+ (with-stdout-to
+ %{targets}
+ (run %{bin:cppo} %{<}))))
+
+(rule
+ (targets unmatched.out)
+ (deps
+ (:< unmatched.cppo))
+ (action
+ (with-stdout-to
+ %{targets}
+ (run %{bin:cppo} %{<}))))
+
+(rule
+ (targets version.out)
+ (deps
+ (:< version.cppo))
+ (action
+ (with-stdout-to
+ %{targets}
+ (run %{bin:cppo} -V X:123.05.2-alpha.1+foo-2.1 %{<}))))
+
+(alias
+ (name runtest)
+ (package cppo)
+ (action
+ (diff ext.ref ext.out)))
+
+(alias
+ (name runtest)
+ (package cppo)
+ (action
+ (diff comments.ref comments.out)))
+
+(alias
+ (name runtest)
+ (package cppo)
+ (action
+ (diff cond.ref cond.out)))
+
+(alias
+ (name runtest)
+ (package cppo)
+ (action
+ (diff tuple.ref tuple.out)))
+
+(alias
+ (name runtest)
+ (package cppo)
+ (action
+ (diff loc.ref loc.out)))
+
+(alias
+ (name runtest)
+ (package cppo)
+ (action
+ (diff paren_arg.ref paren_arg.out)))
+
+(alias
+ (name runtest)
+ (package cppo)
+ (deps version.out))
+
+(alias
+ (name runtest)
+ (package cppo)
+ (action
+ (diff unmatched.ref unmatched.out)))
+
+(alias
+ (name runtest)
+ (package cppo)
+ (deps
+ (:< test.cppo)
+ incl.cppo
+ incl2.cppo)
+ (action
+ (ignore-stdout (run %{bin:cppo} %{<}))))
new file mode 100644
@@ -0,0 +1,10 @@
+hello
+#ext rot13
+abc
+\#endext
+def
+#endext
+goodbye
+
+#ext source
+#endext
new file mode 100644
@@ -0,0 +1,28 @@
+# 1 "ext.cppo"
+hello
+nop
+#raqrkg
+qrs
+# 7 "ext.cppo"
+goodbye
+
+# 9
+(*
+hello
+#ext rot13
+abc
+\#endext
+def
+#endext
+goodbye
+
+#ext source
+#endext
+*)
+(*
+ Environment variables:
+ CPPO_FILE=ext.cppo
+ CPPO_FIRST_LINE=9
+ CPPO_LAST_LINE=11
+*)
+# 11
new file mode 100644
@@ -0,0 +1,3 @@
+included
+
+#include "incl2.cppo"
new file mode 100644
@@ -0,0 +1 @@
+ok
new file mode 100644
@@ -0,0 +1,8 @@
+#define loc __FILE__ __LINE__
+loc
+X(loc)
+X(loc)
+X(Y(loc))
+
+#define F(x) loc
+F()
new file mode 100644
@@ -0,0 +1,21 @@
+# 2 "loc.cppo"
+ "loc.cppo" 2
+# 3 "loc.cppo"
+X(
+# 3 "loc.cppo"
+ "loc.cppo" 3
+# 3 "loc.cppo"
+)
+X(
+# 4 "loc.cppo"
+ "loc.cppo" 4
+# 4 "loc.cppo"
+)
+X(Y(
+# 5 "loc.cppo"
+ "loc.cppo" 5
+# 5 "loc.cppo"
+ ))
+
+# 8 "loc.cppo"
+ "loc.cppo" 8
new file mode 100644
@@ -0,0 +1,3 @@
+#define F(x, y) <x> <y>
+F((1, (2)), 34)
+F((1\,\(2\)), 34)
new file mode 100644
@@ -0,0 +1,4 @@
+# 2 "paren_arg.cppo"
+ <(1, (2))> < 34>
+# 3 "paren_arg.cppo"
+ <(1 , (2 ))> < 34>
new file mode 100755
@@ -0,0 +1,13 @@
+#! /bin/sh -e
+
+echo "# $2"
+echo "(*"
+cat "$1"
+echo "*)"
+echo "(*"
+echo " Environment variables:"
+echo " CPPO_FILE=$CPPO_FILE"
+echo " CPPO_FIRST_LINE=$CPPO_FIRST_LINE"
+echo " CPPO_LAST_LINE=$CPPO_LAST_LINE"
+echo "*)"
+echo "# $3"
new file mode 100644
@@ -0,0 +1,144 @@
+(* comment *)
+
+#define pi 3.14
+f(1)
+#define f(x) x+pi
+f(2)
+#undef pi
+f(3)
+
+#ifdef g
+"g" is defined
+#else
+"g" is not defined
+#endif
+
+#define a(x) b()
+#define b(x) a()
+a()
+
+debug("a")
+debug("b")
+
+#define z 123
+#define y z
+#define x y
+
+#if x lsl 1 = 2*123
+
+#if 1 = 2
+#error "test"
+#endif
+
+success
+#else
+failure
+#endif
+
+#define test_multiline \
+"abc\
+ def" \
+(* 123 \
+ 456 *)
+test_multiline
+
+#define test_args(x, y) x y
+test_args("a","b")
+
+#define test_argc(x) x y
+test_argc(aa\,bb)
+
+#define test_esc(x) x
+test_esc(\,\)\()
+
+blah #define xyz
+#ifdef xyz
+#error "xyz should not have been defined"
+#endif
+
+#define sticky1(x) _
+#define sticky2(x) sticky1()_ (* the 2 underscores should be space-separated *)
+sticky2()
+
+#define empty1
+#define empty2 +empty1+ (* there should be some space between the pluses *)
+empty2
+
+(* (* nested comment with single single quote: ' *) "*)" *)
+
+#define arg
+obj
+ \# define arg
+
+' (* lone single quote *)
+
+#define one 1
+one is not 1
+
+#undef x
+#define x #
+x is #
+
+#undef one
+#define one 1
+#if (one+one = 100 + \
+ 64 lsr 3 / 4 - lnot lnot 100) && \
+ 1 + 3 * 5 = 16 && \
+ 22 mod 7 = 1 && \
+ lnot 0 = 0xffffffffffffffff && \
+ -1 asr 100 = -1 && \
+ -1 land (1 lsl 1 lsr 1) = 1 && \
+ -1 lor 1 = -1 && \
+ -2 lxor 1 = -1 && \
+ lnot -1 = 0 && \
+ true && not false && defined one && \
+ (true || true && false)
+good maths
+#else
+#error "math error"
+#endif
+
+
+#undef f
+#undef g
+#undef x
+#undef y
+
+#define trace(f) \
+let f x = \
+ printf "call %s\n%!" STRINGIFY(f); \
+ let y = f x in \
+ printf "return %s\n%!" STRINGIFY(f); \
+ y \
+;;
+
+trace(g)
+
+#define field(name,type) \
+ val mutable name : type option \
+ method CONCAT(get_, name) = name \
+ method CONCAT(set_, name) x = name <- Some x
+
+class foo () =
+object
+ field(field_1, int)
+ field(field_2, string)
+end
+
+#define DEBUG(x) \
+ (if !debug then \
+ eprintf "[debug] %s %i: " __FILE__ __LINE__; \
+ eprintf x; \
+ eprintf "\n")
+DEBUG("test1 %i %i" x y)
+DEBUG("test2 %i" x)
+
+#include "incl.cppo"
+# 123456
+
+#789 "test"
+#include "incl.cppo"
+
+#define debug(s) Printf.eprintf "%S %i: %s\n%!" __FILE__ __LINE__ s
+
+end
new file mode 100644
@@ -0,0 +1,38 @@
+#if (2 + 2, 5) < (4, 5)
+ mountain
+ #error ""
+#else
+ pistachios
+#endif
+
+#if (3 * 3) = 10 - 1
+ trees
+#else
+ rocks
+ #error ""
+#endif
+
+#if (1) = (1)
+ waves
+#else
+ sharks
+ #error ""
+#endif
+
+
+#define x 11
+#if (x, 2) <> (x, 4/2)
+ honey
+ #error ""
+#else
+ bees
+#endif
+
+#define tuple (0, -5, 3)
+#define tuple2 tuple
+#if (0, -5, x) > tuple2
+ steamboat
+#else
+ koalas
+ #error ""
+#endif
new file mode 100644
@@ -0,0 +1,20 @@
+
+# 5 "tuple.cppo"
+ pistachios
+
+
+# 9 "tuple.cppo"
+ trees
+
+
+# 16 "tuple.cppo"
+ waves
+
+
+
+# 28 "tuple.cppo"
+ bees
+
+
+# 34 "tuple.cppo"
+ steamboat
new file mode 100644
@@ -0,0 +1,14 @@
+#ifdef whatever
+ (
+#else
+ let a = 1 in
+ let b = 2 in
+ (a ||
+#endif
+
+ b)
+
+#define F(x, y) (x + y)
+F(1,(2+3))
+)
+(
new file mode 100644
@@ -0,0 +1,15 @@
+
+# 4 "unmatched.cppo"
+ let a = 1 in
+ let b = 2 in
+ (a ||
+
+
+# 9 "unmatched.cppo"
+ b)
+
+# 12 "unmatched.cppo"
+ (1 + (2+3))
+# 13 "unmatched.cppo"
+)
+(
new file mode 100644
@@ -0,0 +1,30 @@
+#if X_VERSION < (123, 0, 0)
+ alligators
+ #error ""
+#else
+ Cape buffalos
+#endif
+
+#define v X_VERSION
+#if v = (X_MAJOR, X_MINOR, X_PATCH)
+ onion rings
+#else
+ gazpacho
+ #error ""
+#endif
+
+major: X_MAJOR
+minor: X_MINOR
+patch: X_PATCH
+
+#ifdef X_PRERELEASE
+ prerelease: X_PRERELEASE
+#else
+ #error ""
+#endif
+
+#ifdef X_BUILD
+ build: X_BUILD
+#else
+ #error ""
+#endif
new file mode 100644
@@ -0,0 +1,5 @@
+_build
+crowbar.install
+*.byte
+*.native
+.merlin
new file mode 100644
@@ -0,0 +1,9 @@
+v0.2 (04 May 2020)
+---------------------
+
+New generators, printers and port to dune.
+
+v0.1 (01 February 2018)
+---------------------
+
+Initial release
new file mode 100644
@@ -0,0 +1,8 @@
+Copyright (c) 2017 Stephen Dolan
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
new file mode 100644
@@ -0,0 +1,82 @@
+# Crowbar
+
+**Crowbar** is a library for testing code, combining QuickCheck-style
+ property-based testing and the magical bug-finding powers of
+ [afl-fuzz](http://lcamtuf.coredump.cx/afl/).
+
+## TL;DR
+
+There are [some examples](./examples).
+
+Some brief hints:
+
+1. Use an opam switch with AFL instrumentation enabled (e.g. `opam sw 4.04.0+afl`).
+2. Run in AFL mode with `afl-fuzz -i in -o out -- ./_build/myprog.exe @@`.
+3. If you run your executable without arguments, crowbar will perform some simple (non-AFL) testing instead.
+4. Test binaries have a small amount of documentation, available with `--help`.
+
+## writing tests
+
+To test your software, come up with a property you'd like to test, then decide on the input you'd like for Crowbar to vary. A Crowbar test is some invocation of `Crowbar.check_eq` or `Crowbar.check`:
+
+```ocaml
+let identity x =
+ Crowbar.check_eq x x
+```
+
+and instructions for running the test with generated items with `Crowbar.add_test`:
+
+```ocaml
+let () =
+ Crowbar.(add_test ~name:"identity function" [int] (fun i -> identity i))
+```
+
+There are [more examples available](./examples), with varying levels complexity.
+
+## building tests
+
+Include `crowbar` in your list of dependencies via your favorite build system. The resulting executable is a Crowbar test. (Be sure to build a native-code executable, not bytecode.)
+
+To build tests that run under AFL, you'll need to build your tests with a compiler that has AFL instrumentation enabled. (You can also enable it specifically for your build, although this is not recommended if your code has any dependencies, including the OCaml standard library). OCaml compiler variants with AFL enabled by default are available in `opam` with the `+afl` tag. All versions published starting with 4.05.0 are available, along with a backported 4.04.0.
+
+```shell
+$ opam switch 4.06.0+afl
+$ eval `opam config env`
+$ ./build_my_rad_test.sh # or your relevant build runes
+```
+
+## running Tests
+
+Crowbar tests have two modes:
+
+* a simple quickcheck-like mode for testing propositions against totally random input
+* a mode using [afl-persistent](https://github.com/stedolan/ocaml-afl-persistent) to get good performance from `afl-fuzz` with OCaml's instrumentation enabled
+
+Crowbar tests can be directly invoked with `--help` for more documentation at runtime.
+
+### fully random test mode
+
+If you wish to use the quickcheck-like, fully random mode to run all tests distributed here, build the tests as above and then run the binary with no arguments.
+
+```
+$ ./my_rad_test.exe | head -5
+the first test: PASS
+
+the second test: PASS
+```
+
+### AFL mode requirements
+
+To run the tests in AFL mode, you'll need to install American Fuzzy Lop ([latest source tarball](http://lcamtuf.coredump.cx/afl/releases/afl-latest.tgz), although your distribution may also have a package available).
+
+Once `afl-fuzz` is available on your system, create an `input` directory with a non-empty file in it (or use `test/input`, conveniently provided in this repository), and an `output` directory for `afl-fuzz` to store its findings. Then, invoke your test binary:
+
+```
+afl-fuzz -i test/input -o output ./my_rad_test.exe @@
+```
+
+This will launch AFL, which will generate new test cases and track the exploration of the state space. When inputs are discovered which cause a property not to hold, they will be reported as crashes (along with actual crashes, although in the OCaml standard library these are rare). See the [afl-fuzz documentation](https://lcamtuf.coredump.cx/afl/status_screen.txt) for more on AFL's excellent interface.
+
+# What bugs have you found?
+
+[An open issue](https://github.com/stedolan/crowbar/issues/2) has a list of issues discovered by testing with Crowbar. If you use Crowbar to improve your software, please let us know!
new file mode 100644
@@ -0,0 +1,33 @@
+opam-version: "2.0"
+maintainer: "stephen.dolan@cl.cam.ac.uk"
+authors: ["Stephen Dolan"]
+homepage: "https://github.com/stedolan/crowbar"
+bug-reports: "https://github.com/stedolan/crowbar/issues"
+dev-repo: "git+https://github.com/stedolan/crowbar.git"
+license: "MIT"
+build: [
+ [ "dune" "build" "-p" name "-j" jobs ]
+]
+run-test: [
+ [ "dune" "runtest" "-p" name "-j" jobs ]
+]
+depends: [
+ "dune" {build & >= "1.1"}
+ "ocaml" {>= "4.02.0"}
+ "ocplib-endian"
+ "cmdliner"
+ "afl-persistent" {>= "1.1"}
+ "calendar" {with-test}
+ "xmldiff" {with-test}
+ "fpath" {with-test}
+ "pprint" {with-test & < "20180528"}
+ "uucp" {with-test}
+ "uunf" {with-test}
+ "uutf" {with-test}
+]
+synopsis: "Write tests, let a fuzzer find failing cases"
+description: """
+Crowbar is a library for testing code, combining QuickCheck-style
+property-based testing and the magical bug-finding powers of
+[afl-fuzz](http://lcamtuf.coredump.cx/afl/).
+"""
new file mode 100644
@@ -0,0 +1 @@
+(env (dev (flags (:standard -warn-error -A))))
new file mode 100644
@@ -0,0 +1,2 @@
+(lang dune 1.1)
+(name crowbar)
new file mode 100644
@@ -0,0 +1 @@
+output
new file mode 100644
@@ -0,0 +1,3 @@
+(test
+ (name test_calendar)
+ (libraries crowbar calendar))
new file mode 100644
@@ -0,0 +1,29 @@
+open Crowbar
+
+module C = CalendarLib.Calendar.Precise
+
+let time =
+ map [int64] (fun a ->
+ try
+ C.from_mjd (Int64.to_float a /. 100_000_000_000_000.)
+ with
+ CalendarLib.Date.Out_of_bounds -> bad_test ())
+
+let pp_time ppf t =
+ pp ppf "%04d-%02d-%02d %02d:%02d:%02d"
+ (C.year t)
+ (C.month t |> C.Date.int_of_month)
+ (C.day_of_month t)
+ (C.hour t)
+ (C.minute t)
+ (C.second t)
+let time = with_printer pp_time time
+
+let period =
+ map [const 0;const 0;int8;int8;int8;int8] C.Period.make
+
+
+let () =
+ add_test ~name:"calendar" [time; time] @@ fun t1 t2 ->
+ guard (C.compare t1 t2 < 0);
+ check_eq ~pp:pp_time ~eq:C.equal (C.add t1 (C.precise_sub t2 t1)) t2
new file mode 100644
@@ -0,0 +1,4 @@
+(test
+ (name test_fpath)
+ (modules test_fpath)
+ (libraries crowbar fpath))
new file mode 100644
@@ -0,0 +1,18 @@
+open Crowbar
+open Astring
+open Fpath
+let fpath =
+ map [bytes] (fun s ->
+ try
+ v s
+ with
+ Invalid_argument _ -> bad_test ())
+
+
+let () =
+ add_test ~name:"segs" [fpath] @@ fun p ->
+ let np = normalize p in
+ assert (is_dir_path p = is_dir_path np);
+ assert (is_file_path p = is_file_path np);
+ assert (filename p = filename np);
+ check_eq ~eq:equal p (v @@ (fst @@ split_volume p) ^ (String.concat ~sep:dir_sep (segs p)))
new file mode 100644
@@ -0,0 +1 @@
+asdf
new file mode 100644
@@ -0,0 +1,3 @@
+(test
+ (name test_map)
+ (libraries crowbar))
new file mode 100644
@@ -0,0 +1,47 @@
+open Crowbar
+
+module Map = Map.Make (struct
+ type t = int
+ let compare (i : int) (j : int) = compare i j
+end)
+
+type t = ((int * int) list * int Map.t)
+
+let check_map ((list, map) : t) =
+ let rec dedup k = function
+ | [] -> []
+ | (k', v') :: rest when k = k' -> dedup k rest
+ | (k', v') :: rest ->
+ (k', v') :: dedup k' rest in
+ let list = match List.stable_sort (fun a b -> compare (fst a) (fst b)) list with
+ | [] -> []
+ | (k, v) :: rest -> (k, v) :: dedup k rest in
+ List.for_all (fun (k, v) -> Map.find k map = v) list &&
+ list = Map.bindings map
+
+let map_gen : t gen = fix (fun map_gen -> choose [
+ const ([], Map.empty);
+ map [uint8; uint8; map_gen] (fun k v (l, m) ->
+ (k, v) :: l, Map.add k v m);
+ map [uint8; uint8] (fun k v ->
+ [k, v], Map.singleton k v);
+ map [uint8; map_gen] (fun k (l, m) ->
+ let rec rem_all k l =
+ let l' = List.remove_assoc k l in
+ if l = l' then l else rem_all k l' in
+ rem_all k l, Map.remove k m);
+ (* merge? *)
+ map [map_gen; map_gen] (fun (l, m) (l', m') ->
+ l @ l', Map.union (fun k a b -> Some a) m m');
+ map [uint8; map_gen] (fun k (list, map) ->
+ let (l, v, r) = Map.split k map in
+ let (l', vr') = List.partition (fun (kx,vx) -> kx < k) list in
+ let r' = List.filter (fun (kx, vx) -> kx <> k) vr' in
+ let v' = match List.assoc k vr' with n -> Some n | exception Not_found -> None in
+ assert (v = v');
+ (l' @ List.map (fun (k,v) -> k,v+42) r',
+ Map.union (fun k a b -> assert false) l (Map.map (fun v -> v + 42) r)))])
+
+let () =
+ add_test ~name:"map" [map_gen] @@ fun m ->
+ check (check_map m)
new file mode 100644
@@ -0,0 +1,3 @@
+(test
+ (name test_pprint)
+ (libraries crowbar pprint))
new file mode 100644
@@ -0,0 +1,39 @@
+open Crowbar
+open PPrint
+type t = (string * PPrint.document)
+let doc = fix (fun doc -> choose [
+ const ("", empty);
+ const ("a", char 'a');
+ const ("123", string "123");
+ const ("Hello", string "Hello");
+ const ("awordwhichisalittlebittoolong",
+ string "awordwhichisalittlebittoolong");
+ const ("", hardline);
+ map [range 10] (fun n -> ("", break n));
+ map [range 10] (fun n -> ("", break n));
+ map [doc; doc]
+ (fun (sa,da) (sb,db) -> (sa ^ sb, da ^^ db));
+ map [range 10; doc] (fun n (s,d) -> (s, nest n d));
+ map [doc] (fun (s, d) -> (s, group d));
+ map [doc] (fun (s, d) -> (s, align d))
+])
+
+let check_doc (s, d) =
+ let b = Buffer.create 100 in
+ let w = 40 in
+ ToBuffer.pretty 1.0 w b d;
+ let text = Bytes.to_string (Buffer.to_bytes b) in
+ let ws = Str.regexp "[ \t\n\r]*" in
+ (* Printf.printf "doc2{\n%s\n}%!" text; *)
+ let del_ws = Str.global_replace ws "" in
+ (* Printf.printf "[%s] = [%s]\n%!" (del_ws s) (del_ws text);*)
+ Str.split (Str.regexp "\n") text |> List.iter (fun s ->
+ let mspace = Str.regexp "[^ ] " in
+ if String.length s > w then
+ match Str.search_forward mspace s w with
+ | _ -> assert false
+ | exception Not_found -> ());
+ check_eq (del_ws s) (del_ws text)
+
+let () =
+ add_test ~name:"pprint" [doc] check_doc
new file mode 100644
@@ -0,0 +1,3 @@
+(test
+ (name test_serializer)
+ (libraries crowbar))
new file mode 100644
@@ -0,0 +1,34 @@
+type data =
+ | Datum of string
+ | Block of header * data list
+and header = string
+
+type _ ty =
+ | Int : int ty
+ | Bool : bool ty
+ | Prod : 'a ty * 'b ty -> ('a * 'b) ty
+ | List : 'a ty -> 'a list ty
+
+let rec pp_ty : type a . _ -> a ty -> unit = fun ppf ->
+ let printf fmt = Format.fprintf ppf fmt in
+ function
+ | Int -> printf "Int"
+ | Bool -> printf "Bool"
+ | Prod(ta, tb) -> printf "Prod(%a,%a)" pp_ty ta pp_ty tb
+ | List t -> printf "List(%a)" pp_ty t
+
+let rec serialize : type a . a ty -> a -> data = function
+ | Int -> fun n -> Datum (string_of_int n)
+ | Bool -> fun b -> Datum (string_of_bool b)
+ | Prod (ta, tb) -> fun (va, vb) ->
+ Block("pair", [serialize ta va; serialize tb vb])
+ | List t -> fun vs ->
+ Block("list", List.map (serialize t) vs)
+
+let rec deserialize : type a . a ty -> data -> a = function[@warning "-8"]
+ | Int -> fun (Datum s) -> int_of_string s
+ | Bool -> fun (Datum s) -> bool_of_string s
+ | Prod (ta, tb) -> fun (Block("pair", [sa; sb])) ->
+ (deserialize ta sa, deserialize tb sb)
+ | List t -> fun (Block("list", ss)) ->
+ List.map (deserialize t) ss
new file mode 100644
@@ -0,0 +1,47 @@
+open Crowbar
+
+module S = Serializer
+
+type any_ty = Any : 'a S.ty -> any_ty
+
+let ty_gen =
+ with_printer (fun ppf (Any t)-> S.pp_ty ppf t) @@
+ fix (fun ty_gen -> choose [
+ const (Any S.Int);
+ const (Any S.Bool);
+ map [ty_gen; ty_gen] (fun (Any ta) (Any tb) ->
+ Any (S.Prod (ta, tb)));
+ map [ty_gen] (fun (Any t) -> Any (List t));
+ ])
+
+let prod_gen ga gb = map [ga; gb] (fun va vb -> (va, vb))
+
+let rec gen_of_ty : type a . a S.ty -> a gen = function
+ | S.Int -> int
+ | S.Bool -> bool
+ | S.Prod (ta, tb) -> prod_gen (gen_of_ty ta) (gen_of_ty tb)
+ | S.List t -> list (gen_of_ty t)
+
+type pair = Pair : 'a S.ty * 'a -> pair
+
+(* The generator for the final value, [gen_of_ty t], depends on the
+ generated type representation, [t]. This dynamic dependency cannot
+ be expressed with [map], it requires [dynamic_bind]. *)
+let pair_gen : pair gen =
+ dynamic_bind ty_gen @@ fun (Any t) ->
+ map [gen_of_ty t] (fun v -> Pair (t, v))
+
+let rec printer_of_ty : type a . a S.ty -> a printer = function
+ | S.Int -> pp_int
+ | S.Bool -> pp_bool
+ | S.Prod (ta, tb) -> (fun ppf (a, b) ->
+ pp ppf "(%a, %a)" (printer_of_ty ta) a (printer_of_ty tb) b)
+ | S.List t -> pp_list (printer_of_ty t)
+
+let check_pair (Pair (t, v)) =
+ let data = S.serialize t v in
+ match S.deserialize t data with
+ | exception _ -> fail "incorrect deserialization"
+ | v' -> check_eq ~pp:(printer_of_ty t) v v'
+
+let () = add_test ~name:"pairs" [pair_gen] check_pair
new file mode 100644
@@ -0,0 +1,3 @@
+(test
+ (name test_uunf)
+ (libraries uunf uutf uucp crowbar))
new file mode 100644
@@ -0,0 +1,75 @@
+open Crowbar
+
+let uchar =
+ map [int32] (fun n ->
+ let n = (Int32.to_int n land 0xFFFFFFF) mod 0x10FFFF in
+ try Uchar.of_int n
+ with Invalid_argument _ -> bad_test ())
+
+let unicode = list1 uchar
+
+let norm form str =
+ let n = Uunf.create form in
+ let rec add acc v = match Uunf.add n v with
+ | `Uchar u -> add (u :: acc) `Await
+ | `Await | `End -> acc in
+ let rec go acc = function
+ | [] -> List.rev (add acc `End)
+ | (v :: vs) -> go (add acc (`Uchar v)) vs in
+ go [] str
+
+let unicode_to_string s =
+ let b = Buffer.create 10 in
+ List.iter (Uutf.Buffer.add_utf_8 b) s;
+ Buffer.contents b
+
+
+let pp_unicode ppf s =
+ Format.fprintf ppf "@[<v 2>";
+ Format.fprintf ppf "@[\"%s\"@]@ " (unicode_to_string s);
+ s |> List.iter (fun u ->
+ Format.fprintf ppf "@[U+%04x %s (%a)@]@ " (Uchar.to_int u) (Uucp.Name.name u) Uucp.Block.pp (Uucp.Block.block u));
+ Format.fprintf ppf "@]\n"
+
+
+let unicode = with_printer pp_unicode unicode
+
+let () =
+ add_test ~name:"uunf" [unicode] @@ fun s ->
+ let nfc = norm `NFC s in
+ let nfd = norm `NFD s in
+ let nfkc = norm `NFKC s in
+ let nfkd = norm `NFKD s in
+(* [s; nfc; nfd; nfkc; nfkd] |> List.iter (fun s ->
+ Printf.printf "[%s]\n" (unicode_to_string s));
+ Printf.printf "\n%!";*)
+
+ let tests =
+ [
+ nfc, [
+ norm `NFC nfc;
+ norm `NFC nfd];
+
+ nfd, [
+ norm `NFD nfc;
+ norm `NFD nfd];
+
+ nfkc, [
+ norm `NFC nfkc;
+ norm `NFC nfkd;
+ norm `NFKC nfc;
+ norm `NFKC nfd;
+ norm `NFKC nfkc;
+ norm `NFKC nfkd];
+
+ nfkd, [
+ norm `NFD nfkc;
+ norm `NFD nfkd;
+ norm `NFKD nfc;
+ norm `NFKD nfd;
+ norm `NFKD nfkc;
+ norm `NFKD nfkd]
+ ] in
+ tests |> List.iter (fun (s, eqs) ->
+ List.iter (fun s' -> check_eq ~pp:pp_unicode s s') eqs)
+
new file mode 100644
@@ -0,0 +1,3 @@
+(test
+ (name test_xmldiff)
+ (libraries xmldiff crowbar))
new file mode 100644
@@ -0,0 +1,42 @@
+open Crowbar
+
+let ident = choose [const "a"; const "b"; const "c"]
+let elem_name = map [ident] (fun s -> ("", s))
+
+
+let attrs =
+ choose [
+ const Xmldiff.Nmap.empty;
+ map [elem_name; ident] Xmldiff.Nmap.singleton
+ ]
+
+let rec xml = lazy (
+ choose [
+ const (`D "a");
+ map [ident] (fun s -> `D s);
+ map [elem_name; attrs; list (unlazy xml)] (fun s attrs elems ->
+ let rec normalise = function
+ | ([] | [_]) as x -> x
+ | `E _ as el :: xs ->
+ el :: normalise xs
+ | `D s :: xs ->
+ match normalise xs with
+ | `D s' :: xs' ->
+ `D (s ^ s') :: xs'
+ | xs' -> `D s :: xs' in
+ `E (s, attrs, normalise elems))
+ ])
+
+let lazy xml = xml
+
+let xml = map [xml] (fun d -> `E (("", "a"), Xmldiff.Nmap.empty, [d]))
+
+let pp_xml ppf xml =
+ pp ppf "%s" (Xmldiff.string_of_xml xml)
+let xml = with_printer pp_xml xml
+
+
+let () =
+ add_test ~name:"xmldiff" [xml; xml] @@ fun xml1 xml2 ->
+ let (patch, xml3) = Xmldiff.diff_with_final_tree xml1 xml2 in
+ check_eq ~pp:pp_xml xml2 xml3
new file mode 100644
@@ -0,0 +1,582 @@
+type src = Random of Random.State.t | Fd of Unix.file_descr
+type state =
+ {
+ chan : src;
+ buf : Bytes.t;
+ mutable offset : int;
+ mutable len : int
+ }
+
+type 'a printer = Format.formatter -> 'a -> unit
+
+type 'a gen =
+ | Choose of 'a gen list
+ | Map : ('f, 'a) gens * 'f -> 'a gen
+ | Bind : 'a gen * ('a -> 'b gen) -> 'b gen
+ | Option : 'a gen -> 'a option gen
+ | List : 'a gen -> 'a list gen
+ | List1 : 'a gen -> 'a list gen
+ | Unlazy of 'a gen Lazy.t
+ | Primitive of (state -> 'a)
+ | Print of 'a printer * 'a gen
+and ('k, 'res) gens =
+ | [] : ('res, 'res) gens
+ | (::) : 'a gen * ('k, 'res) gens -> ('a -> 'k, 'res) gens
+
+type nonrec +'a list = 'a list = [] | (::) of 'a * 'a list
+
+let unlazy f = Unlazy f
+
+let fix f =
+ let rec lazygen = lazy (f (unlazy lazygen)) in
+ unlazy lazygen
+
+let map gens f = Map (gens, f)
+
+let dynamic_bind m f = Bind(m, f)
+
+let const x = map [] x
+let choose gens = Choose gens
+let option gen = Option gen
+let list gen = List gen
+let list1 gen = List1 gen
+
+let pair gena genb =
+ map (gena :: genb :: []) (fun a b -> (a, b))
+
+let concat_gen_list sep l =
+ match l with
+ | h::t -> List.fold_left (fun acc e ->
+ map [acc; sep; e] (fun acc sep e -> acc ^ sep ^ e)
+ ) h t
+ | [] -> const ""
+
+let with_printer pp gen = Print (pp, gen)
+
+let result gena genb =
+ Choose [
+ Map([gena], fun va -> Ok va);
+ Map([genb], fun vb -> Error vb);
+ ]
+
+
+let pp = Format.fprintf
+let pp_int ppf n = pp ppf "%d" n
+let pp_int32 ppf n = pp ppf "%s" (Int32.to_string n)
+let pp_int64 ppf n = pp ppf "%s" (Int64.to_string n)
+let pp_float ppf f = pp ppf "%f" f
+let pp_bool ppf b = pp ppf "%b" b
+let pp_char ppf c = pp ppf "%c" c
+let pp_uchar ppf c = pp ppf "U+%04x" (Uchar.to_int c)
+let pp_string ppf s = pp ppf "\"%s\"" (String.escaped s)
+let pp_list pv ppf l =
+ pp ppf "@[<hv 1>[%a]@]"
+ (Format.pp_print_list ~pp_sep:(fun ppf () -> pp ppf ";@ ") pv) l
+let pp_option pv ppf = function
+ | None ->
+ Format.fprintf ppf "None"
+ | Some x ->
+ Format.fprintf ppf "(Some %a)" pv x
+
+exception BadTest of string
+exception FailedTest of unit printer
+let guard = function
+ | true -> ()
+ | false -> raise (BadTest "guard failed")
+let bad_test () = raise (BadTest "bad test")
+let nonetheless = function
+ | None -> bad_test ()
+ | Some a -> a
+
+let get_data chan buf off len =
+ match chan with
+ | Random rand ->
+ for i = off to off + len - 1 do
+ Bytes.set buf i (Char.chr (Random.State.bits rand land 0xff))
+ done;
+ len - off
+ | Fd ch ->
+ Unix.read ch buf off len
+
+let refill src =
+ assert (src.offset <= src.len);
+ let remaining = src.len - src.offset in
+ (* move remaining data to start of buffer *)
+ Bytes.blit src.buf src.offset src.buf 0 remaining;
+ src.len <- remaining;
+ src.offset <- 0;
+ let read = get_data src.chan src.buf remaining (Bytes.length src.buf - remaining) in
+ if read = 0 then
+ raise (BadTest "premature end of file")
+ else
+ src.len <- remaining + read
+
+let rec getbytes src n =
+ assert (src.offset <= src.len);
+ if n > Bytes.length src.buf then failwith "request too big";
+ if src.len - src.offset >= n then
+ let off = src.offset in
+ (src.offset <- src.offset + n; off)
+ else
+ (refill src; getbytes src n)
+
+let read_char src =
+ let off = getbytes src 1 in
+ Bytes.get src.buf off
+
+let read_byte src =
+ Char.code (read_char src)
+
+let read_bool src =
+ let n = read_byte src in
+ n land 1 = 1
+
+let bool = Print(pp_bool, Primitive read_bool)
+
+let uint8 = Print(pp_int, Primitive read_byte)
+let int8 = Print(pp_int, Map ([uint8], fun n -> n - 128))
+
+let read_uint16 src =
+ let off = getbytes src 2 in
+ EndianBytes.LittleEndian.get_uint16 src.buf off
+
+let read_int16 src =
+ let off = getbytes src 2 in
+ EndianBytes.LittleEndian.get_int16 src.buf off
+
+let uint16 = Print(pp_int, Primitive read_uint16)
+let int16 = Print(pp_int, Primitive read_int16)
+
+let read_int32 src =
+ let off = getbytes src 4 in
+ EndianBytes.LittleEndian.get_int32 src.buf off
+
+let read_int64 src =
+ let off = getbytes src 8 in
+ EndianBytes.LittleEndian.get_int64 src.buf off
+
+let int32 = Print (pp_int32, Primitive read_int32)
+let int64 = Print (pp_int64, Primitive read_int64)
+
+let int =
+ Print (pp_int,
+ if Sys.word_size <= 32 then
+ Map([int32], Int32.to_int)
+ else
+ Map([int64], Int64.to_int))
+
+let float = Print (pp_float, Primitive (fun src ->
+ let off = getbytes src 8 in
+ EndianBytes.LittleEndian.get_double src.buf off))
+
+let char = Print (pp_char, Primitive read_char)
+
+(* maybe print as a hexdump? *)
+let bytes = Print (pp_string, Primitive (fun src ->
+ (* null-terminated, with '\001' as an escape code *)
+ let buf = Bytes.make 64 '\255' in
+ let rec read_bytes p =
+ if p >= Bytes.length buf then p else
+ match read_char src with
+ | '\000' -> p
+ | '\001' ->
+ Bytes.set buf p (read_char src);
+ read_bytes (p + 1)
+ | c ->
+ Bytes.set buf p c;
+ read_bytes (p + 1) in
+ let count = read_bytes 0 in
+ Bytes.sub_string buf 0 count))
+
+let bytes_fixed n = Print (pp_string, Primitive (fun src ->
+ let off = getbytes src n in
+ Bytes.sub_string src.buf off n))
+
+let choose_int n state =
+ assert (n > 0);
+ if n = 1 then
+ 0
+ else if (n <= 0x100) then
+ read_byte state mod n
+ else if (n < 0x1000000) then
+ Int32.(to_int (abs (rem (read_int32 state) (of_int n))))
+ else
+ Int64.(to_int (abs (rem (read_int64 state) (of_int n))))
+
+let range ?(min=0) n =
+ if n <= 0 then
+ raise (Invalid_argument "Crowbar.range: argument n must be positive");
+ if min < 0 then
+ raise (Invalid_argument "Crowbar.range: argument min must be positive or null");
+ Print (pp_int, Primitive (fun s -> min + choose_int n s))
+
+let uchar : Uchar.t gen =
+ map [range 0x110000] (fun x ->
+ guard (Uchar.is_valid x); Uchar.of_int x)
+let uchar = Print(pp_uchar, uchar)
+
+let rec sequence = function
+ g::gs -> map [g; sequence gs] (fun x xs -> x::xs)
+| [] -> const []
+
+let shuffle_arr arr =
+ let n = Array.length arr in
+ let gs = List.init n (fun i -> range ~min:i (n - i)) in
+ map [sequence gs] @@ fun js ->
+ js |> List.iteri (fun i j ->
+ let t = arr.(i) in arr.(i) <- arr.(j); arr.(j) <- t);
+ arr
+
+let shuffle l = map [shuffle_arr (Array.of_list l)] Array.to_list
+
+exception GenFailed of exn * Printexc.raw_backtrace * unit printer
+
+let minimize_depth : type a . a gen list -> a gen list = fun gens ->
+ let only p = List.filter p gens in
+ let without p = List.filter (fun v -> not (p v)) gens in
+ let branchless = function | _ -> false in
+ let branchy = function | Map _ | Bind _ | Choose _ -> true | _ -> false in
+ let complex = function | Map _ | Bind _ -> true | _ -> false in
+ match only branchless, without branchy, without complex with
+ | x::xs, _ , _ -> x :: xs
+ | [], x::xs, _ -> x :: xs
+ | [], [], x::xs -> x :: xs
+ | [], [], [] -> gens
+
+let rec generate : type a . int -> state -> a gen -> a * unit printer =
+ fun size input gen -> match gen with
+ | Choose xs ->
+ (* FIXME: better distribution? *)
+ (* FIXME: choices of size > 255? *)
+ let gens = if size <= 1 then minimize_depth xs else xs in
+ let n = choose_int (List.length gens) input in
+ let v, pv = generate size input (List.nth gens n) in
+ v, fun ppf () -> pp ppf "#%d %a" n pv ()
+ | Map ([], k) ->
+ k, fun ppf () -> pp ppf "?"
+ | Map (gens, f) ->
+ let rec len : type k res . int -> (k, res) gens -> int =
+ fun acc xs -> match xs with
+ | [] -> acc
+ | _ :: xs -> len (1 + acc) xs in
+ let n = len 0 gens in
+ (* the size parameter is (apparently?) meant to ensure that generation
+ eventually terminates, by limiting the set of options from which the
+ generator might choose once we've gotten deep into a tree. make sure we
+ always mark our passing, even when we've mapped one value into another,
+ so we don't blow the stack. *)
+ let size = (size - 1) / n in
+ let v, pvs = gen_apply size input gens f in
+ begin match v with
+ | Ok v -> v, pvs
+ | Error (e, bt) -> raise (GenFailed (e, bt, pvs))
+ end
+ | Bind (m, f) ->
+ let index, pv_index = generate (size - 1) input m in
+ let a, pv = generate (size - 1) input (f index) in
+ a, (fun ppf () -> pp ppf "(%a) => %a" pv_index () pv ())
+ | Option gen ->
+ if size < 1 then
+ None, fun ppf () -> pp ppf "None"
+ else if read_bool input then
+ let v, pv = generate size input gen in
+ Some v, fun ppf () -> pp ppf "Some (%a)" pv ()
+ else
+ None, fun ppf () -> pp ppf "None"
+ | List gen ->
+ let elems = generate_list size input gen in
+ List.map fst elems,
+ fun ppf () -> pp_list (fun ppf (_, pv) -> pv ppf ()) ppf elems
+ | List1 gen ->
+ let elems = generate_list1 size input gen in
+ List.map fst elems,
+ fun ppf () -> pp_list (fun ppf (_, pv) -> pv ppf ()) ppf elems
+ | Primitive gen ->
+ gen input, fun ppf () -> pp ppf "?"
+ | Unlazy gen ->
+ generate size input (Lazy.force gen)
+ | Print (ppv, gen) ->
+ let v, _ = generate size input gen in
+ v, fun ppf () -> ppv ppf v
+
+and generate_list : type a . int -> state -> a gen -> (a * unit printer) list =
+ fun size input gen ->
+ if size <= 1 then []
+ else if read_bool input then
+ generate_list1 size input gen
+ else
+ []
+
+and generate_list1 : type a . int -> state -> a gen -> (a * unit printer) list =
+ fun size input gen ->
+ let ans = generate (size/2) input gen in
+ ans :: generate_list (size/2) input gen
+
+and gen_apply :
+ type k res . int -> state ->
+ (k, res) gens -> k ->
+ (res, exn * Printexc.raw_backtrace) result * unit printer =
+ fun size state gens f ->
+ let rec go :
+ type k res . int -> state ->
+ (k, res) gens -> k ->
+ (res, exn * Printexc.raw_backtrace) result * unit printer list =
+ fun size input gens -> match gens with
+ | [] -> fun x -> Ok x, []
+ | g :: gs -> fun f ->
+ let v, pv = generate size input g in
+ let res, pvs =
+ match f v with
+ | exception (BadTest _ as e) -> raise e
+ | exception e ->
+ Error (e, Printexc.get_raw_backtrace ()) , []
+ | fv -> go size input gs fv in
+ res, pv :: pvs in
+ let v, pvs = go size state gens f in
+ let pvs = fun ppf () ->
+ match pvs with
+ | [pv] ->
+ pv ppf ()
+ | pvs ->
+ pp_list (fun ppf pv -> pv ppf ()) ppf pvs in
+ v, pvs
+
+
+let fail s = raise (FailedTest (fun ppf () -> pp ppf "%s" s))
+
+let failf format =
+ Format.kasprintf fail format
+
+let check = function
+ | true -> ()
+ | false -> raise (FailedTest (fun ppf () -> pp ppf "check false"))
+
+let check_eq ?pp:pv ?cmp ?eq a b =
+ let pass = match eq, cmp with
+ | Some eq, _ -> eq a b
+ | None, Some cmp -> cmp a b = 0
+ | None, None ->
+ Stdlib.compare a b = 0 in
+ if pass then
+ ()
+ else
+ raise (FailedTest (fun ppf () ->
+ match pv with
+ | None -> pp ppf "different"
+ | Some pv -> pp ppf "@[<hv>%a@ !=@ %a@]" pv a pv b))
+
+let () = Printexc.record_backtrace true
+
+type test = Test : string * ('f, unit) gens * 'f -> test
+
+type test_status =
+ | TestPass of unit printer
+ | BadInput of string
+ | GenFail of exn * Printexc.raw_backtrace * unit printer
+ | TestExn of exn * Printexc.raw_backtrace * unit printer
+ | TestFail of unit printer * unit printer
+
+let run_once (gens : (_, unit) gens) f state =
+ match gen_apply 100 state gens f with
+ | Ok (), pvs -> TestPass pvs
+ | Error (FailedTest p, _), pvs -> TestFail (p, pvs)
+ | Error (e, bt), pvs -> TestExn (e, bt, pvs)
+ | exception (BadTest s) -> BadInput s
+ | exception (GenFailed (e, bt, pvs)) -> GenFail (e, bt, pvs)
+
+let classify_status = function
+ | TestPass _ -> `Pass
+ | BadInput _ -> `Bad
+ | GenFail _ -> `Fail (* slightly dubious... *)
+ | TestExn _ | TestFail _ -> `Fail
+
+let print_status ppf status =
+ let print_ex ppf (e, bt) =
+ pp ppf "%s" (Printexc.to_string e);
+ bt
+ |> Printexc.raw_backtrace_to_string
+ |> Str.split (Str.regexp "\n")
+ |> List.iter (pp ppf "@,%s") in
+ match status with
+ | TestPass pvs ->
+ pp ppf "When given the input:@.@[<v 4>@,%a@,@]@.the test passed."
+ pvs ()
+ | BadInput s ->
+ pp ppf "The testcase was invalid:@.%s" s
+ | GenFail (e, bt, pvs) ->
+ pp ppf "When given the input:@.@[<4>%a@]@.the testcase generator threw an exception:@.@[<v 4>@,%a@,@]"
+ pvs ()
+ print_ex (e, bt)
+ | TestExn (e, bt, pvs) ->
+ pp ppf "When given the input:@.@[<v 4>@,%a@,@]@.the test threw an exception:@.@[<v 4>@,%a@,@]"
+ pvs ()
+ print_ex (e, bt)
+ | TestFail (err, pvs) ->
+ pp ppf "When given the input:@.@[<v 4>@,%a@,@]@.the test failed:@.@[<v 4>@,%a@,@]"
+ pvs ()
+ err ()
+
+let src_of_seed seed =
+ (* try to make this independent of word size *)
+ let seed = Int64.( [|
+ to_int (logand (of_int 0xffff) seed);
+ to_int (logand (of_int 0xffff) (shift_right seed 16));
+ to_int (logand (of_int 0xffff) (shift_right seed 32));
+ to_int (logand (of_int 0xffff) (shift_right seed 48)) |]) in
+ Random (Random.State.make seed)
+
+let run_test ~mode ~silent ?(verbose=false) (Test (name, gens, f)) =
+ let show_status_line ?(clear=false) stat =
+ Printf.printf "%s: %s\n" name stat;
+ if clear then print_newline ();
+ flush stdout in
+ let ppf = Format.std_formatter in
+ if not silent && Unix.isatty Unix.stdout then
+ show_status_line ~clear:false "....";
+ let status = match mode with
+ | `Once state ->
+ run_once gens f state
+ | `Repeat iters ->
+ let worst_status = ref (TestPass (fun _ () -> ())) in
+ let npass = ref 0 in
+ let nbad = ref 0 in
+ while !npass < iters && classify_status !worst_status = `Pass do
+ let seed = Random.int64 Int64.max_int in
+ let state = { chan = src_of_seed seed;
+ buf = Bytes.make 256 '0';
+ offset = 0; len = 0 } in
+ let status = run_once gens f state in
+ begin match classify_status status with
+ | `Pass -> incr npass
+ | `Bad -> incr nbad
+ | `Fail ->
+ (* if not silent then pp ppf "failed with seed %016LX" seed; *)
+ worst_status := status
+ end;
+ done;
+ let status = !worst_status in
+ status in
+ if silent && verbose && classify_status status = `Fail then begin
+ show_status_line
+ ~clear:true "FAIL";
+ pp ppf "%a@." print_status status;
+ end;
+ if not silent then begin
+ match classify_status status with
+ | `Pass ->
+ show_status_line
+ ~clear:true "PASS";
+ if verbose then pp ppf "%a@." print_status status
+ | `Fail ->
+ show_status_line
+ ~clear:true "FAIL";
+ pp ppf "%a@." print_status status;
+ | `Bad ->
+ show_status_line
+ ~clear:true "BAD";
+ pp ppf "%a@." print_status status;
+ end;
+ status
+
+exception TestFailure
+let run_all_tests file verbosity infinity tests =
+ match file, infinity with
+ | None, false ->
+ (* limited-run QuickCheck mode *)
+ let failures = ref 0 in
+ let () = tests |> List.iter (fun t ->
+ match (run_test ~mode:(`Repeat 5000) ~silent:false t |> classify_status) with
+ | `Fail -> failures := !failures + 1
+ | _ -> ()
+ )
+ in
+ !failures
+ | None, true ->
+ (* infinite QuickCheck mode *)
+ let rec go ntests alltests tests = match tests with
+ | [] ->
+ go ntests alltests alltests
+ | t :: rest ->
+ if ntests mod 10000 = 0 then Printf.eprintf "\r%d%!" ntests;
+ match classify_status (run_test ~mode:(`Once { chan = src_of_seed (Random.int64 (Int64.max_int));
+ buf = Bytes.make 256 '0';
+ offset = 0; len = 0 }) ~silent:true ~verbose:true t) with
+ | `Fail -> Printf.printf "%d tests passed before first failure\n%!" ntests
+ | _ -> go (ntests + 1) alltests rest in
+ let () = go 0 tests tests in
+ 1
+ | Some file, _ ->
+ (* AFL mode *)
+ let verbose = List.length verbosity > 0 in
+ let () = AflPersistent.run (fun () ->
+ let fd = Unix.openfile file [Unix.O_RDONLY] 0o000 in
+ let state = { chan = Fd fd; buf = Bytes.make 256 '0';
+ offset = 0; len = 0 } in
+ let status =
+ try run_test ~mode:(`Once state) ~silent:false ~verbose @@
+ List.nth tests (choose_int (List.length tests) state)
+ with
+ BadTest s -> BadInput s
+ in
+ Unix.close fd;
+ match classify_status status with
+ | `Pass | `Bad -> ()
+ | `Fail ->
+ Printexc.record_backtrace false;
+ raise TestFailure)
+ in
+ 0 (* failures come via the exception mechanism above *)
+
+let last_generated_name = ref 0
+let generate_name () =
+ incr last_generated_name;
+ "test" ^ string_of_int !last_generated_name
+
+let registered_tests = ref []
+
+let add_test ?name gens f =
+ let name = match name with
+ | None -> generate_name ()
+ | Some name -> name in
+ registered_tests := Test (name, gens, f) :: !registered_tests
+
+(* cmdliner stuff *)
+
+let randomness_file =
+ let doc = "A file containing some bytes, consulted in constructing test cases. \
+ When `afl-fuzz` is calling the test binary, use `@@` to indicate that \
+ `afl-fuzz` should put its test case here \
+ (e.g. `afl-fuzz -i input -o output ./my_crowbar_test @@`). Re-run a test by \
+ supplying the test file here \
+ (e.g. `./my_crowbar_test output/crashes/id:000000`). If no file is \
+ specified, the test will use OCaml's Random module as a source of \
+ randomness for a predefined number of rounds." in
+ Cmdliner.Arg.(value & pos 0 (some file) None & info [] ~doc ~docv:"FILE")
+
+let verbosity =
+ let doc = "Print information on each test as it's conducted." in
+ Cmdliner.Arg.(value & flag_all & info ["v"; "verbose"] ~doc ~docv:"VERBOSE")
+
+let infinity =
+ let doc = "In non-AFL (quickcheck) mode, continue running until a test failure is \
+ discovered. No attempt is made to track which tests have already been run, \
+ so some tests may be repeated, and if there are no failures reachable, the \
+ test will never terminate without outside intervention." in
+ Cmdliner.Arg.(value & flag & info ["i"] ~doc ~docv:"INFINITE")
+
+let crowbar_info = Cmdliner.Term.info @@ Filename.basename Sys.argv.(0)
+
+let () =
+ at_exit (fun () ->
+ let t = !registered_tests in
+ registered_tests := [];
+ match t with
+ | [] -> ()
+ | t ->
+ let cmd = Cmdliner.Term.(const run_all_tests $ randomness_file $ verbosity $
+ infinity $ const (List.rev t)) in
+ match Cmdliner.Term.eval ~catch:false (cmd, crowbar_info) with
+ | `Ok 0 -> exit 0
+ | `Ok _ -> exit 1
+ | n -> Cmdliner.Term.exit n
+ )
new file mode 100644
@@ -0,0 +1,251 @@
+(** {1:top Types } *)
+
+type 'a gen
+(** ['a gen] knows how to generate ['a] for use in Crowbar tests. *)
+
+type ('k, 'res) gens =
+ | [] : ('res, 'res) gens
+ | (::) : 'a gen * ('k, 'res) gens -> ('a -> 'k, 'res) gens
+(** multiple generators are passed to functions using a listlike syntax.
+ for example, [map [int; int] (fun a b -> a + b)] *)
+
+type 'a printer = Format.formatter -> 'a -> unit
+(** pretty-printers for items generated by Crowbar; useful for the user in
+ translating test failures into bugfixes. *)
+
+(**/**)
+(* re-export stdlib's list
+ We only want to override [] syntax in the argument to Map *)
+type nonrec +'a list = 'a list = [] | (::) of 'a * 'a list
+(**/**)
+
+(** {1:generators Generators } *)
+
+(** {2:simple_generators Simple Generators } *)
+
+val int : int gen
+(** [int] generates an integer ranging from min_int to max_int, inclusive.
+ If you need integers from a smaller domain, consider using {!range}. *)
+
+val uint8 : int gen
+(** [uint8] generates an unsigned byte, ranging from 0 to 255 inclusive. *)
+
+val int8 : int gen
+(** [int8] generates a signed byte, ranging from -128 to 127 inclusive. *)
+
+val uint16 : int gen
+(** [uint16] generates an unsigned 16-bit integer,
+ ranging from 0 to 65535 inclusive. *)
+
+val int16 : int gen
+(** [int16] generates a signed 16-bit integer,
+ ranging from -32768 to 32767 inclusive. *)
+
+val int32 : Int32.t gen
+(** [int32] generates a 32-bit signed integer. *)
+
+val int64 : Int64.t gen
+(** [int64] generates a 64-bit signed integer. *)
+
+val float : float gen
+(** [float] generates a double-precision floating-point number. *)
+
+val char : char gen
+(** [char] generates a char. *)
+
+val uchar : Uchar.t gen
+(** [uchar] generates a Unicode scalar value *)
+
+val bytes : string gen
+(** [bytes] generates a string of arbitrary length (including zero-length strings). *)
+
+val bytes_fixed : int -> string gen
+(** [bytes_fixed length] generates a string of the specified length. *)
+
+val bool : bool gen
+(** [bool] generates a yes or no answer. *)
+
+val range : ?min:int -> int -> int gen
+(** [range ?min n] is a generator for integers between [min] (inclusive)
+ and [min + n] (exclusive). Default [min] value is 0.
+ [range ?min n] will raise [Invalid_argument] for [n <= 0].
+*)
+
+(** {2:generator_functions Functions on Generators } *)
+
+val map : ('f, 'a) gens -> 'f -> 'a gen
+(** [map gens map_fn] provides a means for creating generators using other
+ generators' output. For example, one might generate a Char.t from a
+ {!uint8}:
+ {[
+ open Crowbar
+ let char_gen : Char.t gen = map [uint8] Char.chr
+ ]}
+*)
+
+val unlazy : 'a gen Lazy.t -> 'a gen
+(** [unlazy gen] forces the generator [gen]. It is useful when defining
+ generators for recursive data types:
+
+ {[
+ open Crowbar
+ type a = A of int | Self of a
+ let rec a_gen = lazy (
+ choose [
+ map [int] (fun i -> A i);
+ map [(unlazy a_gen)] (fun s -> Self s);
+ ])
+ let lazy a_gen = a_gen
+ ]}
+*)
+
+val fix : ('a gen -> 'a gen) -> 'a gen
+(** [fix fn] applies the function [fn]. It is useful when defining generators
+ for recursive data types:
+
+ {[
+ open Crowbar
+ type a = A of int | Self of a
+ let rec a_gen = fix (fun a_gen ->
+ choose [
+ map [int] (fun i -> A i);
+ map [a_gen] (fun s -> Self s);
+ ])
+ ]}
+ *)
+
+val const : 'a -> 'a gen
+(** [const a] always generates [a]. *)
+
+val choose : 'a gen list -> 'a gen
+(** [choose gens] chooses a generator arbitrarily from [gens]. *)
+
+val option : 'a gen -> 'a option gen
+(** [option gen] generates either [None] or [Some x], where [x] is the item
+ generated by [gen]. *)
+
+val pair : 'a gen -> 'b gen -> ('a * 'b) gen
+(** [pair gena gen] generates (a, b)
+ where [a] is generated by [gena] and [b] by [genb]. *)
+
+val result : 'a gen -> 'b gen -> ('a, 'b) result gen
+(** [result gena genb] generates either [Ok va] or [Error vb],
+ where [va], [vb] are generated by [gena], [genb] respectively. *)
+
+val list : 'a gen -> 'a list gen
+(** [list gen] makes a generator for lists using [gen]. Lists may be empty; for
+ non-empty lists, use {!list1}. *)
+
+val list1 : 'a gen -> 'a list gen
+(** [list1 gen] makes non-empty list generators. For potentially empty lists,
+ use {!list}.*)
+
+val shuffle : 'a list -> 'a list gen
+(** [shuffle l] generates random permutations of [l]. *)
+
+val concat_gen_list : string gen -> string gen list -> string gen
+(** [concat_gen_list sep l] concatenates a list of string gen [l] inserting the
+ separator [sep] between each *)
+
+val with_printer : 'a printer -> 'a gen -> 'a gen
+(** [with_printer printer gen] generates the same values as [gen]. If [gen]
+ is used to create a failing test case and the test was reached by
+ calling [check_eq] without [pp] set, [printer] will be used to print the
+ failing test case. *)
+
+val dynamic_bind : 'a gen -> ('a -> 'b gen) -> 'b gen
+(** [dynamic_bind gen f] is a monadic bind, it allows to express the
+ generation of a value whose generator itself depends on
+ a previously generated value. This is in contrast with [map gen f],
+ where no further generation happens in [f] after [gen] has
+ generated an element.
+
+ An typical example where this sort of dependencies is required is
+ a serialization library exporting combinators letting you build
+ values of the form ['a serializer]. You may want to test this
+ library by first generating a pair of a serializer and generator
+ ['a serializer * 'a gen] for arbitrary ['a], and then generating
+ values of type ['a] depending on the (generated) generator to test
+ the serializer. There is such an example in the
+ [examples/serializer/] directory of the Crowbar implementation.
+
+ Because the structure of a generator built with [dynamic_bind] is
+ opaque/dynamic (it depends on generated values), the Crowbar
+ library cannot analyze its statically
+ (without generating anything) -- the generator is opaque to the
+ library, hidden in a function. In particular, many optimizations or
+ or fuzzing techniques based on generator analysis are
+ impossible. As a client of the library, you should avoid
+ [dynamic_bind] whenever it is not strictly required to express
+ a given generator, so that you can take advantage of these features
+ (present or future ones). Use the least powerful/complex
+ combinators that suffice for your needs.
+*)
+
+(** {1:printing Printing } *)
+
+(* Format.fprintf, renamed *)
+val pp : Format.formatter -> ('a, Format.formatter, unit) format -> 'a
+val pp_int : int printer
+val pp_int32 : Int32.t printer
+val pp_int64 : Int64.t printer
+val pp_float : float printer
+val pp_bool : bool printer
+val pp_string : string printer
+val pp_list : 'a printer -> 'a list printer
+val pp_option : 'a printer -> 'a option printer
+
+(** {1:testing Testing} *)
+
+val add_test :
+ ?name:string -> ('f, unit) gens -> 'f -> unit
+(** [add_test name generators test_fn] adds [test_fn] to the list of eligible
+ tests to be run when the program is invoked. At runtime, random data will
+ be sent to [generators] to create the input necessary to run [test_fn]. Any
+ failures will be printed annotated with [name]. *)
+
+(** {2:aborting Aborting Tests} *)
+
+val guard : bool -> unit
+(** [guard b] aborts a test if [b] is false. The test will not be recorded
+ or reported as a failure. *)
+
+val bad_test : unit -> 'a
+(** [bad_test ()] aborts a test. The test will not be recorded or reported
+ as a failure. *)
+
+val nonetheless : 'a option -> 'a
+(** [nonetheless o] aborts a test if [o] is None. The test will not be recorded
+ or reported as a failure. *)
+
+(** {2:failing Failing} *)
+
+val fail : string -> 'a
+(** [fail message] generates a test failure and prints [message]. *)
+
+val failf : ('a, Format.formatter, unit, _) format4 -> 'a
+(** [failf format ...] generates a test failure and prints the message
+ specified by the format string [format] and the following arguments.
+ It is set up so that [%a] calls for an ['a printer] and an ['a] value. *)
+
+(** {2:asserting Asserting Properties} *)
+
+val check : bool -> unit
+(** [check b] generates a test failure if [b] is false. No useful information
+ will be printed in this case. *)
+
+val check_eq : ?pp:('a printer) -> ?cmp:('a -> 'a -> int) -> ?eq:('a -> 'a -> bool) ->
+ 'a -> 'a -> unit
+(** [check_eq pp cmp eq x y] evaluates whether x and y are equal, and if they
+ are not, raises a failure and prints an error message.
+ Equality is evaluated as follows:
+
+ {ol
+ {- use a provided [eq]}
+ {- if no [eq] is provided, use a provided [cmp]}
+ {- if neither [eq] nor [cmp] is provided, use Stdlib.compare}}
+
+ If [pp] is provided, use this to print [x] and [y] if they are not equal.
+ If [pp] is not provided, a best-effort printer will be generated from the
+ printers for primitive generators and any printers registered with
+ [with_printer] and used. *)
new file mode 100644
@@ -0,0 +1,3 @@
+(library
+ (public_name crowbar)
+ (libraries cmdliner ocplib-endian afl-persistent str))
new file mode 100644
@@ -0,0 +1,16 @@
+join/bind (v2?)
+
+command line interface:
+ - afl-fuzz mode
+ - quickcheck mode
+ - random fuzzing mode (for me testing, really)
+ - file / file list mode
+ - reproduction mode (seed / file)
+ - select which tests to run
+
+output:
+ - seeds for failed tests
+ - maybe use notty to figure out pretty-printing width
+
+api:
+ - manual testsuite interface?
new file mode 100644
@@ -0,0 +1,45 @@
+# 1.3.2
+
+- The project now builds with dune 1.11.0 and onward (#12, @voodoos)
+
+# 1.3.1
+
+- Fix compatibility with 4.02.3
+
+# 1.3.0
+
+- Add a "feed" API for parsing. This new API let the user feed
+ characters one by one to the parser. It gives more control to the
+ user and the handling of IO errors is simpler and more
+ explicit. Finally, it allocates less (#9, @jeremiedimino)
+
+- Fixes `input_opt`; it was could never return [None] (#9, fixes #7,
+ @jeremiedimino)
+
+- Fixes `parse_many`; it was returning s-expressions in the wrong
+ order (#10, @rgrinberg)
+
+# 1.2.3
+
+- Fix `parse_string_many`; it used to fail on all inputs (#6, @rgrinberg)
+
+# 1.2.2
+
+- Fix compatibility with 4.02.3
+
+# 1.2.1
+
+- Remove inclusion of the `Result` module, which was accidentally
+ added in a previous PR. (#3, @rgrinberg)
+
+# 1.2.0
+
+- Expose low level, monad agnostic parser. (#2, @mefyl)
+
+# 1.1.0
+
+- Add compatibility up-to OCaml 4.02.3 (with disabled tests). (#1, @voodoos)
+
+# 1.0.0
+
+- Initial release
new file mode 100644
@@ -0,0 +1,21 @@
+The MIT License
+
+Copyright (c) 2016 Jane Street Group, LLC <opensource@janestreet.com>
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
new file mode 100644
@@ -0,0 +1,23 @@
+INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),)
+
+default:
+ dune runtest
+
+test:
+ dune runtest
+
+install:
+ dune install $(INSTALL_ARGS)
+
+uninstall:
+ dune uninstall $(INSTALL_ARGS)
+
+reinstall: uninstall install
+
+clean:
+ dune clean
+
+all-supported-ocaml-versions:
+ dune build @install @runtest --workspace dune-workspace.dev
+
+.PHONY: default install uninstall reinstall clean test
new file mode 100644
@@ -0,0 +1,33 @@
+Csexp - Canonical S-expressions
+===============================
+
+This project provides minimal support for parsing and printing
+[S-expressions in canonical form][wikipedia], which is a very simple
+and canonical binary encoding of S-expressions.
+
+[wikipedia]: https://en.wikipedia.org/wiki/Canonical_S-expressions
+
+Example
+-------
+
+```ocaml
+# #require "csexp";;
+# module Sexp = struct type t = Atom of string | List of t list end;;
+module Sexp : sig type t = Atom of string | List of t list end
+# module Csexp = Csexp.Make(Sexp);;
+module Csexp :
+ sig
+ val parse_string : string -> (Sexp.t, int * string) result
+ val parse_string_many : string -> (Sexp.t list, int * string) result
+ val input : in_channel -> (Sexp.t, string) result
+ val input_opt : in_channel -> (Sexp.t option, string) result
+ val input_many : in_channel -> (Sexp.t list, string) result
+ val serialised_length : Sexp.t -> int
+ val to_string : Sexp.t -> string
+ val to_buffer : Buffer.t -> Sexp.t -> unit
+ val to_channel : out_channel -> Sexp.t -> unit
+ end
+# Csexp.to_string (List [ Atom "Hello"; Atom "world!" ]);;
+- : string = "(5:Hello6:world!)"
+```
+
new file mode 100644
@@ -0,0 +1,22 @@
+open StdLabels
+
+module Sexp = struct
+ type t =
+ | Atom of string
+ | List of t list
+end
+
+module Csexp = Csexp.Make (Sexp)
+
+let atom = Sexp.Atom (String.make 128 'x')
+
+let rec gen_sexp depth =
+ if depth = 0 then
+ atom
+ else
+ let x = gen_sexp (depth - 1) in
+ List [ x; x ]
+
+let s = Sys.opaque_identity (Csexp.to_string (gen_sexp 16))
+
+let%bench "of_string" = ignore (Csexp.parse_string s : _ result)
new file mode 100644
@@ -0,0 +1,11 @@
+(library
+ (name csexp_bench)
+ (libraries csexp)
+ (library_flags -linkall)
+ (preprocess (pps ppx_bench))
+ (modules csexp_bench))
+
+(executable
+ (name main)
+ (modules main)
+ (libraries core_bench.inline_benchmarks csexp_bench))
new file mode 100644
@@ -0,0 +1 @@
+let () = Inline_benchmarks_public.Runner.main ~libname:"csexp_bench"
new file mode 100755
@@ -0,0 +1,4 @@
+#!/usr/bin/env sh
+export BENCHMARKS_RUNNER=TRUE
+export BENCH_LIB=csexp_bench
+exec dune exec -- ./main.exe -fork -run-without-cross-library-inlining "$@"
new file mode 100644
@@ -0,0 +1,51 @@
+version: "1.3.2"
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "Parsing and printing of S-expressions in Canonical form"
+description: """
+
+This library provides minimal support for Canonical S-expressions
+[1]. Canonical S-expressions are a binary encoding of S-expressions
+that is super simple and well suited for communication between
+programs.
+
+This library only provides a few helpers for simple applications. If
+you need more advanced support, such as parsing from more fancy input
+sources, you should consider copying the code of this library given
+how simple parsing S-expressions in canonical form is.
+
+To avoid a dependency on a particular S-expression library, the only
+module of this library is parameterised by the type of S-expressions.
+
+[1] https://en.wikipedia.org/wiki/Canonical_S-expressions
+"""
+maintainer: ["Jeremie Dimino <jeremie@dimino.org>"]
+authors: [
+ "Quentin Hocquet <mefyl@gruntech.org>"
+ "Jane Street Group, LLC <opensource@janestreet.com>"
+ "Jeremie Dimino <jeremie@dimino.org>"
+]
+license: "MIT"
+homepage: "https://github.com/ocaml-dune/csexp"
+doc: "https://ocaml-dune.github.io/csexp/"
+bug-reports: "https://github.com/ocaml-dune/csexp/issues"
+depends: [
+ "dune" {>= "1.11"}
+ "ocaml" {>= "4.02.3"}
+ "result" {>= "1.5"}
+]
+dev-repo: "git+https://github.com/ocaml-dune/csexp.git"
+build: [
+ ["dune" "subst"] {pinned}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+# "@runtest" {with-test & ocaml:version >= "4.04"}
+ "@doc" {with-doc}
+ ]
+]
\ No newline at end of file
new file mode 100644
@@ -0,0 +1,14 @@
+build: [
+ ["dune" "subst"] {pinned}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+# "@runtest" {with-test & ocaml:version >= "4.04"}
+ "@doc" {with-doc}
+ ]
+]
new file mode 100644
@@ -0,0 +1,42 @@
+(lang dune 1.11)
+(name csexp)
+(version 1.3.2)
+
+(allow_approximate_merlin)
+
+(license MIT)
+(maintainers "Jeremie Dimino <jeremie@dimino.org>")
+(authors
+ "Quentin Hocquet <mefyl@gruntech.org>"
+ "Jane Street Group, LLC <opensource@janestreet.com>"
+ "Jeremie Dimino <jeremie@dimino.org>")
+(source (github ocaml-dune/csexp))
+(documentation "https://ocaml-dune.github.io/csexp/")
+
+(generate_opam_files true)
+
+(package
+ (name csexp)
+ (depends
+ (ocaml (>= 4.02.3))
+; (ppx_expect :with-test)
+; Disabled because of a dependency cycle
+; (see https://github.com/ocaml-opam/opam-depext/issues/121)
+ (result (>= 1.5)))
+ (synopsis "Parsing and printing of S-expressions in Canonical form")
+ (description "
+This library provides minimal support for Canonical S-expressions
+[1]. Canonical S-expressions are a binary encoding of S-expressions
+that is super simple and well suited for communication between
+programs.
+
+This library only provides a few helpers for simple applications. If
+you need more advanced support, such as parsing from more fancy input
+sources, you should consider copying the code of this library given
+how simple parsing S-expressions in canonical form is.
+
+To avoid a dependency on a particular S-expression library, the only
+module of this library is parameterised by the type of S-expressions.
+
+[1] https://en.wikipedia.org/wiki/Canonical_S-expressions
+"))
new file mode 100644
@@ -0,0 +1,6 @@
+(lang dune 1.0)
+
+;; This file is used by `make all-supported-ocaml-versions`
+(context (opam (switch 4.02.3)))
+(context (opam (switch 4.04.2)))
+(context (opam (switch 4.08.1)))
new file mode 100644
@@ -0,0 +1,333 @@
+module type Sexp = sig
+ type t =
+ | Atom of string
+ | List of t list
+end
+
+module type Monad = sig
+ type 'a t
+
+ val return : 'a -> 'a t
+
+ val bind : 'a t -> ('a -> 'b t) -> 'b t
+end
+
+module Make (Sexp : Sexp) = struct
+ open Sexp
+
+ (* This is to keep compatibility with 4.02 without writing [Result.]
+ everywhere *)
+ type ('a, 'b) result = ('a, 'b) Result.result =
+ | Ok of 'a
+ | Error of 'b
+
+ module Parser = struct
+ exception Parse_error of string
+
+ let parse_error msg = raise (Parse_error msg)
+
+ let parse_errorf f = Format.ksprintf parse_error f
+
+ let premature_end_of_input = "premature end of input"
+
+ module Lexer = struct
+ type state =
+ | Init
+ | Parsing_length
+
+ type t =
+ { mutable state : state
+ ; mutable n : int
+ }
+
+ let create () = { state = Init; n = 0 }
+
+ let int_of_digit c = Char.code c - Char.code '0'
+
+ type _ token =
+ | Await : [> `other ] token
+ | Lparen : [> `other ] token
+ | Rparen : [> `other ] token
+ | Atom : int -> [> `atom ] token
+
+ let feed t c =
+ match (t.state, c) with
+ | Init, '(' -> Lparen
+ | Init, ')' -> Rparen
+ | Init, '0' .. '9' ->
+ t.state <- Parsing_length;
+ t.n <- int_of_digit c;
+ Await
+ | Init, _ ->
+ parse_errorf "invalid character %C, expected '(', ')' or '0'..'9'" c
+ | Parsing_length, '0' .. '9' ->
+ let len = (t.n * 10) + int_of_digit c in
+ if len > Sys.max_string_length then
+ parse_error "atom too big to represent"
+ else (
+ t.n <- len;
+ Await
+ )
+ | Parsing_length, ':' ->
+ t.state <- Init;
+ Atom t.n
+ | Parsing_length, _ ->
+ parse_errorf
+ "invalid character %C while parsing atom length, expected '0'..'9' \
+ or ':'"
+ c
+
+ let feed_eoi t =
+ match t.state with
+ | Init -> ()
+ | Parsing_length -> parse_error premature_end_of_input
+ end
+
+ module L = Lexer
+
+ module Stack = struct
+ type t =
+ | Empty
+ | Open of t
+ | Sexp of Sexp.t * t
+
+ let open_paren stack = Open stack
+
+ let close_paren =
+ let rec loop acc = function
+ | Empty ->
+ parse_error "right parenthesis without matching left parenthesis"
+ | Sexp (sexp, t) -> loop (sexp :: acc) t
+ | Open t -> Sexp (List acc, t)
+ in
+ fun t -> loop [] t
+
+ let to_list =
+ let rec loop acc = function
+ | Empty -> acc
+ | Sexp (sexp, t) -> loop (sexp :: acc) t
+ | Open _ -> parse_error premature_end_of_input
+ in
+ fun t -> loop [] t
+
+ let add_atom s stack = Sexp (Atom s, stack)
+
+ let add_token (x : [ `other ] Lexer.token) stack =
+ match x with
+ | L.Await -> stack
+ | L.Lparen -> open_paren stack
+ | L.Rparen -> close_paren stack
+ end
+ end
+
+ open Parser
+
+ let feed_eoi_single lexer stack =
+ match
+ Lexer.feed_eoi lexer;
+ Stack.to_list stack
+ with
+ | exception Parse_error msg -> Error msg
+ | [ x ] -> Ok x
+ | [] -> Error premature_end_of_input
+ | _ :: _ :: _ -> assert false
+
+ let feed_eoi_many lexer stack =
+ match
+ Lexer.feed_eoi lexer;
+ Stack.to_list stack
+ with
+ | exception Parse_error msg -> Error msg
+ | l -> Ok l
+
+ let one_token s pos len lexer stack k =
+ match Lexer.feed lexer (String.unsafe_get s pos) with
+ | exception Parse_error msg -> Error (pos, msg)
+ | L.Atom atom_len -> (
+ match String.sub s (pos + 1) atom_len with
+ | exception _ -> Error (len, premature_end_of_input)
+ | atom ->
+ let pos = pos + 1 + atom_len in
+ k s pos len lexer (Stack.add_atom atom stack) )
+ | (L.Await | L.Lparen | L.Rparen) as x -> (
+ match Stack.add_token x stack with
+ | exception Parse_error msg -> Error (pos, msg)
+ | stack -> k s (pos + 1) len lexer stack )
+ [@@inlined always]
+
+ let parse_string =
+ let rec loop s pos len lexer stack =
+ if pos = len then
+ match feed_eoi_single lexer stack with
+ | Error msg -> Error (pos, msg)
+ | Ok _ as ok -> ok
+ else
+ one_token s pos len lexer stack cont
+ and cont s pos len lexer stack =
+ match stack with
+ | Stack.Sexp (sexp, Empty) ->
+ if pos = len then
+ Ok sexp
+ else
+ Error (pos, "data after canonical S-expression")
+ | stack -> loop s pos len lexer stack
+ in
+ fun s -> loop s 0 (String.length s) (Lexer.create ()) Empty
+
+ let parse_string_many =
+ let rec loop s pos len lexer stack =
+ if pos = len then
+ match feed_eoi_many lexer stack with
+ | Error msg -> Error (pos, msg)
+ | Ok _ as ok -> ok
+ else
+ one_token s pos len lexer stack loop
+ in
+ fun s -> loop s 0 (String.length s) (Lexer.create ()) Empty
+
+ let one_token ic c lexer stack =
+ match Lexer.feed lexer c with
+ | L.Atom n -> (
+ match really_input_string ic n with
+ | exception End_of_file -> raise (Parse_error premature_end_of_input)
+ | s -> Stack.add_atom s stack )
+ | (L.Await | L.Lparen | L.Rparen) as x -> Stack.add_token x stack
+
+ let input_opt =
+ let rec loop ic lexer stack =
+ let c = input_char ic in
+ match one_token ic c lexer stack with
+ | Sexp (sexp, Empty) -> Ok (Some sexp)
+ | stack -> loop ic lexer stack
+ in
+ fun ic ->
+ let lexer = Lexer.create () in
+ match input_char ic with
+ | exception End_of_file -> Ok None
+ | c -> (
+ try
+ match Lexer.feed lexer c with
+ | L.Atom _ -> assert false
+ | (L.Await | L.Lparen | L.Rparen) as x ->
+ loop ic lexer (Stack.add_token x Empty)
+ with
+ | Parse_error msg -> Error msg
+ | End_of_file -> Error premature_end_of_input )
+
+ let input ic =
+ match input_opt ic with
+ | Ok None -> Error premature_end_of_input
+ | Ok (Some x) -> Ok x
+ | Error msg -> Error msg
+
+ let input_many =
+ let rec loop ic lexer stack =
+ match input_char ic with
+ | exception End_of_file ->
+ Lexer.feed_eoi lexer;
+ Ok (Stack.to_list stack)
+ | c -> loop ic lexer (one_token ic c lexer stack)
+ in
+ fun ic ->
+ try loop ic (Lexer.create ()) Empty with Parse_error msg -> Error msg
+
+ let serialised_length =
+ let rec loop acc t =
+ match t with
+ | Atom s ->
+ let len = String.length s in
+ let x = ref len in
+ let len_len = ref 1 in
+ while !x > 9 do
+ x := !x / 10;
+ incr len_len
+ done;
+ acc + !len_len + 1 + len
+ | List l -> List.fold_left loop acc l
+ in
+ fun t -> loop 0 t
+
+ let to_buffer buf sexp =
+ let rec loop = function
+ | Atom str ->
+ Buffer.add_string buf (string_of_int (String.length str));
+ Buffer.add_string buf ":";
+ Buffer.add_string buf str
+ | List e ->
+ Buffer.add_char buf '(';
+ List.iter loop e;
+ Buffer.add_char buf ')'
+ in
+ loop sexp
+
+ let to_string sexp =
+ let buf = Buffer.create (serialised_length sexp) in
+ to_buffer buf sexp;
+ Buffer.contents buf
+
+ let to_channel oc sexp =
+ let rec loop = function
+ | Atom str ->
+ output_string oc (string_of_int (String.length str));
+ output_char oc ':';
+ output_string oc str
+ | List l ->
+ output_char oc '(';
+ List.iter loop l;
+ output_char oc ')'
+ in
+ loop sexp
+
+ module type Input = sig
+ type t
+
+ module Monad : Monad
+
+ val read_string : t -> int -> (string, string) Result.t Monad.t
+
+ val read_char : t -> (char, string) Result.t Monad.t
+ end
+
+ module Make_parser (Input : Input) = struct
+ open Input.Monad
+
+ let ( >>= ) = bind
+
+ let ( >>=* ) m f =
+ m >>= function
+ | Error _ as err -> return err
+ | Ok x -> f x
+
+ let one_token input c lexer stack =
+ match Lexer.feed lexer c with
+ | exception Parse_error msg -> return (Error msg)
+ | L.Atom n ->
+ Input.read_string input n >>=* fun s ->
+ return (Ok (Stack.add_atom s stack))
+ | (L.Await | L.Lparen | L.Rparen) as x ->
+ return
+ ( match Stack.add_token x stack with
+ | exception Parse_error msg -> Error msg
+ | stack -> Ok stack )
+
+ let parse =
+ let rec loop input lexer stack =
+ Input.read_char input >>= function
+ | Error _ -> return (feed_eoi_single lexer stack)
+ | Ok c -> (
+ one_token input c lexer stack >>=* function
+ | Sexp (sexp, Empty) -> return (Ok sexp)
+ | stack -> loop input lexer stack )
+ in
+ fun input -> loop input (Lexer.create ()) Empty
+
+ let parse_many =
+ let rec loop input lexer stack =
+ Input.read_char input >>= function
+ | Error _ -> return (feed_eoi_many lexer stack)
+ | Ok c ->
+ one_token input c lexer stack >>=* fun stack -> loop input lexer stack
+ in
+ fun input -> loop input (Lexer.create ()) Empty
+ end
+end
new file mode 100644
@@ -0,0 +1,369 @@
+(** Canonical S-expressions *)
+
+(** This module provides minimal support for reading and writing S-expressions
+ in canonical form.
+
+ https://en.wikipedia.org/wiki/Canonical_S-expressions
+
+ Note that because the canonical representation of S-expressions is so
+ simple, this module doesn't go out of his way to provide a fully generic
+ parser and printer and instead just provides a few simple functions. If you
+ are using fancy input sources, simply copy the parser and adapt it. The
+ format is so simple that it's pretty difficult to get it wrong by accident.
+
+ To avoid a dependency on a particular S-expression library, the only module
+ of this library is parameterised by the type of S-expressions.
+
+ {[
+ let rec print = function
+ | Atom str -> Printf.printf "%d:%s" (String.length s)
+ | List l -> List.iter print l
+ ]} *)
+
+module type Sexp = sig
+ type t =
+ | Atom of string
+ | List of t list
+end
+
+module Make (Sexp : Sexp) : sig
+ (** {2 Parsing} *)
+
+ (** [parse_string s] parses a single S-expression encoded in canonical form in
+ [s]. It is an error for [s] to contain a S-expression followed by more
+ data. In case of error, the offset of the error as well as an error
+ message is returned. *)
+ val parse_string : string -> (Sexp.t, int * string) Result.t
+
+ (** [parse_string s] parses a sequence of S-expressions encoded in canonical
+ form in [s] *)
+ val parse_string_many : string -> (Sexp.t list, int * string) Result.t
+
+ (** Read exactly one canonical S-expressions from the given channel. Note that
+ this function never raises [End_of_file]. Instead, it returns [Error]. *)
+ val input : in_channel -> (Sexp.t, string) Result.t
+
+ (** Same as [input] but returns [Ok None] if the end of file has already been
+ reached. If some more characters are available but the end of file is
+ reached before reading a complete S-expression, this function returns
+ [Error]. *)
+ val input_opt : in_channel -> (Sexp.t option, string) Result.t
+
+ (** Read many S-expressions until the end of input is reached. *)
+ val input_many : in_channel -> (Sexp.t list, string) Result.t
+
+ (** {2 Serialising} *)
+
+ (** The length of the serialised representation of a S-expression *)
+ val serialised_length : Sexp.t -> int
+
+ (** [to_string sexp] converts S-expression [sexp] to a string in canonical
+ form. *)
+ val to_string : Sexp.t -> string
+
+ (** [to_buffer buf sexp] outputs the S-expression [sexp] converted to its
+ canonical form to buffer [buf]. *)
+ val to_buffer : Buffer.t -> Sexp.t -> unit
+
+ (** [output oc sexp] outputs the S-expression [sexp] converted to its
+ canonical form to channel [oc]. *)
+ val to_channel : out_channel -> Sexp.t -> unit
+
+ (** {3 Low level parser}
+
+ For efficiently parsing from sources other than strings or input channel.
+ For instance in Lwt or Async programs. *)
+
+ module Parser : sig
+ (** The [Parser] module offers an API that is a balance between sharing the
+ common logic of parsing canonical S-expressions while allowing to write
+ parsers that are as efficient as possible, both in terms of speed and
+ allocations. A carefully written parser using this API will be:
+
+ - fast
+ - perform minimal allocations
+ - perform zero [caml_modify] (a slow function of the OCaml runtime that
+ is emitted when mutating a constructed value)
+
+ {2 Lexers}
+
+ To parse using this API, you must first create a lexer via
+ {!Lexer.create}. The lexer is responsible for scanning the input and
+ forming tokens. The user must feed characters read from the input one by
+ one to the lexer until it yields a token. For instance:
+
+ {[
+ # let lexer = Lexer.create ();;
+ val lexer : Lexer.t = <abstract>
+ # Lexer.feed lexer '(';;
+ - : [ `atom | `other ] Lexer.token = Lparen
+ # Lexer.feed lexer ')';;
+ - : [ `atom | `other ] Lexer.token = Rparen
+ ]}
+
+ When the lexer doesn't have enough to return a token, it simply returns
+ the special token {!Lexer.Await}:
+
+ {[
+ # Lexer.feed lexer '1';;
+ - : [ `atom | `other ] Lexer.token = Await
+ ]}
+
+ Note that since atoms of canonical S-expressions do not need quoting,
+ they are always represented as a contiguous sequence of characters that
+ don't need further processing. To achieve maximum efficiency, the lexer
+ only returns the length of the atom and it is the responsibility of the
+ caller to extract the atom from the input source:
+
+ {[
+ # Lexer.feed lexer '2';;
+ - : [ `atom | `other ] Lexer.token = Await
+ # Lexer.feed lexer ':';;
+ - : [ `atom | `other ] Lexer.token = Atom 2
+ ]}
+
+ When getting [Atom n], the caller should then proceed to read the next
+ [n] characters of the input as a string. For instance, if the input is
+ an [in_channel] the caller should proceed with
+ [really_input_string ic n].
+
+ Finally, when the end of input is reached the user should call
+ {!Lexer.feed_eoi} to make sure the lexer is not awaiting more input. If
+ that is the case, {!Lexer.feed_eoi} will raise:
+
+ {[
+ # Lexer.feed lexer '1';;
+ - : [ `atom | `other ] Lexer.token = Await
+ # Lexer.feed_eoi lexer;;
+ Exception: Parse_error "premature end of input".
+ ]}
+
+ {2 Parsing stacks}
+
+ The lexer doesn't keep track of the structure of the S-expressions. In
+ order to construct a whole structured S-expressions, the caller must
+ maintain a parsing stack via the {!Stack} module. A {!Stack.t} value
+ simply represent a parsed prefix in reverse order.
+
+ For instance, the prefix "1:x((1:y1:z)" will be represented as:
+
+ {[ Sexp (List [ Atom "y"; Atom "z" ], Open (Sexp (Atom "x", Empty))) ]}
+
+ The {!Stack} module offers various primitives to open or close
+ parentheses or insert an atom. And for convenience it provides a
+ function {!Stack.add_token} that takes the output of {!Lexer.feed}
+ directly:
+
+ {[
+ # Stack.add_token Rparen Empty;;
+ - : Stack.t = Open Empty
+ # Stack.add_token Lparen (Open Empty);;
+ - : Stack.t = Sexp (List [], Empty)
+ ]}
+
+ Note that {!Stack.add_token} doesn't accept [Atom _]. This is enforced
+ at the type level by a GADT. The reason for this is that in order to
+ insert an atom, the user must have fetched the contents of the atom
+ themselves. In order to insert an atom into a stack, you can use the
+ function {!Stack.add_atom}:
+
+ {[
+ # Stack.add_atom "foo" (Open Empty);;
+ - : Stack.t = Sexp (Atom "foo", Open Empty)
+ ]}
+
+ When parsing is finished, one may call the function {!Stack.to_list} in
+ order to extract all the toplevel S-expressions from the stack:
+
+ {[
+ # Stack.to_list (Sexp (Atom "x", Sexp (List [Atom "y"], Empty)));;
+ - : Sexp.t list = [List [Atom "y"; Atom "x"]]
+ ]}
+
+ If instead you want to stop parsing as soon a single full S-expression
+ has been discovered, you can match on the structure of the stack. If the
+ stack is of the form [Sexp (_, Empty)], then you know that exactly one
+ S-expression has been parsed and you can stop there.
+
+ {2 Parsing errors}
+
+ In order to reduce allocations to a minumim, parsing errors are reported
+ via the exception {!Parse_error}. It is the responsibility of the caller
+ to catch this exception and return it as an [Error _] value. Functions
+ that may raise [Parse_error] are documented as such.
+
+ When extracting an atom and the input doesn't have enough characters
+ left, the user may raise [Parse_error premature_end_of_input]. This will
+ produce an error message similar to what the various high-level
+ functions of this library produce.
+
+ {2 Building a parsing function}
+
+ Parsing functions should always follow the following pattern:
+
+ + create a lexer and start with an empty parsing stack
+ + iterate over the input, feeding the lexer characters one by one. When
+ the lexer returns [Atom n], fetch the next [n] characters from the
+ input to form an atom
+ + update the stack via [Stack.add_atom] or [Stack.add_token]
+ + if parsing the whole input, call [Lexer.feed_eoi] when the end of
+ input is reached, otherwise stop as soon as the stack is of the form
+ [Sexp (_, Empty)] -
+
+ For instance, to parse a string as a list of S-expressions:
+
+ {[
+ module Sexp = struct
+ type t =
+ | Atom of string
+ | List of t list
+ end
+
+ module Csexp = Csexp.Make (Sexp)
+
+ let extract_atom s pos len =
+ match String.sub s pos len with
+ | exception _ ->
+ (* Turn out-of-bounds errors into [Parse_error] *)
+ raise (Parse_error premature_end_of_input)
+ | s -> s
+
+ let parse_string =
+ let open Csexp.Parser in
+ let rec loop s pos len lexer stack =
+ if pos = len then (
+ Lexer.feed_eoi lexer;
+ Stack.to_list stack
+ ) else
+ match Lexer.feed lexer (String.unsafe_get s pos) with
+ | Atom atom_len ->
+ let atom = extract_atom s (pos + 1) atom_len in
+ loop s (pos + 1 + atom) len lexer (Stack.add_atom atom stack)
+ | (Await | Lparen | Rparen) as x ->
+ loop s (pos + 1) len lexer (Stack.add_token x stack)
+ in
+ fun s ->
+ match loop s 0 (String.length s) (Lexer.create ()) Empty with
+ | v -> Ok v
+ | exception Parse_error msg -> Error msg
+ ]} *)
+
+ exception Parse_error of string
+
+ (** Error message signaling the end of input was reached prematurely. You
+ can use this when extracting an atom from the input and the input
+ doesn't have enough characters. *)
+ val premature_end_of_input : string
+
+ module Lexer : sig
+ (** Lexical analyser *)
+
+ type t
+
+ val create : unit -> t
+
+ type _ token =
+ | Await : [> `other ] token
+ | Lparen : [> `other ] token
+ | Rparen : [> `other ] token
+ | Atom : int -> [> `atom ] token
+
+ (** Feed a character to the parser.
+
+ @raise Parse_error *)
+ val feed : t -> char -> [ `other | `atom ] token
+
+ (** Feed the end of input to the parser.
+
+ You should call this function when the end of input has been reached
+ in order to ensure that the lexer is not awaiting more input, which
+ would be an error.
+
+ @raise Parse_error if the lexer is awaiting more input *)
+ val feed_eoi : t -> unit
+ end
+
+ module Stack : sig
+ (** Parsing stack *)
+
+ type t =
+ | Empty
+ | Open of t
+ | Sexp of Sexp.t * t
+
+ (** Extract the list of full S-expressions contained in a stack.
+
+ For instance:
+
+ {[
+ # to_list (Sexp (Atom "y", Sexp (Atom "x", Empty)));;
+ - : Stack.t list = [Atom "x"; Atom "y"]
+ ]}
+ @raise Parse_error if the stack contains open parentheses that has not
+ been closed. *)
+ val to_list : t -> Sexp.t list
+
+ (** Add a left parenthesis. *)
+ val open_paren : t -> t
+
+ (** Add a right parenthesis. Raise [Parse_error] if the stack contains no
+ opened parentheses.
+
+ For instance:
+
+ {[
+ # close_paren (Sexp (Atom "y", Sexp (Atom "x", Open Empty)));;
+ - : Stack.t = Sexp (List [Atom "x"; Atom "y"], Empty)
+ ]}
+ @raise Parse_error if the stack contains no open open parenthesis. *)
+ val close_paren : t -> t
+
+ (** Insert an atom in the parsing stack:
+
+ {[
+ # add_atom "foo" Empty;;
+ - : Stack.t = Sexp (Atom "foo", Empty)
+ ]} *)
+ val add_atom : string -> t -> t
+
+ (** Add a token as returned by the lexer.
+
+ @raise Parse_error *)
+ val add_token : [ `other ] Lexer.token -> t -> t
+ end
+ end
+
+ (** {3 Deprecated low-level parser} *)
+
+ (** The above are deprecated as the {!Input} signature does not allow to
+ distinguish between IO errors and end of input conditions. Additionally,
+ the use of monads tend to produce parsers that allocates a lot.
+
+ It is recommended to use the {!Parser} module instead. *)
+
+ module type Input = sig
+ type t
+
+ module Monad : sig
+ type 'a t
+
+ val return : 'a -> 'a t
+
+ val bind : 'a t -> ('a -> 'b t) -> 'b t
+ end
+
+ val read_string : t -> int -> (string, string) Result.t Monad.t
+
+ val read_char : t -> (char, string) Result.t Monad.t
+ end
+ [@@deprecated "Use Parser module instead"]
+
+ [@@@warning "-3"]
+
+ module Make_parser (Input : Input) : sig
+ val parse : Input.t -> (Sexp.t, string) Result.t Input.Monad.t
+
+ val parse_many : Input.t -> (Sexp.t list, string) Result.t Input.Monad.t
+ end
+ [@@deprecated "Use Parser module instead"]
+end
new file mode 100644
@@ -0,0 +1,3 @@
+(library
+ (public_name csexp)
+ (libraries result))
new file mode 100644
@@ -0,0 +1,6 @@
+(library
+ (name csexp_tests)
+ (libraries csexp)
+ (inline_tests)
+ (preprocess
+ (pps ppx_expect)))
new file mode 100644
@@ -0,0 +1,142 @@
+module Sexp = struct
+ type t =
+ | Atom of string
+ | List of t list
+end
+
+module Csexp = Csexp.Make (Sexp)
+open Csexp
+
+let roundtrip x =
+ let str = to_string x in
+ match parse_string str with
+ | Result.Error (_, msg) -> failwith msg
+ | Result.Ok exp ->
+ assert (exp = x);
+ print_string str
+
+let%expect_test _ =
+ roundtrip (Sexp.Atom "foo");
+ [%expect {|3:foo|}]
+
+let%expect_test _ =
+ roundtrip (Sexp.List []);
+ [%expect {|()|}]
+
+let%expect_test _ =
+ roundtrip (Sexp.List [ Sexp.Atom "Hello"; Sexp.Atom "World!" ]);
+ [%expect {|(5:Hello6:World!)|}]
+
+let%expect_test _ =
+ roundtrip
+ (Sexp.List
+ [ Sexp.List
+ [ Sexp.Atom "metadata"
+ ; Sexp.List [ Sexp.Atom "foo"; Sexp.Atom "bar" ]
+ ]
+ ; Sexp.List
+ [ Sexp.Atom "produced-files"
+ ; Sexp.List
+ [ Sexp.List
+ [ Sexp.Atom "/tmp/coin"
+ ; Sexp.Atom
+ "/tmp/dune-memory/v2/files/b2/b295e63b0b8e8fae971d9c493be0d261.1"
+ ]
+ ]
+ ]
+ ]);
+ [%expect
+ {|((8:metadata(3:foo3:bar))(14:produced-files((9:/tmp/coin63:/tmp/dune-memory/v2/files/b2/b295e63b0b8e8fae971d9c493be0d261.1))))|}]
+
+let print_parsed r =
+ match r with
+ | Error msg -> Printf.printf "Error %S" msg
+ | Ok sexp -> Printf.printf "Ok %S" (Csexp.to_string sexp)
+
+let parse s =
+ match parse_string s with
+ | Ok x -> print_parsed (Ok x)
+ | Error (_, msg) -> print_parsed (Error msg)
+
+let%expect_test _ =
+ parse "(3:foo)";
+ [%expect {|
+ Ok "(3:foo)" |}]
+
+let%expect_test _ =
+ parse "";
+ [%expect {| Error "premature end of input" |}]
+
+let%expect_test _ =
+ parse "(";
+ [%expect {| Error "premature end of input" |}]
+
+let%expect_test _ =
+ parse "(a)";
+ [%expect {| Error "invalid character 'a', expected '(', ')' or '0'..'9'" |}]
+
+let%expect_test _ =
+ parse "(:)";
+ [%expect {| Error "invalid character ':', expected '(', ')' or '0'..'9'" |}]
+
+let%expect_test _ =
+ parse "(4:foo)";
+ [%expect {| Error "premature end of input" |}]
+
+let%expect_test _ =
+ parse "(5:foo)";
+ [%expect {| Error "premature end of input" |}]
+
+let%expect_test _ =
+ parse "(3:foo)";
+ [%expect {| Ok "(3:foo)" |}]
+
+let sexp_then_stuff s =
+ let fn, oc = Filename.open_temp_file "csexp-test" "" ~mode:[ Open_binary ] in
+ let delete = lazy (Sys.remove fn) in
+ at_exit (fun () -> Lazy.force delete);
+ output_string oc s;
+ close_out oc;
+ let ic = open_in_bin fn in
+ Csexp.input ic |> print_parsed;
+ print_newline ();
+ print_char (input_char ic);
+ close_in ic;
+ Lazy.force delete
+
+let%expect_test _ =
+ sexp_then_stuff "(3:foo)(3:foo)";
+ [%expect {|
+ Ok "(3:foo)"
+ ( |}]
+
+let%expect_test _ =
+ sexp_then_stuff "(3:foo)Additional_stuff";
+ [%expect {|
+ Ok "(3:foo)"
+ A |}]
+
+let%expect_test _ =
+ parse "(3:foo)(3:foo)";
+ [%expect {| Error "data after canonical S-expression" |}]
+
+let%expect_test _ =
+ parse "(3:foo)additional_stuff";
+ [%expect {| Error "data after canonical S-expression" |}]
+
+let parse_many s =
+ match parse_string_many s with
+ | Error (_, msg) -> print_parsed (Error msg)
+ | Ok xs -> xs |> List.iter (fun x -> print_parsed (Ok x))
+
+let%expect_test "parse_string_many - parse empty string" =
+ parse_many "";
+ [%expect {| |}]
+
+let%expect_test "parse_string_many - parse a single csexp" =
+ parse_many "(3:foo)";
+ [%expect {| Ok "(3:foo)" |}]
+
+let%expect_test "parse_string_many - parse many csexp" =
+ parse_many "(3:foo)(3:bar)";
+ [%expect {| Ok "(3:foo)"Ok "(3:bar)" |}]
new file mode 100644
@@ -0,0 +1,4 @@
+; This file is generated by duniverse.
+; Be aware that it is likely to be overwritten by your next duniverse pull invocation.
+
+(vendored_dirs *)
new file mode 100644
@@ -0,0 +1,8 @@
+BRZO
+_b0
+_build
+tmp
+*~
+\.\#*
+\#*#
+*.install
\ No newline at end of file
new file mode 100644
@@ -0,0 +1 @@
+strict_with=always,match_clause=4,strict_else=never
\ No newline at end of file
new file mode 100644
@@ -0,0 +1,98 @@
+v0.8.8 2019-08-01 Zagreb
+------------------------
+
+Fix build on 32-bit platforms.
+
+v0.8.7 2019-07-21 Zagreb
+------------------------
+
+* Require OCaml 4.05.
+* Add `Fmt.hex` and friends. Support for hex dumping.
+ Thanks to David Kaloper Meršinjak for the design and implementation..
+* Add `Fmt.si_size` to format integer magnitudes using SI prefixes.
+* Add `Fmt.uint64_ns_span` to format time spans.
+* Add `Fmt.truncated` to truncate your long strings.
+* Add `Fmt.flush`, has the effect of `Format.pp_print_flush`.
+* Add `Fmt.[Dump.]{field,record}` for records (#9).
+* Add `Fmt.concat` to apply a list of formatters to a value.
+* Add `Fmt.{semi,sps}`, separators.
+* Add `Fmt.{error,error_msg}` to format `result` values.
+* Add `Fmt.failwith_notrace`.
+* Add `Fmt.( ++ )`, alias for `Fmt.append`.
+* Add `Fmt.Dump.string`.
+* Add more ANSI tty formatting styles and make them composable.
+* Change `Fmt.{const,comma,cut,sp}`, generalize signature.
+* Change `Fmt.append`, incompatible signature. Use `Fmt.(pair ~sep:nop)` if
+ you were using it (backward compatible with earlier versions of `Fmt`).
+* Deprecate `Fmt.{strf,kstrf,strf_like}` in favor of `Fmt.{str,kstr,str_like}`.
+* Deprecate `Fmt.{always,unit}` in favor of `Fmt.any`.
+* Deprecate `Fmt.{prefix,suffix}` (specializes Fmt.( ++ )).
+* Deprecate `Fmt.styled_unit`.
+* No longer subvert the `Format` tag system to do dirty things.
+ Thanks to David Kaloper Meršinjak for the work.
+
+v0.8.6 2019-04-01 La Forclaz (VS)
+---------------------------------
+
+* Add `Fmt.{seq,Dump.seq}` to format `'a Seq.t` values. Thanks to
+ Hezekiah M. Carty for the patch.
+* Handle `Pervasives`'s deprecation via dependency on `stdlib-shims`.
+* `Fmt.Dump.signal` format signals added in 4.03.
+* Fix toplevel initialization for omod (#33).
+* Require at least OCaml 4.03 (drops dependency on `result` and `uchar`
+ compatibility packages).
+
+v0.8.5 2017-12-27 La Forclaz (VS)
+---------------------------------
+
+* Fix `Fmt.{kstrf,strf_like}` when they are partially applied
+ and repeatedly called. Thanks to Thomas Gazagnaire for the report.
+* Add `Fmt.comma`.
+* Relax the `Fmt.(invalid_arg, failwith)` type signature. Thanks to
+ Hezekiah M. Carty for the patch.
+
+v0.8.4 2017-07-08 Zagreb
+------------------------
+
+* Add `Fmt.{invalid_arg,failwith}`. Thanks to Hezekiah M. Carty for the patch.
+
+v0.8.3 2017-04-13 La Forclaz (VS)
+---------------------------------
+
+* Fix `Fmt.exn_backtrace`. Thanks to Thomas Leonard for the report.
+
+v0.8.2 2017-03-20 La Forclaz (VS)
+---------------------------------
+
+* Fix `META` file.
+
+v0.8.1 2017-03-15 La Forclaz (VS)
+---------------------------------
+
+* `Fmt_tty.setup`, treat empty `TERM` env var as dumb.
+* Add `Fmt.Dump.uchar` formatter for inspecting `Uchar.t` values.
+
+v0.8.0 2016-05-23 La Forclaz (VS)
+---------------------------------
+
+* Build depend on topkg.
+* Relicense from BSD3 to ISC.
+* Tweak `Fmt.Dump.option` to indent like in sources.
+* Add `Fmt.Dump.signal` formatter for `Sys` signal numbers.
+* Add `Fmt[.Dump].result`, formatter for `result` values.
+* Add `Fmt.{words,paragraphs}` formatters on US-ASCII strings.
+* Add `Fmt.exn[_backtrace]`. Thanks to Edwin Török for suggesting.
+* Add `Fmt.quote`.
+* Rename `Fmt.text_range` to `Fmt.text_loc` and simplify output
+ when range is a position.
+
+v0.7.1 2015-12-03 Cambridge (UK)
+--------------------------------
+
+* Add optional cmdliner support. See the `Fmt_cli` module provided
+ by the package `fmt.cli`.
+
+v0.7.0 2015-09-17 Cambridge (UK)
+--------------------------------
+
+First Release.
new file mode 100644
@@ -0,0 +1,13 @@
+Copyright (c) 2016 The fmt programmers
+
+Permission to use, copy, modify, and/or distribute this software for any
+purpose with or without fee is hereby granted, provided that the above
+copyright notice and this permission notice appear in all copies.
+
+THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
new file mode 100644
@@ -0,0 +1,35 @@
+Fmt — OCaml Format pretty-printer combinators
+-------------------------------------------------------------------------------
+%%VERSION%%
+
+Fmt exposes combinators to devise `Format` pretty-printing functions.
+
+Fmt depends only on the OCaml standard library. The optional `Fmt_tty`
+library that allows to setup formatters for terminal color output
+depends on the Unix library. The optional `Fmt_cli` library that
+provides command line support for Fmt depends on [`Cmdliner`][cmdliner].
+
+Fmt is distributed under the ISC license.
+
+[cmdliner]: http://erratique.ch/software/cmdliner
+
+Home page: http://erratique.ch/software/fmt
+
+## Installation
+
+Fmt can be installed with `opam`:
+
+ opam install fmt
+ opam install base-unix cmdliner fmt # Install all optional libraries
+
+If you don't use `opam` consult the [`opam`](opam) file for build
+instructions.
+
+## Documentation
+
+The documentation and API reference is automatically generated by
+`ocamldoc` from the interfaces. It can be consulted [online][doc]
+and there is a generated version in the `doc` directory of the
+distribution.
+
+[doc]: http://erratique.ch/software/fmt/doc/
new file mode 100644
@@ -0,0 +1,7 @@
+true : bin_annot, safe_string, package(seq), package(stdlib-shims)
+<_b0> : -traverse
+<src> : include
+<src/fmt_tty*> : package(unix)
+<src/fmt_cli*> : package(cmdliner)
+<src/fmt_top*> : package(compiler-libs.toplevel)
+<test> : include
new file mode 100644
@@ -0,0 +1,3 @@
+Fmt
+Fmt_tty
+Fmt_cli
new file mode 100644
@@ -0,0 +1,11 @@
+{0 Fmt {%html: <span class="version">%%VERSION%%</span>%}}
+
+Fmt exposes combinators to devise {!Format} pretty-printing functions.
+
+{1:api API}
+
+{!modules:
+Fmt
+Fmt_tty
+Fmt_cli
+}
new file mode 100644
@@ -0,0 +1,2 @@
+(lang dune 1.0)
+(name fmt)
new file mode 100644
@@ -0,0 +1,35 @@
+opam-version: "2.0"
+maintainer: "Daniel Bünzli <daniel.buenzl i@erratique.ch>"
+authors: [ "The fmt programmers" ]
+homepage: "https://erratique.ch/software/fmt"
+doc: "https://erratique.ch/software/fmt"
+dev-repo: "git+https://github.com/dune-universe/fmt.git"
+bug-reports: "https://github.com/dbuenzli/fmt/issues"
+tags: [ "string" "format" "pretty-print" "org:erratique" ]
+license: "ISC"
+build: [
+ [ "dune" "build" "-p" name "-j" jobs ]
+]
+run-test: [
+ [ "dune" "runtest" "-p" name "-j" jobs ]
+]
+depends: [
+ "dune"
+ "ocaml" {>= "4.07.0"}
+ "stdlib-shims"
+]
+depopts: [ "base-unix" "cmdliner" ]
+conflicts: [ "cmdliner" {< "0.9.8"} ]
+synopsis: "OCaml Format pretty-printer combinators"
+description: """
+Fmt exposes combinators to devise `Format` pretty-printing functions.
+Fmt depends only on the OCaml standard library. The optional `Fmt_tty`
+library that allows to setup formatters for terminal color output
+depends on the Unix library. The optional `Fmt_cli` library that
+provides command line support for Fmt depends on [`Cmdliner`][cmdliner].
+Fmt is distributed under the ISC license.
+[cmdliner]: http://erratique.ch/software/cmdliner
+"""
+url {
+ src: "git+https://github.com/dune-universe/fmt#duniverse-v0.8.8"
+}
new file mode 100644
@@ -0,0 +1,40 @@
+description = "OCaml Format pretty-printer combinators"
+version = "%%VERSION_NUM%%"
+requires = "seq stdlib-shims"
+archive(byte) = "fmt.cma"
+archive(native) = "fmt.cmxa"
+plugin(byte) = "fmt.cma"
+plugin(native) = "fmt.cmxs"
+
+package "tty" (
+ description = "Fmt TTY setup"
+ version = "%%VERSION_NUM%%"
+ requires = "unix fmt"
+ archive(byte) = "fmt_tty.cma"
+ archive(native) = "fmt_tty.cmxa"
+ plugin(byte) = "fmt_tty.cma"
+ plugin(native) = "fmt_tty.cmxs"
+ exists_if = "fmt_tty.cma"
+)
+
+package "cli" (
+ description = "Cmdliner support for Fmt"
+ version = "%%VERSION_NUM%%"
+ requires = "cmdliner fmt"
+ archive(byte) = "fmt_cli.cma"
+ archive(native) = "fmt_cli.cmxa"
+ plugin(byte) = "fmt_cli.cma"
+ plugin(native) = "fmt_cli.cmxs"
+ exists_if = "fmt_cli.cma"
+)
+
+package "top" (
+ description = "Fmt toplevel support"
+ version = "%%VERSION_NUM%%"
+ requires = "fmt fmt.tty"
+ archive(byte) = "fmt_top.cma"
+ archive(native) = "fmt_top.cmxa"
+ plugin(byte) = "fmt_top.cma"
+ plugin(native) = "fmt_top.cmxs"
+ exists_if = "fmt_top.cma"
+)
new file mode 100755
@@ -0,0 +1,18 @@
+#!/usr/bin/env ocaml
+#use "topfind"
+#require "topkg"
+open Topkg
+
+let unix = Conf.with_pkg "base-unix"
+let cmdliner = Conf.with_pkg "cmdliner"
+
+let () =
+ Pkg.describe "fmt" @@ fun c ->
+ let unix = Conf.value c unix in
+ let cmdliner = Conf.value c cmdliner in
+ Ok [ Pkg.mllib "src/fmt.mllib";
+ Pkg.mllib ~cond:unix "src/fmt_tty.mllib";
+ Pkg.mllib ~cond:cmdliner "src/fmt_cli.mllib";
+ Pkg.mllib ~api:[] "src/fmt_top.mllib";
+ Pkg.lib "src/fmt_tty_top_init.ml";
+ Pkg.test "test/test"; ]
new file mode 100644
@@ -0,0 +1,30 @@
+(library
+ (name fmt)
+ (public_name fmt)
+ (libraries result)
+ (modules fmt)
+ (flags :standard -w -3-6-27-34-50)
+ (wrapped false))
+
+(library
+ (name fmt_tty)
+ (public_name fmt.tty)
+ (libraries unix fmt)
+ (modules fmt_tty)
+ (flags :standard -w -3-6-27)
+ (wrapped false))
+
+(library
+ (name fmt_cli)
+ (public_name fmt.cli)
+ (libraries fmt cmdliner)
+ (modules fmt_cli)
+ (flags :standard -w -3-6-27)
+ (wrapped false))
+
+(library
+ (name fmt_top)
+ (public_name fmt.top)
+ (libraries compiler-libs.toplevel fmt)
+ (modules fmt_top)
+ (wrapped false))
new file mode 100644
@@ -0,0 +1,787 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2014 The fmt programmers. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+let invalid_arg' = invalid_arg
+
+(* Errors *)
+
+let err_str_formatter = "Format.str_formatter can't be set."
+
+(* Standard outputs *)
+
+let stdout = Format.std_formatter
+let stderr = Format.err_formatter
+
+(* Formatting *)
+
+let pf = Format.fprintf
+let pr = Format.printf
+let epr = Format.eprintf
+let str = Format.asprintf
+let kpf = Format.kfprintf
+let kstr = Format.kasprintf
+let failwith fmt = kstr failwith fmt
+let failwith_notrace fmt = kstr (fun s -> raise_notrace (Failure s)) fmt
+let invalid_arg fmt = kstr invalid_arg fmt
+let error fmt = kstr (fun s -> Error s) fmt
+let error_msg fmt = kstr (fun s -> Error (`Msg s)) fmt
+
+(* Formatters *)
+
+type 'a t = Format.formatter -> 'a -> unit
+
+let flush ppf _ = Format.pp_print_flush ppf ()
+let nop fmt ppf = ()
+let any fmt ppf _ = pf ppf fmt
+let using f pp ppf v = pp ppf (f v)
+let const pp_v v ppf _ = pp_v ppf v
+let fmt fmt ppf = pf ppf fmt
+
+(* Separators *)
+
+let cut ppf _ = Format.pp_print_cut ppf ()
+let sp ppf _ = Format.pp_print_space ppf ()
+let sps n ppf _ = Format.pp_print_break ppf n 0
+let comma ppf _ = Format.pp_print_string ppf ","; sp ppf ()
+let semi ppf _ = Format.pp_print_string ppf ";"; sp ppf ()
+
+(* Sequencing *)
+
+let iter ?sep:(pp_sep = cut) iter pp_elt ppf v =
+ let is_first = ref true in
+ let pp_elt v =
+ if !is_first then (is_first := false) else pp_sep ppf ();
+ pp_elt ppf v
+ in
+ iter pp_elt v
+
+let iter_bindings ?sep:(pp_sep = cut) iter pp_binding ppf v =
+ let is_first = ref true in
+ let pp_binding k v =
+ if !is_first then (is_first := false) else pp_sep ppf ();
+ pp_binding ppf (k, v)
+ in
+ iter pp_binding v
+
+let append pp_v0 pp_v1 ppf v = pp_v0 ppf v; pp_v1 ppf v
+let ( ++ ) = append
+let concat ?sep pps ppf v = iter ?sep List.iter (fun ppf pp -> pp ppf v) ppf pps
+
+(* Boxes *)
+
+let box ?(indent = 0) pp_v ppf v =
+ Format.(pp_open_box ppf indent; pp_v ppf v; pp_close_box ppf ())
+
+let hbox pp_v ppf v =
+ Format.(pp_open_hbox ppf (); pp_v ppf v; pp_close_box ppf ())
+
+let vbox ?(indent = 0) pp_v ppf v =
+ Format.(pp_open_vbox ppf indent; pp_v ppf v; pp_close_box ppf ())
+
+let hvbox ?(indent = 0) pp_v ppf v =
+ Format.(pp_open_hvbox ppf indent; pp_v ppf v; pp_close_box ppf ())
+
+let hovbox ?(indent = 0) pp_v ppf v =
+ Format.(pp_open_hovbox ppf indent; pp_v ppf v; pp_close_box ppf ())
+
+(* Brackets *)
+
+let surround s1 s2 pp_v ppf v =
+ Format.(pp_print_string ppf s1; pp_v ppf v; pp_print_string ppf s2)
+
+let parens pp_v = box ~indent:1 (surround "(" ")" pp_v)
+let brackets pp_v = box ~indent:1 (surround "[" "]" pp_v)
+let oxford_brackets pp_v = box ~indent:2 (surround "[|" "|]" pp_v)
+let braces pp_v = box ~indent:1 (surround "{" "}" pp_v)
+let quote ?(mark = "\"") pp_v =
+ let pp_mark ppf _ = Format.pp_print_as ppf 1 mark in
+ box ~indent:1 (pp_mark ++ pp_v ++ pp_mark)
+
+(* Stdlib types formatters *)
+
+let bool = Format.pp_print_bool
+let int = Format.pp_print_int
+let nativeint ppf v = pf ppf "%nd" v
+let int32 ppf v = pf ppf "%ld" v
+let int64 ppf v = pf ppf "%Ld" v
+let uint ppf v = pf ppf "%u" v
+let uint32 ppf v = pf ppf "%lu" v
+let uint64 ppf v = pf ppf "%Lu" v
+let unativeint ppf v = pf ppf "%nu" v
+let char = Format.pp_print_char
+let string = Format.pp_print_string
+let buffer ppf b = string ppf (Buffer.contents b)
+let exn ppf e = string ppf (Printexc.to_string e)
+let exn_backtrace ppf (e, bt) =
+ let pp_backtrace_str ppf s =
+ let stop = String.length s - 1 (* there's a newline at the end *) in
+ let rec loop left right =
+ if right = stop then string ppf (String.sub s left (right - left)) else
+ if s.[right] <> '\n' then loop left (right + 1) else
+ begin
+ string ppf (String.sub s left (right - left));
+ cut ppf ();
+ loop (right + 1) (right + 1)
+ end
+ in
+ if s = "" then (string ppf "No backtrace available.") else
+ loop 0 0
+ in
+ pf ppf "@[<v>Exception: %a@,%a@]"
+ exn e pp_backtrace_str (Printexc.raw_backtrace_to_string bt)
+
+let float ppf v = pf ppf "%g" v
+let round x = floor (x +. 0.5)
+let round_dfrac d x =
+ if x -. (round x) = 0. then x else (* x is an integer. *)
+ let m = 10. ** (float_of_int d) in (* m moves 10^-d to 1. *)
+ (floor ((x *. m) +. 0.5)) /. m
+
+let round_dsig d x =
+ if x = 0. then 0. else
+ let m = 10. ** (floor (log10 (abs_float x))) in (* to normalize x. *)
+ (round_dfrac d (x /. m)) *. m
+
+let float_dfrac d ppf f = pf ppf "%g" (round_dfrac d f)
+let float_dsig d ppf f = pf ppf "%g" (round_dsig d f)
+
+let pair ?sep:(pp_sep = cut) pp_fst pp_snd ppf (fst, snd) =
+ pp_fst ppf fst; pp_sep ppf (); pp_snd ppf snd
+
+let option ?none:(pp_none = nop) pp_v ppf = function
+| None -> pp_none ppf ()
+| Some v -> pp_v ppf v
+
+let result ~ok ~error ppf = function
+| Ok v -> ok ppf v
+| Error e -> error ppf e
+
+let list ?sep pp_elt = iter ?sep List.iter pp_elt
+let array ?sep pp_elt = iter ?sep Array.iter pp_elt
+let seq ?sep pp_elt = iter ?sep Seq.iter pp_elt
+let hashtbl ?sep pp_binding = iter_bindings ?sep Hashtbl.iter pp_binding
+let queue ?sep pp_elt = iter Queue.iter pp_elt
+let stack ?sep pp_elt = iter Stack.iter pp_elt
+
+(* Stdlib type dumpers *)
+
+module Dump = struct
+
+ (* Sequencing *)
+
+ let iter iter_f pp_name pp_elt =
+ let pp_v = iter ~sep:sp iter_f (box pp_elt) in
+ parens (pp_name ++ sp ++ pp_v)
+
+ let iter_bindings iter_f pp_name pp_k pp_v =
+ let pp_v = iter_bindings ~sep:sp iter_f (pair pp_k pp_v) in
+ parens (pp_name ++ sp ++ pp_v)
+
+ (* Stlib types *)
+
+ let sig_names =
+ Sys.[ sigabrt, "SIGABRT"; sigalrm, "SIGALRM"; sigfpe, "SIGFPE";
+ sighup, "SIGHUP"; sigill, "SIGILL"; sigint, "SIGINT";
+ sigkill, "SIGKILL"; sigpipe, "SIGPIPE"; sigquit, "SIGQUIT";
+ sigsegv, "SIGSEGV"; sigterm, "SIGTERM"; sigusr1, "SIGUSR1";
+ sigusr2, "SIGUSR2"; sigchld, "SIGCHLD"; sigcont, "SIGCONT";
+ sigstop, "SIGSTOP"; sigtstp, "SIGTSTP"; sigttin, "SIGTTIN";
+ sigttou, "SIGTTOU"; sigvtalrm, "SIGVTALRM"; sigprof, "SIGPROF";
+ sigbus, "SIGBUS"; sigpoll, "SIGPOLL"; sigsys, "SIGSYS";
+ sigtrap, "SIGTRAP"; sigurg, "SIGURG"; sigxcpu, "SIGXCPU";
+ sigxfsz, "SIGXFSZ"; ]
+
+ let signal ppf s = match List.assq_opt s sig_names with
+ | Some name -> string ppf name
+ | None -> pf ppf "SIG(%d)" s
+
+ let uchar ppf u = pf ppf "U+%04X" (Uchar.to_int u)
+ let string ppf s = pf ppf "%S" s
+ let pair pp_fst pp_snd =
+ parens (using fst (box pp_fst) ++ comma ++ using snd (box pp_snd))
+
+ let option pp_v ppf = function
+ | None -> pf ppf "None"
+ | Some v -> pf ppf "@[<2>Some@ @[%a@]@]" pp_v v
+
+ let result ~ok ~error ppf = function
+ | Ok v -> pf ppf "@[<2>Ok@ @[%a@]@]" ok v
+ | Error e -> pf ppf "@[<2>Error@ @[%a@]@]" error e
+
+ let list pp_elt = brackets (list ~sep:semi (box pp_elt))
+ let array pp_elt = oxford_brackets (array ~sep:semi (box pp_elt))
+ let seq pp_elt = brackets (seq ~sep:semi (box pp_elt))
+
+ let hashtbl pp_k pp_v =
+ iter_bindings Hashtbl.iter (any "hashtbl") pp_k pp_v
+
+ let stack pp_elt = iter Stack.iter (any "stack") pp_elt
+ let queue pp_elt = iter Queue.iter (any "queue") pp_elt
+
+ (* Records *)
+
+ let field ?(label = string) l prj pp_v ppf v =
+ pf ppf "@[<1>%a =@ %a@]" label l pp_v (prj v)
+
+ let record pps =
+ box ~indent:2 (surround "{ " " }" @@ vbox (concat ~sep:(any ";@,") pps))
+end
+
+(* Magnitudes *)
+
+let ilog10 x =
+ let rec loop p x = if x = 0 then p else loop (p + 1) (x / 10) in
+ loop (-1) x
+
+let ipow10 n =
+ let rec loop acc n = if n = 0 then acc else loop (acc * 10) (n - 1) in
+ loop 1 n
+
+let si_symb_max = 16
+let si_symb =
+ [| "y"; "z"; "a"; "f"; "p"; "n"; "u"; "m"; ""; "k"; "M"; "G"; "T"; "P";
+ "E"; "Z"; "Y"|]
+
+let rec pp_at_factor ~scale u symb factor ppf s =
+ let m = s / factor in
+ let n = s mod factor in
+ match m with
+ | m when m >= 100 -> (* No fractional digit *)
+ let m_up = if n > 0 then m + 1 else m in
+ if m_up >= 1000 then si_size ~scale u ppf (m_up * factor) else
+ pf ppf "%d%s%s" m_up symb u
+ | m when m >= 10 -> (* One fractional digit w.o. trailing 0 *)
+ let f_factor = factor / 10 in
+ let f_m = n / f_factor in
+ let f_n = n mod f_factor in
+ let f_m_up = if f_n > 0 then f_m + 1 else f_m in
+ begin match f_m_up with
+ | 0 -> pf ppf "%d%s%s" m symb u
+ | f when f >= 10 -> si_size ~scale u ppf (m * factor + f * f_factor)
+ | f -> pf ppf "%d.%d%s%s" m f symb u
+ end
+ | m -> (* Two or zero fractional digits w.o. trailing 0 *)
+ let f_factor = factor / 100 in
+ let f_m = n / f_factor in
+ let f_n = n mod f_factor in
+ let f_m_up = if f_n > 0 then f_m + 1 else f_m in
+ match f_m_up with
+ | 0 -> pf ppf "%d%s%s" m symb u
+ | f when f >= 100 -> si_size ~scale u ppf (m * factor + f * f_factor)
+ | f when f mod 10 = 0 -> pf ppf "%d.%d%s%s" m (f / 10) symb u
+ | f -> pf ppf "%d.%02d%s%s" m f symb u
+
+and si_size ~scale u ppf s = match scale < -8 || scale > 8 with
+| true -> invalid_arg "~scale is %d, must be in [-8;8]" scale
+| false ->
+ let pow_div_3 = if s = 0 then 0 else (ilog10 s / 3) in
+ let symb = (scale + 8) + pow_div_3 in
+ let symb, factor = match symb > si_symb_max with
+ | true -> si_symb_max, ipow10 ((8 - scale) * 3)
+ | false -> symb, ipow10 (pow_div_3 * 3)
+ in
+ if factor = 1
+ then pf ppf "%d%s%s" s si_symb.(symb) u
+ else pp_at_factor ~scale u si_symb.(symb) factor ppf s
+
+let byte_size ppf s = si_size ~scale:0 "B" ppf s
+
+let bi_byte_size ppf s =
+ (* XXX we should get rid of this. *)
+ let _pp_byte_size k i ppf s =
+ let pp_frac = float_dfrac 1 in
+ let div_round_up m n = (m + n - 1) / n in
+ let float = float_of_int in
+ if s < k then pf ppf "%dB" s else
+ let m = k * k in
+ if s < m then begin
+ let kstr = if i = "" then "k" (* SI *) else "K" (* IEC *) in
+ let sk = s / k in
+ if sk < 10
+ then pf ppf "%a%s%sB" pp_frac (float s /. float k) kstr i
+ else pf ppf "%d%s%sB" (div_round_up s k) kstr i
+ end else
+ let g = k * m in
+ if s < g then begin
+ let sm = s / m in
+ if sm < 10
+ then pf ppf "%aM%sB" pp_frac (float s /. float m) i
+ else pf ppf "%dM%sB" (div_round_up s m) i
+ end else
+ let t = k * g in
+ if s < t then begin
+ let sg = s / g in
+ if sg < 10
+ then pf ppf "%aG%sB" pp_frac (float s /. float g) i
+ else pf ppf "%dG%sB" (div_round_up s g) i
+ end else
+ let p = k * t in
+ if s < p then begin
+ let st = s / t in
+ if st < 10
+ then pf ppf "%aT%sB" pp_frac (float s /. float t) i
+ else pf ppf "%dT%sB" (div_round_up s t) i
+ end else begin
+ let sp = s / p in
+ if sp < 10
+ then pf ppf "%aP%sB" pp_frac (float s /. float p) i
+ else pf ppf "%dP%sB" (div_round_up s p) i
+ end
+ in
+ _pp_byte_size 1024 "i" ppf s
+
+(* XXX From 4.08 on use Int64.unsigned_*
+
+ See Hacker's Delight for the implementation of these unsigned_* funs *)
+
+let unsigned_compare x0 x1 = Int64.(compare (sub x0 min_int) (sub x1 min_int))
+let unsigned_div n d = match d < Int64.zero with
+| true -> if unsigned_compare n d < 0 then Int64.zero else Int64.one
+| false ->
+ let q = Int64.(shift_left (div (shift_right_logical n 1) d) 1) in
+ let r = Int64.(sub n (mul q d)) in
+ if unsigned_compare r d >= 0 then Int64.succ q else q
+
+let unsigned_rem n d = Int64.(sub n (mul (unsigned_div n d) d))
+
+let us_span = 1_000L
+let ms_span = 1_000_000L
+let sec_span = 1_000_000_000L
+let min_span = 60_000_000_000L
+let hour_span = 3600_000_000_000L
+let day_span = 86_400_000_000_000L
+let year_span = 31_557_600_000_000_000L
+
+let rec pp_si_span unit_str si_unit si_higher_unit ppf span =
+ let geq x y = unsigned_compare x y >= 0 in
+ let m = unsigned_div span si_unit in
+ let n = unsigned_rem span si_unit in
+ match m with
+ | m when geq m 100L -> (* No fractional digit *)
+ let m_up = if Int64.equal n 0L then m else Int64.succ m in
+ let span' = Int64.mul m_up si_unit in
+ if geq span' si_higher_unit then uint64_ns_span ppf span' else
+ pf ppf "%Ld%s" m_up unit_str
+ | m when geq m 10L -> (* One fractional digit w.o. trailing zero *)
+ let f_factor = unsigned_div si_unit 10L in
+ let f_m = unsigned_div n f_factor in
+ let f_n = unsigned_rem n f_factor in
+ let f_m_up = if Int64.equal f_n 0L then f_m else Int64.succ f_m in
+ begin match f_m_up with
+ | 0L -> pf ppf "%Ld%s" m unit_str
+ | f when geq f 10L ->
+ uint64_ns_span ppf Int64.(add (mul m si_unit) (mul f f_factor))
+ | f -> pf ppf "%Ld.%Ld%s" m f unit_str
+ end
+ | m -> (* Two or zero fractional digits w.o. trailing zero *)
+ let f_factor = unsigned_div si_unit 100L in
+ let f_m = unsigned_div n f_factor in
+ let f_n = unsigned_rem n f_factor in
+ let f_m_up = if Int64.equal f_n 0L then f_m else Int64.succ f_m in
+ match f_m_up with
+ | 0L -> pf ppf "%Ld%s" m unit_str
+ | f when geq f 100L ->
+ uint64_ns_span ppf Int64.(add (mul m si_unit) (mul f f_factor))
+ | f when Int64.equal (Int64.rem f 10L) 0L ->
+ pf ppf "%Ld.%Ld%s" m (Int64.div f 10L) unit_str
+ | f ->
+ pf ppf "%Ld.%02Ld%s" m f unit_str
+
+and pp_non_si unit_str unit unit_lo_str unit_lo unit_lo_size ppf span =
+ let geq x y = unsigned_compare x y >= 0 in
+ let m = unsigned_div span unit in
+ let n = unsigned_rem span unit in
+ if Int64.equal n 0L then pf ppf "%Ld%s" m unit_str else
+ let f_m = unsigned_div n unit_lo in
+ let f_n = unsigned_rem n unit_lo in
+ let f_m_up = if Int64.equal f_n 0L then f_m else Int64.succ f_m in
+ match f_m_up with
+ | f when geq f unit_lo_size ->
+ uint64_ns_span ppf Int64.(add (mul m unit) (mul f unit_lo))
+ | f ->
+ pf ppf "%Ld%s%Ld%s" m unit_str f unit_lo_str
+
+and uint64_ns_span ppf span =
+ let geq x y = unsigned_compare x y >= 0 in
+ let lt x y = unsigned_compare x y = -1 in
+ match span with
+ | s when lt s us_span -> pf ppf "%Ldns" s
+ | s when lt s ms_span -> pp_si_span "us" us_span ms_span ppf s
+ | s when lt s sec_span -> pp_si_span "ms" ms_span sec_span ppf s
+ | s when lt s min_span -> pp_si_span "s" sec_span min_span ppf s
+ | s when lt s hour_span -> pp_non_si "min" min_span "s" sec_span 60L ppf s
+ | s when lt s day_span -> pp_non_si "h" hour_span "min" min_span 60L ppf s
+ | s when lt s year_span -> pp_non_si "d" day_span "h" hour_span 24L ppf s
+ | s ->
+ let m = unsigned_div s year_span in
+ let n = unsigned_rem s year_span in
+ if Int64.equal n 0L then pf ppf "%Lda" m else
+ let f_m = unsigned_div n day_span in
+ let f_n = unsigned_rem n day_span in
+ let f_m_up = if Int64.equal f_n 0L then f_m else Int64.succ f_m in
+ match f_m_up with
+ | f when geq f 366L -> pf ppf "%Lda" (Int64.succ m)
+ | f -> pf ppf "%Lda%Ldd" m f
+
+(* Binary formatting *)
+
+type 'a vec = int * (int -> 'a)
+
+let iter_vec f (n, get) = for i = 0 to n - 1 do f i (get i) done
+let vec ?sep = iter_bindings ?sep iter_vec
+
+let on_string = using String.(fun s -> length s, get s)
+let on_bytes = using Bytes.(fun b -> length b, get b)
+
+let sub_vecs w (n, get) =
+ (n - 1) / w + 1,
+ fun j ->
+ let off = w * j in
+ min w (n - off), fun i -> get (i + off)
+
+let prefix0x = [
+ 0xf , fmt "%01x";
+ 0xff , fmt "%02x";
+ 0xfff , fmt "%03x";
+ 0xffff , fmt "%04x";
+ 0xfffff , fmt "%05x";
+ 0xffffff , fmt "%06x";
+ 0xfffffff , fmt "%07x"; ]
+
+let padded0x ~max = match List.find_opt (fun (x, _) -> max <= x) prefix0x with
+| Some (_, pp) -> pp
+| None -> fmt "%08x"
+
+let ascii ?(w = 0) ?(subst = const char '.') () ppf (n, _ as v) =
+ let pp_char ppf (_, c) =
+ if '\x20' <= c && c < '\x7f' then char ppf c else subst ppf ()
+ in
+ vec pp_char ppf v;
+ if n < w then sps (w - n) ppf ()
+
+let octets ?(w = 0) ?(sep = sp) () ppf (n, _ as v) =
+ let pp_sep ppf i = if i > 0 && i mod 2 = 0 then sep ppf () in
+ let pp_char ppf (i, c) = pp_sep ppf i; pf ppf "%02x" (Char.code c) in
+ vec ~sep:nop pp_char ppf v;
+ for i = n to w - 1 do pp_sep ppf i; sps 2 ppf () done
+
+let addresses ?addr ?(w = 16) pp_vec ppf (n, _ as v) =
+ let addr = match addr with
+ | Some pp -> pp
+ | _ -> padded0x ~max:(((n - 1) / w) * w) ++ const string ": "
+ in
+ let pp_sub ppf (i, sub) = addr ppf (i * w); box pp_vec ppf sub in
+ vbox (vec pp_sub) ppf (sub_vecs w v)
+
+let hex ?(w = 16) () =
+ addresses ~w ((octets ~w () |> box) ++ sps 2 ++ (ascii ~w () |> box))
+
+(* Text and lines *)
+
+let is_nl c = c = '\n'
+let is_nl_or_sp c = is_nl c || c = ' '
+let is_white = function ' ' | '\t' .. '\r' -> true | _ -> false
+let not_white c = not (is_white c)
+let not_white_or_nl c = is_nl c || not_white c
+
+let rec stop_at sat ~start ~max s =
+ if start > max then start else
+ if sat s.[start] then start else
+ stop_at sat ~start:(start + 1) ~max s
+
+let sub s start stop ~max =
+ if start = stop then "" else
+ if start = 0 && stop > max then s else
+ String.sub s start (stop - start)
+
+let words ppf s =
+ let max = String.length s - 1 in
+ let rec loop start s = match stop_at is_white ~start ~max s with
+ | stop when stop > max -> Format.pp_print_string ppf (sub s start stop ~max)
+ | stop ->
+ Format.pp_print_string ppf (sub s start stop ~max);
+ match stop_at not_white ~start:stop ~max s with
+ | stop when stop > max -> ()
+ | stop -> Format.pp_print_space ppf (); loop stop s
+ in
+ let start = stop_at not_white ~start:0 ~max s in
+ if start > max then () else loop start s
+
+let paragraphs ppf s =
+ let max = String.length s - 1 in
+ let rec loop start s = match stop_at is_white ~start ~max s with
+ | stop when stop > max -> Format.pp_print_string ppf (sub s start stop ~max)
+ | stop ->
+ Format.pp_print_string ppf (sub s start stop ~max);
+ match stop_at not_white_or_nl ~start:stop ~max s with
+ | stop when stop > max -> ()
+ | stop ->
+ if s.[stop] <> '\n'
+ then (Format.pp_print_space ppf (); loop stop s) else
+ match stop_at not_white_or_nl ~start:(stop + 1) ~max s with
+ | stop when stop > max -> ()
+ | stop ->
+ if s.[stop] <> '\n'
+ then (Format.pp_print_space ppf (); loop stop s) else
+ match stop_at not_white ~start:(stop + 1) ~max s with
+ | stop when stop > max -> ()
+ | stop ->
+ Format.pp_force_newline ppf ();
+ Format.pp_force_newline ppf ();
+ loop stop s
+ in
+ let start = stop_at not_white ~start:0 ~max s in
+ if start > max then () else loop start s
+
+let text ppf s =
+ let max = String.length s - 1 in
+ let rec loop start s = match stop_at is_nl_or_sp ~start ~max s with
+ | stop when stop > max -> Format.pp_print_string ppf (sub s start stop ~max)
+ | stop ->
+ Format.pp_print_string ppf (sub s start stop ~max);
+ begin match s.[stop] with
+ | ' ' -> Format.pp_print_space ppf ()
+ | '\n' -> Format.pp_force_newline ppf ()
+ | _ -> assert false
+ end;
+ loop (stop + 1) s
+ in
+ loop 0 s
+
+let lines ppf s =
+ let max = String.length s - 1 in
+ let rec loop start s = match stop_at is_nl ~start ~max s with
+ | stop when stop > max -> Format.pp_print_string ppf (sub s start stop ~max)
+ | stop ->
+ Format.pp_print_string ppf (sub s start stop ~max);
+ Format.pp_force_newline ppf ();
+ loop (stop + 1) s
+ in
+ loop 0 s
+
+let truncated ~max ppf s = match String.length s <= max with
+| true -> Format.pp_print_string ppf s
+| false ->
+ for i = 0 to max - 4 do Format.pp_print_char ppf s.[i] done;
+ Format.pp_print_string ppf "..."
+
+let text_loc ppf ((l0, c0), (l1, c1)) =
+ if (l0 : int) == (l1 : int) && (c0 : int) == (c1 : int)
+ then pf ppf "%d.%d" l0 c0
+ else pf ppf "%d.%d-%d.%d" l0 c0 l1 c1
+
+(* HCI fragments *)
+
+let one_of ?(empty = nop) pp_v ppf = function
+| [] -> empty ppf ()
+| [v] -> pp_v ppf v
+| [v0; v1] -> pf ppf "@[either %a or@ %a@]" pp_v v0 pp_v v1
+| _ :: _ as vs ->
+ let rec loop ppf = function
+ | [v] -> pf ppf "or@ %a" pp_v v
+ | v :: vs -> pf ppf "%a,@ " pp_v v; loop ppf vs
+ | [] -> assert false
+ in
+ pf ppf "@[one@ of@ %a@]" loop vs
+
+let did_you_mean
+ ?(pre = any "Unknown") ?(post = nop) ~kind pp_v ppf (v, hints)
+ =
+ match hints with
+ | [] -> pf ppf "@[%a %s %a%a.@]" pre () kind pp_v v post ()
+ | hints ->
+ pf ppf "@[%a %s %a%a.@ Did you mean %a ?@]"
+ pre () kind pp_v v post () (one_of pp_v) hints
+
+(* Conditional UTF-8 and styled formatting. *)
+
+type any = ..
+type 'a attr = int * ('a -> any) * (any -> 'a)
+
+let id = ref 0
+let attr (type a) () =
+ incr id;
+ let module M = struct type any += K of a end in
+ !id, (fun x -> M.K x), (function M.K x -> x | _ -> assert false)
+
+module Int = struct type t = int let compare a b = compare (a: int) b end
+module Imap = Map.Make (Int)
+
+let attrs = ref []
+let store ppf =
+ let open Ephemeron.K1 in
+ let rec go ppf top = function
+ | [] ->
+ let e = create () and v = ref Imap.empty in
+ attrs := e :: List.rev top; set_key e ppf; set_data e v; v
+ | e::es ->
+ match get_key e with
+ | None -> go ppf top es
+ | Some k when not (k == ppf) -> go ppf (e::top) es
+ | Some k ->
+ let v = match get_data e with Some v -> v | _ -> assert false in
+ if not (top == []) then attrs := e :: List.rev_append top es;
+ ignore (Sys.opaque_identity k); v
+ in
+ go ppf [] !attrs
+
+let get (k, _, prj) ppf =
+ match Imap.find_opt k !(store ppf) with Some x -> Some (prj x) | _ -> None
+
+let set (k, inj, _) v ppf =
+ if ppf == Format.str_formatter then invalid_arg' err_str_formatter else
+ let s = store ppf in
+ s := Imap.add k (inj v) !s
+
+let def x = function Some y -> y | _ -> x
+
+let utf_8_attr = attr ()
+let utf_8 ppf = get utf_8_attr ppf |> def true
+let set_utf_8 ppf x = set utf_8_attr x ppf
+
+type style_renderer = [ `Ansi_tty | `None ]
+let style_renderer_attr = attr ()
+let style_renderer ppf = get style_renderer_attr ppf |> def `None
+let set_style_renderer ppf x = set style_renderer_attr x ppf
+
+let with_buffer ?like buf =
+ let ppf = Format.formatter_of_buffer buf in
+ (match like with Some like -> store ppf := !(store like) | _ -> ());
+ ppf
+
+let str_like ppf fmt =
+ let buf = Buffer.create 64 in
+ let bppf = with_buffer ~like:ppf buf in
+ let flush ppf =
+ Format.pp_print_flush ppf ();
+ let s = Buffer.contents buf in
+ Buffer.reset buf; s
+ in
+ Format.kfprintf flush bppf fmt
+
+(* Conditional UTF-8 formatting *)
+
+let if_utf_8 pp_u pp = fun ppf v -> (if utf_8 ppf then pp_u else pp) ppf v
+
+(* Styled formatting *)
+
+type color =
+ [ `Black | `Blue | `Cyan | `Green | `Magenta | `Red | `White | `Yellow ]
+
+type style =
+ [ `None | `Bold | `Faint | `Italic | `Underline | `Reverse
+ | `Fg of [ color | `Hi of color ]
+ | `Bg of [ color | `Hi of color ]
+ | color (** deprecated *) ]
+
+let ansi_style_code = function
+| `Bold -> "1"
+| `Faint -> "2"
+| `Italic -> "3"
+| `Underline -> "4"
+| `Reverse -> "7"
+| `Fg `Black -> "30"
+| `Fg `Red -> "31"
+| `Fg `Green -> "32"
+| `Fg `Yellow -> "33"
+| `Fg `Blue -> "34"
+| `Fg `Magenta -> "35"
+| `Fg `Cyan -> "36"
+| `Fg `White -> "37"
+| `Bg `Black -> "40"
+| `Bg `Red -> "41"
+| `Bg `Green -> "42"
+| `Bg `Yellow -> "43"
+| `Bg `Blue -> "44"
+| `Bg `Magenta -> "45"
+| `Bg `Cyan -> "46"
+| `Bg `White -> "47"
+| `Fg (`Hi `Black) -> "90"
+| `Fg (`Hi `Red) -> "91"
+| `Fg (`Hi `Green) -> "92"
+| `Fg (`Hi `Yellow) -> "93"
+| `Fg (`Hi `Blue) -> "94"
+| `Fg (`Hi `Magenta) -> "95"
+| `Fg (`Hi `Cyan) -> "96"
+| `Fg (`Hi `White) -> "97"
+| `Bg (`Hi `Black) -> "100"
+| `Bg (`Hi `Red) -> "101"
+| `Bg (`Hi `Green) -> "102"
+| `Bg (`Hi `Yellow) -> "103"
+| `Bg (`Hi `Blue) -> "104"
+| `Bg (`Hi `Magenta) -> "105"
+| `Bg (`Hi `Cyan) -> "106"
+| `Bg (`Hi `White) -> "107"
+| `None -> "0"
+(* deprecated *)
+| `Black -> "30"
+| `Red -> "31"
+| `Green -> "32"
+| `Yellow -> "33"
+| `Blue -> "34"
+| `Magenta -> "35"
+| `Cyan -> "36"
+| `White -> "37"
+
+let pp_sgr ppf style =
+ Format.pp_print_as ppf 0 "\027[";
+ Format.pp_print_as ppf 0 style;
+ Format.pp_print_as ppf 0 "m"
+
+let curr_style = attr ()
+
+let styled style pp_v ppf v = match style_renderer ppf with
+| `None -> pp_v ppf v
+| `Ansi_tty ->
+ let curr = match get curr_style ppf with
+ | None -> let s = ref "0" in set curr_style s ppf; s
+ | Some s -> s
+ in
+ let prev = !curr and here = ansi_style_code style in
+ curr := (match style with `None -> here | _ -> prev ^ ";" ^ here);
+ try pp_sgr ppf here; pp_v ppf v; pp_sgr ppf prev; curr := prev with
+ | e -> curr := prev; raise e
+
+(* Records *)
+
+external id : 'a -> 'a = "%identity"
+let label = styled (`Fg `Yellow) string
+let field ?(label = label) ?(sep = any ":@ ") l prj pp_v ppf v =
+ pf ppf "@[<1>%a%a%a@]" label l sep () pp_v (prj v)
+
+let record ?(sep = cut) pps = vbox (concat ~sep pps)
+
+(* Converting with string converters. *)
+
+let of_to_string f ppf v = string ppf (f v)
+let to_to_string pp_v v = str "%a" pp_v v
+
+(* Deprecated *)
+
+let strf = str
+let kstrf = kstr
+let strf_like = str_like
+let always = any
+let unit = any
+let prefix pp_p pp_v ppf v = pp_p ppf (); pp_v ppf v
+let suffix pp_s pp_v ppf v = pp_v ppf v; pp_s ppf ()
+let styled_unit style fmt = styled style (any fmt)
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2014 The fmt programmers
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,689 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2014 The fmt programmers. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+(** {!Format} pretty-printer combinators.
+
+ Consult {{!nameconv}naming conventions} for your pretty-printers.
+
+ {b References}
+ {ul
+ {- The {!Format} module documentation.}
+ {- The required reading {!Format} module
+ {{:https://ocaml.org/learn/tutorials/format.html}tutorial}.}} *)
+
+(** {1:stdos Standard outputs} *)
+
+val stdout : Format.formatter
+(** [stdout] is the standard output formatter. *)
+
+val stderr : Format.formatter
+(** [stderr] is the standard error formatter. *)
+
+(** {1:formatting Formatting} *)
+
+val pf : Format.formatter -> ('a, Format.formatter, unit) Stdlib.format -> 'a
+(** [pf] is {!Format.fprintf}. *)
+
+val pr : ('a, Format.formatter, unit) format -> 'a
+(** [pr] is [pf stdout]. *)
+
+val epr : ('a, Format.formatter, unit) format -> 'a
+(** [epr] is [pf stderr]. *)
+
+val str : ('a, Format.formatter, unit, string) format4 -> 'a
+(** [str] is {!Format.asprintf}.
+
+ {b Note.} When using [strf] {!utf_8} and {!style_renderer} are
+ always respectively set to [true] and [`None]. See also
+ {!str_like}. *)
+
+val kpf : (Format.formatter -> 'a) -> Format.formatter ->
+ ('b, Format.formatter, unit, 'a) Stdlib.format4 -> 'b
+(** [kpf] is {!Format.kfprintf}. *)
+
+val kstr :
+ (string -> 'a) -> ('b, Format.formatter, unit, 'a) format4 -> 'b
+(** [kstr] is like {!str} but continuation based. *)
+
+val str_like :
+ Format.formatter -> ('a, Format.formatter, unit, string) format4 -> 'a
+(** [str_like ppf] is like {!str} except its {!utf_8} and {!style_renderer}
+ settings are those of [ppf]. *)
+
+val with_buffer : ?like:Format.formatter -> Buffer.t -> Format.formatter
+(** [with_buffer ~like b] is a formatter whose {!utf_8} and {!style_renderer}
+ settings are copied from those of {!like} (if provided). *)
+
+val failwith : ('a, Format.formatter, unit, 'b) format4 -> 'a
+(** [failwith] is [kstr failwith], raises {!Stdlib.Failure} with
+ a pretty-printed string argument. *)
+
+val failwith_notrace : ('a, Format.formatter, unit, 'b) format4 -> 'a
+(** [failwith_notrace] is like {!failwith} but raises with {!raise_notrace}. *)
+
+val invalid_arg : ('a, Format.formatter, unit, 'b) format4 -> 'a
+(** [invalid_arg] is [kstr invalid_arg], raises
+ {!Stdlib.Invalid_argument} with a pretty-printed string argument. *)
+
+val error : ('b, Format.formatter , unit, ('a, string) result) format4 -> 'b
+(** [error fmt ...] is [kstr (fun s -> Error s) fmt ...] *)
+
+val error_msg :
+ ('b, Format.formatter , unit, ('a, [`Msg of string]) result) format4 -> 'b
+(** [error_msg fmt ...] is [kstr (fun s -> Error (`Msg s)) fmt ...] *)
+
+(** {1 Formatters} *)
+
+type 'a t = Format.formatter -> 'a -> unit
+(** The type for formatters of values of type ['a]. *)
+
+val flush : 'a t
+(** [flush] has the effect of {!Format.pp_print_flush} *)
+
+val nop : 'a t
+(** [nop] formats nothing. *)
+
+val any : (unit, Format.formatter, unit) Stdlib.format -> 'a t
+(** [any fmt ppf v] formats any value with the constant format [fmt]. *)
+
+val using : ('a -> 'b) -> 'b t -> 'a t
+(** [using f pp ppf v] ppf ppf [(f v)]. *)
+
+val const : 'a t -> 'a -> 'b t
+(** [const pp_v v] always formats [v] using [pp_v]. *)
+
+val fmt : ('a, Format.formatter, unit) Stdlib.format -> Format.formatter -> 'a
+(** [fmt fmt ppf] is [pf ppf fmt]. If [fmt] is used with a single
+ non-constant formatting directive, generates a value of type
+ {!t}. *)
+
+(** {1:seps Separators} *)
+
+val cut : 'a t
+(** [cut] has the effect of {!Format.pp_print_cut}. *)
+
+val sp : 'a t
+(** [sp] has the effect of {!Format.pp_print_space}. *)
+
+val sps : int -> 'a t
+(** [sps n] has the effect of {!Format.pp_print_break}[ n 0]. *)
+
+val comma : 'a t
+(** [comma] is {!Fmt.any}[ ",@ "]. *)
+
+val semi : 'a t
+(** [semi] is {!Fmt.any}[ ";@ "]. *)
+
+(** {1:seq Sequencing} *)
+
+val append : 'a t -> 'a t -> 'a t
+(** [append pp_v0 pp_v1 ppf v] is [pp_v0 ppf v; pp_v1 ppf v]. *)
+
+val ( ++ ) : 'a t -> 'a t -> 'a t
+(** [( ++ )] is {!append}. *)
+
+val concat : ?sep:unit t -> 'a t list -> 'a t
+(** [concat ~sep pps] formats a value using the formaters [pps]
+ and separting each format with [sep] (defaults to {!cut}). *)
+
+val iter : ?sep:unit t -> (('a -> unit) -> 'b -> unit) -> 'a t -> 'b t
+(** [iter ~sep iter pp_elt] formats the iterations of [iter] over a
+ value using [pp_elt]. Iterations are separated by [sep] (defaults to
+ {!cut}). *)
+
+val iter_bindings : ?sep:unit t -> (('a -> 'b -> unit) -> 'c -> unit) ->
+ ('a * 'b) t -> 'c t
+(** [iter_bindings ~sep iter pp_binding] formats the iterations of
+ [iter] over a value using [pp_binding]. Iterations are separated
+ by [sep] (defaults to {!cut}). *)
+
+(** {1:boxes Boxes} *)
+
+val box : ?indent:int -> 'a t -> 'a t
+(** [box ~indent pp ppf] wraps [pp] in a pretty-printing box. The box tries to
+ print as much as possible on every line, while emphasizing the box structure
+ (see {!Format.pp_open_box}). Break hints that lead to a new line add
+ [indent] to the current indentation (defaults to [0]). *)
+
+val hbox : 'a t -> 'a t
+(** [hbox] is like {!box} but is a horizontal box: the line is not split
+ in this box (but may be in sub-boxes). See {!Format.pp_open_hbox}. *)
+
+val vbox : ?indent:int -> 'a t -> 'a t
+(** [vbox] is like {!box} but is a vertical box: every break hint leads
+ to a new line which adds [indent] to the current indentation
+ (defaults to [0]). See {!Format.pp_open_vbox}. *)
+
+val hvbox : ?indent:int -> 'a t -> 'a t
+(** [hvbox] is like {!hbox} if it fits on a single line, or like {!vbox}
+ otherwise. See {!Format.pp_open_hvbox}. *)
+
+val hovbox : ?indent:int -> 'a t -> 'a t
+(** [hovbox] is a condensed {!box}. See {!Format.pp_open_hovbox}. *)
+
+(** {1:bracks Brackets} *)
+
+val parens : 'a t -> 'a t
+(** [parens pp_v ppf] is [pf "@[<1>(%a)@]" pp_v]. *)
+
+val brackets : 'a t -> 'a t
+(** [brackets pp_v ppf] is [pf "@[<1>[%a]@]" pp_v]. *)
+
+val braces : 'a t -> 'a t
+(** [braces pp_v ppf] is [pf "@[<1>{%a}@]" pp_v]. *)
+
+val quote : ?mark:string -> 'a t -> 'a t
+(** [quote ~mark pp_v ppf] is [pf "@[<1>@<1>%s%a@<1>%s@]" mark pp_v mark],
+ [mark] defaults to ["\""], it is always counted as spanning as single
+ column (this allows for UTF-8 encoded marks). *)
+
+(** {1:records Records} *)
+
+val id : 'a -> 'a
+(** [id] is {!Fun.id}. *)
+
+val field :
+ ?label:string t -> ?sep:unit t -> string -> ('b -> 'a) -> 'a t -> 'b t
+(** [field ~label ~sep l prj pp_v] pretty prints a labelled field value as
+ [pf "@[<1>%a%a%a@]" label l sep () (using prj pp_v)]. [label] defaults
+ to [styled `Yellow string] and [sep] to [any ":@ "]. *)
+
+val record : ?sep:unit t -> 'a t list -> 'a t
+(** [record ~sep fields] pretty-prints a value using the concatenation of
+ [fields], separated by [sep] (defaults to [cut]) and framed in a vertical
+ box. *)
+
+(** {1:stdlib Stdlib types}
+
+ Formatters for structures give full control to the client over the
+ formatting process and do not wrap the formatted structures with
+ boxes. Use the {!Dump} module to quickly format values for
+ inspection. *)
+
+val bool : bool t
+(** [bool] is {!Format.pp_print_bool}. *)
+
+val int : int t
+(** [int] is [pf ppf "%d"]. *)
+
+val nativeint : nativeint t
+(** [nativeint ppf] is [pf ppf "%nd"]. *)
+
+val int32 : int32 t
+(** [int32 ppf] is [pf ppf "%ld"]. *)
+
+val int64 : int64 t
+(** [int64 ppf] is [pf ppf "%Ld"]. *)
+
+val uint : int t
+(** [uint ppf] is [pf ppf "%u"]. *)
+
+val unativeint : nativeint t
+(** [unativeint ppf] is [pf ppf "%nu"]. *)
+
+val uint32 : int32 t
+(** [uint32 ppf] is [pf ppf "%lu"]. *)
+
+val uint64 : int64 t
+(** [uint64 ppf] is [pf ppf "%Lu"]. *)
+
+val float : float t
+(** [float ppf] is [pf ppf "%g".] *)
+
+val float_dfrac : int -> float t
+(** [float_dfrac d] rounds the float to the [d]th {e decimal}
+ fractional digit and formats the result with ["%g"]. Ties are
+ rounded towards positive infinity. The result is only defined
+ for [0 <= d <= 16]. *)
+
+val float_dsig : int -> float t
+(** [float_dsig d] rounds the normalized {e decimal} significand
+ of the float to the [d]th decimal fractional digit and formats
+ the result with ["%g"]. Ties are rounded towards positive
+ infinity. The result is NaN on infinities and only defined for
+ [0 <= d <= 16].
+
+ {b Warning.} The current implementation overflows on large [d]
+ and floats. *)
+
+val char : char t
+(** [char] is {!Format.pp_print_char}. *)
+
+val string : string t
+(** [string] is {!Format.pp_print_string}. *)
+
+val buffer : Buffer.t t
+(** [buffer] formats a {!Buffer.t} value's current contents. *)
+
+val exn : exn t
+(** [exn] formats an exception. *)
+
+val exn_backtrace : (exn * Printexc.raw_backtrace) t
+(** [exn_backtrace] formats an exception backtrace. *)
+
+val pair : ?sep:unit t -> 'a t -> 'b t -> ('a * 'b) t
+(** [pair ~sep pp_fst pp_snd] formats a pair. The first and second
+ projection are formatted using [pp_fst] and [pp_snd] and are
+ separated by [sep] (defaults to {!cut}). *)
+
+val option : ?none:unit t -> 'a t -> 'a option t
+(** [option ~none pp_v] formats an optional value. The [Some] case
+ uses [pp_v] and [None] uses [none] (defaults to {!nop}). *)
+
+val result : ok:'a t -> error:'b t -> ('a, 'b) result t
+(** [result ~ok ~error] formats a result value using [ok] for the [Ok]
+ case and [error] for the [Error] case. *)
+
+val list : ?sep:unit t -> 'a t -> 'a list t
+(** [list sep pp_v] formats list elements. Each element of the list is
+ formatted in order with [pp_v]. Elements are separated by [sep]
+ (defaults to {!cut}). If the list is empty, this is {!nop}. *)
+
+val array : ?sep:unit t -> 'a t -> 'a array t
+(** [array sep pp_v] formats array elements. Each element of the array
+ is formatted in order with [pp_v]. Elements are separated by [sep]
+ (defaults to {!cut}). If the array is empty, this is {!nop}. *)
+
+val seq : ?sep:unit t -> 'a t -> 'a Seq.t t
+(** [seq sep pp_v] formats sequence elements. Each element of the sequence
+ is formatted in order with [pp_v]. Elements are separated by [sep]
+ (defaults to {!cut}). If the sequence is empty, this is {!nop}. *)
+
+val hashtbl : ?sep:unit t -> ('a * 'b) t -> ('a, 'b) Hashtbl.t t
+(** [hashtbl ~sep pp_binding] formats the bindings of a hash
+ table. Each binding is formatted with [pp_binding] and bindings
+ are separated by [sep] (defaults to {!cut}). If the hash table has
+ multiple bindings for a given key, all bindings are formatted,
+ with the most recent binding first. If the hash table is empty,
+ this is {!nop}. *)
+
+val queue : ?sep:unit t -> 'a t -> 'a Queue.t t
+(** [queue ~sep pp_v] formats queue elements. Each element of the
+ queue is formatted in least recently added order with
+ [pp_v]. Elements are separated by [sep] (defaults to {!cut}). If
+ the queue is empty, this is {!nop}. *)
+
+val stack : ?sep:unit t -> 'a t -> 'a Stack.t t
+(** [stack ~sep pp_v] formats stack elements. Each element of the
+ stack is formatted from top to bottom order with [pp_v]. Elements
+ are separated by [sep] (defaults to {!cut}). If the stack is
+ empty, this is {!nop}. *)
+
+(** Formatters for inspecting OCaml values.
+
+ Formatters of this module dump OCaml value with little control
+ over the representation but with good default box structures and,
+ whenever possible, using OCaml syntax. *)
+module Dump : sig
+
+ (** {1:stdlib Stdlib types} *)
+
+ val signal : int t
+ (** [signal] formats an OCaml {{!Sys.sigabrt}signal number} as a C
+ POSIX
+ {{:http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/signal.h.html}
+ constant} or ["SIG(%d)"] the signal number is unknown. *)
+
+ val uchar : Uchar.t t
+ (** [uchar] formats an OCaml {!Uchar.t} value using only US-ASCII
+ encoded characters according to the Unicode
+ {{:http://www.unicode.org/versions/latest/appA.pdf}notational
+ convention} for code points. *)
+
+ val string : string t
+ (** [string] is [pf ppf "%S"]. *)
+
+ val pair : 'a t -> 'b t -> ('a * 'b) t
+ (** [pair pp_fst pp_snd] formats an OCaml pair using [pp_fst] and [pp_snd]
+ for the first and second projection. *)
+
+ val option : 'a t -> 'a option t
+ (** [option pp_v] formats an OCaml option using [pp_v] for the [Some]
+ case. No parentheses are added. *)
+
+ val result : ok:'a t -> error:'b t -> ('a, 'b) result t
+ (** [result ~ok ~error] formats an OCaml result using [ok] for the [Ok]
+ case value and [error] for the [Error] case value. No parentheses
+ are added. *)
+
+ val list : 'a t -> 'a list t
+ (** [list pp_v] formats an OCaml list using [pp_v] for the list
+ elements. *)
+
+ val array : 'a t -> 'a array t
+ (** [array pp_v] formats an OCaml array using [pp_v] for the array
+ elements. *)
+
+ val seq : 'a t -> 'a Seq.t t
+ (** [seq pp_v] formats an OCaml sequence using [pp_v] for the sequence
+ elements. *)
+
+ val hashtbl : 'a t -> 'b t -> ('a, 'b) Hashtbl.t t
+ (** [hashtbl pp_k pp_v] formats an unspecified representation of the
+ bindings of a hash table using [pp_k] for the keys and [pp_v]
+ for the values. If the hash table has multiple bindings for a
+ given key, all bindings are formatted, with the most recent
+ binding first. *)
+
+ val queue : 'a t -> 'a Queue.t t
+ (** [queue pp_v] formats an unspecified representation of an OCaml
+ queue using [pp_v] to format its elements, in least recently added
+ order. *)
+
+ val stack : 'a t -> 'a Stack.t t
+ (** [stack pp_v] formats an unspecified representation of an OCaml
+ stack using [pp_v] to format its elements in top to bottom order. *)
+
+ (** {1:record Records} *)
+
+ val field : ?label:string t -> string -> ('b -> 'a) -> 'a t -> 'b t
+ (** [field ~label l prj pp_v] pretty prints a named field using [label]
+ (defaults to [styled `Yellow string]) for the label, and [using prj pp_v]
+ for the field value. *)
+
+ val record : 'a t list -> 'a t
+ (** [record fields] pretty-prints a value using the concatenation of
+ [fields], separated by [";@,"], framed in a vertical
+ box and surrounded by {!braces}. *)
+
+ (** {1:seq Sequencing}
+
+ These are akin to {!iter} and {!iter_bindings} but
+ delimit the sequences with {!parens}. *)
+
+ val iter : (('a -> unit) -> 'b -> unit) -> 'b t -> 'a t -> 'b t
+ (** [iter iter pp_name pp_elt] formats an unspecified representation
+ of the iterations of [iter] over a value using [pp_elt]. The
+ iteration is named by [pp_name]. *)
+
+ val iter_bindings : (('a -> 'b -> unit) -> 'c -> unit) -> 'c t -> 'a t
+ -> 'b t -> 'c t
+ (** [iter_bindings ~sep iter pp_name pp_k pp_v] formats an
+ unspecified representation of the iterations of [iter] over a
+ value using [pp_k] and [pp_v]. The iteration is named by
+ [pp_name]. *)
+end
+
+(** {1:mgs Magnitudes} *)
+
+val si_size : scale:int -> string -> int t
+(** [si_size ~scale unit] formats a non negative integer
+ representing unit [unit] at scale 10{^scale * 3}, depending on
+ its magnitude, using power of 3
+ {{:https://www.bipm.org/en/publications/si-brochure/chapter3.html}
+ SI prefixes} (i.e. all of them except deca, hector, deci and
+ centi). Only US-ASCII characters are used, [µ] (10{^-6}) is
+ written using [u].
+
+ [scale] indicates the scale 10{^scale * 3} an integer
+ represents, for example [-1] for m[unit] (10{^-3}), [0] for
+ [unit] (10{^0}), [1] for [kunit] (10{^3}); it must be in the
+ range \[[-8];[8]\] or [Invalid_argument] is raised.
+
+ Except at the maximal yotta scale always tries to show three
+ digits of data with trailing fractional zeros omited. Rounds
+ towards positive infinity (over approximates). *)
+
+val byte_size : int t
+(** [byte_size] is [si_size ~scale:0 "B"]. *)
+
+val bi_byte_size : int t
+(** [bi_byte_size] formats a byte size according to its magnitude
+ using {{:https://en.wikipedia.org/wiki/Binary_prefix}binary prefixes}
+ up to pebi bytes (2{^15}). *)
+
+val uint64_ns_span : int64 t
+(** [uint64_ns_span] formats an {e unsigned} nanosecond time span
+ according to its magnitude using
+ {{:http://www.bipm.org/en/publications/si-brochure/chapter3.html}SI
+ prefixes} on seconds and
+ {{:http://www.bipm.org/en/publications/si-brochure/table6.html}accepted
+ non-SI units}. Years are counted in Julian years (365.25 SI-accepted days)
+ as {{:http://www.iau.org/publications/proceedings_rules/units/}defined}
+ by the International Astronomical Union (IAU). Only US-ASCII characters
+ are used ([us] is used for [µs]). *)
+
+(** {1:binary Binary data} *)
+
+type 'a vec = int * (int -> 'a)
+(** The type for random addressable, sized sequences. Each [(n, f)]
+ represents the sequence [f 0, ..., f (n - 1)]. *)
+
+val on_bytes : char vec t -> bytes t
+(** [on_bytes pp] is [pp] adapted to format (entire) [bytes]. *)
+
+val on_string : char vec t -> string t
+(** [on_string pp] is [pp] adapted to format (entire) [string]s. *)
+
+val ascii : ?w:int -> ?subst:unit t -> unit -> char vec t
+(** [ascii ~w ~subst ()] formats character sequences by printing
+ characters in the {e printable US-ASCII range} ([[0x20];[0x7E]])
+ as is, and replacing the rest with [subst] (defaults to [fmt "."]).
+ [w] causes the output to be right padded to the size of formatting
+ at least [w] sequence elements (defaults to [0]). *)
+
+val octets : ?w:int -> ?sep:unit t -> unit -> char vec t
+(** [octets ~w ~sep ()] formats character sequences as hexadecimal
+ digits. It prints groups of successive characters of unspecified
+ length together, separated by [sep] (defaults to {!sp}). [w]
+ causes the output to be right padded to the size of formatting at
+ least [w] sequence elements (defaults to [0]). *)
+
+val addresses : ?addr:int t -> ?w:int -> 'a vec t -> 'a vec t
+(** [addresses pp] formats sequences by applying [pp] to consecutive
+ subsequences of length [w] (defaults to 16). [addr] formats
+ subsequence offsets (defaults to an unspecified hexadecimal
+ format). *)
+
+val hex : ?w:int -> unit -> char vec t
+(** [hex ~w ()] formats character sequences as traditional hex dumps,
+ matching the output of {e xxd} and forcing line breaks after every
+ [w] characters (defaults to 16). *)
+
+(** {1:text Words, paragraphs, text and lines}
+
+ {b Note.} These functions only work on US-ASCII strings and/or
+ with newlines (['\n']). If you are dealing with UTF-8 strings or
+ different kinds of line endings you should use the pretty-printers
+ from {!Uuseg_string}.
+
+ {b White space.} White space is one of the following US-ASCII
+ characters: space [' '] ([0x20]), tab ['\t'] ([0x09]), newline
+ ['\n'] ([0x0A]), vertical tab ([0x0B]), form feed ([0x0C]),
+ carriage return ['\r'] ([0x0D]). *)
+
+val words : string t
+(** [words] formats words by suppressing initial and trailing
+ white space and replacing consecutive white space with
+ a single {!Format.pp_print_space}. *)
+
+val paragraphs : string t
+(** [paragraphs] formats paragraphs by suppressing initial and trailing
+ spaces and newlines, replacing blank lines (a line made only
+ of white space) by a two {!Format.pp_force_newline} and remaining
+ consecutive white space with a single {!Format.pp_print_space}. *)
+
+val text : string t
+(** [text] formats text by respectively replacing spaces and newlines in
+ the string with {!Format.pp_print_space} and {!Format.pp_force_newline}. *)
+
+val lines : string t
+(** [lines] formats lines by replacing newlines (['\n']) in the string
+ with calls to {!Format.pp_force_newline}. *)
+
+val truncated : max:int -> string t
+(** [truncated ~max] formats a string using at most [max]
+ characters. If the string doesn't fit, it is truncated and ended
+ with three consecutive dots which do count towards [max]. *)
+
+val text_loc : ((int * int) * (int * int)) t
+(** [text_loc] formats a line-column text range according to
+ {{:http://www.gnu.org/prep/standards/standards.html#Errors}
+ GNU conventions}. *)
+
+(** {1:hci HCI fragments} *)
+
+val one_of : ?empty:unit t -> 'a t -> 'a list t
+(** [one_of ~empty pp_v ppf l] formats according to the length of [l]
+ {ul
+ {- [0], formats {!empty} (defaults to {!nop}).}
+ {- [1], formats the element with [pp_v].}
+ {- [2], formats ["either %a or %a"] with the list elements}
+ {- [n], formats ["one of %a, ... or %a"] with the list elements}} *)
+
+val did_you_mean :
+ ?pre:unit t -> ?post:unit t -> kind:string -> 'a t -> ('a * 'a list) t
+(** [did_you_mean ~pre kind ~post pp_v] formats a faulty value [v] of
+ kind [kind] and a list of [hints] that [v] could have been
+ mistaken for.
+
+ [pre] defaults to [unit "Unknown"], [post] to {!nop} they surround
+ the faulty value before the "did you mean" part as follows ["%a %s
+ %a%a." pre () kind pp_v v post ()]. If [hints] is empty no "did
+ you mean" part is printed. *)
+
+(** {1:utf8_cond Conditional UTF-8 formatting}
+
+ {b Note.} Since {!Format} is not UTF-8 aware using UTF-8 output
+ may derail the pretty printing process. Use the pretty-printers
+ from {!Uuseg_string} if you are serious about UTF-8 formatting. *)
+
+val if_utf_8 : 'a t -> 'a t -> 'a t
+(** [if_utf_8 pp_u pp ppf v] is:
+ {ul
+ {- [pp_u ppf v] if [utf_8 ppf] is [true].}
+ {- [pp ppf v] otherwise.}} *)
+
+val utf_8 : Format.formatter -> bool
+(** [utf_8 ppf] is [true] if UTF-8 output is enabled on [ppf]. If
+ {!set_utf_8} hasn't been called on [ppf] this is [true]. *)
+
+val set_utf_8 : Format.formatter -> bool -> unit
+(** [set_utf_8 ppf b] enables or disables conditional UTF-8 formatting
+ on [ppf].
+
+ @raise Invalid_argument if [ppf] is {!Format.str_formatter}: it is
+ is always UTF-8 enabled. *)
+
+(** {1:styled Styled formatting} *)
+
+type color =
+ [ `Black | `Blue | `Cyan | `Green | `Magenta | `Red | `White | `Yellow ]
+(** The type for colors. *)
+
+type style =
+ [ `None | `Bold | `Faint | `Italic | `Underline | `Reverse
+ | `Fg of [ color | `Hi of color ]
+ | `Bg of [ color | `Hi of color ]
+ | color (** deprecated *) ]
+(** The type for styles:
+ {ul
+ {- [`None] resets the styling.}
+ {- [`Bold], [`Faint], [`Italic], [`Underline] and [`Reverse] are
+ display attributes.}
+ {- [`Fg _] is the foreground color or high-intensity color on [`Hi _].}
+ {- [`Bg _] is the foreground color or high-intensity color on [`Hi _].}
+ {- [#color] is the foreground colour, {b deprecated} use [`Fg
+ #color] instead.}} *)
+
+val styled : style -> 'a t -> 'a t
+(** [styled s pp] formats like [pp] but styled with [s]. *)
+
+(** {2 Style rendering control} *)
+
+type style_renderer = [ `Ansi_tty | `None ]
+(** The type for style renderers.
+ {ul
+ {- [`Ansi_tty], renders styles using
+ {{:http://www.ecma-international.org/publications/standards/Ecma-048.htm}
+ ANSI escape sequences}.}
+ {- [`None], styled rendering has no effect.}} *)
+
+val style_renderer : Format.formatter -> style_renderer
+(** [style_renderer ppf] is the style renderer used by [ppf]. If
+ {!set_style_renderer} has never been called on [ppf] this is
+ [`None]. *)
+
+val set_style_renderer : Format.formatter -> style_renderer -> unit
+(** [set_style_renderer ppf r] sets the style renderer of [ppf] to [r].
+
+ @raise Invalid_argument if [ppf] is {!Format.str_formatter}: its
+ renderer is always [`None]. *)
+
+(** {1:stringconverters Converting with string value converters} *)
+
+val of_to_string : ('a -> string) -> 'a t
+(** [of_to_string f ppf v] is [string ppf (f v)]. *)
+
+val to_to_string : 'a t -> 'a -> string
+(** [to_to_string pp_v v] is [strf "%a" pp_v v]. *)
+
+(** {1:deprecated Deprecated} *)
+
+val strf : ('a, Format.formatter, unit, string) format4 -> 'a
+(** @deprecated use {!str} instead. *)
+
+val kstrf : (string -> 'a) -> ('b, Format.formatter, unit, 'a) format4 -> 'b
+(** @deprecated use {!kstr} instead. *)
+
+val strf_like :
+ Format.formatter -> ('a, Format.formatter, unit, string) format4 -> 'a
+(** @deprecated use {!str_like} instead. *)
+
+val always : (unit, Format.formatter, unit) Stdlib.format -> 'a t
+(** @deprecated use {!any} instead. *)
+
+val unit : (unit, Format.formatter, unit) Stdlib.format -> unit t
+(** @deprecated use {!any}. *)
+
+val prefix : unit t -> 'a t -> 'a t
+(** @deprecated use {!( ++ )}. *)
+
+val suffix : unit t -> 'a t -> 'a t
+(** @deprecated use {!( ++ )}. *)
+
+val styled_unit :
+ style -> (unit, Format.formatter, unit) Stdlib.format -> unit t
+(** @deprecated, use [styled s (any fmt)] instead *)
+
+(** {1:nameconv Naming conventions}
+
+ Given a type [ty] use:
+
+ {ul
+ {- [pp_ty] for a pretty printer that provides full control to the
+ client and does not wrap the formatted value in an enclosing
+ box. See {{!stdlib}these examples}.}
+ {- [pp_dump_ty] for a pretty printer that provides little control
+ over the pretty-printing process, wraps the rendering in an
+ enclosing box and tries as much as possible to respect the
+ OCaml syntax. These pretty-printers should make it easy to
+ inspect and understand values of the given type, they are
+ mainly used for quick printf debugging and/or toplevel interaction.
+ See {{!Dump.stdlib} these examples}.}}
+
+ If you are in a situation where making a difference between [dump_ty]
+ and [pp_ty] doesn't make sense then use [pp_ty].
+
+ For a type [ty] that is the main type of the module (the "[M.t]"
+ convention) drop the suffix, that is simply use [M.pp] and
+ [M.pp_dump]. *)
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2014 The fmt programmers
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1 @@
+Fmt
new file mode 100644
@@ -0,0 +1,32 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2015 The fmt programmers. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+let strf = Format.asprintf
+
+open Cmdliner
+
+let style_renderer ?env ?docs () =
+ let enum = ["auto", None; "always", Some `Ansi_tty; "never", Some `None] in
+ let color = Arg.enum enum in
+ let enum_alts = Arg.doc_alts_enum enum in
+ let doc = strf "Colorize the output. $(docv) must be %s." enum_alts in
+ Arg.(value & opt color None & info ["color"] ?env ~doc ~docv:"WHEN" ?docs)
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2015 The fmt programmers
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,45 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2015 The fmt programmers. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+(** {!Cmdliner} support for [Fmt]. *)
+
+(** {1 Option for setting the style renderer} *)
+
+val style_renderer : ?env:Cmdliner.Arg.env -> ?docs:string -> unit ->
+ Fmt.style_renderer option Cmdliner.Term.t
+(** [style_renderer ?env ?docs ()] is a {!Cmdliner} option [--color] that can
+ be directly used with the optional arguments of
+ {{!Fmt_tty.tty_setup}TTY setup} or to control
+ {{!Fmt.set_style_renderer}style rendering}. The option is
+ documented under [docs] (defaults to the default in
+ {!Cmdliner.Arg.info}).
+
+ The option is a tri-state enumerated value that when used with
+ {{!Fmt_tty.tty_setup}TTY setup} takes over the automatic setup:
+ {ul
+ {- [--color=never], the value is [Some `None], forces no styling.}
+ {- [--color=always], the value is [Some `Ansi], forces ANSI styling.}
+ {- [--color=auto] or absent, the value is [None], automatic setup
+ takes place.}}
+
+ If [env] is provided, the option default value ([None]) can be
+ overridden by the corresponding environment variable. *)
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2015 The fmt programmers
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1 @@
+Fmt_cli
new file mode 100644
@@ -0,0 +1,23 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2015 The fmt programmers. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+let () = ignore (Toploop.use_file Format.err_formatter "fmt_tty_top_init.ml")
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2015 The fmt programmers
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1 @@
+Fmt_top
\ No newline at end of file
new file mode 100644
@@ -0,0 +1,78 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2015 The fmt programmers. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+let is_infix ~affix s =
+ (* Damned, already missing astring, from which this is c&p *)
+ let len_a = String.length affix in
+ let len_s = String.length s in
+ if len_a > len_s then false else
+ let max_idx_a = len_a - 1 in
+ let max_idx_s = len_s - len_a in
+ let rec loop i k =
+ if i > max_idx_s then false else
+ if k > max_idx_a then true else
+ if k > 0 then
+ if String.get affix k = String.get s (i + k) then loop i (k + 1) else
+ loop (i + 1) 0
+ else if String.get affix 0 = String.get s i then loop i 1 else
+ loop (i + 1) 0
+ in
+ loop 0 0
+
+let setup ?style_renderer ?utf_8 oc =
+ let ppf =
+ if oc == Stdlib.stdout then Fmt.stdout else
+ if oc == Stdlib.stderr then Fmt.stderr else
+ Format.formatter_of_out_channel oc
+ in
+ let style_renderer = match style_renderer with
+ | Some r -> r
+ | None ->
+ let dumb =
+ try match Sys.getenv "TERM" with
+ | "dumb" | "" -> true
+ | _ -> false
+ with
+ Not_found -> true
+ in
+ let isatty = try Unix.(isatty (descr_of_out_channel oc)) with
+ | Unix.Unix_error _ -> false
+ in
+ if not dumb && isatty then `Ansi_tty else `None
+ in
+ let utf_8 = match utf_8 with
+ | Some b -> b
+ | None ->
+ let has_utf_8 var =
+ try is_infix "UTF-8" (String.uppercase_ascii (Sys.getenv var))
+ with Not_found -> false
+ in
+ has_utf_8 "LANG" || has_utf_8 "LC_ALL" || has_utf_8 "LC_CTYPE"
+ in
+ Fmt.set_style_renderer ppf style_renderer;
+ Fmt.set_utf_8 ppf utf_8;
+ ppf
+
+let setup_std_outputs ?style_renderer ?utf_8 () =
+ ignore (setup ?style_renderer ?utf_8 stdout);
+ ignore (setup ?style_renderer ?utf_8 stderr);
+ ()
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2015 The fmt programmers
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,50 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2015 The fmt programmers. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+(** [Fmt] TTY setup.
+
+ [Fmt_tty] provides simple automatic setup on channel formatters for:
+ {ul
+ {- {!Fmt.set_style_renderer}. [`Ansi_tty] is used if the channel
+ {{!Unix.isatty}is a tty} and the environment variable
+ [TERM] is defined and its value is not ["dumb"]. [`None] is
+ used otherwise.}
+ {- {!Fmt.set_utf_8}. [true] is used if one of the following
+ environment variables has ["UTF-8"] as a case insensitive
+ substring: [LANG], [LC_ALL], [LC_CTYPE].}} *)
+
+(** {1:tty_setup TTY setup} *)
+
+val setup : ?style_renderer:Fmt.style_renderer -> ?utf_8:bool ->
+ out_channel -> Format.formatter
+(** [setup ?style_renderer ?utf_8 outc] is a formatter for [outc] with
+ {!Fmt.set_style_renderer} and {!Fmt.set_utf_8} correctly setup. If
+ [style_renderer] or [utf_8] are specified they override the automatic
+ setup.
+
+ If [outc] is {!stdout}, {!Fmt.stdout} is returned. If [outc] is
+ {!stderr}, {!Fmt.stderr} is returned. *)
+
+val setup_std_outputs : ?style_renderer:Fmt.style_renderer -> ?utf_8:bool ->
+ unit -> unit
+(** [setup_std_outputs ?style_renderer ?utf_8 ()] applies {!setup}
+ on {!stdout} and {!stderr}. *)
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2015 The fmt programmers
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1 @@
+Fmt_tty
new file mode 100644
@@ -0,0 +1,23 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2015 The fmt programmers. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+let () = Fmt_tty.setup_std_outputs ()
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2015 The fmt programmers
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,322 @@
+(*---------------------------------------------------------------------------
+ Copyright (c) 2015 The fmt programmers. All rights reserved.
+ Distributed under the ISC license, see terms at the end of the file.
+ %%NAME%% %%VERSION%%
+ ---------------------------------------------------------------------------*)
+
+(*
+let test_exn_backtrace () = (* Don't move this test in the file. *)
+ try failwith "Test" with
+ | ex ->
+ let bt = Printexc.get_raw_backtrace () in
+ let fmt = Fmt.strf "%a" Fmt.exn_backtrace (ex,bt) in
+ assert begin match Printexc.backtrace_status () with
+ | false -> fmt = "Exception: Failure(\"Test\")\nNo backtrace available."
+ | true ->
+ fmt = "Exception: Failure(\"Test\")\n\
+ Raised at file \"pervasives.ml\", line 32, characters 22-33\n\
+ Called from file \"test/test.ml\", line 8, characters 6-21"
+ end
+*)
+
+let test_dump_uchar () =
+ let str u = Format.asprintf "%a" Fmt.Dump.uchar u in
+ assert (str Uchar.min = "U+0000");
+ assert (str Uchar.(succ min) = "U+0001");
+ assert (str Uchar.(of_int 0xFFFF) = "U+FFFF");
+ assert (str Uchar.(succ (of_int 0xFFFF)) = "U+10000");
+ assert (str Uchar.(pred max) = "U+10FFFE");
+ assert (str Uchar.max = "U+10FFFF");
+ ()
+
+let test_utf_8 () =
+ let ppf = Format.formatter_of_buffer (Buffer.create 23) in
+ assert (Fmt.utf_8 ppf = true);
+ Fmt.set_utf_8 ppf false;
+ assert (Fmt.utf_8 ppf = false);
+ Fmt.set_utf_8 ppf true;
+ assert (Fmt.utf_8 ppf = true);
+ ()
+
+let test_style_renderer () =
+ let ppf = Format.formatter_of_buffer (Buffer.create 23) in
+ assert (Fmt.style_renderer ppf = `None);
+ Fmt.set_style_renderer ppf `Ansi_tty;
+ assert (Fmt.style_renderer ppf = `Ansi_tty);
+ Fmt.set_style_renderer ppf `None;
+ assert (Fmt.style_renderer ppf = `None);
+ ()
+
+let test_exn_typechecks () =
+ let (_ : bool) = true || Fmt.failwith "%s" "" in
+ let (_ : bool) = true || Fmt.invalid_arg "%s" "" in
+ ()
+
+let test_kstr_str_like_partial_app () =
+ let assertf f = assert (f "X" = f "X") in
+ let test_kstrf fmt = Fmt.kstr (fun x -> x) fmt in
+ let test_strf_like fmt = Fmt.str_like Fmt.stderr fmt in
+ assertf (test_strf_like "%s");
+ assertf (test_kstrf "%s");
+ ()
+
+
+let test_byte_size () =
+ let size s = Fmt.str "%a" Fmt.byte_size s in
+ assert (size 0 = "0B");
+ assert (size 999 = "999B");
+ assert (size 1000 = "1kB");
+ assert (size 1001 = "1.01kB");
+ assert (size 1010 = "1.01kB");
+ assert (size 1011 = "1.02kB");
+ assert (size 1020 = "1.02kB");
+ assert (size 1100 = "1.1kB");
+ assert (size 1101 = "1.11kB");
+ assert (size 1109 = "1.11kB");
+ assert (size 1111 = "1.12kB");
+ assert (size 1119 = "1.12kB");
+ assert (size 1120 = "1.12kB");
+ assert (size 1121 = "1.13kB");
+ assert (size 9990 = "9.99kB");
+ assert (size 9991 = "10kB");
+ assert (size 9999 = "10kB");
+ assert (size 10_000 = "10kB");
+ assert (size 10_001 = "10.1kB");
+ assert (size 10_002 = "10.1kB");
+ assert (size 10_099 = "10.1kB");
+ assert (size 10_100 = "10.1kB");
+ assert (size 10_100 = "10.1kB");
+ assert (size 10_101 = "10.2kB");
+ assert (size 10_199 = "10.2kB");
+ assert (size 10_199 = "10.2kB");
+ assert (size 10_200 = "10.2kB");
+ assert (size 10_201 = "10.3kB");
+ assert (size 99_901 = "100kB");
+ assert (size 99_999 = "100kB");
+ assert (size 100_000 = "100kB");
+ assert (size 100_001 = "101kB");
+ assert (size 100_999 = "101kB");
+ assert (size 101_000 = "101kB");
+ assert (size 101_001 = "102kB");
+ assert (size 999_000 = "999kB");
+ assert (size 999_001 = "1MB");
+ assert (size 999_999 = "1MB");
+ assert (size 1_000_000 = "1MB");
+ assert (size 1_000_001 = "1.01MB");
+ assert (size 1_009_999 = "1.01MB");
+ assert (size 1_010_000 = "1.01MB");
+ assert (size 1_010_001 = "1.02MB");
+ assert (size 1_019_999 = "1.02MB");
+ assert (size 1_020_000 = "1.02MB");
+ assert (size 1_020_001 = "1.03MB");
+ assert (size 1_990_000 = "1.99MB");
+ assert (size 1_990_001 = "2MB");
+ assert (size 1_999_999 = "2MB");
+ assert (size 2_000_000 = "2MB");
+ assert (size 9_990_000 = "9.99MB");
+ assert (size 9_990_001 = "10MB");
+ assert (size 9_990_999 = "10MB");
+ assert (size 10_000_000 = "10MB");
+ assert (size 10_000_001 = "10.1MB");
+ assert (size 10_099_999 = "10.1MB");
+ assert (size 10_100_000 = "10.1MB");
+ assert (size 10_900_001 = "11MB");
+ assert (size 10_999_999 = "11MB");
+ assert (size 11_000_000 = "11MB");
+ assert (size 11_000_001 = "11.1MB");
+ assert (size 99_900_000 = "99.9MB");
+ assert (size 99_900_001 = "100MB");
+ assert (size 99_999_999 = "100MB");
+ assert (size 100_000_000 = "100MB");
+ assert (size 100_000_001 = "101MB");
+ assert (size 100_999_999 = "101MB");
+ assert (size 101_000_000 = "101MB");
+ assert (size 101_000_000 = "101MB");
+ assert (size 999_000_000 = "999MB");
+ assert (size 999_000_001 = "1GB");
+ assert (size 999_999_999 = "1GB");
+ assert (size 1_000_000_000 = "1GB");
+ assert (size 1_000_000_001 = "1.01GB");
+ assert (size 1_000_000_001 = "1.01GB");
+ ()
+
+let test_uint64_ns_span () =
+ let span s = Fmt.str "%a" Fmt.uint64_ns_span (Int64.of_string s) in
+ assert (span "0u0" = "0ns");
+ assert (span "0u999" = "999ns");
+ assert (span "0u1_000" = "1us");
+ assert (span "0u1_001" = "1.01us");
+ assert (span "0u1_009" = "1.01us");
+ assert (span "0u1_010" = "1.01us");
+ assert (span "0u1_011" = "1.02us");
+ assert (span "0u1_090" = "1.09us");
+ assert (span "0u1_091" = "1.1us");
+ assert (span "0u1_100" = "1.1us");
+ assert (span "0u1_101" = "1.11us");
+ assert (span "0u1_109" = "1.11us");
+ assert (span "0u1_110" = "1.11us");
+ assert (span "0u1_111" = "1.12us");
+ assert (span "0u1_990" = "1.99us");
+ assert (span "0u1_991" = "2us");
+ assert (span "0u1_999" = "2us");
+ assert (span "0u2_000" = "2us");
+ assert (span "0u2_001" = "2.01us");
+ assert (span "0u9_990" = "9.99us");
+ assert (span "0u9_991" = "10us");
+ assert (span "0u9_999" = "10us");
+ assert (span "0u10_000" = "10us");
+ assert (span "0u10_001" = "10.1us");
+ assert (span "0u10_099" = "10.1us");
+ assert (span "0u10_100" = "10.1us");
+ assert (span "0u10_101" = "10.2us");
+ assert (span "0u10_900" = "10.9us");
+ assert (span "0u10_901" = "11us");
+ assert (span "0u10_999" = "11us");
+ assert (span "0u11_000" = "11us");
+ assert (span "0u11_001" = "11.1us");
+ assert (span "0u11_099" = "11.1us");
+ assert (span "0u11_100" = "11.1us");
+ assert (span "0u11_101" = "11.2us");
+ assert (span "0u99_900" = "99.9us");
+ assert (span "0u99_901" = "100us");
+ assert (span "0u99_999" = "100us");
+ assert (span "0u100_000" = "100us");
+ assert (span "0u100_001" = "101us");
+ assert (span "0u100_999" = "101us");
+ assert (span "0u101_000" = "101us");
+ assert (span "0u101_001" = "102us");
+ assert (span "0u101_999" = "102us");
+ assert (span "0u102_000" = "102us");
+ assert (span "0u999_000" = "999us");
+ assert (span "0u999_001" = "1ms");
+ assert (span "0u999_001" = "1ms");
+ assert (span "0u999_999" = "1ms");
+ assert (span "0u1_000_000" = "1ms");
+ assert (span "0u1_000_001" = "1.01ms");
+ assert (span "0u1_009_999" = "1.01ms");
+ assert (span "0u1_010_000" = "1.01ms");
+ assert (span "0u1_010_001" = "1.02ms");
+ assert (span "0u9_990_000" = "9.99ms");
+ assert (span "0u9_990_001" = "10ms");
+ assert (span "0u9_999_999" = "10ms");
+ assert (span "0u10_000_000" = "10ms");
+ assert (span "0u10_000_001" = "10.1ms");
+ assert (span "0u10_000_001" = "10.1ms");
+ assert (span "0u10_099_999" = "10.1ms");
+ assert (span "0u10_100_000" = "10.1ms");
+ assert (span "0u10_100_001" = "10.2ms");
+ assert (span "0u99_900_000" = "99.9ms");
+ assert (span "0u99_900_001" = "100ms");
+ assert (span "0u99_999_999" = "100ms");
+ assert (span "0u100_000_000" = "100ms");
+ assert (span "0u100_000_001" = "101ms");
+ assert (span "0u100_999_999" = "101ms");
+ assert (span "0u101_000_000" = "101ms");
+ assert (span "0u101_000_001" = "102ms");
+ assert (span "0u999_000_000" = "999ms");
+ assert (span "0u999_000_001" = "1s");
+ assert (span "0u999_999_999" = "1s");
+ assert (span "0u1_000_000_000" = "1s");
+ assert (span "0u1_000_000_001" = "1.01s");
+ assert (span "0u1_009_999_999" = "1.01s");
+ assert (span "0u1_010_000_000" = "1.01s");
+ assert (span "0u1_010_000_001" = "1.02s");
+ assert (span "0u1_990_000_000" = "1.99s");
+ assert (span "0u1_990_000_001" = "2s");
+ assert (span "0u1_999_999_999" = "2s");
+ assert (span "0u2_000_000_000" = "2s");
+ assert (span "0u2_000_000_001" = "2.01s");
+ assert (span "0u9_990_000_000" = "9.99s");
+ assert (span "0u9_999_999_999" = "10s");
+ assert (span "0u10_000_000_000" = "10s");
+ assert (span "0u10_000_000_001" = "10.1s");
+ assert (span "0u10_099_999_999" = "10.1s");
+ assert (span "0u10_100_000_000" = "10.1s");
+ assert (span "0u10_100_000_001" = "10.2s");
+ assert (span "0u59_900_000_000" = "59.9s");
+ assert (span "0u59_900_000_001" = "1min");
+ assert (span "0u59_999_999_999" = "1min");
+ assert (span "0u60_000_000_000" = "1min");
+ assert (span "0u60_000_000_001" = "1min1s");
+ assert (span "0u60_999_999_999" = "1min1s");
+ assert (span "0u61_000_000_000" = "1min1s");
+ assert (span "0u61_000_000_001" = "1min2s");
+ assert (span "0u119_000_000_000" = "1min59s");
+ assert (span "0u119_000_000_001" = "2min");
+ assert (span "0u119_999_999_999" = "2min");
+ assert (span "0u120_000_000_000" = "2min");
+ assert (span "0u120_000_000_001" = "2min1s");
+ assert (span "0u3599_000_000_000" = "59min59s");
+ assert (span "0u3599_000_000_001" = "1h");
+ assert (span "0u3599_999_999_999" = "1h");
+ assert (span "0u3600_000_000_000" = "1h");
+ assert (span "0u3600_000_000_001" = "1h1min");
+ assert (span "0u3659_000_000_000" = "1h1min");
+ assert (span "0u3659_000_000_001" = "1h1min");
+ assert (span "0u3659_999_999_999" = "1h1min");
+ assert (span "0u3660_000_000_000" = "1h1min");
+ assert (span "0u3660_000_000_001" = "1h2min");
+ assert (span "0u3660_000_000_001" = "1h2min");
+ assert (span "0u3660_000_000_001" = "1h2min");
+ assert (span "0u3720_000_000_000" = "1h2min");
+ assert (span "0u3720_000_000_001" = "1h3min");
+ assert (span "0u7140_000_000_000" = "1h59min");
+ assert (span "0u7140_000_000_001" = "2h");
+ assert (span "0u7199_999_999_999" = "2h");
+ assert (span "0u7200_000_000_000" = "2h");
+ assert (span "0u7200_000_000_001" = "2h1min");
+ assert (span "0u86340_000_000_000" = "23h59min");
+ assert (span "0u86340_000_000_001" = "1d");
+ assert (span "0u86400_000_000_000" = "1d");
+ assert (span "0u86400_000_000_001" = "1d1h");
+ assert (span "0u89999_999_999_999" = "1d1h");
+ assert (span "0u90000_000_000_000" = "1d1h");
+ assert (span "0u90000_000_000_001" = "1d2h");
+ assert (span "0u169200_000_000_000" = "1d23h");
+ assert (span "0u169200_000_000_001" = "2d");
+ assert (span "0u169200_000_000_001" = "2d");
+ assert (span "0u172799_999_999_999" = "2d");
+ assert (span "0u172800_000_000_000" = "2d");
+ assert (span "0u172800_000_000_001" = "2d1h");
+ assert (span "0u31536000_000_000_000" = "365d");
+ assert (span "0u31554000_000_000_000" = "365d5h");
+ assert (
+ (* Technically this should round to a year but it does get rendered.
+ I don't think it matters, it's not inacurate per se. *)
+ span "0u31554000_000_000_001" = "365d6h");
+ assert (span "0u31557600_000_000_000" = "1a");
+ assert (span "0u31557600_000_000_001" = "1a1d");
+ assert (span "0u63028800_000_000_000" = "1a365d");
+ assert (span "0u63093600_000_000_000" = "1a365d");
+ assert (span "0u63093600_000_000_001" = "2a");
+ assert (span "0u63115200_000_000_000" = "2a");
+ assert (span "0u63115200_000_000_001" = "2a1d");
+ ()
+
+let tests () =
+ test_dump_uchar ();
+ test_utf_8 ();
+ test_style_renderer ();
+ test_kstr_str_like_partial_app ();
+ test_byte_size ();
+ test_uint64_ns_span ();
+ Printf.printf "Done.\n";
+ ()
+
+let () = tests ()
+
+(*---------------------------------------------------------------------------
+ Copyright (c) 2015 The fmt programmers
+
+ Permission to use, copy, modify, and/or distribute this software for any
+ purpose with or without fee is hereby granted, provided that the above
+ copyright notice and this permission notice appear in all copies.
+
+ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ ---------------------------------------------------------------------------*)
new file mode 100644
@@ -0,0 +1,2 @@
+_build
+.merlin
new file mode 100644
@@ -0,0 +1,22 @@
+v1.3 (13th Nov 2018)
+---------------------
+
+Uses /bin/sh instead of /bin/bash to fix install problems
+
+v1.2 (22nd May 2017)
+---------------------
+
+Allow installation on non-AFL switches.
+(Doesn't do much, but lets you use Crowbar in quickcheck mode)
+
+
+v1.1 (12th January 2017)
+---------------------
+
+Improved stability of instrumentation output
+
+
+v1.0 (6th December 2016)
+---------------------
+
+Initial release
new file mode 100644
@@ -0,0 +1,8 @@
+Copyright (c) 2016 Stephen Dolan
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
new file mode 100644
@@ -0,0 +1,17 @@
+# afl-persistent - persistent-mode afl-fuzz for ocaml
+
+by using `AflPersistent.run`, you can fuzz things really fast:
+
+```ocaml
+let f () =
+ let s = read_line () in
+ match Array.to_list (Array.init (String.length s) (String.get s)) with
+ ['s'; 'e'; 'c'; 'r'; 'e'; 't'; ' '; 'c'; 'o'; 'd'; 'e'] -> failwith "uh oh"
+ | _ -> ()
+
+let _ = AflPersistent.run f
+```
+
+compile with a version of ocaml that supports afl. that means trunk
+for now, but the next release (4.05) will work too, and pass the
+`-afl-instrument` option to ocamlopt.
new file mode 100644
@@ -0,0 +1,49 @@
+# This file is generated by dune, edit dune-project instead
+version: "1.3"
+synopsis: "Use afl-fuzz in persistent mode"
+description: """
+afl-fuzz normally works by repeatedly fork()ing the program being
+tested. using this package, you can run afl-fuzz in 'persistent mode',
+which avoids repeated forking and is much faster.
+"""
+maintainer: ["stephen.dolan@cl.cam.ac.uk"]
+authors: ["Stephen Dolan"]
+license: "MIT"
+homepage: "https://github.com/stedolan/ocaml-afl-persistent"
+bug-reports: "https://github.com/stedolan/ocaml-afl-persistent/issues"
+depends: [
+ "dune" {>= "2.0"}
+ "ocaml" {>= "4.00"}
+ "base-unix"
+]
+build: [
+ ["dune" "subst"] {pinned}
+ [
+ "dune"
+ "build"
+ "-p"
+ name
+ "-j"
+ jobs
+ "@install"
+ "@runtest" {with-test}
+ "@doc" {with-doc}
+ ]
+]
+dev-repo: "git+https://github.com/stedolan/ocaml-afl-persistent.git"
+opam-version: "2.0"
+post-messages: [
+"afl-persistent is installed, but since AFL instrumentation is not available
+with this OCaml compiler, instrumented fuzzing with afl-fuzz won't work.
+
+To use instrumented fuzzing, switch to an OCaml version supporting AFL, such
+as 4.07.1+afl." {success & !afl-available}
+
+"afl-persistent is installed, but since the current OCaml compiler does
+not enable AFL instrumentation by default, most packages will not be
+instrumented and fuzzing with afl-fuzz may not be effective.
+
+To globally enable AFL instrumentation, use an OCaml switch such as
+4.07.1+afl." {success & afl-available & !afl-always}
+]
+
new file mode 100644
@@ -0,0 +1,16 @@
+opam-version: "2.0"
+post-messages: [
+"afl-persistent is installed, but since AFL instrumentation is not available
+with this OCaml compiler, instrumented fuzzing with afl-fuzz won't work.
+
+To use instrumented fuzzing, switch to an OCaml version supporting AFL, such
+as 4.07.1+afl." {success & !afl-available}
+
+"afl-persistent is installed, but since the current OCaml compiler does
+not enable AFL instrumentation by default, most packages will not be
+instrumented and fuzzing with afl-fuzz may not be effective.
+
+To globally enable AFL instrumentation, use an OCaml switch such as
+4.07.1+afl." {success & afl-available & !afl-always}
+]
+
new file mode 100644
@@ -0,0 +1,21 @@
+external reset_instrumentation : bool -> unit = "caml_reset_afl_instrumentation"
+external sys_exit : int -> 'a = "caml_sys_exit"
+
+let run f =
+ let _ = try ignore (Sys.getenv "##SIG_AFL_PERSISTENT##") with Not_found -> () in
+ let persist = match Sys.getenv "__AFL_PERSISTENT" with
+ | _ -> true
+ | exception Not_found -> false in
+ let pid = Unix.getpid () in
+ if persist then begin
+ reset_instrumentation true;
+ for _ = 1 to 1000 do
+ f ();
+ Unix.kill pid Sys.sigstop;
+ reset_instrumentation false
+ done;
+ f ();
+ sys_exit 0;
+ end else
+ f ()
+
new file mode 100644
@@ -0,0 +1 @@
+val run : (unit -> unit) -> unit
new file mode 100644
@@ -0,0 +1 @@
+let run f = f ()
new file mode 100755
@@ -0,0 +1,43 @@
+#!/bin/sh
+
+set -e
+set -x
+
+ocamlc='ocamlc -g -bin-annot'
+ocamlopt='ocamlopt -g -bin-annot'
+
+echo 'print_string "hello"' > afl_check.ml
+
+if ocamlopt -dcmm -c afl_check.ml 2>&1 | grep -q caml_afl; then
+ afl_always=true
+else
+ afl_always=false
+fi
+
+if [ "$(ocamlopt -afl-instrument afl_check.ml -o test 2>/dev/null && ./test)" = "hello" ]; then
+ ocamlopt="$ocamlopt -afl-inst-ratio 0"
+ afl_available=true
+elif [ "$(ocamlopt -version)" = 4.04.0+afl ]; then
+ # hack for the backported 4.04+afl branch
+ export AFL_INST_RATIO=0
+ afl_available=true
+else
+ afl_available=false
+fi
+
+cat > afl-persistent.config <<EOF
+opam-version: "1.2"
+afl-available: $afl_available
+afl-always: $afl_always
+EOF
+
+if [ $afl_available = true ]; then
+ cp "$1" aflPersistent.ml
+else
+ cp "$2" aflPersistent.ml
+fi
+exit 0
+# test
+cp ../test.ml .
+ocamlc unix.cma afl-persistent.cma test.ml -o test && ./test
+ocamlopt unix.cmxa afl-persistent.cmxa test.ml -o test && ./test
new file mode 100644
@@ -0,0 +1,20 @@
+(rule
+ (targets afl-persistent.config aflPersistent.ml)
+ (deps
+ detect.sh
+ (:aflyes aflPersistent.available.ml)
+ (:aflno aflPersistent.stub.ml))
+ (action
+ (run sh ./detect.sh %{aflyes} %{aflno})))
+
+(library
+ (wrapped false)
+ (public_name afl-persistent)
+ (name afl_persistent)
+ (modules aflPersistent)
+ (libraries unix))
+
+(test
+ (name test)
+ (modules test)
+ (libraries afl_persistent))
new file mode 100644
@@ -0,0 +1,23 @@
+(lang dune 2.0)
+(name afl-persistent)
+; version field is optional
+(version 1.3)
+
+(generate_opam_files true)
+
+(maintainers "stephen.dolan@cl.cam.ac.uk")
+(source (github stedolan/ocaml-afl-persistent))
+(license MIT)
+(authors "Stephen Dolan")
+
+(package
+ (name afl-persistent)
+ (synopsis "Use afl-fuzz in persistent mode")
+ (description
+"\| afl-fuzz normally works by repeatedly fork()ing the program being
+"\| tested. using this package, you can run afl-fuzz in 'persistent mode',
+"\| which avoids repeated forking and is much faster.
+)
+ (depends
+ (ocaml (>= 4.00))
+ base-unix))
new file mode 100644
@@ -0,0 +1,3 @@
+let () =
+ AflPersistent.run (fun () -> exit 0);
+ failwith "AflPersistent.run failed"
new file mode 100644
@@ -0,0 +1,22 @@
+external reset_instrumentation : bool -> unit = "caml_reset_afl_instrumentation"
+external sys_exit : int -> 'a = "caml_sys_exit"
+
+let name n =
+ fst (Test.tests.(int_of_string n - 1))
+let run n =
+ snd (Test.tests.(int_of_string n - 1)) ()
+
+let orig_random = Random.get_state ()
+
+let () =
+ (* Random.set_state orig_random; *)
+ reset_instrumentation true;
+ begin
+ match Sys.argv with
+ | [| _; "len" |] -> print_int (Array.length Test.tests); print_newline (); flush stdout
+ | [| _; "name"; n |] -> print_string (name n); flush stdout
+ | [| _; "1"; n |] -> run n
+ | [| _; "2"; n |] -> run n; (* Random.set_state orig_random; *)reset_instrumentation false; run n
+ | _ -> failwith "error"
+ end;
+ sys_exit 0
new file mode 100644
@@ -0,0 +1,73 @@
+let opaque = Sys.opaque_identity
+
+let lists n =
+ let l = opaque [n; n; n] in
+ match List.rev l with
+ | [a; b; c] when a = n && b = n && c = n -> ()
+ | _ -> assert false
+
+let fresh_exception x =
+ opaque @@
+ let module M = struct
+ exception E of int
+ let throw () = raise (E x)
+ end in
+ try
+ M.throw ()
+ with
+ M.E n -> assert (n = x)
+
+let obj_with_closure x =
+ opaque (object method foo = x end)
+
+let r = ref 42
+let state () =
+ incr r;
+ if !r > 43 then print_string "woo" else ()
+
+let classes (x : int) =
+ opaque @@
+ let module M = struct
+ class a = object
+ method foo = x
+ end
+ class c = object
+ inherit a
+ end
+ end in
+ let o = new M.c in
+ assert (o#foo = x)
+
+
+class c_global = object
+ method foo = 42
+end
+let obj_ordering () = opaque @@
+ (* Object IDs change, but should be in the same relative order *)
+ let a = new c_global in
+ let b = new c_global in
+ if a < b then print_string "a" else print_string "b"
+
+let random () = opaque @@
+ (* as long as there's no self_init, this should be deterministic *)
+ if Random.int 100 < 50 then print_string "a" else print_string "b";
+ if Random.int 100 < 50 then print_string "a" else print_string "b";
+ if Random.int 100 < 50 then print_string "a" else print_string "b";
+ if Random.int 100 < 50 then print_string "a" else print_string "b";
+ if Random.int 100 < 50 then print_string "a" else print_string "b";
+ if Random.int 100 < 50 then print_string "a" else print_string "b";
+ if Random.int 100 < 50 then print_string "a" else print_string "b";
+ if Random.int 100 < 50 then print_string "a" else print_string "b";
+ if Random.int 100 < 50 then print_string "a" else print_string "b"
+
+let tests =
+ [| ("lists", fun () -> lists 42);
+ ("manylists", fun () -> for i = 1 to 10 do lists 42 done);
+ ("exceptions", fun () -> fresh_exception 100);
+ ("objects", fun () -> ignore (obj_with_closure 42));
+ (* ("state", state); *) (* this one should fail *)
+ ("classes", fun () -> classes 42);
+ ("obj_ordering", obj_ordering);
+ (* ("random", random); *)
+ |]
+
new file mode 100755
@@ -0,0 +1,33 @@
+#!/bin/bash
+
+set -e
+
+ocamlopt -c -afl-instrument test.ml
+ocamlopt -afl-inst-ratio 0 test.cmx harness.ml -o test
+
+NTESTS=`./test len`
+failures=''
+echo "running $NTESTS tests..."
+for t in `seq 1 $NTESTS`; do
+ printf "%14s: " `./test name $t`
+ # when run twice, the instrumentation output should double
+ afl-showmap -q -o output-1 -- ./test 1 $t
+ afl-showmap -q -o output-2 -- ./test 2 $t
+ # see afl-showmap.c for what the numbers mean
+ cat output-1 | sed '
+ s/:6/:7/; s/:5/:6/;
+ s/:4/:5/; s/:3/:4/;
+ s/:2/:4/; s/:1/:2/;
+ ' > output-2-predicted
+ if cmp -s output-2-predicted output-2; then
+ echo "passed."
+ else
+ echo "failed:"
+ paste output-2 output-1
+ failures=1
+ fi
+done
+
+if [ -z "$failures" ]; then echo "all tests passed"; fi
+
+rm -f {test,harness}.{cmi,cmx,o} test output-{1,2,2-predicted}
new file mode 100644
@@ -0,0 +1,3 @@
+_build/
+.merlin
+*.install
new file mode 100644
@@ -0,0 +1,19 @@
+language: c
+sudo: required
+install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh
+script: bash -ex .travis-opam.sh
+global:
+ - PACKAGE=ocplib-endian
+ - TESTS=true
+env:
+ - OCAML_VERSION=4.09
+ - OCAML_VERSION=4.08
+ - OCAML_VERSION=4.07
+ - OCAML_VERSION=4.06
+ - OCAML_VERSION=4.05
+ - OCAML_VERSION=4.04
+ - OCAML_VERSION=4.03
+ - OCAML_VERSION=4.02
+os:
+ - linux
+ - osx
new file mode 100644
@@ -0,0 +1,55 @@
+1.1
+---
+
+* Add the OPAM support for building the documentation
+* Use the correct bytes_set primitive for OCaml >= 4.07.0
+ (issue #21 fixed in #22 @hhugo)
+* Fix tests on big endian architectures
+ (issue #20 reported by @TC01 and @olafhering)
+* Fix documentation typo (@bobot)
+* Change cppo to a build dependency (@TheLortex)
+* Port to Dune from jbuilder (@avsm)
+* Upgrade opam metadata to 2.0 format (@avsm)
+* Remove code for OCaml <4.01 support, as the minimum
+ supported version is now OCaml 4.02+ (@avsm)
+* Build with jbuilder (unreleased, superseded by dune)
+
+1.0
+---------------
+
+* Install generated .mli files
+* Build documentation
+* Fix README links
+
+0.8
+---------------
+
+* Replace optcomp with cppo, removing hard dependency on camlp4.
+
+0.7
+---------------
+
+* Fix dependencies.
+
+0.6
+---------------
+
+* Port to OCaml 4.02 -safe-string: Add an EndianBytes module.
+* Add unoptimized get_float, get_double, set_float and set_double to every modules.
+* Add a native endian version of interfaces.
+
+0.5
+---------------
+
+* Fix to avoid problems with integers outside of the range [0; 255] with set_int8.
+* Add travis CI files.
+
+0.4
+---------------
+
+* Fix ocamlfind dependency on optcomp
+
+0.3
+---------------
+
+First release.
new file mode 100644
@@ -0,0 +1,521 @@
+
+As a special exception to the GNU Library General Public License, you may link,
+statically or dynamically, a "work that uses the Library" with a publicly
+distributed version of the Library to produce an executable file containing
+portions of the Library, and distribute that executable file under terms of
+your choice, without any of the additional requirements listed in clause 6 of
+the GNU Library General Public License. By "a publicly distributed version of
+the Library", we mean either the unmodified Library as distributed by upstream
+author, or a modified version of the Library that is distributed under the
+conditions defined in clause 3 of the GNU Library General Public License. This
+exception does not however invalidate any other reasons why the executable file
+might be covered by the GNU Library General Public License.
+
+-----------------------------------------------------------------------
+ GNU LESSER GENERAL PUBLIC LICENSE
+ Version 2.1, February 1999
+
+ Copyright (C) 1991, 1999 Free Software Foundation, Inc.
+ 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+[This is the first released version of the Lesser GPL. It also counts
+ as the successor of the GNU Library Public License, version 2, hence
+ the version number 2.1.]
+
+ Preamble
+
+ The licenses for most software are designed to take away your
+freedom to share and change it. By contrast, the GNU General Public
+Licenses are intended to guarantee your freedom to share and change
+free software--to make sure the software is free for all its users.
+
+ This license, the Lesser General Public License, applies to some
+specially designated software packages--typically libraries--of the
+Free Software Foundation and other authors who decide to use it. You
+can use it too, but we suggest you first think carefully about whether
+this license or the ordinary General Public License is the better
+strategy to use in any particular case, based on the explanations
+below.
+
+ When we speak of free software, we are referring to freedom of use,
+not price. Our General Public Licenses are designed to make sure that
+you have the freedom to distribute copies of free software (and charge
+for this service if you wish); that you receive source code or can get
+it if you want it; that you can change the software and use pieces of
+it in new free programs; and that you are informed that you can do
+these things.
+
+ To protect your rights, we need to make restrictions that forbid
+distributors to deny you these rights or to ask you to surrender these
+rights. These restrictions translate to certain responsibilities for
+you if you distribute copies of the library or if you modify it.
+
+ For example, if you distribute copies of the library, whether gratis
+or for a fee, you must give the recipients all the rights that we gave
+you. You must make sure that they, too, receive or can get the source
+code. If you link other code with the library, you must provide
+complete object files to the recipients, so that they can relink them
+with the library after making changes to the library and recompiling
+it. And you must show them these terms so they know their rights.
+
+ We protect your rights with a two-step method: (1) we copyright the
+library, and (2) we offer you this license, which gives you legal
+permission to copy, distribute and/or modify the library.
+
+ To protect each distributor, we want to make it very clear that
+there is no warranty for the free library. Also, if the library is
+modified by someone else and passed on, the recipients should know
+that what they have is not the original version, so that the original
+author's reputation will not be affected by problems that might be
+introduced by others.
+^L
+ Finally, software patents pose a constant threat to the existence of
+any free program. We wish to make sure that a company cannot
+effectively restrict the users of a free program by obtaining a
+restrictive license from a patent holder. Therefore, we insist that
+any patent license obtained for a version of the library must be
+consistent with the full freedom of use specified in this license.
+
+ Most GNU software, including some libraries, is covered by the
+ordinary GNU General Public License. This license, the GNU Lesser
+General Public License, applies to certain designated libraries, and
+is quite different from the ordinary General Public License. We use
+this license for certain libraries in order to permit linking those
+libraries into non-free programs.
+
+ When a program is linked with a library, whether statically or using
+a shared library, the combination of the two is legally speaking a
+combined work, a derivative of the original library. The ordinary
+General Public License therefore permits such linking only if the
+entire combination fits its criteria of freedom. The Lesser General
+Public License permits more lax criteria for linking other code with
+the library.
+
+ We call this license the "Lesser" General Public License because it
+does Less to protect the user's freedom than the ordinary General
+Public License. It also provides other free software developers Less
+of an advantage over competing non-free programs. These disadvantages
+are the reason we use the ordinary General Public License for many
+libraries. However, the Lesser license provides advantages in certain
+special circumstances.
+
+ For example, on rare occasions, there may be a special need to
+encourage the widest possible use of a certain library, so that it
+becomes a de-facto standard. To achieve this, non-free programs must
+be allowed to use the library. A more frequent case is that a free
+library does the same job as widely used non-free libraries. In this
+case, there is little to gain by limiting the free library to free
+software only, so we use the Lesser General Public License.
+
+ In other cases, permission to use a particular library in non-free
+programs enables a greater number of people to use a large body of
+free software. For example, permission to use the GNU C Library in
+non-free programs enables many more people to use the whole GNU
+operating system, as well as its variant, the GNU/Linux operating
+system.
+
+ Although the Lesser General Public License is Less protective of the
+users' freedom, it does ensure that the user of a program that is
+linked with the Library has the freedom and the wherewithal to run
+that program using a modified version of the Library.
+
+ The precise terms and conditions for copying, distribution and
+modification follow. Pay close attention to the difference between a
+"work based on the library" and a "work that uses the library". The
+former contains code derived from the library, whereas the latter must
+be combined with the library in order to run.
+^L
+ GNU LESSER GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License Agreement applies to any software library or other
+program which contains a notice placed by the copyright holder or
+other authorized party saying it may be distributed under the terms of
+this Lesser General Public License (also called "this License").
+Each licensee is addressed as "you".
+
+ A "library" means a collection of software functions and/or data
+prepared so as to be conveniently linked with application programs
+(which use some of those functions and data) to form executables.
+
+ The "Library", below, refers to any such software library or work
+which has been distributed under these terms. A "work based on the
+Library" means either the Library or any derivative work under
+copyright law: that is to say, a work containing the Library or a
+portion of it, either verbatim or with modifications and/or translated
+straightforwardly into another language. (Hereinafter, translation is
+included without limitation in the term "modification".)
+
+ "Source code" for a work means the preferred form of the work for
+making modifications to it. For a library, complete source code means
+all the source code for all modules it contains, plus any associated
+interface definition files, plus the scripts used to control
+compilation and installation of the library.
+
+ Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope. The act of
+running a program using the Library is not restricted, and output from
+such a program is covered only if its contents constitute a work based
+on the Library (independent of the use of the Library in a tool for
+writing it). Whether that is true depends on what the Library does
+and what the program that uses the Library does.
+
+ 1. You may copy and distribute verbatim copies of the Library's
+complete source code as you receive it, in any medium, provided that
+you conspicuously and appropriately publish on each copy an
+appropriate copyright notice and disclaimer of warranty; keep intact
+all the notices that refer to this License and to the absence of any
+warranty; and distribute a copy of this License along with the
+Library.
+
+ You may charge a fee for the physical act of transferring a copy,
+and you may at your option offer warranty protection in exchange for a
+fee.
+
+ 2. You may modify your copy or copies of the Library or any portion
+of it, thus forming a work based on the Library, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+ a) The modified work must itself be a software library.
+
+ b) You must cause the files modified to carry prominent notices
+ stating that you changed the files and the date of any change.
+
+ c) You must cause the whole of the work to be licensed at no
+ charge to all third parties under the terms of this License.
+
+ d) If a facility in the modified Library refers to a function or a
+ table of data to be supplied by an application program that uses
+ the facility, other than as an argument passed when the facility
+ is invoked, then you must make a good faith effort to ensure that,
+ in the event an application does not supply such function or
+ table, the facility still operates, and performs whatever part of
+ its purpose remains meaningful.
+
+ (For example, a function in a library to compute square roots has
+ a purpose that is entirely well-defined independent of the
+ application. Therefore, Subsection 2d requires that any
+ application-supplied function or table used by this function must
+ be optional: if the application does not supply it, the square
+ root function must still compute square roots.)
+
+These requirements apply to the modified work as a whole. If
+identifiable sections of that work are not derived from the Library,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works. But when you
+distribute the same sections as part of a whole which is a work based
+on the Library, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote
+it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Library.
+
+In addition, mere aggregation of another work not based on the Library
+with the Library (or with a work based on the Library) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+ 3. You may opt to apply the terms of the ordinary GNU General Public
+License instead of this License to a given copy of the Library. To do
+this, you must alter all the notices that refer to this License, so
+that they refer to the ordinary GNU General Public License, version 2,
+instead of to this License. (If a newer version than version 2 of the
+ordinary GNU General Public License has appeared, then you can specify
+that version instead if you wish.) Do not make any other change in
+these notices.
+^L
+ Once this change is made in a given copy, it is irreversible for
+that copy, so the ordinary GNU General Public License applies to all
+subsequent copies and derivative works made from that copy.
+
+ This option is useful when you wish to copy part of the code of
+the Library into a program that is not a library.
+
+ 4. You may copy and distribute the Library (or a portion or
+derivative of it, under Section 2) in object code or executable form
+under the terms of Sections 1 and 2 above provided that you accompany
+it with the complete corresponding machine-readable source code, which
+must be distributed under the terms of Sections 1 and 2 above on a
+medium customarily used for software interchange.
+
+ If distribution of object code is made by offering access to copy
+from a designated place, then offering equivalent access to copy the
+source code from the same place satisfies the requirement to
+distribute the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+ 5. A program that contains no derivative of any portion of the
+Library, but is designed to work with the Library by being compiled or
+linked with it, is called a "work that uses the Library". Such a
+work, in isolation, is not a derivative work of the Library, and
+therefore falls outside the scope of this License.
+
+ However, linking a "work that uses the Library" with the Library
+creates an executable that is a derivative of the Library (because it
+contains portions of the Library), rather than a "work that uses the
+library". The executable is therefore covered by this License.
+Section 6 states terms for distribution of such executables.
+
+ When a "work that uses the Library" uses material from a header file
+that is part of the Library, the object code for the work may be a
+derivative work of the Library even though the source code is not.
+Whether this is true is especially significant if the work can be
+linked without the Library, or if the work is itself a library. The
+threshold for this to be true is not precisely defined by law.
+
+ If such an object file uses only numerical parameters, data
+structure layouts and accessors, and small macros and small inline
+functions (ten lines or less in length), then the use of the object
+file is unrestricted, regardless of whether it is legally a derivative
+work. (Executables containing this object code plus portions of the
+Library will still fall under Section 6.)
+
+ Otherwise, if the work is a derivative of the Library, you may
+distribute the object code for the work under the terms of Section 6.
+Any executables containing that work also fall under Section 6,
+whether or not they are linked directly with the Library itself.
+^L
+ 6. As an exception to the Sections above, you may also combine or
+link a "work that uses the Library" with the Library to produce a
+work containing portions of the Library, and distribute that work
+under terms of your choice, provided that the terms permit
+modification of the work for the customer's own use and reverse
+engineering for debugging such modifications.
+
+ You must give prominent notice with each copy of the work that the
+Library is used in it and that the Library and its use are covered by
+this License. You must supply a copy of this License. If the work
+during execution displays copyright notices, you must include the
+copyright notice for the Library among them, as well as a reference
+directing the user to the copy of this License. Also, you must do one
+of these things:
+
+ a) Accompany the work with the complete corresponding
+ machine-readable source code for the Library including whatever
+ changes were used in the work (which must be distributed under
+ Sections 1 and 2 above); and, if the work is an executable linked
+ with the Library, with the complete machine-readable "work that
+ uses the Library", as object code and/or source code, so that the
+ user can modify the Library and then relink to produce a modified
+ executable containing the modified Library. (It is understood
+ that the user who changes the contents of definitions files in the
+ Library will not necessarily be able to recompile the application
+ to use the modified definitions.)
+
+ b) Use a suitable shared library mechanism for linking with the
+ Library. A suitable mechanism is one that (1) uses at run time a
+ copy of the library already present on the user's computer system,
+ rather than copying library functions into the executable, and (2)
+ will operate properly with a modified version of the library, if
+ the user installs one, as long as the modified version is
+ interface-compatible with the version that the work was made with.
+
+ c) Accompany the work with a written offer, valid for at least
+ three years, to give the same user the materials specified in
+ Subsection 6a, above, for a charge no more than the cost of
+ performing this distribution.
+
+ d) If distribution of the work is made by offering access to copy
+ from a designated place, offer equivalent access to copy the above
+ specified materials from the same place.
+
+ e) Verify that the user has already received a copy of these
+ materials or that you have already sent this user a copy.
+
+ For an executable, the required form of the "work that uses the
+Library" must include any data and utility programs needed for
+reproducing the executable from it. However, as a special exception,
+the materials to be distributed need not include anything that is
+normally distributed (in either source or binary form) with the major
+components (compiler, kernel, and so on) of the operating system on
+which the executable runs, unless that component itself accompanies
+the executable.
+
+ It may happen that this requirement contradicts the license
+restrictions of other proprietary libraries that do not normally
+accompany the operating system. Such a contradiction means you cannot
+use both them and the Library together in an executable that you
+distribute.
+^L
+ 7. You may place library facilities that are a work based on the
+Library side-by-side in a single library together with other library
+facilities not covered by this License, and distribute such a combined
+library, provided that the separate distribution of the work based on
+the Library and of the other library facilities is otherwise
+permitted, and provided that you do these two things:
+
+ a) Accompany the combined library with a copy of the same work
+ based on the Library, uncombined with any other library
+ facilities. This must be distributed under the terms of the
+ Sections above.
+
+ b) Give prominent notice with the combined library of the fact
+ that part of it is a work based on the Library, and explaining
+ where to find the accompanying uncombined form of the same work.
+
+ 8. You may not copy, modify, sublicense, link with, or distribute
+the Library except as expressly provided under this License. Any
+attempt otherwise to copy, modify, sublicense, link with, or
+distribute the Library is void, and will automatically terminate your
+rights under this License. However, parties who have received copies,
+or rights, from you under this License will not have their licenses
+terminated so long as such parties remain in full compliance.
+
+ 9. You are not required to accept this License, since you have not
+signed it. However, nothing else grants you permission to modify or
+distribute the Library or its derivative works. These actions are
+prohibited by law if you do not accept this License. Therefore, by
+modifying or distributing the Library (or any work based on the
+Library), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Library or works based on it.
+
+ 10. Each time you redistribute the Library (or any work based on the
+Library), the recipient automatically receives a license from the
+original licensor to copy, distribute, link with or modify the Library
+subject to these terms and conditions. You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties with
+this License.
+^L
+ 11. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Library at all. For example, if a patent
+license would not permit royalty-free redistribution of the Library by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Library.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply, and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system which is
+implemented by public license practices. Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+ 12. If the distribution and/or use of the Library is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Library under this License
+may add an explicit geographical distribution limitation excluding those
+countries, so that distribution is permitted only in or among
+countries not thus excluded. In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+ 13. The Free Software Foundation may publish revised and/or new
+versions of the Lesser General Public License from time to time.
+Such new versions will be similar in spirit to the present version,
+but may differ in detail to address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Library
+specifies a version number of this License which applies to it and
+"any later version", you have the option of following the terms and
+conditions either of that version or of any later version published by
+the Free Software Foundation. If the Library does not specify a
+license version number, you may choose any version ever published by
+the Free Software Foundation.
+^L
+ 14. If you wish to incorporate parts of the Library into other free
+programs whose distribution conditions are incompatible with these,
+write to the author to ask for permission. For software which is
+copyrighted by the Free Software Foundation, write to the Free
+Software Foundation; we sometimes make exceptions for this. Our
+decision will be guided by the two goals of preserving the free status
+of all derivatives of our free software and of promoting the sharing
+and reuse of software generally.
+
+ NO WARRANTY
+
+ 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
+WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
+EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
+OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
+KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
+LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
+THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+ 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
+WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
+AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
+FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
+CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
+LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
+RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
+FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
+DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+^L
+ How to Apply These Terms to Your New Libraries
+
+ If you develop a new library, and you want it to be of the greatest
+possible use to the public, we recommend making it free software that
+everyone can redistribute and change. You can do so by permitting
+redistribution under these terms (or, alternatively, under the terms
+of the ordinary General Public License).
+
+ To apply these terms, attach the following notices to the library.
+It is safest to attach them to the start of each source file to most
+effectively convey the exclusion of warranty; and each file should
+have at least the "copyright" line and a pointer to where the full
+notice is found.
+
+
+ <one line to give the library's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+ License as published by the Free Software Foundation; either
+ version 2.1 of the License, or (at your option) any later version.
+
+ This library is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public
+ License along with this library; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+Also add information on how to contact you by electronic and paper mail.
+
+You should also get your employer (if you work as a programmer) or
+your school, if any, to sign a "copyright disclaimer" for the library,
+if necessary. Here is a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the
+ library `Frob' (a library for tweaking knobs) written by James
+ Random Hacker.
+
+ <signature of Ty Coon>, 1 April 1990
+ Ty Coon, President of Vice
+
+That's all there is to it!
new file mode 100644
@@ -0,0 +1,13 @@
+.PHONY: all clean test doc
+
+all:
+ dune build
+
+clean:
+ dune clean
+
+test:
+ dune runtest --profile=release
+
+doc:
+ dune build @doc
new file mode 100644
@@ -0,0 +1,16 @@
+ocplib-endian
+=============
+
+Optimised functions to read and write int16/32/64 from strings, bytes
+and bigarrays, based on primitives added in version 4.01.
+
+The library implements three modules:
+- [EndianString](src/endianString.cppo.mli) works directly on strings, and provides submodules BigEndian and LittleEndian, with their unsafe counter-parts;
+- [EndianBytes](src/endianBytes.cppo.mli) works directly on bytes, and provides submodules BigEndian and LittleEndian, with their unsafe counter-parts;
+- [EndianBigstring](src/endianBigstring.cppo.mli) works on bigstrings (Bigarrays of chars), and provides submodules BigEndian and LittleEndian, with their unsafe counter-parts;
+
+
+= Hacking =
+
+The tests only pass in dune release profile. The debug mode prevents
+cross module inlining, which prevents unboxing in the tests.
\ No newline at end of file
new file mode 100644
@@ -0,0 +1,2 @@
+(lang dune 1.0)
+(name ocplib-endian)
new file mode 100644
@@ -0,0 +1,30 @@
+opam-version: "2.0"
+name: "ocplib-endian"
+synopsis: "Optimised functions to read and write int16/32/64 from strings and bigarrays"
+description: """
+The library implements three modules:
+* [EndianString](https://github.com/OCamlPro/ocplib-endian/blob/master/src/endianString.mli) works directly on strings, and provides submodules BigEndian and LittleEndian, with their unsafe counter-parts;
+* [EndianBytes](https://github.com/OCamlPro/ocplib-endian/blob/master/src/endianBytes.mli) works directly on bytes, and provides submodules BigEndian and LittleEndian, with their unsafe counter-parts;
+* [EndianBigstring](https://github.com/OCamlPro/ocplib-endian/blob/master/src/endianBigstring.mli) works on bigstrings (Bigarrays of chars), and provides submodules BigEndian and LittleEndian, with their unsafe counter-parts.
+"""
+maintainer: "pierre.chambart@ocamlpro.com"
+authors: "Pierre Chambart"
+homepage: "https://github.com/OCamlPro/ocplib-endian"
+bug-reports: "https://github.com/OCamlPro/ocplib-endian/issues"
+doc: "https://ocamlpro.github.io/ocplib-endian/ocplib-endian/"
+depends: [
+ "base-bytes"
+ "ocaml" {>= "4.02.3"}
+ "cppo" {>= "1.1.0" & build}
+ "dune" {build & >= "1.0"}
+]
+build: [
+ ["dune" "build" "-p" name "-j" jobs
+ "@install"
+ "@runtest" {with-test}
+ "@doc" {with-doc}]
+]
+dev-repo: "git+https://github.com/OCamlPro/ocplib-endian.git"
+url {
+ src: "https://github.com/OCamlPro/ocplib-endian/archive/1.1.tar.gz"
+}
new file mode 100644
@@ -0,0 +1,32 @@
+ let get_uint16 s off =
+ if not Sys.big_endian
+ then swap16 (get_16 s off)
+ else get_16 s off
+
+ let get_int16 s off =
+ ((get_uint16 s off) lsl ( Sys.word_size - 17 )) asr ( Sys.word_size - 17 )
+
+ let get_int32 s off =
+ if not Sys.big_endian
+ then swap32 (get_32 s off)
+ else get_32 s off
+
+ let get_int64 s off =
+ if not Sys.big_endian
+ then swap64 (get_64 s off)
+ else get_64 s off
+
+ let set_int16 s off v =
+ if not Sys.big_endian
+ then (set_16 s off (swap16 v))
+ else set_16 s off v
+
+ let set_int32 s off v =
+ if not Sys.big_endian
+ then set_32 s off (swap32 v)
+ else set_32 s off v
+
+ let set_int64 s off v =
+ if not Sys.big_endian
+ then set_64 s off (swap64 v)
+ else set_64 s off v
new file mode 100644
@@ -0,0 +1,24 @@
+[@@@warning "-32"]
+
+let sign8 v =
+ (v lsl ( Sys.word_size - 9 )) asr ( Sys.word_size - 9 )
+
+let sign16 v =
+ (v lsl ( Sys.word_size - 17 )) asr ( Sys.word_size - 17 )
+
+let get_uint8 s off =
+ Char.code (get_char s off)
+let get_int8 s off =
+ ((get_uint8 s off) lsl ( Sys.word_size - 9 )) asr ( Sys.word_size - 9 )
+let set_int8 s off v =
+ (* It is ok to cast using unsafe_chr because both String.set
+ and Bigarray.Array1.set (on bigstrings) use the 'store unsigned int8'
+ primitives that effectively extract the bits before writing *)
+ set_char s off (Char.unsafe_chr v)
+
+let unsafe_get_uint8 s off =
+ Char.code (unsafe_get_char s off)
+let unsafe_get_int8 s off =
+ ((unsafe_get_uint8 s off) lsl ( Sys.word_size - 9 )) asr ( Sys.word_size - 9 )
+let unsafe_set_int8 s off v =
+ unsafe_set_char s off (Char.unsafe_chr v)
new file mode 100644
@@ -0,0 +1,100 @@
+external swap16 : int -> int = "%bswap16"
+external swap32 : int32 -> int32 = "%bswap_int32"
+external swap64 : int64 -> int64 = "%bswap_int64"
+external swapnative : nativeint -> nativeint = "%bswap_native"
+
+module BigEndian = struct
+
+ let get_char = get_char
+ let get_uint8 = get_uint8
+ let get_int8 = get_int8
+ let set_char = set_char
+ let set_int8 = set_int8
+
+#include "be_ocaml_401.ml"
+#include "common_float.ml"
+
+end
+
+module BigEndian_unsafe = struct
+
+ let get_char = unsafe_get_char
+ let get_uint8 = unsafe_get_uint8
+ let get_int8 = unsafe_get_int8
+ let set_char = unsafe_set_char
+ let set_int8 = unsafe_set_int8
+ let get_16 = unsafe_get_16
+ let get_32 = unsafe_get_32
+ let get_64 = unsafe_get_64
+ let set_16 = unsafe_set_16
+ let set_32 = unsafe_set_32
+ let set_64 = unsafe_set_64
+
+#include "be_ocaml_401.ml"
+#include "common_float.ml"
+
+end
+
+module LittleEndian = struct
+
+ let get_char = get_char
+ let get_uint8 = get_uint8
+ let get_int8 = get_int8
+ let set_char = set_char
+ let set_int8 = set_int8
+
+#include "le_ocaml_401.ml"
+#include "common_float.ml"
+
+end
+
+module LittleEndian_unsafe = struct
+
+ let get_char = unsafe_get_char
+ let get_uint8 = unsafe_get_uint8
+ let get_int8 = unsafe_get_int8
+ let set_char = unsafe_set_char
+ let set_int8 = unsafe_set_int8
+ let get_16 = unsafe_get_16
+ let get_32 = unsafe_get_32
+ let get_64 = unsafe_get_64
+ let set_16 = unsafe_set_16
+ let set_32 = unsafe_set_32
+ let set_64 = unsafe_set_64
+
+#include "le_ocaml_401.ml"
+#include "common_float.ml"
+
+end
+
+module NativeEndian = struct
+
+ let get_char = get_char
+ let get_uint8 = get_uint8
+ let get_int8 = get_int8
+ let set_char = set_char
+ let set_int8 = set_int8
+
+#include "ne_ocaml_401.ml"
+#include "common_float.ml"
+
+end
+
+module NativeEndian_unsafe = struct
+
+ let get_char = unsafe_get_char
+ let get_uint8 = unsafe_get_uint8
+ let get_int8 = unsafe_get_int8
+ let set_char = unsafe_set_char
+ let set_int8 = unsafe_set_int8
+ let get_16 = unsafe_get_16
+ let get_32 = unsafe_get_32
+ let get_64 = unsafe_get_64
+ let set_16 = unsafe_set_16
+ let set_32 = unsafe_set_32
+ let set_64 = unsafe_set_64
+
+#include "ne_ocaml_401.ml"
+#include "common_float.ml"
+
+end
new file mode 100644
@@ -0,0 +1,5 @@
+
+let get_float buff i = Int32.float_of_bits (get_int32 buff i)
+let get_double buff i = Int64.float_of_bits (get_int64 buff i)
+let set_float buff i v = set_int32 buff i (Int32.bits_of_float v)
+let set_double buff i v = set_int64 buff i (Int64.bits_of_float v)
new file mode 100644
@@ -0,0 +1,75 @@
+(rule
+ (targets endianString.mli)
+ (deps (:< endianString.cppo.mli))
+ (action
+ (run %{bin:cppo} %{<} -o %{targets})))
+
+(rule
+ (targets endianString.ml)
+ (deps
+ (:< endianString.cppo.ml)
+ common.ml
+ common_401.ml)
+ (action
+ (run %{bin:cppo} -V OCAML:%{ocaml_version} %{<} -o %{targets})))
+
+(rule
+ (targets endianBytes.mli)
+ (deps
+ (:< endianBytes.cppo.mli))
+ (action
+ (run %{bin:cppo} %{<} -o %{targets})))
+
+(rule
+ (targets endianBytes.ml)
+ (deps
+ (:< endianBytes.cppo.ml)
+ common.ml
+ common_401.ml)
+ (action
+ (run %{bin:cppo} -V OCAML:%{ocaml_version} %{<} -o %{targets})))
+
+(rule
+ (targets endianBigstring.mli)
+ (deps
+ (:< endianBigstring.cppo.mli))
+ (action
+ (run %{bin:cppo} %{<} -o %{targets})))
+
+(rule
+ (targets endianBigstring.ml)
+ (deps
+ (:< endianBigstring.cppo.ml)
+ common.ml
+ common_401.ml)
+ (action
+ (run %{bin:cppo} %{<} -o %{targets})))
+
+(rule
+ (targets common_401.ml)
+ (deps
+ (:< common_401.cppo.ml)
+ be_ocaml_401.ml
+ le_ocaml_401.ml
+ ne_ocaml_401.ml
+ common_float.ml)
+ (action
+ (run %{bin:cppo} %{<} -o %{targets})))
+
+(library
+ (name ocplib_endian)
+ (public_name ocplib-endian)
+ (synopsis "Optimised functions to read and write int16/32/64 from strings and bytes")
+ (wrapped false)
+ (ocamlopt_flags (:standard -inline 1000))
+ (modules endianString endianBytes)
+ (libraries bytes))
+
+(library
+ (name ocplib_endian_bigstring)
+ (public_name ocplib-endian.bigstring)
+ (synopsis "Optimised functions to read and write int16/32/64 from bigarrays")
+ (wrapped false)
+ (modules endianBigstring)
+ (ocamlopt_flags (:standard -inline 1000))
+ (libraries ocplib_endian bigarray bytes))
new file mode 100644
@@ -0,0 +1,112 @@
+(************************************************************************)
+(* ocplib-endian *)
+(* *)
+(* Copyright 2012 OCamlPro *)
+(* *)
+(* This file is distributed under the terms of the GNU Lesser General *)
+(* Public License as published by the Free Software Foundation; either *)
+(* version 2.1 of the License, or (at your option) any later version, *)
+(* with the OCaml static compilation exception. *)
+(* *)
+(* ocplib-endian is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU General Public License for more details. *)
+(* *)
+(************************************************************************)
+
+open Bigarray
+
+type bigstring = (char, int8_unsigned_elt, c_layout) Array1.t
+
+module type EndianBigstringSig = sig
+ (** Functions reading according to Big Endian byte order *)
+
+ val get_char : bigstring -> int -> char
+ (** [get_char buff i] reads 1 byte at offset i as a char *)
+
+ val get_uint8 : bigstring -> int -> int
+ (** [get_uint8 buff i] reads 1 byte at offset i as an unsigned int of 8
+ bits. i.e. It returns a value between 0 and 2^8-1 *)
+
+ val get_int8 : bigstring -> int -> int
+ (** [get_int8 buff i] reads 1 byte at offset i as a signed int of 8
+ bits. i.e. It returns a value between -2^7 and 2^7-1 *)
+
+ val get_uint16 : bigstring -> int -> int
+ (** [get_uint16 buff i] reads 2 bytes at offset i as an unsigned int
+ of 16 bits. i.e. It returns a value between 0 and 2^16-1 *)
+
+ val get_int16 : bigstring -> int -> int
+ (** [get_int16 buff i] reads 2 byte at offset i as a signed int of
+ 16 bits. i.e. It returns a value between -2^15 and 2^15-1 *)
+
+ val get_int32 : bigstring -> int -> int32
+ (** [get_int32 buff i] reads 4 bytes at offset i as an int32. *)
+
+ val get_int64 : bigstring -> int -> int64
+ (** [get_int64 buff i] reads 8 bytes at offset i as an int64. *)
+
+ val get_float : bigstring -> int -> float
+ (** [get_float buff i] is equivalent to
+ [Int32.float_of_bits (get_int32 buff i)] *)
+
+ val get_double : bigstring -> int -> float
+ (** [get_double buff i] is equivalent to
+ [Int64.float_of_bits (get_int64 buff i)] *)
+
+ val set_char : bigstring -> int -> char -> unit
+ (** [set_char buff i v] writes [v] to [buff] at offset [i] *)
+
+ val set_int8 : bigstring -> int -> int -> unit
+ (** [set_int8 buff i v] writes the least significant 8 bits of [v]
+ to [buff] at offset [i] *)
+
+ val set_int16 : bigstring -> int -> int -> unit
+ (** [set_int16 buff i v] writes the least significant 16 bits of [v]
+ to [buff] at offset [i] *)
+
+ val set_int32 : bigstring -> int -> int32 -> unit
+ (** [set_int32 buff i v] writes [v] to [buff] at offset [i] *)
+
+ val set_int64 : bigstring -> int -> int64 -> unit
+ (** [set_int64 buff i v] writes [v] to [buff] at offset [i] *)
+
+ val set_float : bigstring -> int -> float -> unit
+ (** [set_float buff i v] is equivalent to
+ [set_int32 buff i (Int32.bits_of_float v)] *)
+
+ val set_double : bigstring -> int -> float -> unit
+ (** [set_double buff i v] is equivalent to
+ [set_int64 buff i (Int64.bits_of_float v)] *)
+
+end
+
+let get_char (s:bigstring) off =
+ Array1.get s off
+let set_char (s:bigstring) off v =
+ Array1.set s off v
+let unsafe_get_char (s:bigstring) off =
+ Array1.unsafe_get s off
+let unsafe_set_char (s:bigstring) off v =
+ Array1.unsafe_set s off v
+
+#include "common.ml"
+
+external unsafe_get_16 : bigstring -> int -> int = "%caml_bigstring_get16u"
+external unsafe_get_32 : bigstring -> int -> int32 = "%caml_bigstring_get32u"
+external unsafe_get_64 : bigstring -> int -> int64 = "%caml_bigstring_get64u"
+
+external unsafe_set_16 : bigstring -> int -> int -> unit = "%caml_bigstring_set16u"
+external unsafe_set_32 : bigstring -> int -> int32 -> unit = "%caml_bigstring_set32u"
+external unsafe_set_64 : bigstring -> int -> int64 -> unit = "%caml_bigstring_set64u"
+
+external get_16 : bigstring -> int -> int = "%caml_bigstring_get16"
+external get_32 : bigstring -> int -> int32 = "%caml_bigstring_get32"
+external get_64 : bigstring -> int -> int64 = "%caml_bigstring_get64"
+
+external set_16 : bigstring -> int -> int -> unit = "%caml_bigstring_set16"
+external set_32 : bigstring -> int -> int32 -> unit = "%caml_bigstring_set32"
+external set_64 : bigstring -> int -> int64 -> unit = "%caml_bigstring_set64"
+
+#include "common_401.ml"
new file mode 100644
@@ -0,0 +1,128 @@
+(************************************************************************)
+(* ocplib-endian *)
+(* *)
+(* Copyright 2012 OCamlPro *)
+(* *)
+(* This file is distributed under the terms of the GNU Lesser General *)
+(* Public License as published by the Free Software Foundation; either *)
+(* version 2.1 of the License, or (at your option) any later version, *)
+(* with the OCaml static compilation exception. *)
+(* *)
+(* ocplib-endian is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU General Public License for more details. *)
+(* *)
+(************************************************************************)
+
+open Bigarray
+type bigstring = (char, int8_unsigned_elt, c_layout) Array1.t
+
+module type EndianBigstringSig = sig
+ (** Functions reading according to Big Endian byte order *)
+
+ val get_char : bigstring -> int -> char
+ (** [get_char buff i] reads 1 byte at offset i as a char *)
+
+ val get_uint8 : bigstring -> int -> int
+ (** [get_uint8 buff i] reads 1 byte at offset i as an unsigned int of 8
+ bits. i.e. It returns a value between 0 and 2^8-1 *)
+
+ val get_int8 : bigstring -> int -> int
+ (** [get_int8 buff i] reads 1 byte at offset i as a signed int of 8
+ bits. i.e. It returns a value between -2^7 and 2^7-1 *)
+
+ val get_uint16 : bigstring -> int -> int
+ (** [get_uint16 buff i] reads 2 bytes at offset i as an unsigned int
+ of 16 bits. i.e. It returns a value between 0 and 2^16-1 *)
+
+ val get_int16 : bigstring -> int -> int
+ (** [get_int16 buff i] reads 2 byte at offset i as a signed int of
+ 16 bits. i.e. It returns a value between -2^15 and 2^15-1 *)
+
+ val get_int32 : bigstring -> int -> int32
+ (** [get_int32 buff i] reads 4 bytes at offset i as an int32. *)
+
+ val get_int64 : bigstring -> int -> int64
+ (** [get_int64 buff i] reads 8 bytes at offset i as an int64. *)
+
+ val get_float : bigstring -> int -> float
+ (** [get_float buff i] is equivalent to
+ [Int32.float_of_bits (get_int32 buff i)] *)
+
+ val get_double : bigstring -> int -> float
+ (** [get_double buff i] is equivalent to
+ [Int64.float_of_bits (get_int64 buff i)] *)
+
+ val set_char : bigstring -> int -> char -> unit
+ (** [set_char buff i v] writes [v] to [buff] at offset [i] *)
+
+ val set_int8 : bigstring -> int -> int -> unit
+ (** [set_int8 buff i v] writes the least significant 8 bits of [v]
+ to [buff] at offset [i] *)
+
+ val set_int16 : bigstring -> int -> int -> unit
+ (** [set_int16 buff i v] writes the least significant 16 bits of [v]
+ to [buff] at offset [i] *)
+
+ val set_int32 : bigstring -> int -> int32 -> unit
+ (** [set_int32 buff i v] writes [v] to [buff] at offset [i] *)
+
+ val set_int64 : bigstring -> int -> int64 -> unit
+ (** [set_int64 buff i v] writes [v] to [buff] at offset [i] *)
+
+ val set_float : bigstring -> int -> float -> unit
+ (** [set_float buff i v] is equivalent to
+ [set_int32 buff i (Int32.bits_of_float v)] *)
+
+ val set_double : bigstring -> int -> float -> unit
+ (** [set_double buff i v] is equivalent to
+ [set_int64 buff i (Int64.bits_of_float v)] *)
+
+end
+
+module BigEndian : sig
+ (** Functions reading according to Big Endian byte order without
+ checking for overflow *)
+
+ include EndianBigstringSig
+
+end
+
+module BigEndian_unsafe : sig
+ (** Functions reading according to Big Endian byte order without
+ checking for overflow *)
+
+ include EndianBigstringSig
+
+end
+
+module LittleEndian : sig
+ (** Functions reading according to Little Endian byte order *)
+
+ include EndianBigstringSig
+
+end
+
+module LittleEndian_unsafe : sig
+ (** Functions reading according to Big Endian byte order without
+ checking for overflow *)
+
+ include EndianBigstringSig
+
+end
+
+module NativeEndian : sig
+ (** Functions reading according to machine endianness *)
+
+ include EndianBigstringSig
+
+end
+
+module NativeEndian_unsafe : sig
+ (** Functions reading according to machine endianness without
+ checking for overflow *)
+
+ include EndianBigstringSig
+
+end
new file mode 100644
@@ -0,0 +1,130 @@
+(************************************************************************)
+(* ocplib-endian *)
+(* *)
+(* Copyright 2014 OCamlPro *)
+(* *)
+(* This file is distributed under the terms of the GNU Lesser General *)
+(* Public License as published by the Free Software Foundation; either *)
+(* version 2.1 of the License, or (at your option) any later version, *)
+(* with the OCaml static compilation exception. *)
+(* *)
+(* ocplib-endian is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU General Public License for more details. *)
+(* *)
+(************************************************************************)
+
+module type EndianBytesSig = sig
+ (** Functions reading according to Big Endian byte order *)
+
+ val get_char : Bytes.t -> int -> char
+ (** [get_char buff i] reads 1 byte at offset i as a char *)
+
+ val get_uint8 : Bytes.t -> int -> int
+ (** [get_uint8 buff i] reads 1 byte at offset i as an unsigned int of 8
+ bits. i.e. It returns a value between 0 and 2^8-1 *)
+
+ val get_int8 : Bytes.t -> int -> int
+ (** [get_int8 buff i] reads 1 byte at offset i as a signed int of 8
+ bits. i.e. It returns a value between -2^7 and 2^7-1 *)
+
+ val get_uint16 : Bytes.t -> int -> int
+ (** [get_uint16 buff i] reads 2 bytes at offset i as an unsigned int
+ of 16 bits. i.e. It returns a value between 0 and 2^16-1 *)
+
+ val get_int16 : Bytes.t -> int -> int
+ (** [get_int16 buff i] reads 2 byte at offset i as a signed int of
+ 16 bits. i.e. It returns a value between -2^15 and 2^15-1 *)
+
+ val get_int32 : Bytes.t -> int -> int32
+ (** [get_int32 buff i] reads 4 bytes at offset i as an int32. *)
+
+ val get_int64 : Bytes.t -> int -> int64
+ (** [get_int64 buff i] reads 8 bytes at offset i as an int64. *)
+
+ val get_float : Bytes.t -> int -> float
+ (** [get_float buff i] is equivalent to
+ [Int32.float_of_bits (get_int32 buff i)] *)
+
+ val get_double : Bytes.t -> int -> float
+ (** [get_double buff i] is equivalent to
+ [Int64.float_of_bits (get_int64 buff i)] *)
+
+ val set_char : Bytes.t -> int -> char -> unit
+ (** [set_char buff i v] writes [v] to [buff] at offset [i] *)
+
+ val set_int8 : Bytes.t -> int -> int -> unit
+ (** [set_int8 buff i v] writes the least significant 8 bits of [v]
+ to [buff] at offset [i] *)
+
+ val set_int16 : Bytes.t -> int -> int -> unit
+ (** [set_int16 buff i v] writes the least significant 16 bits of [v]
+ to [buff] at offset [i] *)
+
+ val set_int32 : Bytes.t -> int -> int32 -> unit
+ (** [set_int32 buff i v] writes [v] to [buff] at offset [i] *)
+
+ val set_int64 : Bytes.t -> int -> int64 -> unit
+ (** [set_int64 buff i v] writes [v] to [buff] at offset [i] *)
+
+ val set_float : Bytes.t -> int -> float -> unit
+ (** [set_float buff i v] is equivalent to
+ [set_int32 buff i (Int32.bits_of_float v)] *)
+
+ val set_double : Bytes.t -> int -> float -> unit
+ (** [set_double buff i v] is equivalent to
+ [set_int64 buff i (Int64.bits_of_float v)] *)
+
+end
+
+let get_char (s:Bytes.t) off =
+ Bytes.get s off
+let set_char (s:Bytes.t) off v =
+ Bytes.set s off v
+let unsafe_get_char (s:Bytes.t) off =
+ Bytes.unsafe_get s off
+let unsafe_set_char (s:Bytes.t) off v =
+ Bytes.unsafe_set s off v
+
+#include "common.ml"
+
+#if OCAML_VERSION < (4, 07, 0)
+
+external unsafe_get_16 : Bytes.t -> int -> int = "%caml_string_get16u"
+external unsafe_get_32 : Bytes.t -> int -> int32 = "%caml_string_get32u"
+external unsafe_get_64 : Bytes.t -> int -> int64 = "%caml_string_get64u"
+
+external unsafe_set_16 : Bytes.t -> int -> int -> unit = "%caml_string_set16u"
+external unsafe_set_32 : Bytes.t -> int -> int32 -> unit = "%caml_string_set32u"
+external unsafe_set_64 : Bytes.t -> int -> int64 -> unit = "%caml_string_set64u"
+
+external get_16 : Bytes.t -> int -> int = "%caml_string_get16"
+external get_32 : Bytes.t -> int -> int32 = "%caml_string_get32"
+external get_64 : Bytes.t -> int -> int64 = "%caml_string_get64"
+
+external set_16 : Bytes.t -> int -> int -> unit = "%caml_string_set16"
+external set_32 : Bytes.t -> int -> int32 -> unit = "%caml_string_set32"
+external set_64 : Bytes.t -> int -> int64 -> unit = "%caml_string_set64"
+
+#else
+
+external unsafe_get_16 : Bytes.t -> int -> int = "%caml_bytes_get16u"
+external unsafe_get_32 : Bytes.t -> int -> int32 = "%caml_bytes_get32u"
+external unsafe_get_64 : Bytes.t -> int -> int64 = "%caml_bytes_get64u"
+
+external unsafe_set_16 : Bytes.t -> int -> int -> unit = "%caml_bytes_set16u"
+external unsafe_set_32 : Bytes.t -> int -> int32 -> unit = "%caml_bytes_set32u"
+external unsafe_set_64 : Bytes.t -> int -> int64 -> unit = "%caml_bytes_set64u"
+
+external get_16 : Bytes.t -> int -> int = "%caml_bytes_get16"
+external get_32 : Bytes.t -> int -> int32 = "%caml_bytes_get32"
+external get_64 : Bytes.t -> int -> int64 = "%caml_bytes_get64"
+
+external set_16 : Bytes.t -> int -> int -> unit = "%caml_bytes_set16"
+external set_32 : Bytes.t -> int -> int32 -> unit = "%caml_bytes_set32"
+external set_64 : Bytes.t -> int -> int64 -> unit = "%caml_bytes_set64"
+
+#endif
+
+#include "common_401.ml"
new file mode 100644
@@ -0,0 +1,124 @@
+(************************************************************************)
+(* ocplib-endian *)
+(* *)
+(* Copyright 2014 OCamlPro *)
+(* *)
+(* This file is distributed under the terms of the GNU Lesser General *)
+(* Public License as published by the Free Software Foundation; either *)
+(* version 2.1 of the License, or (at your option) any later version, *)
+(* with the OCaml static compilation exception. *)
+(* *)
+(* ocplib-endian is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU General Public License for more details. *)
+(* *)
+(************************************************************************)
+
+module type EndianBytesSig = sig
+ (** Functions reading according to Big Endian byte order *)
+
+ val get_char : Bytes.t -> int -> char
+ (** [get_char buff i] reads 1 byte at offset i as a char *)
+
+ val get_uint8 : Bytes.t -> int -> int
+ (** [get_uint8 buff i] reads 1 byte at offset i as an unsigned int of 8
+ bits. i.e. It returns a value between 0 and 2^8-1 *)
+
+ val get_int8 : Bytes.t -> int -> int
+ (** [get_int8 buff i] reads 1 byte at offset i as a signed int of 8
+ bits. i.e. It returns a value between -2^7 and 2^7-1 *)
+
+ val get_uint16 : Bytes.t -> int -> int
+ (** [get_uint16 buff i] reads 2 bytes at offset i as an unsigned int
+ of 16 bits. i.e. It returns a value between 0 and 2^16-1 *)
+
+ val get_int16 : Bytes.t -> int -> int
+ (** [get_int16 buff i] reads 2 byte at offset i as a signed int of
+ 16 bits. i.e. It returns a value between -2^15 and 2^15-1 *)
+
+ val get_int32 : Bytes.t -> int -> int32
+ (** [get_int32 buff i] reads 4 bytes at offset i as an int32. *)
+
+ val get_int64 : Bytes.t -> int -> int64
+ (** [get_int64 buff i] reads 8 bytes at offset i as an int64. *)
+
+ val get_float : Bytes.t -> int -> float
+ (** [get_float buff i] is equivalent to
+ [Int32.float_of_bits (get_int32 buff i)] *)
+
+ val get_double : Bytes.t -> int -> float
+ (** [get_double buff i] is equivalent to
+ [Int64.float_of_bits (get_int64 buff i)] *)
+
+ val set_char : Bytes.t -> int -> char -> unit
+ (** [set_char buff i v] writes [v] to [buff] at offset [i] *)
+
+ val set_int8 : Bytes.t -> int -> int -> unit
+ (** [set_int8 buff i v] writes the least significant 8 bits of [v]
+ to [buff] at offset [i] *)
+
+ val set_int16 : Bytes.t -> int -> int -> unit
+ (** [set_int16 buff i v] writes the least significant 16 bits of [v]
+ to [buff] at offset [i] *)
+
+ val set_int32 : Bytes.t -> int -> int32 -> unit
+ (** [set_int32 buff i v] writes [v] to [buff] at offset [i] *)
+
+ val set_int64 : Bytes.t -> int -> int64 -> unit
+ (** [set_int64 buff i v] writes [v] to [buff] at offset [i] *)
+
+ val set_float : Bytes.t -> int -> float -> unit
+ (** [set_float buff i v] is equivalent to
+ [set_int32 buff i (Int32.bits_of_float v)] *)
+
+ val set_double : Bytes.t -> int -> float -> unit
+ (** [set_double buff i v] is equivalent to
+ [set_int64 buff i (Int64.bits_of_float v)] *)
+
+end
+
+module BigEndian : sig
+ (** Functions reading according to Big Endian byte order *)
+
+ include EndianBytesSig
+
+end
+
+module BigEndian_unsafe : sig
+ (** Functions reading according to Big Endian byte order without
+ checking for overflow *)
+
+ include EndianBytesSig
+
+end
+
+module LittleEndian : sig
+ (** Functions reading according to Little Endian byte order *)
+
+ include EndianBytesSig
+
+end
+
+module LittleEndian_unsafe : sig
+ (** Functions reading according to Big Endian byte order without
+ checking for overflow *)
+
+ include EndianBytesSig
+
+end
+
+module NativeEndian : sig
+ (** Functions reading according to machine endianness *)
+
+ include EndianBytesSig
+
+end
+
+module NativeEndian_unsafe : sig
+ (** Functions reading according to machine endianness without
+ checking for overflow *)
+
+ include EndianBytesSig
+
+end
new file mode 100644
@@ -0,0 +1,118 @@
+(************************************************************************)
+(* ocplib-endian *)
+(* *)
+(* Copyright 2012 OCamlPro *)
+(* *)
+(* This file is distributed under the terms of the GNU Lesser General *)
+(* Public License as published by the Free Software Foundation; either *)
+(* version 2.1 of the License, or (at your option) any later version, *)
+(* with the OCaml static compilation exception. *)
+(* *)
+(* ocplib-endian is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU General Public License for more details. *)
+(* *)
+(************************************************************************)
+
+module type EndianStringSig = sig
+ (** Functions reading according to Big Endian byte order *)
+
+ val get_char : string -> int -> char
+ (** [get_char buff i] reads 1 byte at offset i as a char *)
+
+ val get_uint8 : string -> int -> int
+ (** [get_uint8 buff i] reads 1 byte at offset i as an unsigned int of 8
+ bits. i.e. It returns a value between 0 and 2^8-1 *)
+
+ val get_int8 : string -> int -> int
+ (** [get_int8 buff i] reads 1 byte at offset i as a signed int of 8
+ bits. i.e. It returns a value between -2^7 and 2^7-1 *)
+
+ val get_uint16 : string -> int -> int
+ (** [get_uint16 buff i] reads 2 bytes at offset i as an unsigned int
+ of 16 bits. i.e. It returns a value between 0 and 2^16-1 *)
+
+ val get_int16 : string -> int -> int
+ (** [get_int16 buff i] reads 2 byte at offset i as a signed int of
+ 16 bits. i.e. It returns a value between -2^15 and 2^15-1 *)
+
+ val get_int32 : string -> int -> int32
+ (** [get_int32 buff i] reads 4 bytes at offset i as an int32. *)
+
+ val get_int64 : string -> int -> int64
+ (** [get_int64 buff i] reads 8 bytes at offset i as an int64. *)
+
+ val get_float : string -> int -> float
+ (** [get_float buff i] is equivalent to
+ [Int32.float_of_bits (get_int32 buff i)] *)
+
+ val get_double : string -> int -> float
+ (** [get_double buff i] is equivalent to
+ [Int64.float_of_bits (get_int64 buff i)] *)
+
+ val set_char : Bytes.t -> int -> char -> unit
+ (** @deprecated This is a deprecated alias of {!endianBytes.set_char}. *)
+
+ val set_int8 : Bytes.t -> int -> int -> unit
+ (** @deprecated This is a deprecated alias of {!endianBytes.set_int8}. *)
+
+ val set_int16 : Bytes.t -> int -> int -> unit
+ (** @deprecated This is a deprecated alias of {!endianBytes.set_int16}. *)
+
+ val set_int32 : Bytes.t -> int -> int32 -> unit
+ (** @deprecated This is a deprecated alias of {!endianBytes.set_int32}. *)
+
+ val set_int64 : Bytes.t -> int -> int64 -> unit
+ (** @deprecated This is a deprecated alias of {!endianBytes.set_int64}. *)
+
+ val set_float : Bytes.t -> int -> float -> unit
+ (** @deprecated This is a deprecated alias of {!endianBytes.set_float}. *)
+
+ val set_double : Bytes.t -> int -> float -> unit
+ (** @deprecated This is a deprecated alias of {!endianBytes.set_double}. *)
+
+end
+
+let get_char (s:string) off =
+ String.get s off
+let set_char (s:Bytes.t) off v =
+ Bytes.set s off v
+let unsafe_get_char (s:string) off =
+ String.unsafe_get s off
+let unsafe_set_char (s:Bytes.t) off v =
+ Bytes.unsafe_set s off v
+
+#include "common.ml"
+
+external unsafe_get_16 : string -> int -> int = "%caml_string_get16u"
+external unsafe_get_32 : string -> int -> int32 = "%caml_string_get32u"
+external unsafe_get_64 : string -> int -> int64 = "%caml_string_get64u"
+
+external get_16 : string -> int -> int = "%caml_string_get16"
+external get_32 : string -> int -> int32 = "%caml_string_get32"
+external get_64 : string -> int -> int64 = "%caml_string_get64"
+
+#if OCAML_VERSION < (4, 07, 0)
+
+external unsafe_set_16 : Bytes.t -> int -> int -> unit = "%caml_string_set16u"
+external unsafe_set_32 : Bytes.t -> int -> int32 -> unit = "%caml_string_set32u"
+external unsafe_set_64 : Bytes.t -> int -> int64 -> unit = "%caml_string_set64u"
+
+external set_16 : Bytes.t -> int -> int -> unit = "%caml_string_set16"
+external set_32 : Bytes.t -> int -> int32 -> unit = "%caml_string_set32"
+external set_64 : Bytes.t -> int -> int64 -> unit = "%caml_string_set64"
+
+#else
+
+external unsafe_set_16 : Bytes.t -> int -> int -> unit = "%caml_bytes_set16u"
+external unsafe_set_32 : Bytes.t -> int -> int32 -> unit = "%caml_bytes_set32u"
+external unsafe_set_64 : Bytes.t -> int -> int64 -> unit = "%caml_bytes_set64u"
+
+external set_16 : Bytes.t -> int -> int -> unit = "%caml_bytes_set16"
+external set_32 : Bytes.t -> int -> int32 -> unit = "%caml_bytes_set32"
+external set_64 : Bytes.t -> int -> int64 -> unit = "%caml_bytes_set64"
+
+#endif
+
+#include "common_401.ml"
new file mode 100644
@@ -0,0 +1,121 @@
+(************************************************************************)
+(* ocplib-endian *)
+(* *)
+(* Copyright 2012 OCamlPro *)
+(* *)
+(* This file is distributed under the terms of the GNU Lesser General *)
+(* Public License as published by the Free Software Foundation; either *)
+(* version 2.1 of the License, or (at your option) any later version, *)
+(* with the OCaml static compilation exception. *)
+(* *)
+(* ocplib-endian is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU General Public License for more details. *)
+(* *)
+(************************************************************************)
+
+module type EndianStringSig = sig
+ (** Functions reading according to Big Endian byte order *)
+
+ val get_char : string -> int -> char
+ (** [get_char buff i] reads 1 byte at offset i as a char *)
+
+ val get_uint8 : string -> int -> int
+ (** [get_uint8 buff i] reads 1 byte at offset i as an unsigned int of 8
+ bits. i.e. It returns a value between 0 and 2^8-1 *)
+
+ val get_int8 : string -> int -> int
+ (** [get_int8 buff i] reads 1 byte at offset i as a signed int of 8
+ bits. i.e. It returns a value between -2^7 and 2^7-1 *)
+
+ val get_uint16 : string -> int -> int
+ (** [get_uint16 buff i] reads 2 bytes at offset i as an unsigned int
+ of 16 bits. i.e. It returns a value between 0 and 2^16-1 *)
+
+ val get_int16 : string -> int -> int
+ (** [get_int16 buff i] reads 2 byte at offset i as a signed int of
+ 16 bits. i.e. It returns a value between -2^15 and 2^15-1 *)
+
+ val get_int32 : string -> int -> int32
+ (** [get_int32 buff i] reads 4 bytes at offset i as an int32. *)
+
+ val get_int64 : string -> int -> int64
+ (** [get_int64 buff i] reads 8 bytes at offset i as an int64. *)
+
+ val get_float : string -> int -> float
+ (** [get_float buff i] is equivalent to
+ [Int32.float_of_bits (get_int32 buff i)] *)
+
+ val get_double : string -> int -> float
+ (** [get_double buff i] is equivalent to
+ [Int64.float_of_bits (get_int64 buff i)] *)
+
+ val set_char : Bytes.t -> int -> char -> unit
+ (** @deprecated This is a deprecated alias of {!endianBytes.set_char}. *)
+
+ val set_int8 : Bytes.t -> int -> int -> unit
+ (** @deprecated This is a deprecated alias of {!endianBytes.set_int8}. *)
+
+ val set_int16 : Bytes.t -> int -> int -> unit
+ (** @deprecated This is a deprecated alias of {!endianBytes.set_int16}. *)
+
+ val set_int32 : Bytes.t -> int -> int32 -> unit
+ (** @deprecated This is a deprecated alias of {!endianBytes.set_int32}. *)
+
+ val set_int64 : Bytes.t -> int -> int64 -> unit
+ (** @deprecated This is a deprecated alias of {!endianBytes.set_int64}. *)
+
+ val set_float : Bytes.t -> int -> float -> unit
+ (** @deprecated This is a deprecated alias of {!endianBytes.set_float}. *)
+
+ val set_double : Bytes.t -> int -> float -> unit
+ (** @deprecated This is a deprecated alias of {!endianBytes.set_double}. *)
+
+end
+
+module BigEndian : sig
+ (** Functions reading according to Big Endian byte order without
+ checking for overflow *)
+
+ include EndianStringSig
+
+end
+
+module BigEndian_unsafe : sig
+ (** Functions reading according to Big Endian byte order without
+ checking for overflow *)
+
+ include EndianStringSig
+
+end
+
+module LittleEndian : sig
+ (** Functions reading according to Little Endian byte order *)
+
+ include EndianStringSig
+
+end
+
+module LittleEndian_unsafe : sig
+ (** Functions reading according to Big Endian byte order without
+ checking for overflow *)
+
+ include EndianStringSig
+
+end
+
+module NativeEndian : sig
+ (** Functions reading according to machine endianness *)
+
+ include EndianStringSig
+
+end
+
+module NativeEndian_unsafe : sig
+ (** Functions reading according to machine endianness without
+ checking for overflow *)
+
+ include EndianStringSig
+
+end
new file mode 100644
@@ -0,0 +1,32 @@
+ let get_uint16 s off =
+ if Sys.big_endian
+ then swap16 (get_16 s off)
+ else get_16 s off
+
+ let get_int16 s off =
+ ((get_uint16 s off) lsl ( Sys.word_size - 17 )) asr ( Sys.word_size - 17 )
+
+ let get_int32 s off =
+ if Sys.big_endian
+ then swap32 (get_32 s off)
+ else get_32 s off
+
+ let get_int64 s off =
+ if Sys.big_endian
+ then swap64 (get_64 s off)
+ else get_64 s off
+
+ let set_int16 s off v =
+ if Sys.big_endian
+ then (set_16 s off (swap16 v))
+ else set_16 s off v
+
+ let set_int32 s off v =
+ if Sys.big_endian
+ then set_32 s off (swap32 v)
+ else set_32 s off v
+
+ let set_int64 s off v =
+ if Sys.big_endian
+ then set_64 s off (swap64 v)
+ else set_64 s off v
new file mode 100644
@@ -0,0 +1,20 @@
+ let get_uint16 s off =
+ get_16 s off
+
+ let get_int16 s off =
+ ((get_uint16 s off) lsl ( Sys.word_size - 17 )) asr ( Sys.word_size - 17 )
+
+ let get_int32 s off =
+ get_32 s off
+
+ let get_int64 s off =
+ get_64 s off
+
+ let set_int16 s off v =
+ set_16 s off v
+
+ let set_int32 s off v =
+ set_32 s off v
+
+ let set_int64 s off v =
+ set_64 s off v
new file mode 100644
@@ -0,0 +1,436 @@
+
+let buffer_size = 10000
+let loops = 10000
+
+let allocdiff =
+ let stat1 = Gc.quick_stat () in
+ let stat2 = Gc.quick_stat () in
+ (stat2.Gc.minor_words -. stat1.Gc.minor_words)
+
+let test_fun s f =
+ let t1 = Unix.gettimeofday () in
+ let stat1 = Gc.quick_stat () in
+ f ();
+ let stat2 = Gc.quick_stat () in
+ let t2 = Unix.gettimeofday () in
+ Printf.printf "%s: time %f alloc: %f\n%!" s (t2 -. t1)
+ (stat2.Gc.minor_words -. stat1.Gc.minor_words -. allocdiff)
+
+module Bytes_test = struct
+ open EndianBytes
+ module BE = BigEndian
+ module LE = LittleEndian
+
+ let buffer = Bytes.create buffer_size
+
+ let loop_read_uint16_be () =
+ for i = 0 to Bytes.length buffer - 2 do
+ ignore(BE.get_uint16 buffer i)
+ done
+
+ let loop_read_uint16_le () =
+ for i = 0 to Bytes.length buffer - 2 do
+ ignore(LE.get_uint16 buffer i)
+ done
+
+ let loop_read_int16_be () =
+ for i = 0 to Bytes.length buffer - 2 do
+ ignore(BE.get_int16 buffer i)
+ done
+
+ let loop_read_int16_le () =
+ for i = 0 to Bytes.length buffer - 2 do
+ ignore(LE.get_int16 buffer i)
+ done
+
+ let loop_read_int32_be () =
+ for i = 0 to Bytes.length buffer - 4 do
+ ignore(Int32.to_int (BE.get_int32 buffer i))
+ done
+
+ let loop_read_int32_le () =
+ for i = 0 to Bytes.length buffer - 4 do
+ ignore(Int32.to_int (LE.get_int32 buffer i))
+ done
+
+ let loop_read_int64_be () =
+ for i = 0 to Bytes.length buffer - 8 do
+ ignore(Int64.to_int (BE.get_int64 buffer i))
+ done
+
+ let loop_read_int64_le () =
+ for i = 0 to Bytes.length buffer - 8 do
+ ignore(Int64.to_int (LE.get_int64 buffer i))
+ done
+
+ let loop_write_int16_be () =
+ for i = 0 to Bytes.length buffer - 2 do
+ ignore(BE.set_int16 buffer i 10)
+ done
+
+ let loop_write_int16_le () =
+ for i = 0 to Bytes.length buffer - 2 do
+ ignore(LE.set_int16 buffer i 10)
+ done
+
+ let loop_write_int32_be () =
+ for i = 0 to Bytes.length buffer - 4 do
+ ignore((BE.set_int32 buffer i) 10l)
+ done
+
+ let loop_write_int32_le () =
+ for i = 0 to Bytes.length buffer - 4 do
+ ignore((LE.set_int32 buffer i) 10l)
+ done
+
+ let loop_write_int64_be () =
+ for i = 0 to Bytes.length buffer - 8 do
+ ignore((BE.set_int64 buffer i) 10L)
+ done
+
+ let loop_write_int64_le () =
+ for i = 0 to Bytes.length buffer - 8 do
+ ignore((LE.set_int64 buffer i) 10L)
+ done
+
+ let do_loop f () =
+ for i = 0 to loops - 1 do
+ f ()
+ done
+
+ let run s f = test_fun s (do_loop f)
+
+ let run_test () =
+ run "loop_read_uint16_be" loop_read_uint16_be;
+ run "loop_read_uint16_le" loop_read_uint16_le;
+ run "loop_read_int16_be" loop_read_int16_be;
+ run "loop_read_int16_le" loop_read_int16_le;
+ run "loop_read_int32_be" loop_read_int32_be;
+ run "loop_read_int32_le" loop_read_int32_le;
+ run "loop_read_int64_be" loop_read_int64_be;
+ run "loop_read_int64_le" loop_read_int64_le;
+ run "loop_write_int16_be" loop_write_int16_be;
+ run "loop_write_int16_le" loop_write_int16_le;
+ run "loop_write_int32_be" loop_write_int32_be;
+ run "loop_write_int32_le" loop_write_int32_le;
+ run "loop_write_int64_be" loop_write_int64_be;
+ run "loop_write_int64_le" loop_write_int64_le
+
+end
+
+module Bytes_unsafe_test = struct
+ open EndianBytes
+ module BE = BigEndian_unsafe
+ module LE = LittleEndian_unsafe
+
+ let buffer = Bytes.create buffer_size
+
+ let loop_read_uint16_be () =
+ for i = 0 to Bytes.length buffer - 2 do
+ ignore(BE.get_uint16 buffer i)
+ done
+
+ let loop_read_uint16_le () =
+ for i = 0 to Bytes.length buffer - 2 do
+ ignore(LE.get_uint16 buffer i)
+ done
+
+ let loop_read_int16_be () =
+ for i = 0 to Bytes.length buffer - 2 do
+ ignore(BE.get_int16 buffer i)
+ done
+
+ let loop_read_int16_le () =
+ for i = 0 to Bytes.length buffer - 2 do
+ ignore(LE.get_int16 buffer i)
+ done
+
+ let loop_read_int32_be () =
+ for i = 0 to Bytes.length buffer - 4 do
+ ignore(Int32.to_int (BE.get_int32 buffer i))
+ done
+
+ let loop_read_int32_le () =
+ for i = 0 to Bytes.length buffer - 4 do
+ ignore(Int32.to_int (LE.get_int32 buffer i))
+ done
+
+ let loop_read_int64_be () =
+ for i = 0 to Bytes.length buffer - 8 do
+ ignore(Int64.to_int (BE.get_int64 buffer i))
+ done
+
+ let loop_read_int64_le () =
+ for i = 0 to Bytes.length buffer - 8 do
+ ignore(Int64.to_int (LE.get_int64 buffer i))
+ done
+
+ let loop_write_int16_be () =
+ for i = 0 to Bytes.length buffer - 2 do
+ ignore(BE.set_int16 buffer i 10)
+ done
+
+ let loop_write_int16_le () =
+ for i = 0 to Bytes.length buffer - 2 do
+ ignore(LE.set_int16 buffer i 10)
+ done
+
+ let loop_write_int32_be () =
+ for i = 0 to Bytes.length buffer - 4 do
+ ignore((BE.set_int32 buffer i) 10l)
+ done
+
+ let loop_write_int32_le () =
+ for i = 0 to Bytes.length buffer - 4 do
+ ignore((LE.set_int32 buffer i) 10l)
+ done
+
+ let loop_write_int64_be () =
+ for i = 0 to Bytes.length buffer - 8 do
+ ignore((BE.set_int64 buffer i) 10L)
+ done
+
+ let loop_write_int64_le () =
+ for i = 0 to Bytes.length buffer - 8 do
+ ignore((LE.set_int64 buffer i) 10L)
+
+ done
+
+ let do_loop f () =
+ for i = 0 to loops - 1 do
+ f ()
+ done
+
+ let run s f = test_fun s (do_loop f)
+
+ let run_test () =
+ run "loop_read_uint16_be" loop_read_uint16_be;
+ run "loop_read_uint16_le" loop_read_uint16_le;
+ run "loop_read_int16_be" loop_read_int16_be;
+ run "loop_read_int16_le" loop_read_int16_le;
+ run "loop_read_int32_be" loop_read_int32_be;
+ run "loop_read_int32_le" loop_read_int32_le;
+ run "loop_read_int64_be" loop_read_int64_be;
+ run "loop_read_int64_le" loop_read_int64_le;
+ run "loop_write_int16_be" loop_write_int16_be;
+ run "loop_write_int16_le" loop_write_int16_le;
+ run "loop_write_int32_be" loop_write_int32_be;
+ run "loop_write_int32_le" loop_write_int32_le;
+ run "loop_write_int64_be" loop_write_int64_be;
+ run "loop_write_int64_le" loop_write_int64_le
+
+end
+
+module Bigstring_test = struct
+ open EndianBigstring
+ module BE = BigEndian
+ module LE = LittleEndian
+ open Bigarray
+ let buffer = Array1.create char c_layout buffer_size
+
+ let loop_read_uint16_be () =
+ for i = 0 to Bigarray.Array1.dim buffer - 2 do
+ ignore(BE.get_uint16 buffer i)
+ done
+
+ let loop_read_uint16_le () =
+ for i = 0 to Bigarray.Array1.dim buffer - 2 do
+ ignore(LE.get_uint16 buffer i)
+ done
+
+ let loop_read_int16_be () =
+ for i = 0 to Bigarray.Array1.dim buffer - 2 do
+ ignore(BE.get_int16 buffer i)
+ done
+
+ let loop_read_int16_le () =
+ for i = 0 to Bigarray.Array1.dim buffer - 2 do
+ ignore(LE.get_int16 buffer i)
+ done
+
+ let loop_read_int32_be () =
+ for i = 0 to Bigarray.Array1.dim buffer - 4 do
+ ignore(Int32.to_int (BE.get_int32 buffer i))
+ done
+
+ let loop_read_int32_le () =
+ for i = 0 to Bigarray.Array1.dim buffer - 4 do
+ ignore(Int32.to_int (LE.get_int32 buffer i))
+ done
+
+ let loop_read_int64_be () =
+ for i = 0 to Bigarray.Array1.dim buffer - 8 do
+ ignore(Int64.to_int (BE.get_int64 buffer i))
+ done
+
+ let loop_read_int64_le () =
+ for i = 0 to Bigarray.Array1.dim buffer - 8 do
+ ignore(Int64.to_int (LE.get_int64 buffer i))
+ done
+
+ let loop_write_int16_be () =
+ for i = 0 to Bigarray.Array1.dim buffer - 2 do
+ ignore(BE.set_int16 buffer i 10)
+ done
+
+ let loop_write_int16_le () =
+ for i = 0 to Bigarray.Array1.dim buffer - 2 do
+ ignore(LE.set_int16 buffer i 10)
+ done
+
+ let loop_write_int32_be () =
+ for i = 0 to Bigarray.Array1.dim buffer - 4 do
+ ignore((BE.set_int32 buffer i) 10l)
+ done
+
+ let loop_write_int32_le () =
+ for i = 0 to Bigarray.Array1.dim buffer - 4 do
+ ignore((LE.set_int32 buffer i) 10l)
+ done
+
+ let loop_write_int64_be () =
+ for i = 0 to Bigarray.Array1.dim buffer - 8 do
+ ignore((BE.set_int64 buffer i) 10L)
+ done
+
+ let loop_write_int64_le () =
+ for i = 0 to Bigarray.Array1.dim buffer - 8 do
+ ignore((LE.set_int64 buffer i) 10L)
+ done
+
+ let do_loop f () =
+ for i = 0 to loops - 1 do
+ f ()
+ done
+
+ let run s f = test_fun s (do_loop f)
+
+ let run_test () =
+ run "loop_read_uint16_be" loop_read_uint16_be;
+ run "loop_read_uint16_le" loop_read_uint16_le;
+ run "loop_read_int16_be" loop_read_int16_be;
+ run "loop_read_int16_le" loop_read_int16_le;
+ run "loop_read_int32_be" loop_read_int32_be;
+ run "loop_read_int32_le" loop_read_int32_le;
+ run "loop_read_int64_be" loop_read_int64_be;
+ run "loop_read_int64_le" loop_read_int64_le;
+ run "loop_write_int16_be" loop_write_int16_be;
+ run "loop_write_int16_le" loop_write_int16_le;
+ run "loop_write_int32_be" loop_write_int32_be;
+ run "loop_write_int32_le" loop_write_int32_le;
+ run "loop_write_int64_be" loop_write_int64_be;
+ run "loop_write_int64_le" loop_write_int64_le
+
+end
+
+module Bigstring_unsafe_test = struct
+ open EndianBigstring
+ module BE = BigEndian_unsafe
+ module LE = LittleEndian_unsafe
+ open Bigarray
+ let buffer = Array1.create char c_layout buffer_size
+
+ let loop_read_uint16_be () =
+ for i = 0 to Bigarray.Array1.dim buffer - 2 do
+ ignore(BE.get_uint16 buffer i)
+ done
+
+ let loop_read_uint16_le () =
+ for i = 0 to Bigarray.Array1.dim buffer - 2 do
+ ignore(LE.get_uint16 buffer i)
+ done
+
+ let loop_read_int16_be () =
+ for i = 0 to Bigarray.Array1.dim buffer - 2 do
+ ignore(BE.get_int16 buffer i)
+ done
+
+ let loop_read_int16_le () =
+ for i = 0 to Bigarray.Array1.dim buffer - 2 do
+ ignore(LE.get_int16 buffer i)
+ done
+
+ let loop_read_int32_be () =
+ for i = 0 to Bigarray.Array1.dim buffer - 4 do
+ ignore(Int32.to_int (BE.get_int32 buffer i))
+ done
+
+ let loop_read_int32_le () =
+ for i = 0 to Bigarray.Array1.dim buffer - 4 do
+ ignore(Int32.to_int (LE.get_int32 buffer i))
+ done
+
+ let loop_read_int64_be () =
+ for i = 0 to Bigarray.Array1.dim buffer - 8 do
+ ignore(Int64.to_int (BE.get_int64 buffer i))
+ done
+
+ let loop_read_int64_le () =
+ for i = 0 to Bigarray.Array1.dim buffer - 8 do
+ ignore(Int64.to_int (LE.get_int64 buffer i))
+ done
+
+ let loop_write_int16_be () =
+ for i = 0 to Bigarray.Array1.dim buffer - 2 do
+ ignore(BE.set_int16 buffer i 10)
+ done
+
+ let loop_write_int16_le () =
+ for i = 0 to Bigarray.Array1.dim buffer - 2 do
+ ignore(LE.set_int16 buffer i 10)
+ done
+
+ let loop_write_int32_be () =
+ for i = 0 to Bigarray.Array1.dim buffer - 4 do
+ ignore((BE.set_int32 buffer i) 10l)
+ done
+
+ let loop_write_int32_le () =
+ for i = 0 to Bigarray.Array1.dim buffer - 4 do
+ ignore((LE.set_int32 buffer i) 10l)
+ done
+
+ let loop_write_int64_be () =
+ for i = 0 to Bigarray.Array1.dim buffer - 8 do
+ ignore((BE.set_int64 buffer i) 10L)
+ done
+
+ let loop_write_int64_le () =
+ for i = 0 to Bigarray.Array1.dim buffer - 8 do
+ ignore((LE.set_int64 buffer i) 10L)
+ done
+
+ let do_loop f () =
+ for i = 0 to loops - 1 do
+ f ()
+ done
+
+ let run s f = test_fun s (do_loop f)
+
+ let run_test () =
+ run "loop_read_uint16_be" loop_read_uint16_be;
+ run "loop_read_uint16_le" loop_read_uint16_le;
+ run "loop_read_int16_be" loop_read_int16_be;
+ run "loop_read_int16_le" loop_read_int16_le;
+ run "loop_read_int32_be" loop_read_int32_be;
+ run "loop_read_int32_le" loop_read_int32_le;
+ run "loop_read_int64_be" loop_read_int64_be;
+ run "loop_read_int64_le" loop_read_int64_le;
+ run "loop_write_int16_be" loop_write_int16_be;
+ run "loop_write_int16_le" loop_write_int16_le;
+ run "loop_write_int32_be" loop_write_int32_be;
+ run "loop_write_int32_le" loop_write_int32_le;
+ run "loop_write_int64_be" loop_write_int64_be;
+ run "loop_write_int64_le" loop_write_int64_le
+
+end
+
+let () =
+ Printf.printf "safe bytes:\n%!";
+ Bytes_test.run_test ();
+ Printf.printf "unsafe bytes:\n%!";
+ Bytes_unsafe_test.run_test ();
+ Printf.printf "safe bigstring:\n%!";
+ Bigstring_test.run_test ();
+ Printf.printf "unsafe bigstring:\n%!";
+ Bigstring_unsafe_test.run_test ()
new file mode 100644
@@ -0,0 +1,35 @@
+(rule
+ (targets test_string.ml)
+ (deps (:< test_string.cppo.ml))
+ (action (run %{bin:cppo} %{<} -o %{targets})))
+
+(rule
+ (targets test_bytes.ml)
+ (deps (:< test_bytes.cppo.ml))
+ (action (run %{bin:cppo} %{<} -o %{targets})))
+
+(rule
+ (targets test_bigstring.ml)
+ (deps (:< test_bigstring.cppo.ml))
+ (action (run %{bin:cppo} %{<} -o %{targets})))
+
+(library
+ (name tests)
+ (wrapped false)
+ (modules test_string test_bytes test_bigstring)
+ (libraries ocplib-endian ocplib-endian.bigstring bigarray bytes))
+
+(executables
+ (names test)
+ (modules test)
+ (libraries ocplib-endian tests))
+
+(executables
+ (names bench)
+ (modules bench)
+ (libraries ocplib-endian ocplib-endian.bigstring))
+
+(alias
+ (name runtest)
+ (deps (:< test.exe))
+ (action (run %{<})))
new file mode 100644
@@ -0,0 +1,39 @@
+
+let allocdiff =
+ let stat1 = Gc.quick_stat () in
+ let stat2 = Gc.quick_stat () in
+ (stat2.Gc.minor_words -. stat1.Gc.minor_words)
+
+let () =
+ Test_bigstring.test1 ();
+ let stat1 = Gc.quick_stat () in
+ Test_bigstring.test2 ();
+ if Sys.word_size = 64 then Test_bigstring.test_64 ();
+ let stat2 = Gc.quick_stat () in
+ (* with a 32 bit system, int64 must be heap allocated *)
+ if Sys.word_size = 32 then Test_bigstring.test_64 ();
+ let alloc1 = stat2.Gc.minor_words -. stat1.Gc.minor_words -. allocdiff in
+ Printf.printf "bigstring: allocated words %f\n%!" alloc1;
+
+ Test_string.test1 ();
+ let stat1 = Gc.quick_stat () in
+ Test_string.test2 ();
+ if Sys.word_size = 64 then Test_string.test_64 ();
+ let stat2 = Gc.quick_stat () in
+ if Sys.word_size = 32 then Test_string.test_64 ();
+ let alloc2 = stat2.Gc.minor_words -. stat1.Gc.minor_words -. allocdiff in
+ Printf.printf "string: allocated words %f\n%!" alloc2;
+
+ Test_bytes.test1 ();
+ let stat1 = Gc.quick_stat () in
+ Test_bytes.test2 ();
+ if Sys.word_size = 64 then Test_bytes.test_64 ();
+ let stat2 = Gc.quick_stat () in
+ if Sys.word_size = 32 then Test_bytes.test_64 ();
+ let alloc3 = stat2.Gc.minor_words -. stat1.Gc.minor_words -. allocdiff in
+ Printf.printf "bytes: allocated words %f\n%!" alloc3;
+ (* we cannot ensure that there are no allocations only with the
+ primives added in 4.01.0 *)
+ if (alloc1 <> 0. || alloc2 <> 0. || alloc3 <> 0.)
+ then exit 1
+ else exit 0
new file mode 100644
@@ -0,0 +1,191 @@
+open Bigarray
+open EndianBigstring
+
+[@@@warning "-52-53"]
+
+module BE = BigEndian
+module LE = LittleEndian
+module NE = NativeEndian
+
+let big_endian = Sys.big_endian
+
+let bigstring_of_string s =
+ let a = Array1.create char c_layout (String.length s) in
+ for i = 0 to String.length s - 1 do
+ a.{i} <- s.[i]
+ done;
+ a
+
+let s = bigstring_of_string (String.make 10 '\x00')
+
+let assert_bound_check2 f v1 v2 =
+ try
+ ignore(f v1 v2);
+ assert false
+ with
+ | Invalid_argument("index out of bounds") -> ()
+
+let assert_bound_check3 f v1 v2 v3 =
+ try
+ ignore(f v1 v2 v3);
+ assert false
+ with
+ | Invalid_argument("index out of bounds") -> ()
+
+let test1 () =
+ assert_bound_check2 BE.get_int8 s (-1);
+ assert_bound_check2 BE.get_int8 s 10;
+ assert_bound_check2 BE.get_uint16 s (-1);
+ assert_bound_check2 BE.get_uint16 s 9;
+ assert_bound_check2 BE.get_int32 s (-1);
+ assert_bound_check2 BE.get_int32 s 7;
+ assert_bound_check2 BE.get_int64 s (-1);
+ assert_bound_check2 BE.get_int64 s 3;
+
+ assert_bound_check3 BE.set_int8 s (-1) 0;
+ assert_bound_check3 BE.set_int8 s 10 0;
+ assert_bound_check3 BE.set_int16 s (-1) 0;
+ assert_bound_check3 BE.set_int16 s 9 0;
+ assert_bound_check3 BE.set_int32 s (-1) 0l;
+ assert_bound_check3 BE.set_int32 s 7 0l;
+ assert_bound_check3 BE.set_int64 s (-1) 0L;
+ assert_bound_check3 BE.set_int64 s 3 0L
+
+let test2 () =
+ BE.set_int8 s 0 63; (* in [0; 127] *)
+ assert( BE.get_uint8 s 0 = 63 );
+ assert( BE.get_int8 s 0 = 63 );
+
+ BE.set_int8 s 0 155; (* in [128; 255] *)
+ assert( BE.get_uint8 s 0 = 155 );
+
+ BE.set_int8 s 0 (-103); (* in [-128; -1] *)
+ assert( BE.get_int8 s 0 = (-103) );
+
+ BE.set_int8 s 0 0x1234; (* outside of the [-127;255] range *)
+ assert( BE.get_uint8 s 0 = 0x34 );
+ assert( BE.get_int8 s 0 = 0x34 );
+
+ BE.set_int8 s 0 0xAACD; (* outside of the [-127;255] range, -0x33 land 0xFF = 0xCD*)
+ assert( BE.get_uint8 s 0 = 0xCD );
+ assert( BE.get_int8 s 0 = (-0x33) );
+
+ BE.set_int16 s 0 0x1234;
+ assert( BE.get_uint16 s 0 = 0x1234 );
+ assert( BE.get_uint16 s 1 = 0x3400 );
+ assert( BE.get_uint16 s 2 = 0 );
+
+ assert( LE.get_uint16 s 0 = 0x3412 );
+ assert( LE.get_uint16 s 1 = 0x0034 );
+ assert( LE.get_uint16 s 2 = 0 );
+
+ if big_endian then begin
+ assert( BE.get_uint16 s 0 = NE.get_uint16 s 0 );
+ assert( BE.get_uint16 s 1 = NE.get_uint16 s 1 );
+ assert( BE.get_uint16 s 2 = NE.get_uint16 s 2 );
+ end
+ else begin
+ assert( LE.get_uint16 s 0 = NE.get_uint16 s 0 );
+ assert( LE.get_uint16 s 1 = NE.get_uint16 s 1 );
+ assert( LE.get_uint16 s 2 = NE.get_uint16 s 2 );
+ end;
+
+ assert( BE.get_int16 s 0 = 0x1234 );
+ assert( BE.get_int16 s 1 = 0x3400 );
+ assert( BE.get_int16 s 2 = 0 );
+
+ BE.set_int16 s 0 0xFEDC;
+ assert( BE.get_uint16 s 0 = 0xFEDC );
+ assert( BE.get_uint16 s 1 = 0xDC00 );
+ assert( BE.get_uint16 s 2 = 0 );
+
+ assert( LE.get_uint16 s 0 = 0xDCFE );
+ assert( LE.get_uint16 s 1 = 0x00DC );
+ assert( LE.get_uint16 s 2 = 0 );
+
+ if big_endian then begin
+ assert( BE.get_uint16 s 0 = NE.get_uint16 s 0 );
+ assert( BE.get_uint16 s 1 = NE.get_uint16 s 1 );
+ assert( BE.get_uint16 s 2 = NE.get_uint16 s 2 );
+ end
+ else begin
+ assert( LE.get_uint16 s 0 = NE.get_uint16 s 0 );
+ assert( LE.get_uint16 s 1 = NE.get_uint16 s 1 );
+ assert( LE.get_uint16 s 2 = NE.get_uint16 s 2 );
+ end;
+
+ assert( BE.get_int16 s 0 = -292 );
+ assert( BE.get_int16 s 1 = -9216 );
+ assert( BE.get_int16 s 2 = 0 );
+
+ if big_endian
+ then begin
+ NE.set_int16 s 0 0x1234;
+ assert( BE.get_uint16 s 0 = 0x1234 );
+ assert( BE.get_uint16 s 1 = 0x3400 );
+ assert( BE.get_uint16 s 2 = 0 )
+ end;
+
+ LE.set_int16 s 0 0x1234;
+ assert( BE.get_uint16 s 0 = 0x3412 );
+ assert( BE.get_uint16 s 1 = 0x1200 );
+ assert( BE.get_uint16 s 2 = 0 );
+
+ if not big_endian
+ then begin
+ NE.set_int16 s 0 0x1234;
+ assert( BE.get_uint16 s 0 = 0x3412 );
+ assert( BE.get_uint16 s 1 = 0x1200 );
+ assert( BE.get_uint16 s 2 = 0 )
+ end;
+
+ LE.set_int16 s 0 0xFEDC;
+ assert( LE.get_uint16 s 0 = 0xFEDC );
+ assert( LE.get_uint16 s 1 = 0x00FE );
+ assert( LE.get_uint16 s 2 = 0 );
+
+ BE.set_int32 s 0 0x12345678l;
+ assert( BE.get_int32 s 0 = 0x12345678l );
+ assert( LE.get_int32 s 0 = 0x78563412l );
+ if big_endian
+ then assert( BE.get_int32 s 0 = NE.get_int32 s 0 )
+ else assert( LE.get_int32 s 0 = NE.get_int32 s 0 );
+
+ LE.set_int32 s 0 0x12345678l;
+ assert( LE.get_int32 s 0 = 0x12345678l );
+ assert( BE.get_int32 s 0 = 0x78563412l );
+
+ if big_endian
+ then assert( BE.get_int32 s 0 = NE.get_int32 s 0 )
+ else assert( LE.get_int32 s 0 = NE.get_int32 s 0 );
+
+ NE.set_int32 s 0 0x12345678l;
+ if big_endian
+ then assert( BE.get_int32 s 0 = 0x12345678l )
+ else assert( LE.get_int32 s 0 = 0x12345678l );
+
+ ()
+
+let test_64 () =
+ BE.set_int64 s 0 0x1234567890ABCDEFL;
+ assert( BE.get_int64 s 0 = 0x1234567890ABCDEFL );
+ assert( LE.get_int64 s 0 = 0xEFCDAB9078563412L );
+
+ if big_endian
+ then assert( BE.get_int64 s 0 = NE.get_int64 s 0 )
+ else assert( LE.get_int64 s 0 = NE.get_int64 s 0 );
+
+ LE.set_int64 s 0 0x1234567890ABCDEFL;
+ assert( LE.get_int64 s 0 = 0x1234567890ABCDEFL );
+ assert( BE.get_int64 s 0 = 0xEFCDAB9078563412L );
+
+ if big_endian
+ then assert( BE.get_int64 s 0 = NE.get_int64 s 0 )
+ else assert( LE.get_int64 s 0 = NE.get_int64 s 0 );
+
+ NE.set_int64 s 0 0x1234567890ABCDEFL;
+ if big_endian
+ then assert( BE.get_int64 s 0 = 0x1234567890ABCDEFL )
+ else assert( LE.get_int64 s 0 = 0x1234567890ABCDEFL );
+
+ ()
new file mode 100644
@@ -0,0 +1,185 @@
+open EndianBytes
+[@@@warning "-52"]
+
+let to_t x = x
+(* do not allocate to avoid breaking tests *)
+
+module BE = BigEndian
+module LE = LittleEndian
+module NE = NativeEndian
+
+let big_endian = Sys.big_endian
+
+let s = Bytes.make 10 '\x00'
+
+let assert_bound_check2 f v1 v2 =
+ try
+ ignore(f v1 v2);
+ assert false
+ with
+ | Invalid_argument("index out of bounds") -> ()
+
+let assert_bound_check3 f v1 v2 v3 =
+ try
+ ignore(f v1 v2 v3);
+ assert false
+ with
+ | Invalid_argument("index out of bounds") -> ()
+
+let test1 () =
+ assert_bound_check2 BE.get_int8 (to_t s) (-1);
+ assert_bound_check2 BE.get_int8 (to_t s) 10;
+ assert_bound_check2 BE.get_uint16 (to_t s) (-1);
+ assert_bound_check2 BE.get_uint16 (to_t s) 9;
+ assert_bound_check2 BE.get_int32 (to_t s) (-1);
+ assert_bound_check2 BE.get_int32 (to_t s) 7;
+ assert_bound_check2 BE.get_int64 (to_t s) (-1);
+ assert_bound_check2 BE.get_int64 (to_t s) 3;
+
+ assert_bound_check3 BE.set_int8 s (-1) 0;
+ assert_bound_check3 BE.set_int8 s 10 0;
+ assert_bound_check3 BE.set_int16 s (-1) 0;
+ assert_bound_check3 BE.set_int16 s 9 0;
+ assert_bound_check3 BE.set_int32 s (-1) 0l;
+ assert_bound_check3 BE.set_int32 s 7 0l;
+ assert_bound_check3 BE.set_int64 s (-1) 0L;
+ assert_bound_check3 BE.set_int64 s 3 0L
+
+let test2 () =
+ BE.set_int8 s 0 63; (* in [0; 127] *)
+ assert( BE.get_uint8 (to_t s) 0 = 63 );
+ assert( BE.get_int8 (to_t s) 0 = 63 );
+
+ BE.set_int8 s 0 155; (* in [128; 255] *)
+ assert( BE.get_uint8 (to_t s) 0 = 155 );
+
+ BE.set_int8 s 0 (-103); (* in [-128; -1] *)
+ assert( BE.get_int8 (to_t s) 0 = (-103) );
+
+ BE.set_int8 s 0 0x1234; (* outside of the [-127;255] range *)
+ assert( BE.get_uint8 (to_t s) 0 = 0x34 );
+ assert( BE.get_int8 (to_t s) 0 = 0x34 );
+
+ BE.set_int8 s 0 0xAACD; (* outside of the [-127;255] range, -0x33 land 0xFF = 0xCD*)
+ assert( BE.get_uint8 (to_t s) 0 = 0xCD );
+ assert( BE.get_int8 (to_t s) 0 = (-0x33) );
+
+ BE.set_int16 s 0 0x1234;
+ assert( BE.get_uint16 (to_t s) 0 = 0x1234 );
+ assert( BE.get_uint16 (to_t s) 1 = 0x3400 );
+ assert( BE.get_uint16 (to_t s) 2 = 0 );
+
+ assert( LE.get_uint16 (to_t s) 0 = 0x3412 );
+ assert( LE.get_uint16 (to_t s) 1 = 0x0034 );
+ assert( LE.get_uint16 (to_t s) 2 = 0 );
+
+ if big_endian then begin
+ assert( BE.get_uint16 (to_t s) 0 = NE.get_uint16 (to_t s) 0 );
+ assert( BE.get_uint16 (to_t s) 1 = NE.get_uint16 (to_t s) 1 );
+ assert( BE.get_uint16 (to_t s) 2 = NE.get_uint16 (to_t s) 2 );
+ end
+ else begin
+ assert( LE.get_uint16 (to_t s) 0 = NE.get_uint16 (to_t s) 0 );
+ assert( LE.get_uint16 (to_t s) 1 = NE.get_uint16 (to_t s) 1 );
+ assert( LE.get_uint16 (to_t s) 2 = NE.get_uint16 (to_t s) 2 );
+ end;
+
+ assert( BE.get_int16 (to_t s) 0 = 0x1234 );
+ assert( BE.get_int16 (to_t s) 1 = 0x3400 );
+ assert( BE.get_int16 (to_t s) 2 = 0 );
+
+ BE.set_int16 s 0 0xFEDC;
+ assert( BE.get_uint16 (to_t s) 0 = 0xFEDC );
+ assert( BE.get_uint16 (to_t s) 1 = 0xDC00 );
+ assert( BE.get_uint16 (to_t s) 2 = 0 );
+
+ assert( LE.get_uint16 (to_t s) 0 = 0xDCFE );
+ assert( LE.get_uint16 (to_t s) 1 = 0x00DC );
+ assert( LE.get_uint16 (to_t s) 2 = 0 );
+
+ if big_endian then begin
+ assert( BE.get_uint16 (to_t s) 0 = NE.get_uint16 (to_t s) 0 );
+ assert( BE.get_uint16 (to_t s) 1 = NE.get_uint16 (to_t s) 1 );
+ assert( BE.get_uint16 (to_t s) 2 = NE.get_uint16 (to_t s) 2 );
+ end
+ else begin
+ assert( LE.get_uint16 (to_t s) 0 = NE.get_uint16 (to_t s) 0 );
+ assert( LE.get_uint16 (to_t s) 1 = NE.get_uint16 (to_t s) 1 );
+ assert( LE.get_uint16 (to_t s) 2 = NE.get_uint16 (to_t s) 2 );
+ end;
+
+ assert( BE.get_int16 (to_t s) 0 = -292 );
+ assert( BE.get_int16 (to_t s) 1 = -9216 );
+ assert( BE.get_int16 (to_t s) 2 = 0 );
+
+ if big_endian
+ then begin
+ NE.set_int16 s 0 0x1234;
+ assert( BE.get_uint16 (to_t s) 0 = 0x1234 );
+ assert( BE.get_uint16 (to_t s) 1 = 0x3400 );
+ assert( BE.get_uint16 (to_t s) 2 = 0 )
+ end;
+
+ LE.set_int16 s 0 0x1234;
+ assert( BE.get_uint16 (to_t s) 0 = 0x3412 );
+ assert( BE.get_uint16 (to_t s) 1 = 0x1200 );
+ assert( BE.get_uint16 (to_t s) 2 = 0 );
+
+ if not big_endian
+ then begin
+ NE.set_int16 s 0 0x1234;
+ assert( BE.get_uint16 (to_t s) 0 = 0x3412 );
+ assert( BE.get_uint16 (to_t s) 1 = 0x1200 );
+ assert( BE.get_uint16 (to_t s) 2 = 0 )
+ end;
+
+ LE.set_int16 s 0 0xFEDC;
+ assert( LE.get_uint16 (to_t s) 0 = 0xFEDC );
+ assert( LE.get_uint16 (to_t s) 1 = 0x00FE );
+ assert( LE.get_uint16 (to_t s) 2 = 0 );
+
+ BE.set_int32 s 0 0x12345678l;
+ assert( BE.get_int32 (to_t s) 0 = 0x12345678l );
+ assert( LE.get_int32 (to_t s) 0 = 0x78563412l );
+ if big_endian
+ then assert( BE.get_int32 (to_t s) 0 = NE.get_int32 (to_t s) 0 )
+ else assert( LE.get_int32 (to_t s) 0 = NE.get_int32 (to_t s) 0 );
+
+ LE.set_int32 s 0 0x12345678l;
+ assert( LE.get_int32 (to_t s) 0 = 0x12345678l );
+ assert( BE.get_int32 (to_t s) 0 = 0x78563412l );
+
+ if big_endian
+ then assert( BE.get_int32 (to_t s) 0 = NE.get_int32 (to_t s) 0 )
+ else assert( LE.get_int32 (to_t s) 0 = NE.get_int32 (to_t s) 0 );
+
+ NE.set_int32 s 0 0x12345678l;
+ if big_endian
+ then assert( BE.get_int32 (to_t s) 0 = 0x12345678l )
+ else assert( LE.get_int32 (to_t s) 0 = 0x12345678l );
+
+ ()
+
+let test_64 () =
+ BE.set_int64 s 0 0x1234567890ABCDEFL;
+ assert( BE.get_int64 (to_t s) 0 = 0x1234567890ABCDEFL );
+ assert( LE.get_int64 (to_t s) 0 = 0xEFCDAB9078563412L );
+
+ if big_endian
+ then assert( BE.get_int64 (to_t s) 0 = NE.get_int64 (to_t s) 0 )
+ else assert( LE.get_int64 (to_t s) 0 = NE.get_int64 (to_t s) 0 );
+
+ LE.set_int64 s 0 0x1234567890ABCDEFL;
+ assert( LE.get_int64 (to_t s) 0 = 0x1234567890ABCDEFL );
+ assert( BE.get_int64 (to_t s) 0 = 0xEFCDAB9078563412L );
+
+ if big_endian
+ then assert( BE.get_int64 (to_t s) 0 = NE.get_int64 (to_t s) 0 )
+ else assert( LE.get_int64 (to_t s) 0 = NE.get_int64 (to_t s) 0 );
+
+ NE.set_int64 s 0 0x1234567890ABCDEFL;
+ if big_endian
+ then assert( BE.get_int64 (to_t s) 0 = 0x1234567890ABCDEFL )
+ else assert( LE.get_int64 (to_t s) 0 = 0x1234567890ABCDEFL );
+
+ ()
new file mode 100644
@@ -0,0 +1,185 @@
+open EndianString
+[@@@warning "-52"]
+
+let to_t = Bytes.unsafe_to_string
+(* do not allocate to avoid breaking tests *)
+
+module BE = BigEndian
+module LE = LittleEndian
+module NE = NativeEndian
+
+let big_endian = Sys.big_endian
+
+let s = Bytes.make 10 '\x00'
+
+let assert_bound_check2 f v1 v2 =
+ try
+ ignore(f v1 v2);
+ assert false
+ with
+ | Invalid_argument("index out of bounds") -> ()
+
+let assert_bound_check3 f v1 v2 v3 =
+ try
+ ignore(f v1 v2 v3);
+ assert false
+ with
+ | Invalid_argument("index out of bounds") -> ()
+
+let test1 () =
+ assert_bound_check2 BE.get_int8 (to_t s) (-1);
+ assert_bound_check2 BE.get_int8 (to_t s) 10;
+ assert_bound_check2 BE.get_uint16 (to_t s) (-1);
+ assert_bound_check2 BE.get_uint16 (to_t s) 9;
+ assert_bound_check2 BE.get_int32 (to_t s) (-1);
+ assert_bound_check2 BE.get_int32 (to_t s) 7;
+ assert_bound_check2 BE.get_int64 (to_t s) (-1);
+ assert_bound_check2 BE.get_int64 (to_t s) 3;
+
+ assert_bound_check3 BE.set_int8 s (-1) 0;
+ assert_bound_check3 BE.set_int8 s 10 0;
+ assert_bound_check3 BE.set_int16 s (-1) 0;
+ assert_bound_check3 BE.set_int16 s 9 0;
+ assert_bound_check3 BE.set_int32 s (-1) 0l;
+ assert_bound_check3 BE.set_int32 s 7 0l;
+ assert_bound_check3 BE.set_int64 s (-1) 0L;
+ assert_bound_check3 BE.set_int64 s 3 0L
+
+let test2 () =
+ BE.set_int8 s 0 63; (* in [0; 127] *)
+ assert( BE.get_uint8 (to_t s) 0 = 63 );
+ assert( BE.get_int8 (to_t s) 0 = 63 );
+
+ BE.set_int8 s 0 155; (* in [128; 255] *)
+ assert( BE.get_uint8 (to_t s) 0 = 155 );
+
+ BE.set_int8 s 0 (-103); (* in [-128; -1] *)
+ assert( BE.get_int8 (to_t s) 0 = (-103) );
+
+ BE.set_int8 s 0 0x1234; (* outside of the [-127;255] range *)
+ assert( BE.get_uint8 (to_t s) 0 = 0x34 );
+ assert( BE.get_int8 (to_t s) 0 = 0x34 );
+
+ BE.set_int8 s 0 0xAACD; (* outside of the [-127;255] range, -0x33 land 0xFF = 0xCD*)
+ assert( BE.get_uint8 (to_t s) 0 = 0xCD );
+ assert( BE.get_int8 (to_t s) 0 = (-0x33) );
+
+ BE.set_int16 s 0 0x1234;
+ assert( BE.get_uint16 (to_t s) 0 = 0x1234 );
+ assert( BE.get_uint16 (to_t s) 1 = 0x3400 );
+ assert( BE.get_uint16 (to_t s) 2 = 0 );
+
+ assert( LE.get_uint16 (to_t s) 0 = 0x3412 );
+ assert( LE.get_uint16 (to_t s) 1 = 0x0034 );
+ assert( LE.get_uint16 (to_t s) 2 = 0 );
+
+ if big_endian then begin
+ assert( BE.get_uint16 (to_t s) 0 = NE.get_uint16 (to_t s) 0 );
+ assert( BE.get_uint16 (to_t s) 1 = NE.get_uint16 (to_t s) 1 );
+ assert( BE.get_uint16 (to_t s) 2 = NE.get_uint16 (to_t s) 2 );
+ end
+ else begin
+ assert( LE.get_uint16 (to_t s) 0 = NE.get_uint16 (to_t s) 0 );
+ assert( LE.get_uint16 (to_t s) 1 = NE.get_uint16 (to_t s) 1 );
+ assert( LE.get_uint16 (to_t s) 2 = NE.get_uint16 (to_t s) 2 );
+ end;
+
+ assert( BE.get_int16 (to_t s) 0 = 0x1234 );
+ assert( BE.get_int16 (to_t s) 1 = 0x3400 );
+ assert( BE.get_int16 (to_t s) 2 = 0 );
+
+ BE.set_int16 s 0 0xFEDC;
+ assert( BE.get_uint16 (to_t s) 0 = 0xFEDC );
+ assert( BE.get_uint16 (to_t s) 1 = 0xDC00 );
+ assert( BE.get_uint16 (to_t s) 2 = 0 );
+
+ assert( LE.get_uint16 (to_t s) 0 = 0xDCFE );
+ assert( LE.get_uint16 (to_t s) 1 = 0x00DC );
+ assert( LE.get_uint16 (to_t s) 2 = 0 );
+
+ if big_endian then begin
+ assert( BE.get_uint16 (to_t s) 0 = NE.get_uint16 (to_t s) 0 );
+ assert( BE.get_uint16 (to_t s) 1 = NE.get_uint16 (to_t s) 1 );
+ assert( BE.get_uint16 (to_t s) 2 = NE.get_uint16 (to_t s) 2 );
+ end
+ else begin
+ assert( LE.get_uint16 (to_t s) 0 = NE.get_uint16 (to_t s) 0 );
+ assert( LE.get_uint16 (to_t s) 1 = NE.get_uint16 (to_t s) 1 );
+ assert( LE.get_uint16 (to_t s) 2 = NE.get_uint16 (to_t s) 2 );
+ end;
+
+ assert( BE.get_int16 (to_t s) 0 = -292 );
+ assert( BE.get_int16 (to_t s) 1 = -9216 );
+ assert( BE.get_int16 (to_t s) 2 = 0 );
+
+ if big_endian
+ then begin
+ NE.set_int16 s 0 0x1234;
+ assert( BE.get_uint16 (to_t s) 0 = 0x1234 );
+ assert( BE.get_uint16 (to_t s) 1 = 0x3400 );
+ assert( BE.get_uint16 (to_t s) 2 = 0 )
+ end;
+
+ LE.set_int16 s 0 0x1234;
+ assert( BE.get_uint16 (to_t s) 0 = 0x3412 );
+ assert( BE.get_uint16 (to_t s) 1 = 0x1200 );
+ assert( BE.get_uint16 (to_t s) 2 = 0 );
+
+ if not big_endian
+ then begin
+ NE.set_int16 s 0 0x1234;
+ assert( BE.get_uint16 (to_t s) 0 = 0x3412 );
+ assert( BE.get_uint16 (to_t s) 1 = 0x1200 );
+ assert( BE.get_uint16 (to_t s) 2 = 0 )
+ end;
+
+ LE.set_int16 s 0 0xFEDC;
+ assert( LE.get_uint16 (to_t s) 0 = 0xFEDC );
+ assert( LE.get_uint16 (to_t s) 1 = 0x00FE );
+ assert( LE.get_uint16 (to_t s) 2 = 0 );
+
+ BE.set_int32 s 0 0x12345678l;
+ assert( BE.get_int32 (to_t s) 0 = 0x12345678l );
+ assert( LE.get_int32 (to_t s) 0 = 0x78563412l );
+ if big_endian
+ then assert( BE.get_int32 (to_t s) 0 = NE.get_int32 (to_t s) 0 )
+ else assert( LE.get_int32 (to_t s) 0 = NE.get_int32 (to_t s) 0 );
+
+ LE.set_int32 s 0 0x12345678l;
+ assert( LE.get_int32 (to_t s) 0 = 0x12345678l );
+ assert( BE.get_int32 (to_t s) 0 = 0x78563412l );
+
+ if big_endian
+ then assert( BE.get_int32 (to_t s) 0 = NE.get_int32 (to_t s) 0 )
+ else assert( LE.get_int32 (to_t s) 0 = NE.get_int32 (to_t s) 0 );
+
+ NE.set_int32 s 0 0x12345678l;
+ if big_endian
+ then assert( BE.get_int32 (to_t s) 0 = 0x12345678l )
+ else assert( LE.get_int32 (to_t s) 0 = 0x12345678l );
+
+ ()
+
+let test_64 () =
+ BE.set_int64 s 0 0x1234567890ABCDEFL;
+ assert( BE.get_int64 (to_t s) 0 = 0x1234567890ABCDEFL );
+ assert( LE.get_int64 (to_t s) 0 = 0xEFCDAB9078563412L );
+
+ if big_endian
+ then assert( BE.get_int64 (to_t s) 0 = NE.get_int64 (to_t s) 0 )
+ else assert( LE.get_int64 (to_t s) 0 = NE.get_int64 (to_t s) 0 );
+
+ LE.set_int64 s 0 0x1234567890ABCDEFL;
+ assert( LE.get_int64 (to_t s) 0 = 0x1234567890ABCDEFL );
+ assert( BE.get_int64 (to_t s) 0 = 0xEFCDAB9078563412L );
+
+ if big_endian
+ then assert( BE.get_int64 (to_t s) 0 = NE.get_int64 (to_t s) 0 )
+ else assert( LE.get_int64 (to_t s) 0 = NE.get_int64 (to_t s) 0 );
+
+ NE.set_int64 s 0 0x1234567890ABCDEFL;
+ if big_endian
+ then assert( BE.get_int64 (to_t s) 0 = 0x1234567890ABCDEFL )
+ else assert( LE.get_int64 (to_t s) 0 = 0x1234567890ABCDEFL );
+
+ ()
new file mode 100755
@@ -0,0 +1,15 @@
+1.5 (17/02/2020)
+----------------
+
+- Make Result an alias of Stdlib.Result on OCaml >= 4.08.
+
+1.4 (27/03/2019)
+----------------
+
+- Switch to Dune.
+- Do not refer to Pervasives; it is deprecated.
+
+1.3 (05/02/2018)
+----------------
+
+- Switch to jbuilder.
new file mode 100755
@@ -0,0 +1,24 @@
+Copyright (c) 2015, Jane Street Group, LLC <opensource@janestreet.com>
+All rights reserved.
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+ * Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+ * Neither the name of Jane Street Group nor the names of his
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND ANY
+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE AUTHOR AND CONTRIBUTORS BE LIABLE FOR ANY
+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
new file mode 100755
@@ -0,0 +1,17 @@
+INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),)
+
+default:
+ dune build @install
+
+install:
+ dune install $(INSTALL_ARGS)
+
+uninstall:
+ dune uninstall $(INSTALL_ARGS)
+
+reinstall: uninstall reinstall
+
+clean:
+ dune clean
+
+.PHONY: default install uninstall reinstall clean
new file mode 100755
@@ -0,0 +1,5 @@
+Compatibility Result module.
+
+Projects that want to use the new result type defined in OCaml >= 4.03
+while staying compatible with older version of OCaml should use the
+`Result` module defined in this library.
new file mode 100755
@@ -0,0 +1,12 @@
+(library
+ (name result)
+ (public_name result)
+ (modules result))
+
+(rule
+ (with-stdout-to
+ selected
+ (run %{ocaml} %{dep:which_result.ml} %{ocaml_version})))
+
+(rule
+ (copy# %{read:selected} result.ml))
new file mode 100755
@@ -0,0 +1,3 @@
+(lang dune 1.0)
+(name result)
+(version 1.5)
new file mode 100755
@@ -0,0 +1,2 @@
+include Stdlib.Result
+type ('a, 'b) result = ('a, 'b) Stdlib.Result.t = Ok of 'a | Error of 'b
new file mode 100755
@@ -0,0 +1,2 @@
+type nonrec ('a, 'b) result = ('a, 'b) result = Ok of 'a | Error of 'b
+type ('a, 'b) t = ('a, 'b) result
new file mode 100755
@@ -0,0 +1,2 @@
+type ('a, 'b) result = Ok of 'a | Error of 'b
+type ('a, 'b) t = ('a, 'b) result
new file mode 100755
@@ -0,0 +1,18 @@
+version: "1.5"
+opam-version: "2.0"
+maintainer: "opensource@janestreet.com"
+authors: ["Jane Street Group, LLC <opensource@janestreet.com>"]
+homepage: "https://github.com/janestreet/result"
+dev-repo: "git+https://github.com/janestreet/result.git"
+bug-reports: "https://github.com/janestreet/result/issues"
+license: "BSD-3-Clause"
+build: [["dune" "build" "-p" name "-j" jobs]]
+depends: [
+ "ocaml"
+ "dune" {>= "1.0"}
+]
+synopsis: "Compatibility Result module"
+description: """
+Projects that want to use the new result type defined in OCaml >= 4.03
+while staying compatible with older version of OCaml should use the
+Result module defined in this library."""
\ No newline at end of file
new file mode 100755
@@ -0,0 +1,14 @@
+let () =
+ let version =
+ Scanf.sscanf Sys.argv.(1) "%d.%d" (fun major minor -> (major, minor))
+ in
+ let file =
+ if version < (4, 03) then
+ "result-as-newtype.ml"
+ else
+ if version < (4, 08) then
+ "result-as-alias.ml"
+ else
+ "result-as-alias-4.08.ml"
+ in
+ print_string file
new file mode 100644
@@ -0,0 +1,5 @@
+0.1.0 2019-02-19 London
+-----------------------
+
+First release. In this release, only the `Stdlib` module is backported
+to older version of OCaml.
new file mode 100644
@@ -0,0 +1,203 @@
+In the following, "the OCaml Core System" refers to all files marked
+"Copyright INRIA" in this distribution.
+
+The OCaml Core System is distributed under the terms of the
+GNU Lesser General Public License (LGPL) version 2.1 (included below).
+
+As a special exception to the GNU Lesser General Public License, you
+may link, statically or dynamically, a "work that uses the OCaml Core
+System" with a publicly distributed version of the OCaml Core System
+to produce an executable file containing portions of the OCaml Core
+System, and distribute that executable file under terms of your
+choice, without any of the additional requirements listed in clause 6
+of the GNU Lesser General Public License. By "a publicly distributed
+version of the OCaml Core System", we mean either the unmodified OCaml
+Core System as distributed by INRIA, or a modified version of the
+OCaml Core System that is distributed under the conditions defined in
+clause 2 of the GNU Lesser General Public License. This exception
+does not however invalidate any other reasons why the executable file
+might be covered by the GNU Lesser General Public License.
+
+----------------------------------------------------------------------
+
+GNU LESSER GENERAL PUBLIC LICENSE
+
+Version 2.1, February 1999
+
+Copyright (C) 1991, 1999 Free Software Foundation, Inc.
+51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+Everyone is permitted to copy and distribute verbatim copies
+of this license document, but changing it is not allowed.
+
+[This is the first released version of the Lesser GPL. It also counts
+ as the successor of the GNU Library Public License, version 2, hence
+ the version number 2.1.]
+
+Preamble
+
+The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users.
+
+This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below.
+
+When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things.
+
+To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it.
+
+For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights.
+
+We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library.
+
+To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others.
+
+Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license.
+
+Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs.
+
+When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library.
+
+We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances.
+
+For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License.
+
+In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system.
+
+Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library.
+
+The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run.
+
+TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you".
+
+A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables.
+
+The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".)
+
+"Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library.
+
+Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does.
+
+1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library.
+
+You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee.
+
+2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions:
+
+ a) The modified work must itself be a software library.
+ b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change.
+ c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License.
+ d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful.
+
+ (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.)
+
+These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library.
+
+In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License.
+
+3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices.
+
+Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy.
+
+This option is useful when you wish to copy part of the code of the Library into a program that is not a library.
+
+4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange.
+
+If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code.
+
+5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License.
+
+However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables.
+
+When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law.
+
+If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.)
+
+Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself.
+
+6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications.
+
+You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things:
+
+ a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.)
+ b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with.
+ c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution.
+ d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place.
+ e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy.
+
+For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable.
+
+It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute.
+
+7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things:
+
+ a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above.
+ b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work.
+
+8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance.
+
+9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it.
+
+10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License.
+
+11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library.
+
+If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances.
+
+It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice.
+
+This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License.
+
+12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License.
+
+13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation.
+
+14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally.
+
+NO WARRANTY
+
+15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
+END OF TERMS AND CONDITIONS
+
+How to Apply These Terms to Your New Libraries
+
+If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License).
+
+To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found.
+
+one line to give the library's name and an idea of what it does.
+Copyright (C) year name of author
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 2.1 of the License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public
+License along with this library; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+Also add information on how to contact you by electronic and paper mail.
+
+You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names:
+
+Yoyodyne, Inc., hereby disclaims all copyright interest in
+the library `Frob' (a library for tweaking knobs) written
+by James Random Hacker.
+
+signature of Ty Coon, 1 April 1990
+Ty Coon, President of Vice
+
+That's all there is to it!
+
+--------------------------------------------------
new file mode 100644
@@ -0,0 +1,2 @@
+# stdlib-shims
+Shims for forward-compatibility between versions of the OCaml standard library
new file mode 100644
@@ -0,0 +1 @@
+(lang dune 1.0)
new file mode 100644
@@ -0,0 +1,14 @@
+(lang dune 1.0)
+
+;; Run the following command to test against all supported versions of
+;; OCaml:
+;;
+;; $ dune runtest --workspace dune-workspace.dev
+
+(context (opam (switch 4.02.3)))
+(context (opam (switch 4.03.0)))
+(context (opam (switch 4.04.2)))
+(context (opam (switch 4.05.0)))
+(context (opam (switch 4.06.1)))
+(context (opam (switch 4.07.0)))
+(context (opam (switch 4.08.0+trunk)))
new file mode 100644
@@ -0,0 +1,97 @@
+(* -*- tuareg -*- *)
+
+open StdLabels
+open Jbuild_plugin.V1
+
+let version = Scanf.sscanf ocaml_version "%u.%u" (fun a b -> (a, b))
+
+let modules_in_4_02 =
+ [ "Arg"
+ ; "Array"
+ ; "ArrayLabels"
+ ; "Buffer"
+ ; "Bytes"
+ ; "BytesLabels"
+ ; "Callback"
+ ; "Char"
+ ; "Complex"
+ ; "Digest"
+ ; "Filename"
+ ; "Format"
+ ; "Gc"
+ ; "Genlex"
+ ; "Hashtbl"
+ ; "Int32"
+ ; "Int64"
+ ; "Lazy"
+ ; "Lexing"
+ ; "List"
+ ; "ListLabels"
+ ; "Map"
+ ; "Marshal"
+ ; "MoreLabels"
+ ; "Nativeint"
+ ; "Obj"
+ ; "Oo"
+ ; "Parsing"
+ ; "Pervasives"
+ ; "Printexc"
+ ; "Printf"
+ ; "Queue"
+ ; "Random"
+ ; "Scanf"
+ ; "Set"
+ ; "Stack"
+ ; "StdLabels"
+ ; "Stream"
+ ; "String"
+ ; "StringLabels"
+ ; "Sys"
+ ; "Weak"
+ ]
+
+let modules_post_4_02 =
+ [ "Float", (4, 07)
+ ; "Seq", (4, 07)
+ ; "Stdlib", (4, 07)
+ ; "Uchar", (4, 03)
+ ]
+
+let available_modules =
+ modules_in_4_02 @
+ (List.filter modules_post_4_02 ~f:(fun (m, v) ->
+ version >= v)
+ |> List.map ~f:fst)
+
+let all_modules_except_stdlib =
+ available_modules
+ |> List.filter ~f:((<>) "Stdlib")
+ |> List.sort ~cmp:String.compare
+
+let longest_module_name =
+ List.fold_left all_modules_except_stdlib ~init:0
+ ~f:(fun acc m -> max acc (String.length m))
+
+let stdlib_rule =
+ Printf.sprintf {|
+(rule
+ (with-stdout-to stdlib.ml
+ (echo "\
+%s
+
+include Pervasives
+")))
+|}
+ (List.map all_modules_except_stdlib
+ ~f:(fun m -> Printf.sprintf "module %-*s = %s" longest_module_name m m)
+ |> String.concat ~sep:"\n")
+
+let () =
+ Printf.ksprintf send {|
+(library
+ (wrapped false)
+ (name stdlib_shims)
+ (public_name stdlib-shims))
+%s
+|}
+ (if version >= (4, 07) then "" else stdlib_rule)
new file mode 100644
@@ -0,0 +1,24 @@
+version: "0.1.0"
+opam-version: "2.0"
+maintainer: "The stdlib-shims programmers"
+authors: "The stdlib-shims programmers"
+homepage: "https://github.com/ocaml/stdlib-shims"
+doc: "https://ocaml.github.io/stdlib-shims/"
+dev-repo: "git+https://github.com/ocaml/stdlib-shims.git"
+bug-reports: "https://github.com/ocaml/stdlib-shims/issues"
+tags: ["stdlib" "compatibility" "org:ocaml"]
+license: ["typeof OCaml system"]
+available: [ ]
+depends: [
+ "dune"
+ "ocaml" {>= "4.02.3"}
+]
+build: [ "dune" "build" "-p" name "-j" jobs ]
+synopsis: "Backport some of the new stdlib features to older compiler"
+description: """
+Backport some of the new stdlib features to older compiler,
+such as the Stdlib module.
+
+This allows projects that require compatibility with older compiler to
+use these new features in their code.
+"""
\ No newline at end of file
new file mode 100644
@@ -0,0 +1,3 @@
+(test
+ (name test)
+ (libraries stdlib_shims))
new file mode 100644
@@ -0,0 +1,2 @@
+let _ = Stdlib.(+)
+let _ = Stdlib.List.map
new file mode 100644
@@ -0,0 +1,119 @@
+opam-version: "2.0"
+synopsis: "opam-monorepo generated lockfile"
+maintainer: "opam-monorepo"
+depends: [
+ "afl-persistent" {= "1.3"}
+ "base-bigarray" {= "base"}
+ "base-bytes" {= "base"}
+ "base-threads" {= "base"}
+ "base-unix" {= "base"}
+ "cmdliner" {= "1.0.4+dune"}
+ "cppo" {= "1.6.7"}
+ "crowbar" {= "0.2"}
+ "csexp" {= "1.3.2"}
+ "fmt" {= "0.8.8+dune"}
+ "ocaml" {= "4.12.0"}
+ "ocaml-base-compiler" {= "4.12.0~beta1"}
+ "ocaml-config" {= "2"}
+ "ocaml-options-vanilla" {= "1"}
+ "ocplib-endian" {= "1.1"}
+ "result" {= "1.5"}
+ "stdlib-shims" {= "0.1.0"}
+]
+depexts: ["libsystemd-dev" "libxen-dev" "m4"] {os-distribution = "debian"}
+pin-depends: [
+ [
+ "afl-persistent.1.3"
+ "git+file:///home/edwin-work/afl-persistent#09539920681aafb7f792d5280c76d4020848b3c0"
+ ]
+ [
+ "cmdliner.1.0.4+dune"
+ "https://github.com/dune-universe/cmdliner/archive/v1.0.4+dune.tar.gz"
+ ]
+ [
+ "cppo.1.6.7"
+ "https://github.com/ocaml-community/cppo/releases/download/v1.6.7/cppo-v1.6.7.tbz"
+ ]
+ ["crowbar.0.2" "https://github.com/stedolan/crowbar/archive/v0.2.tar.gz"]
+ [
+ "csexp.1.3.2"
+ "https://github.com/ocaml-dune/csexp/releases/download/1.3.2/csexp-1.3.2.tbz"
+ ]
+ [
+ "fmt.0.8.8+dune"
+ "https://github.com/dune-universe/fmt/archive/v0.8.8+dune.tar.gz"
+ ]
+ [
+ "ocplib-endian.1.1"
+ "https://github.com/OCamlPro/ocplib-endian/archive/1.1.tar.gz"
+ ]
+ [
+ "result.1.5"
+ "https://github.com/janestreet/result/releases/download/1.5/result-1.5.tbz"
+ ]
+ [
+ "stdlib-shims.0.1.0"
+ "https://github.com/ocaml/stdlib-shims/releases/download/0.1.0/stdlib-shims-0.1.0.tbz"
+ ]
+]
+x-opam-monorepo-duniverse-dirs: [
+ [
+ "git+file:///home/edwin-work/afl-persistent#09539920681aafb7f792d5280c76d4020848b3c0"
+ "ocaml-afl-persistent"
+ ]
+ [
+ "https://github.com/OCamlPro/ocplib-endian/archive/1.1.tar.gz"
+ "ocplib-endian"
+ [
+ "md5=dedf4d69c1b87b3c6c7234f632399285"
+ "sha512=39351c666d1394770696fa89ac62f7c137ad1697d99888bfba2cc8de2c61df05dd8b3aa327c117bf38f3e29e081026d2c575c5ad0022bde92b3d43aba577d3f9"
+ ]
+ ]
+ [
+ "https://github.com/dune-universe/cmdliner/archive/v1.0.4+dune.tar.gz"
+ "cmdliner"
+ [
+ "sha256=ffc09f07a9e394d6be4dbecea7add601ff00519a91dff4c95b9cd0a4aa60eceb"
+ ]
+ ]
+ [
+ "https://github.com/dune-universe/fmt/archive/v0.8.8+dune.tar.gz"
+ "fmt"
+ [
+ "sha256=da16172528cc5ebde062fcb25e46085962ddd5fd32d2dc00eb07697384f0eb2d"
+ ]
+ ]
+ [
+ "https://github.com/janestreet/result/releases/download/1.5/result-1.5.tbz"
+ "result"
+ ["md5=1b82dec78849680b49ae9a8a365b831b"]
+ ]
+ [
+ "https://github.com/ocaml-community/cppo/releases/download/v1.6.7/cppo-v1.6.7.tbz"
+ "cppo"
+ [
+ "sha256=db553e3e6c206df09b1858c3aef5e21e56564d593642a3c78bcedb6af36f529d"
+ "sha512=9722b50fd23aaccf86816313333a3bf8fc7c6b4ef06b153e5e1e1aaf14670cf51a4aac52fb1b4a0e5531699c4047a1eff6c24c969f7e5063e78096c2195b5819"
+ ]
+ ]
+ [
+ "https://github.com/ocaml-dune/csexp/releases/download/1.3.2/csexp-1.3.2.tbz"
+ "csexp"
+ [
+ "sha256=f21f427b277f07e8bfd050e00c640a5893c1bf4b689147640fa383255dcf1c4a"
+ "sha512=ff1bd6a7c6bb3a73ca9ab0506c9ec1f357657deaa9ecc7eb32955817d9b0f266d976af3e2b8fc34c621cb0caf1fde55f9a609dd184e2054f500bf09afeb83026"
+ ]
+ ]
+ [
+ "https://github.com/ocaml/stdlib-shims/releases/download/0.1.0/stdlib-shims-0.1.0.tbz"
+ "stdlib-shims"
+ ["md5=12b5704eed70c6bff5ac39a16db1425d"]
+ ]
+ [
+ "https://github.com/stedolan/crowbar/archive/v0.2.tar.gz"
+ "crowbar"
+ ["md5=55e85b9fcc3a777bc7c70ec57b136e7c"]
+ ]
+]
+x-opam-monorepo-root-packages: ["xen" "xenstore" "xenstored"]
+x-opam-monorepo-version: "0.2"
To run the unit tests these dependencies need to be available. The developer can either install them themselves using opam, or we can add them as subdirs here. Dune will automatically pick the libraries from the system or build it from the subdir as needed, no changes to the dune files are needed. The duniverse/ subdir was generated by using the 'opam monorepo' command: https://github.com/ocamllabs/opam-monorepo This wrote a lockfile (xen.opam.locked) containing tarball sources and hashes, and then opam monorepo pull downloaded the sources. Signed-off-by: Edwin Török <edvin.torok@citrix.com> --- tools/ocaml/duniverse/cmdliner/.gitignore | 10 + tools/ocaml/duniverse/cmdliner/.ocp-indent | 1 + tools/ocaml/duniverse/cmdliner/B0.ml | 9 + tools/ocaml/duniverse/cmdliner/CHANGES.md | 255 +++ tools/ocaml/duniverse/cmdliner/LICENSE.md | 13 + tools/ocaml/duniverse/cmdliner/Makefile | 77 + tools/ocaml/duniverse/cmdliner/README.md | 51 + tools/ocaml/duniverse/cmdliner/_tags | 3 + tools/ocaml/duniverse/cmdliner/build.ml | 155 ++ tools/ocaml/duniverse/cmdliner/cmdliner.opam | 32 + tools/ocaml/duniverse/cmdliner/doc/api.odocl | 1 + tools/ocaml/duniverse/cmdliner/dune-project | 2 + tools/ocaml/duniverse/cmdliner/pkg/META | 7 + tools/ocaml/duniverse/cmdliner/pkg/pkg.ml | 33 + .../ocaml/duniverse/cmdliner/src/cmdliner.ml | 309 ++++ .../ocaml/duniverse/cmdliner/src/cmdliner.mli | 1624 +++++++++++++++++ .../duniverse/cmdliner/src/cmdliner.mllib | 11 + .../duniverse/cmdliner/src/cmdliner_arg.ml | 356 ++++ .../duniverse/cmdliner/src/cmdliner_arg.mli | 111 ++ .../duniverse/cmdliner/src/cmdliner_base.ml | 302 +++ .../duniverse/cmdliner/src/cmdliner_base.mli | 68 + .../duniverse/cmdliner/src/cmdliner_cline.ml | 199 ++ .../duniverse/cmdliner/src/cmdliner_cline.mli | 34 + .../duniverse/cmdliner/src/cmdliner_docgen.ml | 352 ++++ .../cmdliner/src/cmdliner_docgen.mli | 30 + .../duniverse/cmdliner/src/cmdliner_info.ml | 233 +++ .../duniverse/cmdliner/src/cmdliner_info.mli | 140 ++ .../cmdliner/src/cmdliner_manpage.ml | 502 +++++ .../cmdliner/src/cmdliner_manpage.mli | 100 + .../duniverse/cmdliner/src/cmdliner_msg.ml | 116 ++ .../duniverse/cmdliner/src/cmdliner_msg.mli | 56 + .../cmdliner/src/cmdliner_suggest.ml | 54 + .../cmdliner/src/cmdliner_suggest.mli | 25 + .../duniverse/cmdliner/src/cmdliner_term.ml | 41 + .../duniverse/cmdliner/src/cmdliner_term.mli | 40 + .../duniverse/cmdliner/src/cmdliner_trie.ml | 97 + .../duniverse/cmdliner/src/cmdliner_trie.mli | 35 + tools/ocaml/duniverse/cmdliner/src/dune | 4 + tools/ocaml/duniverse/cmdliner/test/chorus.ml | 31 + tools/ocaml/duniverse/cmdliner/test/cp_ex.ml | 54 + .../ocaml/duniverse/cmdliner/test/darcs_ex.ml | 149 ++ tools/ocaml/duniverse/cmdliner/test/dune | 12 + tools/ocaml/duniverse/cmdliner/test/revolt.ml | 9 + tools/ocaml/duniverse/cmdliner/test/rm_ex.ml | 53 + .../ocaml/duniverse/cmdliner/test/tail_ex.ml | 73 + .../ocaml/duniverse/cmdliner/test/test_man.ml | 100 + .../duniverse/cmdliner/test/test_man_utf8.ml | 11 + .../duniverse/cmdliner/test/test_opt_req.ml | 13 + .../ocaml/duniverse/cmdliner/test/test_pos.ml | 13 + .../duniverse/cmdliner/test/test_pos_all.ml | 11 + .../duniverse/cmdliner/test/test_pos_left.ml | 11 + .../duniverse/cmdliner/test/test_pos_req.ml | 15 + .../duniverse/cmdliner/test/test_pos_rev.ml | 14 + .../duniverse/cmdliner/test/test_term_dups.ml | 19 + .../cmdliner/test/test_with_used_args.ml | 18 + tools/ocaml/duniverse/cppo/.gitignore | 5 + tools/ocaml/duniverse/cppo/.ocp-indent | 22 + tools/ocaml/duniverse/cppo/.travis.yml | 16 + tools/ocaml/duniverse/cppo/CODEOWNERS | 8 + tools/ocaml/duniverse/cppo/Changes | 85 + tools/ocaml/duniverse/cppo/INSTALL.md | 17 + tools/ocaml/duniverse/cppo/LICENSE.md | 24 + tools/ocaml/duniverse/cppo/Makefile | 18 + tools/ocaml/duniverse/cppo/README.md | 521 ++++++ tools/ocaml/duniverse/cppo/VERSION | 1 + tools/ocaml/duniverse/cppo/appveyor.yml | 14 + tools/ocaml/duniverse/cppo/cppo.opam | 31 + .../ocaml/duniverse/cppo/cppo_ocamlbuild.opam | 27 + tools/ocaml/duniverse/cppo/dune-project | 3 + tools/ocaml/duniverse/cppo/examples/Makefile | 8 + tools/ocaml/duniverse/cppo/examples/debug.ml | 7 + tools/ocaml/duniverse/cppo/examples/dune | 32 + tools/ocaml/duniverse/cppo/examples/french.ml | 34 + tools/ocaml/duniverse/cppo/examples/lexer.mll | 9 + .../duniverse/cppo/ocamlbuild_plugin/_tags | 1 + .../duniverse/cppo/ocamlbuild_plugin/dune | 6 + .../cppo/ocamlbuild_plugin/ocamlbuild_cppo.ml | 35 + .../ocamlbuild_plugin/ocamlbuild_cppo.mli | 9 + tools/ocaml/duniverse/cppo/src/compat.ml | 7 + .../ocaml/duniverse/cppo/src/cppo_command.ml | 63 + .../ocaml/duniverse/cppo/src/cppo_command.mli | 11 + tools/ocaml/duniverse/cppo/src/cppo_eval.ml | 697 +++++++ tools/ocaml/duniverse/cppo/src/cppo_eval.mli | 29 + tools/ocaml/duniverse/cppo/src/cppo_lexer.mll | 721 ++++++++ tools/ocaml/duniverse/cppo/src/cppo_main.ml | 230 +++ .../ocaml/duniverse/cppo/src/cppo_parser.mly | 266 +++ tools/ocaml/duniverse/cppo/src/cppo_types.ml | 98 + tools/ocaml/duniverse/cppo/src/cppo_types.mli | 70 + .../ocaml/duniverse/cppo/src/cppo_version.mli | 1 + tools/ocaml/duniverse/cppo/src/dune | 21 + tools/ocaml/duniverse/cppo/test/capital.cppo | 6 + tools/ocaml/duniverse/cppo/test/capital.ref | 6 + tools/ocaml/duniverse/cppo/test/comments.cppo | 7 + tools/ocaml/duniverse/cppo/test/comments.ref | 8 + tools/ocaml/duniverse/cppo/test/cond.cppo | 47 + tools/ocaml/duniverse/cppo/test/cond.ref | 17 + tools/ocaml/duniverse/cppo/test/dune | 130 ++ tools/ocaml/duniverse/cppo/test/ext.cppo | 10 + tools/ocaml/duniverse/cppo/test/ext.ref | 28 + tools/ocaml/duniverse/cppo/test/incl.cppo | 3 + tools/ocaml/duniverse/cppo/test/incl2.cppo | 1 + tools/ocaml/duniverse/cppo/test/loc.cppo | 8 + tools/ocaml/duniverse/cppo/test/loc.ref | 21 + .../ocaml/duniverse/cppo/test/paren_arg.cppo | 3 + tools/ocaml/duniverse/cppo/test/paren_arg.ref | 4 + tools/ocaml/duniverse/cppo/test/source.sh | 13 + tools/ocaml/duniverse/cppo/test/test.cppo | 144 ++ tools/ocaml/duniverse/cppo/test/tuple.cppo | 38 + tools/ocaml/duniverse/cppo/test/tuple.ref | 20 + .../ocaml/duniverse/cppo/test/unmatched.cppo | 14 + tools/ocaml/duniverse/cppo/test/unmatched.ref | 15 + tools/ocaml/duniverse/cppo/test/version.cppo | 30 + tools/ocaml/duniverse/crowbar/.gitignore | 5 + tools/ocaml/duniverse/crowbar/CHANGES.md | 9 + tools/ocaml/duniverse/crowbar/LICENSE.md | 8 + tools/ocaml/duniverse/crowbar/README.md | 82 + tools/ocaml/duniverse/crowbar/crowbar.opam | 33 + tools/ocaml/duniverse/crowbar/dune | 1 + tools/ocaml/duniverse/crowbar/dune-project | 2 + .../duniverse/crowbar/examples/.gitignore | 1 + .../duniverse/crowbar/examples/calendar/dune | 3 + .../examples/calendar/test_calendar.ml | 29 + .../duniverse/crowbar/examples/fpath/dune | 4 + .../crowbar/examples/fpath/test_fpath.ml | 18 + .../duniverse/crowbar/examples/input/testcase | 1 + .../ocaml/duniverse/crowbar/examples/map/dune | 3 + .../crowbar/examples/map/test_map.ml | 47 + .../duniverse/crowbar/examples/pprint/dune | 3 + .../crowbar/examples/pprint/test_pprint.ml | 39 + .../crowbar/examples/serializer/dune | 3 + .../crowbar/examples/serializer/serializer.ml | 34 + .../examples/serializer/test_serializer.ml | 47 + .../duniverse/crowbar/examples/uunf/dune | 3 + .../crowbar/examples/uunf/test_uunf.ml | 75 + .../duniverse/crowbar/examples/xmldiff/dune | 3 + .../crowbar/examples/xmldiff/test_xmldiff.ml | 42 + tools/ocaml/duniverse/crowbar/src/crowbar.ml | 582 ++++++ tools/ocaml/duniverse/crowbar/src/crowbar.mli | 251 +++ tools/ocaml/duniverse/crowbar/src/dune | 3 + tools/ocaml/duniverse/crowbar/src/todo | 16 + tools/ocaml/duniverse/csexp/CHANGES.md | 45 + tools/ocaml/duniverse/csexp/LICENSE.md | 21 + tools/ocaml/duniverse/csexp/Makefile | 23 + tools/ocaml/duniverse/csexp/README.md | 33 + .../duniverse/csexp/bench/csexp_bench.ml | 22 + tools/ocaml/duniverse/csexp/bench/dune | 11 + tools/ocaml/duniverse/csexp/bench/main.ml | 1 + tools/ocaml/duniverse/csexp/bench/runner.sh | 4 + tools/ocaml/duniverse/csexp/csexp.opam | 51 + .../ocaml/duniverse/csexp/csexp.opam.template | 14 + tools/ocaml/duniverse/csexp/dune-project | 42 + .../ocaml/duniverse/csexp/dune-workspace.dev | 6 + tools/ocaml/duniverse/csexp/src/csexp.ml | 333 ++++ tools/ocaml/duniverse/csexp/src/csexp.mli | 369 ++++ tools/ocaml/duniverse/csexp/src/dune | 3 + tools/ocaml/duniverse/csexp/test/dune | 6 + tools/ocaml/duniverse/csexp/test/test.ml | 142 ++ tools/ocaml/duniverse/dune | 4 + tools/ocaml/duniverse/fmt/.gitignore | 8 + tools/ocaml/duniverse/fmt/.ocp-indent | 1 + tools/ocaml/duniverse/fmt/CHANGES.md | 98 + tools/ocaml/duniverse/fmt/LICENSE.md | 13 + tools/ocaml/duniverse/fmt/README.md | 35 + tools/ocaml/duniverse/fmt/_tags | 7 + tools/ocaml/duniverse/fmt/doc/api.odocl | 3 + tools/ocaml/duniverse/fmt/doc/index.mld | 11 + tools/ocaml/duniverse/fmt/dune-project | 2 + tools/ocaml/duniverse/fmt/fmt.opam | 35 + tools/ocaml/duniverse/fmt/pkg/META | 40 + tools/ocaml/duniverse/fmt/pkg/pkg.ml | 18 + tools/ocaml/duniverse/fmt/src/dune | 30 + tools/ocaml/duniverse/fmt/src/fmt.ml | 787 ++++++++ tools/ocaml/duniverse/fmt/src/fmt.mli | 689 +++++++ tools/ocaml/duniverse/fmt/src/fmt.mllib | 1 + tools/ocaml/duniverse/fmt/src/fmt_cli.ml | 32 + tools/ocaml/duniverse/fmt/src/fmt_cli.mli | 45 + tools/ocaml/duniverse/fmt/src/fmt_cli.mllib | 1 + tools/ocaml/duniverse/fmt/src/fmt_top.ml | 23 + tools/ocaml/duniverse/fmt/src/fmt_top.mllib | 1 + tools/ocaml/duniverse/fmt/src/fmt_tty.ml | 78 + tools/ocaml/duniverse/fmt/src/fmt_tty.mli | 50 + tools/ocaml/duniverse/fmt/src/fmt_tty.mllib | 1 + .../duniverse/fmt/src/fmt_tty_top_init.ml | 23 + tools/ocaml/duniverse/fmt/test/test.ml | 322 ++++ .../duniverse/ocaml-afl-persistent/.gitignore | 2 + .../duniverse/ocaml-afl-persistent/CHANGES.md | 22 + .../duniverse/ocaml-afl-persistent/LICENSE.md | 8 + .../duniverse/ocaml-afl-persistent/README.md | 17 + .../ocaml-afl-persistent/afl-persistent.opam | 49 + .../afl-persistent.opam.template | 16 + .../aflPersistent.available.ml | 21 + .../ocaml-afl-persistent/aflPersistent.mli | 1 + .../aflPersistent.stub.ml | 1 + .../duniverse/ocaml-afl-persistent/detect.sh | 43 + .../ocaml/duniverse/ocaml-afl-persistent/dune | 20 + .../ocaml-afl-persistent/dune-project | 23 + .../duniverse/ocaml-afl-persistent/test.ml | 3 + .../ocaml-afl-persistent/test/harness.ml | 22 + .../ocaml-afl-persistent/test/test.ml | 73 + .../ocaml-afl-persistent/test/test.sh | 33 + .../ocaml/duniverse/ocplib-endian/.gitignore | 3 + .../ocaml/duniverse/ocplib-endian/.travis.yml | 19 + .../ocaml/duniverse/ocplib-endian/CHANGES.md | 55 + .../ocaml/duniverse/ocplib-endian/COPYING.txt | 521 ++++++ tools/ocaml/duniverse/ocplib-endian/Makefile | 13 + tools/ocaml/duniverse/ocplib-endian/README.md | 16 + .../duniverse/ocplib-endian/dune-project | 2 + .../ocplib-endian/ocplib-endian.opam | 30 + .../ocplib-endian/src/be_ocaml_401.ml | 32 + .../duniverse/ocplib-endian/src/common.ml | 24 + .../ocplib-endian/src/common_401.cppo.ml | 100 + .../ocplib-endian/src/common_float.ml | 5 + tools/ocaml/duniverse/ocplib-endian/src/dune | 75 + .../ocplib-endian/src/endianBigstring.cppo.ml | 112 ++ .../src/endianBigstring.cppo.mli | 128 ++ .../ocplib-endian/src/endianBytes.cppo.ml | 130 ++ .../ocplib-endian/src/endianBytes.cppo.mli | 124 ++ .../ocplib-endian/src/endianString.cppo.ml | 118 ++ .../ocplib-endian/src/endianString.cppo.mli | 121 ++ .../ocplib-endian/src/le_ocaml_401.ml | 32 + .../ocplib-endian/src/ne_ocaml_401.ml | 20 + .../duniverse/ocplib-endian/tests/bench.ml | 436 +++++ .../ocaml/duniverse/ocplib-endian/tests/dune | 35 + .../duniverse/ocplib-endian/tests/test.ml | 39 + .../tests/test_bigstring.cppo.ml | 191 ++ .../ocplib-endian/tests/test_bytes.cppo.ml | 185 ++ .../ocplib-endian/tests/test_string.cppo.ml | 185 ++ tools/ocaml/duniverse/result/CHANGES.md | 15 + tools/ocaml/duniverse/result/LICENSE.md | 24 + tools/ocaml/duniverse/result/Makefile | 17 + tools/ocaml/duniverse/result/README.md | 5 + tools/ocaml/duniverse/result/dune | 12 + tools/ocaml/duniverse/result/dune-project | 3 + .../duniverse/result/result-as-alias-4.08.ml | 2 + .../ocaml/duniverse/result/result-as-alias.ml | 2 + .../duniverse/result/result-as-newtype.ml | 2 + tools/ocaml/duniverse/result/result.opam | 18 + tools/ocaml/duniverse/result/which_result.ml | 14 + tools/ocaml/duniverse/stdlib-shims/CHANGES.md | 5 + tools/ocaml/duniverse/stdlib-shims/LICENSE | 203 +++ tools/ocaml/duniverse/stdlib-shims/README.md | 2 + .../ocaml/duniverse/stdlib-shims/dune-project | 1 + .../duniverse/stdlib-shims/dune-workspace.dev | 14 + tools/ocaml/duniverse/stdlib-shims/src/dune | 97 + .../duniverse/stdlib-shims/stdlib-shims.opam | 24 + tools/ocaml/duniverse/stdlib-shims/test/dune | 3 + .../ocaml/duniverse/stdlib-shims/test/test.ml | 2 + tools/ocaml/xen.opam.locked | 119 ++ 248 files changed, 18334 insertions(+) create mode 100644 tools/ocaml/duniverse/cmdliner/.gitignore create mode 100644 tools/ocaml/duniverse/cmdliner/.ocp-indent create mode 100644 tools/ocaml/duniverse/cmdliner/B0.ml create mode 100644 tools/ocaml/duniverse/cmdliner/CHANGES.md create mode 100644 tools/ocaml/duniverse/cmdliner/LICENSE.md create mode 100644 tools/ocaml/duniverse/cmdliner/Makefile create mode 100644 tools/ocaml/duniverse/cmdliner/README.md create mode 100644 tools/ocaml/duniverse/cmdliner/_tags create mode 100755 tools/ocaml/duniverse/cmdliner/build.ml create mode 100644 tools/ocaml/duniverse/cmdliner/cmdliner.opam create mode 100644 tools/ocaml/duniverse/cmdliner/doc/api.odocl create mode 100644 tools/ocaml/duniverse/cmdliner/dune-project create mode 100644 tools/ocaml/duniverse/cmdliner/pkg/META create mode 100755 tools/ocaml/duniverse/cmdliner/pkg/pkg.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner.mli create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner.mllib create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_arg.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_arg.mli create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_base.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_base.mli create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_cline.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_cline.mli create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_docgen.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_docgen.mli create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_info.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_info.mli create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_manpage.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_manpage.mli create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_msg.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_msg.mli create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_suggest.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_suggest.mli create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_term.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_term.mli create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_trie.ml create mode 100644 tools/ocaml/duniverse/cmdliner/src/cmdliner_trie.mli create mode 100644 tools/ocaml/duniverse/cmdliner/src/dune create mode 100644 tools/ocaml/duniverse/cmdliner/test/chorus.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/cp_ex.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/darcs_ex.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/dune create mode 100644 tools/ocaml/duniverse/cmdliner/test/revolt.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/rm_ex.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/tail_ex.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/test_man.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/test_man_utf8.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/test_opt_req.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/test_pos.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/test_pos_all.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/test_pos_left.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/test_pos_req.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/test_pos_rev.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/test_term_dups.ml create mode 100644 tools/ocaml/duniverse/cmdliner/test/test_with_used_args.ml create mode 100644 tools/ocaml/duniverse/cppo/.gitignore create mode 100644 tools/ocaml/duniverse/cppo/.ocp-indent create mode 100644 tools/ocaml/duniverse/cppo/.travis.yml create mode 100644 tools/ocaml/duniverse/cppo/CODEOWNERS create mode 100644 tools/ocaml/duniverse/cppo/Changes create mode 100644 tools/ocaml/duniverse/cppo/INSTALL.md create mode 100644 tools/ocaml/duniverse/cppo/LICENSE.md create mode 100644 tools/ocaml/duniverse/cppo/Makefile create mode 100644 tools/ocaml/duniverse/cppo/README.md create mode 100644 tools/ocaml/duniverse/cppo/VERSION create mode 100644 tools/ocaml/duniverse/cppo/appveyor.yml create mode 100644 tools/ocaml/duniverse/cppo/cppo.opam create mode 100644 tools/ocaml/duniverse/cppo/cppo_ocamlbuild.opam create mode 100644 tools/ocaml/duniverse/cppo/dune-project create mode 100644 tools/ocaml/duniverse/cppo/examples/Makefile create mode 100644 tools/ocaml/duniverse/cppo/examples/debug.ml create mode 100644 tools/ocaml/duniverse/cppo/examples/dune create mode 100644 tools/ocaml/duniverse/cppo/examples/french.ml create mode 100644 tools/ocaml/duniverse/cppo/examples/lexer.mll create mode 100644 tools/ocaml/duniverse/cppo/ocamlbuild_plugin/_tags create mode 100644 tools/ocaml/duniverse/cppo/ocamlbuild_plugin/dune create mode 100644 tools/ocaml/duniverse/cppo/ocamlbuild_plugin/ocamlbuild_cppo.ml create mode 100644 tools/ocaml/duniverse/cppo/ocamlbuild_plugin/ocamlbuild_cppo.mli create mode 100644 tools/ocaml/duniverse/cppo/src/compat.ml create mode 100644 tools/ocaml/duniverse/cppo/src/cppo_command.ml create mode 100644 tools/ocaml/duniverse/cppo/src/cppo_command.mli create mode 100644 tools/ocaml/duniverse/cppo/src/cppo_eval.ml create mode 100644 tools/ocaml/duniverse/cppo/src/cppo_eval.mli create mode 100644 tools/ocaml/duniverse/cppo/src/cppo_lexer.mll create mode 100644 tools/ocaml/duniverse/cppo/src/cppo_main.ml create mode 100644 tools/ocaml/duniverse/cppo/src/cppo_parser.mly create mode 100644 tools/ocaml/duniverse/cppo/src/cppo_types.ml create mode 100644 tools/ocaml/duniverse/cppo/src/cppo_types.mli create mode 100644 tools/ocaml/duniverse/cppo/src/cppo_version.mli create mode 100644 tools/ocaml/duniverse/cppo/src/dune create mode 100644 tools/ocaml/duniverse/cppo/test/capital.cppo create mode 100644 tools/ocaml/duniverse/cppo/test/capital.ref create mode 100644 tools/ocaml/duniverse/cppo/test/comments.cppo create mode 100644 tools/ocaml/duniverse/cppo/test/comments.ref create mode 100644 tools/ocaml/duniverse/cppo/test/cond.cppo create mode 100644 tools/ocaml/duniverse/cppo/test/cond.ref create mode 100644 tools/ocaml/duniverse/cppo/test/dune create mode 100644 tools/ocaml/duniverse/cppo/test/ext.cppo create mode 100644 tools/ocaml/duniverse/cppo/test/ext.ref create mode 100644 tools/ocaml/duniverse/cppo/test/incl.cppo create mode 100644 tools/ocaml/duniverse/cppo/test/incl2.cppo create mode 100644 tools/ocaml/duniverse/cppo/test/loc.cppo create mode 100644 tools/ocaml/duniverse/cppo/test/loc.ref create mode 100644 tools/ocaml/duniverse/cppo/test/paren_arg.cppo create mode 100644 tools/ocaml/duniverse/cppo/test/paren_arg.ref create mode 100755 tools/ocaml/duniverse/cppo/test/source.sh create mode 100644 tools/ocaml/duniverse/cppo/test/test.cppo create mode 100644 tools/ocaml/duniverse/cppo/test/tuple.cppo create mode 100644 tools/ocaml/duniverse/cppo/test/tuple.ref create mode 100644 tools/ocaml/duniverse/cppo/test/unmatched.cppo create mode 100644 tools/ocaml/duniverse/cppo/test/unmatched.ref create mode 100644 tools/ocaml/duniverse/cppo/test/version.cppo create mode 100644 tools/ocaml/duniverse/crowbar/.gitignore create mode 100644 tools/ocaml/duniverse/crowbar/CHANGES.md create mode 100644 tools/ocaml/duniverse/crowbar/LICENSE.md create mode 100644 tools/ocaml/duniverse/crowbar/README.md create mode 100644 tools/ocaml/duniverse/crowbar/crowbar.opam create mode 100644 tools/ocaml/duniverse/crowbar/dune create mode 100644 tools/ocaml/duniverse/crowbar/dune-project create mode 100644 tools/ocaml/duniverse/crowbar/examples/.gitignore create mode 100644 tools/ocaml/duniverse/crowbar/examples/calendar/dune create mode 100644 tools/ocaml/duniverse/crowbar/examples/calendar/test_calendar.ml create mode 100644 tools/ocaml/duniverse/crowbar/examples/fpath/dune create mode 100644 tools/ocaml/duniverse/crowbar/examples/fpath/test_fpath.ml create mode 100644 tools/ocaml/duniverse/crowbar/examples/input/testcase create mode 100644 tools/ocaml/duniverse/crowbar/examples/map/dune create mode 100644 tools/ocaml/duniverse/crowbar/examples/map/test_map.ml create mode 100644 tools/ocaml/duniverse/crowbar/examples/pprint/dune create mode 100644 tools/ocaml/duniverse/crowbar/examples/pprint/test_pprint.ml create mode 100644 tools/ocaml/duniverse/crowbar/examples/serializer/dune create mode 100644 tools/ocaml/duniverse/crowbar/examples/serializer/serializer.ml create mode 100644 tools/ocaml/duniverse/crowbar/examples/serializer/test_serializer.ml create mode 100644 tools/ocaml/duniverse/crowbar/examples/uunf/dune create mode 100644 tools/ocaml/duniverse/crowbar/examples/uunf/test_uunf.ml create mode 100644 tools/ocaml/duniverse/crowbar/examples/xmldiff/dune create mode 100644 tools/ocaml/duniverse/crowbar/examples/xmldiff/test_xmldiff.ml create mode 100644 tools/ocaml/duniverse/crowbar/src/crowbar.ml create mode 100644 tools/ocaml/duniverse/crowbar/src/crowbar.mli create mode 100644 tools/ocaml/duniverse/crowbar/src/dune create mode 100644 tools/ocaml/duniverse/crowbar/src/todo create mode 100644 tools/ocaml/duniverse/csexp/CHANGES.md create mode 100644 tools/ocaml/duniverse/csexp/LICENSE.md create mode 100644 tools/ocaml/duniverse/csexp/Makefile create mode 100644 tools/ocaml/duniverse/csexp/README.md create mode 100644 tools/ocaml/duniverse/csexp/bench/csexp_bench.ml create mode 100644 tools/ocaml/duniverse/csexp/bench/dune create mode 100644 tools/ocaml/duniverse/csexp/bench/main.ml create mode 100755 tools/ocaml/duniverse/csexp/bench/runner.sh create mode 100644 tools/ocaml/duniverse/csexp/csexp.opam create mode 100644 tools/ocaml/duniverse/csexp/csexp.opam.template create mode 100644 tools/ocaml/duniverse/csexp/dune-project create mode 100644 tools/ocaml/duniverse/csexp/dune-workspace.dev create mode 100644 tools/ocaml/duniverse/csexp/src/csexp.ml create mode 100644 tools/ocaml/duniverse/csexp/src/csexp.mli create mode 100644 tools/ocaml/duniverse/csexp/src/dune create mode 100644 tools/ocaml/duniverse/csexp/test/dune create mode 100644 tools/ocaml/duniverse/csexp/test/test.ml create mode 100644 tools/ocaml/duniverse/dune create mode 100644 tools/ocaml/duniverse/fmt/.gitignore create mode 100644 tools/ocaml/duniverse/fmt/.ocp-indent create mode 100644 tools/ocaml/duniverse/fmt/CHANGES.md create mode 100644 tools/ocaml/duniverse/fmt/LICENSE.md create mode 100644 tools/ocaml/duniverse/fmt/README.md create mode 100644 tools/ocaml/duniverse/fmt/_tags create mode 100644 tools/ocaml/duniverse/fmt/doc/api.odocl create mode 100644 tools/ocaml/duniverse/fmt/doc/index.mld create mode 100644 tools/ocaml/duniverse/fmt/dune-project create mode 100644 tools/ocaml/duniverse/fmt/fmt.opam create mode 100644 tools/ocaml/duniverse/fmt/pkg/META create mode 100755 tools/ocaml/duniverse/fmt/pkg/pkg.ml create mode 100644 tools/ocaml/duniverse/fmt/src/dune create mode 100644 tools/ocaml/duniverse/fmt/src/fmt.ml create mode 100644 tools/ocaml/duniverse/fmt/src/fmt.mli create mode 100644 tools/ocaml/duniverse/fmt/src/fmt.mllib create mode 100644 tools/ocaml/duniverse/fmt/src/fmt_cli.ml create mode 100644 tools/ocaml/duniverse/fmt/src/fmt_cli.mli create mode 100644 tools/ocaml/duniverse/fmt/src/fmt_cli.mllib create mode 100644 tools/ocaml/duniverse/fmt/src/fmt_top.ml create mode 100644 tools/ocaml/duniverse/fmt/src/fmt_top.mllib create mode 100644 tools/ocaml/duniverse/fmt/src/fmt_tty.ml create mode 100644 tools/ocaml/duniverse/fmt/src/fmt_tty.mli create mode 100644 tools/ocaml/duniverse/fmt/src/fmt_tty.mllib create mode 100644 tools/ocaml/duniverse/fmt/src/fmt_tty_top_init.ml create mode 100644 tools/ocaml/duniverse/fmt/test/test.ml create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/.gitignore create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/CHANGES.md create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/LICENSE.md create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/README.md create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/afl-persistent.opam create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/afl-persistent.opam.template create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/aflPersistent.available.ml create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/aflPersistent.mli create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/aflPersistent.stub.ml create mode 100755 tools/ocaml/duniverse/ocaml-afl-persistent/detect.sh create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/dune create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/dune-project create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/test.ml create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/test/harness.ml create mode 100644 tools/ocaml/duniverse/ocaml-afl-persistent/test/test.ml create mode 100755 tools/ocaml/duniverse/ocaml-afl-persistent/test/test.sh create mode 100644 tools/ocaml/duniverse/ocplib-endian/.gitignore create mode 100644 tools/ocaml/duniverse/ocplib-endian/.travis.yml create mode 100644 tools/ocaml/duniverse/ocplib-endian/CHANGES.md create mode 100644 tools/ocaml/duniverse/ocplib-endian/COPYING.txt create mode 100644 tools/ocaml/duniverse/ocplib-endian/Makefile create mode 100644 tools/ocaml/duniverse/ocplib-endian/README.md create mode 100644 tools/ocaml/duniverse/ocplib-endian/dune-project create mode 100644 tools/ocaml/duniverse/ocplib-endian/ocplib-endian.opam create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/be_ocaml_401.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/common.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/common_401.cppo.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/common_float.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/dune create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/endianBigstring.cppo.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/endianBigstring.cppo.mli create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/endianBytes.cppo.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/endianBytes.cppo.mli create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/endianString.cppo.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/endianString.cppo.mli create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/le_ocaml_401.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/src/ne_ocaml_401.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/tests/bench.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/tests/dune create mode 100644 tools/ocaml/duniverse/ocplib-endian/tests/test.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/tests/test_bigstring.cppo.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/tests/test_bytes.cppo.ml create mode 100644 tools/ocaml/duniverse/ocplib-endian/tests/test_string.cppo.ml create mode 100755 tools/ocaml/duniverse/result/CHANGES.md create mode 100755 tools/ocaml/duniverse/result/LICENSE.md create mode 100755 tools/ocaml/duniverse/result/Makefile create mode 100755 tools/ocaml/duniverse/result/README.md create mode 100755 tools/ocaml/duniverse/result/dune create mode 100755 tools/ocaml/duniverse/result/dune-project create mode 100755 tools/ocaml/duniverse/result/result-as-alias-4.08.ml create mode 100755 tools/ocaml/duniverse/result/result-as-alias.ml create mode 100755 tools/ocaml/duniverse/result/result-as-newtype.ml create mode 100755 tools/ocaml/duniverse/result/result.opam create mode 100755 tools/ocaml/duniverse/result/which_result.ml create mode 100644 tools/ocaml/duniverse/stdlib-shims/CHANGES.md create mode 100644 tools/ocaml/duniverse/stdlib-shims/LICENSE create mode 100644 tools/ocaml/duniverse/stdlib-shims/README.md create mode 100644 tools/ocaml/duniverse/stdlib-shims/dune-project create mode 100644 tools/ocaml/duniverse/stdlib-shims/dune-workspace.dev create mode 100644 tools/ocaml/duniverse/stdlib-shims/src/dune create mode 100644 tools/ocaml/duniverse/stdlib-shims/stdlib-shims.opam create mode 100644 tools/ocaml/duniverse/stdlib-shims/test/dune create mode 100644 tools/ocaml/duniverse/stdlib-shims/test/test.ml create mode 100644 tools/ocaml/xen.opam.locked