pax_global_header00006660000000000000000000000064127543130300014510gustar00rootroot0000000000000052 comment=ee81ce49bab31757837bed35a182d29cbd54dfcb utop-1.19.3/000077500000000000000000000000001275431303000125725ustar00rootroot00000000000000utop-1.19.3/.gitignore000066400000000000000000000001531275431303000145610ustar00rootroot00000000000000_build/ /utop-*.tar.gz /setup.data /setup.log /setup.exe /setup-dev.exe /man/*.gz /src/lib/uTop_version.ml utop-1.19.3/.travis.yml000066400000000000000000000003721275431303000147050ustar00rootroot00000000000000language: c sudo: required install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh script: bash -ex .travis-opam.sh env: - OCAML_VERSION=4.01 - OCAML_VERSION=4.02 - OCAML_VERSION=4.03 os: - linux - osx utop-1.19.3/CHANGES.md000066400000000000000000000145041275431303000141700ustar00rootroot000000000000001.19.3 (2016-08-15) ------------------- * fix compatibility with 4.04.0+beta1 1.19.2 (2016-04-25) ------------------- * Make ppx\_tools dependency optional 1.19.1 (2016-04-18) ------------------- * fix compatibility with 4.03.0+beta2 1.19 (2016-04-07) ----------------- * allow to configure the external editor with `UTop.set_external_editor` * add `UTop.set_margin_function` to allow users to set the margin for the toplevel outcome. It is 80 by default * better for quoted strings (`{|...|}`) * add a `#pwd` directive * experimental support for running utop in the middle of a program with `UTop_main.interact` * fix Async integration (automatic waiting of `_ Deferred.t` value). The new version is more robust against future change in Async * fix use of the non-existing `replace-in-string` function in the emacs mode (Syohei Yoshida) * fallback to Latin-1 for invalid UTF-8 sequences in the compiler output 1.18.2 (2016-03-02) ------------------- * fix compatibility with OCaml 4.03 1.18.1 (2015-11-03) ------------------- * fix compatibility with findlib 1.5.6 1.18 (2015-06-23) ----------------- * emace mode improvements (Mads Hartmann Jensen) - add `utop-minor-mode` to make integration with major modes cleaner - clean-up of the elisp code * add `UTop.end_and_accept_current_phrase` to avoid typing `;;` at the end of every phrases * fix compatibility with OCaml trunk 1.17 (2014-12-12) ----------------- * re-export `Config.load_path` as `UTop.load_path` (Peter Zotov) * enable utop-command to be buffer-local (Mads Hartmann Jensen) * fix 4.01 compatibility (Peter Zotov) 1.16 (2014-10-20) ----------------- * make camlp4 support optional * require OCaml 4.01.0 or newer * implement wrapper for -safe-string 1.15 (2014-08-30) ----------------- * fix compatibility with OCaml 4.02.0 1.14 (2014-07-05) ----------------- * fix compatibility with OCaml 4.00.1 and earlier 1.13 (2014-07-04) ----------------- * don't try to colorize the output when there is too much * add auto-completion for the `#ppx` directive * add support for -ppx, -dparsetree and -dsource * fix compatiblity with OCaml 4.02 * update pa_optcomp * do not display the camlp4 welcome message 1.12 (2014-04-21) ----------------- * supports -require for scripts * support for React 1.0.0 * make utop.el compatible with melpa: http://melpa.milkbox.net 1.11 (2014-02-11) ----------------- * update the async hook following the renaming of `Async_core` to `Async_kernel` * fix tab completion not working on some emacs * complete `#load_rec` the same way as `#load` 1.10 (2013-12-10) ----------------- * add the `-require` command line argument to specify packages on the command line 1.9 (2013-11-26) ---------------- * automatically load all files in `$OCAML_TOPLEVEL_PATH/autoload` at startup. Can be disabled with `autoload: false` in `~/.utoprc` or `-no-autoload`. * fix #38: handle errors from custom camlp4 ast filters * fix #7: avoid a stack overflow in UTop_lexer 1.8 (2013-10-25) ---------------- * handle new syntax errors * extend `#typeof` to values and modules. Thanks to Thomas Refis for this feature 1.7 (2013-08-08) ---------------- * fix compilation with ocaml < 4.01 1.6 (2013-08-07) ---------------- * hide topfind messages by default * more predefined prompts available via `#utop_prompt_XXX` * fix a bug in `#require` when passing multiple packages * display errors in ~/.lambda-term-inputrc nicely * doc update * fix an issue when using first-class modules 1.5 (2013-04-28) ---------------- * when evaluating a region/buffer in emacs, evaluate all phrases instead of just the first one. Thanks to Matthias Andreas Benkard for this feature * change the default prompt from `#` to `$` to match the standard toplevel * add the option `UTop.show_box` to allow one to hide the completion bar * enhance the lwt/async hooks for automatically waiting on a thread/deferred. Hooks were not triggered when the type of the expression was a type alias 1.4 (2013-03-09) ---------------- * hide identifiers starting with `_`. This can be disabled with `UTop.set_hide_reserved false`. * automatically load camlp4 parsing (with original syntax) when trying to load a syntax extension * fix a small bug when using camlp4, causing an exception to be raised when pressing `Enter` in the middle of a comment 1.3 (2013-01-29) ---------------- * allow to automatically wait for ascync deferred values * added the `-short-paths` options for OCaml >= 4.01.0 (and make it the default) 1.2.1 (2012-07-31) ------------------ * fix: do not expunge `Toploop` * install a non-expunged version of utop: `utop-full` 1.2 (2012-07-30) ---------------- * ocaml 4.00 compatibility * prevent findlib from being initialized twice * better highlighting of errors * automatically insert `Lwt_main.run` for toplevel expressions of type `'a Lwt.t` * better camlp4 support * parse quotations and antiquotations to handle completion inside them * better support revised syntax * emacs mode improvements * various fixes * highlight errors * add a menu * add interactive list of findlib packages * packages can be pre-loaded via the file variable `utop-package-list` * better tuareg integration * typerex integration * allow to complete using the toplevel environment in a tuareg buffer * allow to change the utop command * use the same history as the terminal mode * follow output of ocaml 1.1 (2010-08-06) ---------------- * add completion on labels * add completion on methods * smarter completion on record fields * fix a bug in the lexer * improvement for the emacs mode: * now pressing Tab really complete input * when sending input from a tuareg buffer, the cursor follow the end of buffer in all utop windows * fix usage of threads * add help * add manual pages * show more information in the prompt: * show the current value of the macro counter * show the nnumber of key pressed since the beginning of a macro when recording a macro * show intermediate key sequence * better support for light colors terminals * add colors for module name and directives * add `UTop.smart_accept` to send only lines terminating with a `;;` token * search for compiler libraries at configure time * add a script to install compiler libraries * fix compatibility with ocaml 3.13 utop-1.19.3/LICENSE000066400000000000000000000027561275431303000136110ustar00rootroot00000000000000Copyright (c) 2011, Jeremie Dimino 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 Jeremie Dimino 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. utop-1.19.3/Makefile000066400000000000000000000036541275431303000142420ustar00rootroot00000000000000# Makefile # -------- # Copyright : (c) 2012, Jeremie Dimino # Licence : BSD3 # # Generic Makefile for oasis project # Set to setup.exe for the release SETUP := setup.exe # Default rule default: build # Setup for the development version setup-dev.exe: _oasis setup.ml sed '/^#/D' setup.ml > setup_dev.ml ocamlfind ocamlopt -o $@ -linkpkg -package ocamlbuild,oasis.dynrun setup_dev.ml || \ ocamlfind ocamlc -o $@ -linkpkg -package ocamlbuild,oasis.dynrun setup_dev.ml || true rm -f setup_dev.* # Setup for the release setup.exe: setup.ml ocamlopt.opt -w -3 -o $@ $< || ocamlopt -w -3 -o $@ $< || ocamlc -w -3 -o $@ $< rm -f setup.cmx setup.cmi setup.o setup.obj setup.cmo build: $(SETUP) setup.data ./$(SETUP) -build $(BUILDFLAGS) doc: $(SETUP) setup.data build ./$(SETUP) -doc $(DOCFLAGS) cp style.css _build/utop-api.docdir/ test: $(SETUP) setup.data build ./$(SETUP) -test $(TESTFLAGS) all: $(SETUP) ./$(SETUP) -all $(ALLFLAGS) install: $(SETUP) setup.data ocamlfind remove utop 2>/dev/null || true ./$(SETUP) -install $(INSTALLFLAGS) uninstall: $(SETUP) setup.data ./$(SETUP) -uninstall $(UNINSTALLFLAGS) reinstall: $(SETUP) setup.data ocamlfind remove utop 2>/dev/null || true ./$(SETUP) -reinstall $(REINSTALLFLAGS) clean: $(SETUP) ./$(SETUP) -clean $(CLEANFLAGS) distclean: $(SETUP) ./$(SETUP) -distclean $(DISTCLEANFLAGS) configure: $(SETUP) ./$(SETUP) -configure $(CONFIGUREFLAGS) setup.data: $(SETUP) ./$(SETUP) -configure $(CONFIGUREFLAGS) gh-pages: doc git clone `git config --get remote.origin.url` .gh-pages --reference . git -C .gh-pages checkout --orphan gh-pages git -C .gh-pages reset git -C .gh-pages clean -dxf cp -t .gh-pages/ _build/utop-api.docdir/* git -C .gh-pages add . git -C .gh-pages commit -m "Update Pages" git -C .gh-pages push origin gh-pages -f rm -rf .gh-pages .PHONY: default build doc test all install uninstall reinstall clean distclean configure gh-pages utop-1.19.3/README.md000066400000000000000000000171251275431303000140570ustar00rootroot00000000000000utop - a universal toplevel for OCaml ===================================== utop is an improved toplevel for OCaml. It can run in a terminal or in Emacs. It supports line edition, history, real-time and context sensitive completion, colors, and more. It integrates with the tuareg and typerex modes in Emacs. [![Travis build Status](https://travis-ci.org/diml/utop.svg?branch=master)](https://travis-ci.org/diml/utop) Installation via opam --------------------- The easiest and recommended way of installing utop is via [opam](https://opam.ocaml.org/): $ opam install utop If you want to build it manually, you should install all the dependencies listed in the next section. Dependencies ------------ * [OCaml](http://caml.inria.fr/ocaml/) (>= 4.01.0) * [findlib](http://projects.camlcity.org/projects/findlib.html) (>= 1.4.0) * [cppo](http://mjambon.com/cppo.html) (>= 1.0.1) * [react](http://erratique.ch/software/react) * [lwt](http://ocsigen.org/lwt/) (>= 2.4.0) built with react support * [Camomile](http://github.com/yoriyuki/Camomile) (>= 0.8) * [zed](http://github.com/diml/zed) (>= 1.2) * [lambda-term](http://github.com/diml/lambda-term) (>= 1.2) * [camlp4](http://github.com/ocaml/camlp4) (optional) For building the development version, you also need to install [oasis](http://oasis.forge.ocamlcore.org/) (>= 0.4.0). Installation from sources ------------------------- To build and install utop: $ ./configure $ make $ make install If you want to be able to use camlp4, rather use: $ ./configure --enable-camlp4 ### Documentation and manual pages _(optional)_ To build the documentation: $ make doc It will then be installed by `make install`. ### Tests _(optional)_ To build and execute tests: $ ./configure --enable-tests $ make test Usage ----- To use utop, simply run: $ utop utop display a bar after the prompt which is used to show possible completions in real-time. You can navigate in it using `M-left` and `M-right`, and select one completion using `M-tab`. The `M` denotes the meta key, which is `Alt` most of the time. Customization ------------- ### Colors To add colors to utop, copy one of the files `utoprc-dark` or `utoprc-light` to `~/.utoprc`. `utoprc-dark` is for terminals with dark colors (such as white on black) and `utoprc-light` is for terminals with light colors (such as black on white). ### Prompt You can customize the prompt of utop by setting the reference `UTop.prompt`. ### Key bindings Key bindings in the terminal can be changed by writing a `~/.lambda-term-inputrc` file. For example: [read-line] C-left: complete-bar-prev C-right: complete-bar-next C-down: complete-bar If manual pages are correctly installed you can see a description of this file by executing: $ man 5 lambda-term-inputrc ### UTop API UTop exposes several more settings through its API; see [documentation](http://diml.github.io/utop). Integration with emacs ---------------------- ### Main setup To use utop in emacs, first you need to make sure emacs can find the command `utop` and the file `utop.el`. `utop.el` is available through [melpa](https://melpa.org/), so `M-x package-install RET utop RET` should do. If this doesn't work and you installed utop via opam, you can add this to your `~/.emacs`: ```scheme ;; Add the opam lisp dir to the emacs load path (add-to-list 'load-path (replace-regexp-in-string "\n" "/share/emacs/site-lisp" (shell-command-to-string "opam config var prefix"))) ;; Automatically load utop.el (autoload 'utop "utop" "Toplevel for OCaml" t) ``` In any case, if you installed utop via opam you should add this to your `~/.emacs`: ```scheme ;; Use the opam installed utop (setq utop-command "opam config exec -- utop -emacs") ``` This was tested with opam 1.2. For older versions of opam, you can copy&paste this to your `~/.emacs`: ```scheme ;; Setup environment variables using opam (dolist (var (car (read-from-string (shell-command-to-string "opam config env --sexp")))) (setenv (car var) (cadr var))) ;; Update the emacs path (setq exec-path (append (parse-colon-path (getenv "PATH")) (list exec-directory))) ;; Update the emacs load path (add-to-list 'load-path (expand-file-name "../../share/emacs/site-lisp" (getenv "OCAML_TOPLEVEL_PATH"))) ;; Automatically load utop.el (autoload 'utop "utop" "Toplevel for OCaml" t) ``` ### Usage Then you can execute utop inside emacs with: `M-x utop`. utop also ships with a minor mode that has the following key-bindings | key-binding | function | Description | |-------------|-------------------|------------------------------| | C-c C-s | utop | Start a utop buffer | | C-x C-e | utop-eval-phrase | Evaluate the current phrase | | C-x C-r | utop-eval-region | Evaluate the selected region | | C-c C-b | utop-eval-buffer | Evaluate the current buffer | | C-c C-k | utop-kill | Kill a running utop process | You can enable the minor mode using `M-x utop-minor-mode`, or you can have it enabled by default with the following configuration: ```scheme (autoload 'utop-minor-mode "utop" "Minor mode for utop" t) (add-hook 'tuareg-mode-hook 'utop-minor-mode) ``` If you plan to use utop with another major-mode than tuareg, replace `tuareg-mode-hook` by the appropriate hook. The utop minor mode will work out of the box with these modes: `tuareg-mode`, `caml-mode` and `typerex-mode`. For other modes you will need to set the following three variables: - `utop-skip-blank-and-comments` - `utop-skip-to-end-of-phrase` - `utop-discover-phrase` You can also complete text in a buffer using the environment of the toplevel. For that bind the function `utop-edit-complete` to the key you want. Common error ------------ If you get this error when running utop in a terminal or in emacs this means that the environment variable `CAML_LD_LIBRARY_PATH` is not set correctly: Fatal error: cannot load shared library dlllwt-unix_stubs Reason: dlopen(dlllwt-unix_stubs.so, 138): image not found It shall point to the directory `stublibs` inside your ocaml installation. Creating a custom utop-enabled toplevel --------------------------------------- If you want to create a custom toplevel with utop instead of the classic one you need to link it with utop and its dependencies and call `UTop_main.main` in the last linked unit. You also need to pass the `-thread` switch when linking the toplevel. The easiest way to do that is by using ocamlfind: $ ocamlfind ocamlmktop -o myutop -thread -linkpkg -package utop myutop_main.cmo Where `myutop_main.ml` contains: ```ocaml let () = UTop_main.main () ``` You can also use the `ocamlc` sub-command instead of `ocamlmktop`, in this case you need to pass these thee extra arguments: * `-linkall` to be sure all units are linked into the produced toplevel * `-package compiler-libs.toplevel` * `-predicates create_toploop` With the last option ocamlfind will generate a small ocaml unit, linked just before `myutop_main.cmo`, which will register at startup packages already linked in the toplevel so they are not loaded again by the `#require` directive. It does the same with the `ocamlmktop` sub-command. For example: $ ocamlfind ocamlc -o myutop -thread -linkpkg -linkall -predicates create_toploop \ -package compiler-libs.toplevel,utop myutop.cmo Note that if you are not using ocamlfind, you will need to do that yourself. You have to call `Topfind.don't_load` with the list of all packages linked with the toplevel. A full example using ocamlbuild is provided in the [examples/custom-utop](examples/custom-utop) directory. utop-1.19.3/_oasis000066400000000000000000000106701275431303000137760ustar00rootroot00000000000000# +-------------------------------------------------------------------+ # | Package parameters | # +-------------------------------------------------------------------+ OASISFormat: 0.4 OCamlVersion: >= 4.01 Name: utop Version: 1.19.3 LicenseFile: LICENSE License: BSD-3-clause Authors: Jeremie Dimino Maintainers: Jeremie Dimino Homepage: https://github.com/diml/utop BuildTools: ocamlbuild Plugins: DevFiles (0.3), META (0.3) XDevFilesEnableMakefile: false FilesAB: src/lib/uTop_version.ml.ab AlphaFeatures: ocamlbuild_more_args XOCamlbuildPluginTags: package(cppo_ocamlbuild) Synopsis: Universal toplevel for OCaml Description: utop is an improved toplevel for OCaml. It can run in a terminal or in Emacs. It supports line edition, history, real-time and context sensitive completion, colors, and more. . It integrates with the tuareg mode in Emacs. # +-------------------------------------------------------------------+ # | The toplevel | # +-------------------------------------------------------------------+ Flag camlp4 Description: camlp4 support Default: false Flag interact Description: enable UTop_main.interact (requires ppx_tools) Default: false Library utop Path: src/lib Modules: UTop, UTop_main InternalModules: UTop_private, UTop_version, UTop_lexer, UTop_token, UTop_complete, UTop_styles, UTop_cmt_lifter BuildDepends: threads, findlib, lambda-term (>= 1.2) XMETADescription: utop configuration XMETARequires: findlib, lambda-term Library "utop-camlp4" Build$: flag(camlp4) Install$: flag(camlp4) FindlibName: camlp4 FindlibParent: utop Path: src/camlp4 Modules: UTop_camlp4 BuildDepends: utop, camlp4 XMETAType: syntax XMETADescription: Camlp4 integration Executable utop Install: true Path: src/top CompiledObject: byte MainIs: uTop_top.ml BuildDepends: threads, findlib, lambda-term, utop DataFiles: utop.el ($datadir/emacs/site-lisp) Executable "utop-full" Install: true Path: src/top CompiledObject: byte MainIs: uTop_top_full.ml BuildDepends: threads, findlib, lambda-term, utop DataFiles: utop.el ($datadir/emacs/site-lisp) # +-------------------------------------------------------------------+ # | Doc | # +-------------------------------------------------------------------+ Document "utop-api" Title: API reference for utop Type: ocamlbuild (0.3) Install: true InstallDir: $htmldir/api DataFiles: style.css BuildTools: ocamldoc XOCamlbuildPath: ./ XOCamlbuildLibraries: utop XOCamlbuildExtraArgs: "-docflag -t -docflag 'API reference for utop' -docflags '-colorize-code -short-functors -charset utf-8 -css-style style.css'" # +-------------------------------------------------------------------+ # | Manual pages | # +-------------------------------------------------------------------+ Document "utop-man" Type: custom (0.3) Title: Man page for utop Install: true BuildTools: gzip XCustom: $gzip -c man/utop.1 > man/utop.1.gz XCustomClean: $rm man/utop.1.gz DataFiles: man/utop.1.gz InstallDir: $mandir/man1 Document "utop-full-man" Type: custom (0.3) Title: Man page for utop Install: true BuildTools: gzip XCustom: $gzip -c man/utop-full.1 > man/utop-full.1.gz XCustomClean: $rm man/utop-full.1.gz DataFiles: man/utop-full.1.gz InstallDir: $mandir/man1 Document "utoprc-man" Type: custom (0.3) Title: Man page for utoprc Install: true BuildTools: gzip XCustom: $gzip -c man/utoprc.5 > man/utoprc.5.gz XCustomClean: $rm man/utoprc.5.gz DataFiles: man/utoprc.5.gz InstallDir: $mandir/man5 # +-------------------------------------------------------------------+ # | Configuration examples | # +-------------------------------------------------------------------+ Document "utoprcs" Type: custom (0.3) Title: utoprc examples XCustom: true Install: true DataFiles: utoprc-dark, utoprc-light # +-------------------------------------------------------------------+ # | Misc | # +-------------------------------------------------------------------+ SourceRepository head Type: git Location: https://github.com/diml/utop.git Browser: https://github.com/diml/utop utop-1.19.3/_tags000066400000000000000000000031201275431303000136060ustar00rootroot00000000000000# -*- conf -*- : cppo_V_OCAML, cppo_interact, package(compiler-libs) : use_camlp5 <**/*.ml>: warn(-3-40@8) # OASIS_START # DO NOT EDIT (digest: 0e8c977c59cd4b29b0e0ba0f7c9f1d20) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process true: annot, bin_annot <**/.svn>: -traverse <**/.svn>: not_hygienic ".bzr": -traverse ".bzr": not_hygienic ".hg": -traverse ".hg": not_hygienic ".git": -traverse ".git": not_hygienic "_darcs": -traverse "_darcs": not_hygienic # Library utop "src/lib/utop.cmxs": use_utop : package(findlib) : package(lambda-term) : package(threads) # Library utop-camlp4 "src/camlp4/utop-camlp4.cmxs": use_utop-camlp4 : package(camlp4) : package(findlib) : package(lambda-term) : package(threads) : use_utop # Executable utop "src/top/uTop_top.byte": package(findlib) "src/top/uTop_top.byte": package(lambda-term) "src/top/uTop_top.byte": package(threads) "src/top/uTop_top.byte": use_utop # Executable utop-full "src/top/uTop_top_full.byte": package(findlib) "src/top/uTop_top_full.byte": package(lambda-term) "src/top/uTop_top_full.byte": package(threads) "src/top/uTop_top_full.byte": use_utop : package(findlib) : package(lambda-term) : package(threads) : use_utop # OASIS_STOP utop-1.19.3/configure000077500000000000000000000005531275431303000145040ustar00rootroot00000000000000#!/bin/sh # OASIS_START # DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) set -e FST=true for i in "$@"; do if $FST; then set -- FST=false fi case $i in --*=*) ARG=${i%%=*} VAL=${i##*=} set -- "$@" "$ARG" "$VAL" ;; *) set -- "$@" "$i" ;; esac done ocaml setup.ml -configure "$@" # OASIS_STOP utop-1.19.3/examples/000077500000000000000000000000001275431303000144105ustar00rootroot00000000000000utop-1.19.3/examples/custom-utop/000077500000000000000000000000001275431303000167075ustar00rootroot00000000000000utop-1.19.3/examples/custom-utop/Makefile000066400000000000000000000002111275431303000203410ustar00rootroot00000000000000OC := ocamlbuild -classic-display -no-links -use-ocamlfind build: $(OC) -tag thread -pkg threads,utop myutop.top clean: $(OC) -clean utop-1.19.3/examples/custom-utop/myutop.mltop000066400000000000000000000000141275431303000213140ustar00rootroot00000000000000Myutop_main utop-1.19.3/examples/custom-utop/myutop_main.ml000066400000000000000000000001001275431303000215710ustar00rootroot00000000000000 (* Start utop. It never returns. *) let () = UTop_main.main () utop-1.19.3/examples/interact/000077500000000000000000000000001275431303000162215ustar00rootroot00000000000000utop-1.19.3/examples/interact/Makefile000066400000000000000000000002331275431303000176570ustar00rootroot00000000000000OC := ocamlbuild -classic-display -no-links -use-ocamlfind build: $(OC) -pkg threads,compiler-libs.toplevel,utop test_program.byte clean: $(OC) -clean utop-1.19.3/examples/interact/_tags000066400000000000000000000001071275431303000172370ustar00rootroot00000000000000true: thread, linkall, predicate(create_toploop), warn(-40), bin_annot utop-1.19.3/examples/interact/test_program.ml000066400000000000000000000004001275431303000212530ustar00rootroot00000000000000type t = A of int | B of string let some_value = [A 42; B "Hello, world"] let () = print_endline "Starting utop now!"; UTop_main.interact ~search_path:["_build"] ~unit:__MODULE__ ~loc:__POS__ ~values:[V ("some_value", some_value)] ;; utop-1.19.3/examples/interact/test_program.mli000066400000000000000000000000141275431303000214250ustar00rootroot00000000000000(* empty *) utop-1.19.3/man/000077500000000000000000000000001275431303000133455ustar00rootroot00000000000000utop-1.19.3/man/utop-full.1000066400000000000000000000011211275431303000153510ustar00rootroot00000000000000\" utop.1 \" ------ \" Copyright : (c) 2011, Jeremie Dimino \" Licence : BSD3 \" \" This file is a part of utop. .TH UTOP-FULL 1 "August 2011" .SH NAME utop-full \- Universal toplevel for OCaml .SH SYNOPSIS .B utop [ .I options ] [ .I object-files ] [ .I script-file ] .SH DESCRIPTION .B utop-full is the same as .B utop (1) except that compiler libraries are available. .SH OPTIONS Same as .BR utop (1). .SH FILES Same as .BR utop (1). .SH AUTHOR Jérémie Dimino .SH "SEE ALSO" .BR utoprc (5), .BR lambda-term-inputrc (5), .BR ocaml (1). utop-1.19.3/man/utop.1000066400000000000000000000046441275431303000144260ustar00rootroot00000000000000\" utop.1 \" ------ \" Copyright : (c) 2011, Jeremie Dimino \" Licence : BSD3 \" \" This file is a part of utop. .TH UTOP 1 "August 2011" .SH NAME utop \- Universal toplevel for OCaml .SH SYNOPSIS .B utop [ .I options ] [ .I object-files ] [ .I script-file ] .SH DESCRIPTION .B utop is a enhanced toplevel for OCaml with many features, including context sensitive completion. When you start .B utop what you see is the prompt followed by a bar containing words. This is the completion bar, it contains the possible completion and is updated as you type. The highlighted word in the completion bar is the selected word. You can navigate using the keys Alt+Left and Alt+Right and you can complete using the currently selected word by pressing Alt+Tab (you can configure these bindings in the file .I ~/.lambda-term-inputrc , see .BR lambda-term-inputrc (5) for details). utop supports completion on: * directives and directive arguments * identifiers * record fields * variants * function labels * object methods Colors are by default configured for terminals with dark colors, such as white on black, so the prompt may looks too bright on light colors terminals. You can change that by setting the color profile of utop. For that type: UTop.set_profile UTop.Light;; You can then add this line to your .I ~/.ocamlinit file. You can enable basic syntax highlighting in utop by writing a .I ~/.utoprc file. See .BR utoprc (5) for that. Finally utop can run in emacs. For that you have to add the following line to your .I ~/.emacs file: (autoload 'utop "utop" "Toplevel for OCaml" t) then you can run utop by pressing M-x and typing "utop". utop support completion in emacs mode. Just press Tab to complete a word. You can also integrate it with the tuareg, caml or typerex mode. For that add the following lines to your .I ~/.emacs file: (autoload 'utop-minor-mode "utop" "Minor mode for utop" t) (add-hook 'tuareg-mode-hook 'utop-minor-mode) .SH OPTIONS Same as .BR ocaml (1). .SH FILES .I ~/.ocamlinit .RS The initialization file of the toplevel. .RE .I ~/.utoprc .RS The configuration file for utop. See .BR utoprc (5). .RE .I ~/.lambda-term-inputrc .RS The file containing key bindings. See .BR lambda-term-inputrc (5). .SH AUTHOR Jérémie Dimino .SH "SEE ALSO" .BR utoprc (5), .BR lambda-term-inputrc (5), .BR ocaml (1). utop-1.19.3/man/utoprc.5000066400000000000000000000060451275431303000147540ustar00rootroot00000000000000\" utoprc.5 \" -------- \" Copyright : (c) 2011, Jeremie Dimino \" Licence : BSD3 \" \" This file is a part of utop. .TH UTOPRC 5 "August 2011" .SH NAME utoprc \- Configuration file of utop .SH SYNOPSIS .B ~/.utoprc .SH DESCRIPTION This manual page describes the format of the .I ~/.utoprc file. This is a text file which contains the configuration of utop. Comments start with a '!' and empty lines are ignored. Configuration lines are of the form: : .I may contains the '*' star character. In that case any key which match the pattern is given the value after the colon. The boolean key .I autoload can be set to .I false to disable the autoloading of files in .I $OCAML_TOPLEVEL_PATH/autoload at startup. The key .I external-editor can be set to a command line. It is used to edit the input when pressing C-x C-e. It defaults to the contents of the .I EDITOR environment variable. The key .I profile may have the value .I dark or .I light. This is the same as calling .I UTop.set_profile in .I ~/.ocamlinit. The following style keys are used by utop: * identifier * module * comment * doc * constant * keyword * symbol * string * char * quotation * error * directive * parenthesis * blanks For each of these keys, the following sub-keys are used: * key.foreground * key.background * key.bold * key.underline * key.reverse * key.blink .I key.foreground and .I key.background are colors, and the others are booleans. Colors may be one of the standard terminal colors: * black * red * green * yellow * blue * magenta * cyan * white * light-black * light-red * light-green * light-yellow * light-blue * light-magenta * light-cyan * light-white or X11 colors, prefixed with "x-". For example: identifier.foreground: x-goldenrod Colors can also be given by their RGB components, written #RRGGBB. For example: identifier.foreground: #5fbf7f utop will choose the nearest color of the terminal when specifying a X11 color or a color given by its RGB components. If you are using gnome-terminal or konsole, you can enable 256 colors by setting the environment variable TERM to "xterm-256color". .SH FILES .I ~/.utoprc .SH EXAMPLE profile: dark .RS .RE identifier.foreground: none .RS .RE comment.foreground: x-chocolate1 .RS .RE doc.foreground: x-light-salmon .RS .RE constant.foreground: x-aquamarine .RS .RE keyword.foreground: x-cyan1 .RS .RE symbol.foreground: x-cyan1 .RS .RE string.foreground: x-light-salmon .RS .RE char.foreground: x-light-salmon .RS .RE quotation.foreground: x-purple .RS .RE error.foreground: x-red .RS .RE parenthesis.background: blue .SH AUTHOR Jérémie Dimino .SH "SEE ALSO" .BR utop (1). utop-1.19.3/myocamlbuild.ml000066400000000000000000000625011275431303000156110ustar00rootroot00000000000000(* * myocamlbuild.ml * --------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of utop. *) (* OASIS_START *) (* DO NOT EDIT (digest: f68667f1e12528c7f5c9b0cee2c6ae4b) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) let ns_ str = str let s_ str = str let f_ (str: ('a, 'b, 'c, 'd) format4) = str let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" let init = [] end module OASISString = struct (* # 22 "src/oasis/OASISString.ml" *) (** Various string utilities. Mostly inspired by extlib and batteries ExtString and BatString libraries. @author Sylvain Le Gall *) let nsplitf str f = if str = "" then [] else let buf = Buffer.create 13 in let lst = ref [] in let push () = lst := Buffer.contents buf :: !lst; Buffer.clear buf in let str_len = String.length str in for i = 0 to str_len - 1 do if f str.[i] then push () else Buffer.add_char buf str.[i] done; push (); List.rev !lst (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the separator. *) let nsplit str c = nsplitf str ((=) c) let find ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in while !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else what_idx := 0; incr str_idx done; if !what_idx <> String.length what then raise Not_found else !str_idx - !what_idx let sub_start str len = let str_len = String.length str in if len >= str_len then "" else String.sub str len (str_len - len) let sub_end ?(offset=0) str len = let str_len = String.length str in if len >= str_len then "" else String.sub str 0 (str_len - len) let starts_with ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in let ok = ref true in while !ok && !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else ok := false; incr str_idx done; if !what_idx = String.length what then true else false let strip_starts_with ~what str = if starts_with ~what str then sub_start str (String.length what) else raise Not_found let ends_with ~what ?(offset=0) str = let what_idx = ref ((String.length what) - 1) in let str_idx = ref ((String.length str) - 1) in let ok = ref true in while !ok && offset <= !str_idx && 0 <= !what_idx do if str.[!str_idx] = what.[!what_idx] then decr what_idx else ok := false; decr str_idx done; if !what_idx = -1 then true else false let strip_ends_with ~what str = if ends_with ~what str then sub_end str (String.length what) else raise Not_found let replace_chars f s = let buf = Buffer.create (String.length s) in String.iter (fun c -> Buffer.add_char buf (f c)) s; Buffer.contents buf let lowercase_ascii = replace_chars (fun c -> if (c >= 'A' && c <= 'Z') then Char.chr (Char.code c + 32) else c) let uncapitalize_ascii s = if s <> "" then (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) else s let uppercase_ascii = replace_chars (fun c -> if (c >= 'a' && c <= 'z') then Char.chr (Char.code c - 32) else c) let capitalize_ascii s = if s <> "" then (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) else s end module OASISExpr = struct (* # 22 "src/oasis/OASISExpr.ml" *) open OASISGettext type test = string type flag = string type t = | EBool of bool | ENot of t | EAnd of t * t | EOr of t * t | EFlag of flag | ETest of test * string type 'a choices = (t * 'a) list let eval var_get t = let rec eval' = function | EBool b -> b | ENot e -> not (eval' e) | EAnd (e1, e2) -> (eval' e1) && (eval' e2) | EOr (e1, e2) -> (eval' e1) || (eval' e2) | EFlag nm -> let v = var_get nm in assert(v = "true" || v = "false"); (v = "true") | ETest (nm, vl) -> let v = var_get nm in (v = vl) in eval' t let choose ?printer ?name var_get lst = let rec choose_aux = function | (cond, vl) :: tl -> if eval var_get cond then vl else choose_aux tl | [] -> let str_lst = if lst = [] then s_ "" else String.concat (s_ ", ") (List.map (fun (cond, vl) -> match printer with | Some p -> p vl | None -> s_ "") lst) in match name with | Some nm -> failwith (Printf.sprintf (f_ "No result for the choice list '%s': %s") nm str_lst) | None -> failwith (Printf.sprintf (f_ "No result for a choice list: %s") str_lst) in choose_aux (List.rev lst) end # 292 "myocamlbuild.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) type t = string MapString.t let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" let load ?(allow_empty=false) ?(filename=default_filename) () = if Sys.file_exists filename then begin let chn = open_in_bin filename in let st = Stream.of_channel chn in let line = ref 1 in let st_line = Stream.from (fun _ -> try match Stream.next st with | '\n' -> incr line; Some '\n' | c -> Some c with Stream.Failure -> None) in let lexer = Genlex.make_lexer ["="] st_line in let rec read_file mp = match Stream.npeek 3 lexer with | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> Stream.junk lexer; Stream.junk lexer; Stream.junk lexer; read_file (MapString.add nm value mp) | [] -> mp | _ -> failwith (Printf.sprintf "Malformed data file '%s' line %d" filename !line) in let mp = read_file MapString.empty in close_in chn; mp end else if allow_empty then begin MapString.empty end else begin failwith (Printf.sprintf "Unable to load environment, the file '%s' doesn't exist." filename) end let rec var_expand str env = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) env with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff let var_get name env = var_expand (MapString.find name env) env let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end # 397 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild * by N. Pouillard and others * * Updated on 2009/02/28 * * Modified by Sylvain Le Gall *) open Ocamlbuild_plugin type conf = { no_automatic_syntax: bool; } (* these functions are not really officially exported *) let run_and_read = Ocamlbuild_pack.My_unix.run_and_read let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings let exec_from_conf exec = let exec = let env_filename = Pathname.basename BaseEnvLight.default_filename in let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in try BaseEnvLight.var_get exec env with Not_found -> Printf.eprintf "W: Cannot get variable %s\n" exec; exec in let fix_win32 str = if Sys.os_type = "Win32" then begin let buff = Buffer.create (String.length str) in (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. *) String.iter (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) str; Buffer.contents buff end else begin str end in fix_win32 exec let split s ch = let buf = Buffer.create 13 in let x = ref [] in let flush () = x := (Buffer.contents buf) :: !x; Buffer.clear buf in String.iter (fun c -> if c = ch then flush () else Buffer.add_char buf c) s; flush (); List.rev !x let split_nl s = split s '\n' let before_space s = try String.before s (String.index s ' ') with Not_found -> s (* ocamlfind command *) let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] (* This lists all supported packages. *) let find_packages () = List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) (* Mock to list available syntaxes. *) let find_syntaxes () = ["camlp4o"; "camlp4r"] let well_known_syntax = [ "camlp4.quotations.o"; "camlp4.quotations.r"; "camlp4.exceptiontracer"; "camlp4.extend"; "camlp4.foldgenerator"; "camlp4.listcomprehension"; "camlp4.locationstripper"; "camlp4.macro"; "camlp4.mapgenerator"; "camlp4.metagenerator"; "camlp4.profiler"; "camlp4.tracer" ] let dispatch conf = function | After_options -> (* By using Before_options one let command line options have an higher * priority on the contrary using After_options will guarantee to have * the higher priority override default commands by ocamlfind ones *) Options.ocamlc := ocamlfind & A"ocamlc"; Options.ocamlopt := ocamlfind & A"ocamlopt"; Options.ocamldep := ocamlfind & A"ocamldep"; Options.ocamldoc := ocamlfind & A"ocamldoc"; Options.ocamlmktop := ocamlfind & A"ocamlmktop"; Options.ocamlmklib := ocamlfind & A"ocamlmklib" | After_rules -> (* When one link an OCaml library/binary/package, one should use * -linkpkg *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; if not (conf.no_automatic_syntax) then begin (* For each ocamlfind package one inject the -package option when * compiling, computing dependencies, generating documentation and * linking. *) List.iter begin fun pkg -> let base_args = [A"-package"; A pkg] in (* TODO: consider how to really choose camlp4o or camlp4r. *) let syn_args = [A"-syntax"; A "camlp4o"] in let (args, pargs) = (* Heuristic to identify syntax extensions: whether they end in ".syntax"; some might not. *) if Filename.check_suffix pkg "syntax" || List.mem pkg well_known_syntax then (syn_args @ base_args, syn_args) else (base_args, []) in flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; (* TODO: Check if this is allowed for OCaml < 3.12.1 *) flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; end (find_packages ()); end; (* Like -package but for extensions syntax. Morover -syntax is useless * when linking. *) List.iter begin fun syntax -> flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; end (find_syntaxes ()); (* The default "thread" tag is not compatible with ocamlfind. * Indeed, the default rules add the "threads.cma" or "threads.cmxa" * options when using this tag. When using the "-linkpkg" option with * ocamlfind, this module will then be added twice on the command line. * * To solve this, one approach is to add the "-thread" option when using * the "threads" package using the previous plugin. *) flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); | _ -> () end module MyOCamlbuildBase = struct (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall *) open Ocamlbuild_plugin module OC = Ocamlbuild_pack.Ocaml_compiler type dir = string type file = string type name = string type tag = string (* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { lib_ocaml: (name * dir list * string list) list; lib_c: (name * dir * file list) list; flags: (tag list * (spec OASISExpr.choices)) list; (* Replace the 'dir: include' from _tags by a precise interdepends in * directory. *) includes: (dir * dir list) list; } let env_filename = Pathname.basename BaseEnvLight.default_filename let dispatch_combine lst = fun e -> List.iter (fun dispatch -> dispatch e) lst let tag_libstubs nm = "use_lib"^nm^"_stubs" let nm_libstubs nm = nm^"_stubs" let dispatch t e = let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in match e with | Before_options -> let no_trailing_dot s = if String.length s >= 1 && s.[0] = '.' then String.sub s 1 ((String.length s) - 1) else s in List.iter (fun (opt, var) -> try opt := no_trailing_dot (BaseEnvLight.var_get var env) with Not_found -> Printf.eprintf "W: Cannot get variable %s\n" var) [ Options.ext_obj, "ext_obj"; Options.ext_lib, "ext_lib"; Options.ext_dll, "ext_dll"; ] | After_rules -> (* Declare OCaml libraries *) List.iter (function | nm, [], intf_modules -> ocaml_lib nm; let cmis = List.map (fun m -> (OASISString.uncapitalize_ascii m) ^ ".cmi") intf_modules in dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis | nm, dir :: tl, intf_modules -> ocaml_lib ~dir:dir (dir^"/"^nm); List.iter (fun dir -> List.iter (fun str -> flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) ["compile"; "infer_interface"; "doc"]) tl; let cmis = List.map (fun m -> dir^"/"^(OASISString.uncapitalize_ascii m)^".cmi") intf_modules in dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] cmis) t.lib_ocaml; (* Declare directories dependencies, replace "include" in _tags. *) List.iter (fun (dir, include_dirs) -> Pathname.define_context dir include_dirs) t.includes; (* Declare C libraries *) List.iter (fun (lib, dir, headers) -> (* Handle C part of library *) flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; A("-l"^(nm_libstubs lib))]); flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); (* When ocaml link something that use the C library, then one need that file to be up to date. This holds both for programs and for libraries. *) dep ["link"; "ocaml"; tag_libstubs lib] [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; dep ["compile"; "ocaml"; tag_libstubs lib] [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; (* TODO: be more specific about what depends on headers *) (* Depends on .h files *) dep ["compile"; "c"] headers; (* Setup search path for lib *) flag ["link"; "ocaml"; "use_"^lib] (S[A"-I"; P(dir)]); ) t.lib_c; (* Add flags *) List.iter (fun (tags, cond_specs) -> let spec = BaseEnvLight.var_choose cond_specs env in let rec eval_specs = function | S lst -> S (List.map eval_specs lst) | A str -> A (BaseEnvLight.var_expand str env) | spec -> spec in flag tags & (eval_specs spec)) t.flags | _ -> () let dispatch_default conf t = dispatch_combine [ dispatch t; MyOCamlbuildFindlib.dispatch conf; ] end # 766 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { MyOCamlbuildBase.lib_ocaml = [("utop", ["src/lib"], []); ("utop-camlp4", ["src/camlp4"], [])]; lib_c = []; flags = []; includes = [("src/top", ["src/lib"]); ("src/camlp4", ["src/lib"])] } ;; let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; # 783 "myocamlbuild.ml" (* OASIS_STOP *) let () = dispatch (fun hook -> dispatch_default hook; Ocamlbuild_cppo.dispatcher hook; match hook with | Before_options -> Options.make_links := false | After_rules -> (* Copy tags from *.byte to *.top *) tag_file "src/top/uTop_top.top" (List.filter (* Remove the "file:..." tag and syntax extensions. *) (fun tag -> not (String.is_prefix "file:" tag) && not (String.is_suffix tag ".syntax")) (Tags.elements (tags_of_pathname "src/top/uTop_top.byte"))); (* Use -linkpkg for creating toplevels *) flag ["ocaml"; "link"; "toplevel"] & A"-linkpkg"; let env = BaseEnvLight.load () in let stdlib = BaseEnvLight.var_get "standard_library" env in let paths = [A "-I"; A "+camlp5"] in flag ["ocaml"; "compile"; "use_camlp5"] & S paths; flag ["ocaml"; "ocamldep"; "use_camlp5"] & S paths; flag ["ocaml"; "doc"; "use_camlp5"] & S paths; (* Expunge compiler modules *) rule "toplevel expunge" ~dep:"src/top/uTop_top.top" ~prod:"src/top/uTop_top.byte" (fun _ _ -> (* Build the list of explicit dependencies. *) let packages = Tags.fold (fun tag packages -> if String.is_prefix "package(" tag then String.sub tag 8 (String.length tag - 9) :: packages else packages) (tags_of_pathname "src/top/uTop_top.byte") [] in (* Build the list of dependencies. *) let deps = Findlib.topological_closure (List.rev_map Findlib.query packages) in (* Build the set of locations of dependencies. *) let locs = List.fold_left (fun set pkg -> StringSet.add pkg.Findlib.location set) StringSet.empty deps in (* Directories to search for .cmi: *) let directories = StringSet.add stdlib (StringSet.add (stdlib / "threads") locs) in (* Construct the set of modules to keep by listing .cmi files: *) let modules = StringSet.fold (fun directory set -> List.fold_left (fun set fname -> if Pathname.check_extension fname "cmi" then StringSet.add (module_name_of_pathname fname) set else set) set (Array.to_list (Pathname.readdir directory))) directories StringSet.empty in (* These are not in the stdlib path since 4.00 *) let modules = StringSet.add "Toploop" modules in let modules = StringSet.add "Topmain" modules in Cmd (S [A (stdlib / "expunge"); A "src/top/uTop_top.top"; A "src/top/uTop_top.byte"; A "UTop"; A "UTop_private"; S(List.map (fun x -> A x) (StringSet.elements modules))])); rule "full toplevel (not expunged)" ~dep:"src/top/uTop_top.top" ~prod:"src/top/uTop_top_full.byte" (fun _ _ -> cp "src/top/uTop_top.top" "src/top/uTop_top_full.byte"); let interact_enabled = BaseEnvLight.var_get "interact" env = "true" in flag ["cppo"; "cppo_interact"] ( if interact_enabled then S [A "-D"; A "ENABLE_INTERACT"] else N); rule "format lifter" ~prod:"src/lib/uTop_cmt_lifter.ml" (fun _ _ -> let ocaml_version = Scanf.sscanf (BaseEnvLight.var_get "ocaml_version" env) "%u.%u" (fun a b -> (a, b)) in if ocaml_version < (4, 02) || not interact_enabled then Echo ([], "src/lib/uTop_cmt_lifter.ml") else Cmd (S [ P "ocamlfind" ; A "ppx_tools/genlifter" ; A "-I" ; A "+compiler-libs" ; A "Cmt_format.cmt_infos" ; Sh ">" ; A "src/lib/uTop_cmt_lifter.ml" ])) | _ -> ()) utop-1.19.3/opam000066400000000000000000000013761275431303000134600ustar00rootroot00000000000000opam-version: "1.2" maintainer: "jeremie@dimino.org" authors: ["Jérémie Dimino"] license: "BSD3" homepage: "https://github.com/diml/utop" bug-reports: "https://github.com/diml/utop/issues" dev-repo: "git://github.com/diml/utop.git" build: [ ["./configure" "--prefix" prefix "--%{camlp4:enable}%-camlp4" "--%{ppx_tools:enable}%-interact"] [make] ] install: [ [make "install"] ] build-doc: [ ["ocaml" "setup.ml" "-doc"] ] remove: [ ["ocamlfind" "remove" "utop"] ] depends: [ "base-unix" "base-threads" "ocamlfind" {>= "1.4.0"} "lambda-term" {>= "1.2"} "lwt" "react" {>= "1.0.0"} "cppo" {>= "1.1.2"} "oasis" {>= "0.3.0"} ] depopts: [ "camlp4" "ppx_tools" ] available: [ ocaml-version >= "4.01" ] utop-1.19.3/setup.ml000066400000000000000000006054641275431303000143030ustar00rootroot00000000000000(* * setup.ml * -------- * Copyright : (c) 2012, Jeremie Dimino * Licence : BSD3 * * This file is a part of utop. *) (* OASIS_START *) (* DO NOT EDIT (digest: 8e5cfe23708be275159e82f4ad56c6c9) *) (* Regenerated by OASIS v0.4.6 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) let ns_ str = str let s_ str = str let f_ (str: ('a, 'b, 'c, 'd) format4) = str let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" let init = [] end module OASISContext = struct (* # 22 "src/oasis/OASISContext.ml" *) open OASISGettext type level = [ `Debug | `Info | `Warning | `Error] type t = { (* TODO: replace this by a proplist. *) quiet: bool; info: bool; debug: bool; ignore_plugins: bool; ignore_unknown_fields: bool; printf: level -> string -> unit; } let printf lvl str = let beg = match lvl with | `Error -> s_ "E: " | `Warning -> s_ "W: " | `Info -> s_ "I: " | `Debug -> s_ "D: " in prerr_endline (beg^str) let default = ref { quiet = false; info = false; debug = false; ignore_plugins = false; ignore_unknown_fields = false; printf = printf; } let quiet = {!default with quiet = true} let fspecs () = (* TODO: don't act on default. *) let ignore_plugins = ref false in ["-quiet", Arg.Unit (fun () -> default := {!default with quiet = true}), s_ " Run quietly"; "-info", Arg.Unit (fun () -> default := {!default with info = true}), s_ " Display information message"; "-debug", Arg.Unit (fun () -> default := {!default with debug = true}), s_ " Output debug message"; "-ignore-plugins", Arg.Set ignore_plugins, s_ " Ignore plugin's field."; "-C", (* TODO: remove this chdir. *) Arg.String (fun str -> Sys.chdir str), s_ "dir Change directory before running."], fun () -> {!default with ignore_plugins = !ignore_plugins} end module OASISString = struct (* # 22 "src/oasis/OASISString.ml" *) (** Various string utilities. Mostly inspired by extlib and batteries ExtString and BatString libraries. @author Sylvain Le Gall *) let nsplitf str f = if str = "" then [] else let buf = Buffer.create 13 in let lst = ref [] in let push () = lst := Buffer.contents buf :: !lst; Buffer.clear buf in let str_len = String.length str in for i = 0 to str_len - 1 do if f str.[i] then push () else Buffer.add_char buf str.[i] done; push (); List.rev !lst (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the separator. *) let nsplit str c = nsplitf str ((=) c) let find ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in while !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else what_idx := 0; incr str_idx done; if !what_idx <> String.length what then raise Not_found else !str_idx - !what_idx let sub_start str len = let str_len = String.length str in if len >= str_len then "" else String.sub str len (str_len - len) let sub_end ?(offset=0) str len = let str_len = String.length str in if len >= str_len then "" else String.sub str 0 (str_len - len) let starts_with ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in let ok = ref true in while !ok && !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else ok := false; incr str_idx done; if !what_idx = String.length what then true else false let strip_starts_with ~what str = if starts_with ~what str then sub_start str (String.length what) else raise Not_found let ends_with ~what ?(offset=0) str = let what_idx = ref ((String.length what) - 1) in let str_idx = ref ((String.length str) - 1) in let ok = ref true in while !ok && offset <= !str_idx && 0 <= !what_idx do if str.[!str_idx] = what.[!what_idx] then decr what_idx else ok := false; decr str_idx done; if !what_idx = -1 then true else false let strip_ends_with ~what str = if ends_with ~what str then sub_end str (String.length what) else raise Not_found let replace_chars f s = let buf = Buffer.create (String.length s) in String.iter (fun c -> Buffer.add_char buf (f c)) s; Buffer.contents buf let lowercase_ascii = replace_chars (fun c -> if (c >= 'A' && c <= 'Z') then Char.chr (Char.code c + 32) else c) let uncapitalize_ascii s = if s <> "" then (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) else s let uppercase_ascii = replace_chars (fun c -> if (c >= 'a' && c <= 'z') then Char.chr (Char.code c - 32) else c) let capitalize_ascii s = if s <> "" then (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) else s end module OASISUtils = struct (* # 22 "src/oasis/OASISUtils.ml" *) open OASISGettext module MapExt = struct module type S = sig include Map.S val add_list: 'a t -> (key * 'a) list -> 'a t val of_list: (key * 'a) list -> 'a t val to_list: 'a t -> (key * 'a) list end module Make (Ord: Map.OrderedType) = struct include Map.Make(Ord) let rec add_list t = function | (k, v) :: tl -> add_list (add k v t) tl | [] -> t let of_list lst = add_list empty lst let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] end end module MapString = MapExt.Make(String) module SetExt = struct module type S = sig include Set.S val add_list: t -> elt list -> t val of_list: elt list -> t val to_list: t -> elt list end module Make (Ord: Set.OrderedType) = struct include Set.Make(Ord) let rec add_list t = function | e :: tl -> add_list (add e t) tl | [] -> t let of_list lst = add_list empty lst let to_list = elements end end module SetString = SetExt.Make(String) let compare_csl s1 s2 = String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2) module HashStringCsl = Hashtbl.Make (struct type t = string let equal s1 s2 = (compare_csl s1 s2) = 0 let hash s = Hashtbl.hash (OASISString.lowercase_ascii s) end) module SetStringCsl = SetExt.Make (struct type t = string let compare = compare_csl end) let varname_of_string ?(hyphen='_') s = if String.length s = 0 then begin invalid_arg "varname_of_string" end else begin let buf = OASISString.replace_chars (fun c -> if ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') || ('0' <= c && c <= '9') then c else hyphen) s; in let buf = (* Start with a _ if digit *) if '0' <= s.[0] && s.[0] <= '9' then "_"^buf else buf in OASISString.lowercase_ascii buf end let varname_concat ?(hyphen='_') p s = let what = String.make 1 hyphen in let p = try OASISString.strip_ends_with ~what p with Not_found -> p in let s = try OASISString.strip_starts_with ~what s with Not_found -> s in p^what^s let is_varname str = str = varname_of_string str let failwithf fmt = Printf.ksprintf failwith fmt end module PropList = struct (* # 22 "src/oasis/PropList.ml" *) open OASISGettext type name = string exception Not_set of name * string option exception No_printer of name exception Unknown_field of name * name let () = Printexc.register_printer (function | Not_set (nm, Some rsn) -> Some (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) | Not_set (nm, None) -> Some (Printf.sprintf (f_ "Field '%s' is not set") nm) | No_printer nm -> Some (Printf.sprintf (f_ "No default printer for value %s") nm) | Unknown_field (nm, schm) -> Some (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm) | _ -> None) module Data = struct type t = (name, unit -> unit) Hashtbl.t let create () = Hashtbl.create 13 let clear t = Hashtbl.clear t (* # 78 "src/oasis/PropList.ml" *) end module Schema = struct type ('ctxt, 'extra) value = { get: Data.t -> string; set: Data.t -> ?context:'ctxt -> string -> unit; help: (unit -> string) option; extra: 'extra; } type ('ctxt, 'extra) t = { name: name; fields: (name, ('ctxt, 'extra) value) Hashtbl.t; order: name Queue.t; name_norm: string -> string; } let create ?(case_insensitive=false) nm = { name = nm; fields = Hashtbl.create 13; order = Queue.create (); name_norm = (if case_insensitive then OASISString.lowercase_ascii else fun s -> s); } let add t nm set get extra help = let key = t.name_norm nm in if Hashtbl.mem t.fields key then failwith (Printf.sprintf (f_ "Field '%s' is already defined in schema '%s'") nm t.name); Hashtbl.add t.fields key { set = set; get = get; help = help; extra = extra; }; Queue.add nm t.order let mem t nm = Hashtbl.mem t.fields nm let find t nm = try Hashtbl.find t.fields (t.name_norm nm) with Not_found -> raise (Unknown_field (nm, t.name)) let get t data nm = (find t nm).get data let set t data nm ?context x = (find t nm).set data ?context x let fold f acc t = Queue.fold (fun acc k -> let v = find t k in f acc k v.extra v.help) acc t.order let iter f t = fold (fun () -> f) () t let name t = t.name end module Field = struct type ('ctxt, 'value, 'extra) t = { set: Data.t -> ?context:'ctxt -> 'value -> unit; get: Data.t -> 'value; sets: Data.t -> ?context:'ctxt -> string -> unit; gets: Data.t -> string; help: (unit -> string) option; extra: 'extra; } let new_id = let last_id = ref 0 in fun () -> incr last_id; !last_id let create ?schema ?name ?parse ?print ?default ?update ?help extra = (* Default value container *) let v = ref None in (* If name is not given, create unique one *) let nm = match name with | Some s -> s | None -> Printf.sprintf "_anon_%d" (new_id ()) in (* Last chance to get a value: the default *) let default () = match default with | Some d -> d | None -> raise (Not_set (nm, Some (s_ "no default value"))) in (* Get data *) let get data = (* Get value *) try (Hashtbl.find data nm) (); match !v with | Some x -> x | None -> default () with Not_found -> default () in (* Set data *) let set data ?context x = let x = match update with | Some f -> begin try f ?context (get data) x with Not_set _ -> x end | None -> x in Hashtbl.replace data nm (fun () -> v := Some x) in (* Parse string value, if possible *) let parse = match parse with | Some f -> f | None -> fun ?context s -> failwith (Printf.sprintf (f_ "Cannot parse field '%s' when setting value %S") nm s) in (* Set data, from string *) let sets data ?context s = set ?context data (parse ?context s) in (* Output value as string, if possible *) let print = match print with | Some f -> f | None -> fun _ -> raise (No_printer nm) in (* Get data, as a string *) let gets data = print (get data) in begin match schema with | Some t -> Schema.add t nm sets gets extra help | None -> () end; { set = set; get = get; sets = sets; gets = gets; help = help; extra = extra; } let fset data t ?context x = t.set data ?context x let fget data t = t.get data let fsets data t ?context s = t.sets data ?context s let fgets data t = t.gets data end module FieldRO = struct let create ?schema ?name ?parse ?print ?default ?update ?help extra = let fld = Field.create ?schema ?name ?parse ?print ?default ?update ?help extra in fun data -> Field.fget data fld end end module OASISMessage = struct (* # 22 "src/oasis/OASISMessage.ml" *) open OASISGettext open OASISContext let generic_message ~ctxt lvl fmt = let cond = if ctxt.quiet then false else match lvl with | `Debug -> ctxt.debug | `Info -> ctxt.info | _ -> true in Printf.ksprintf (fun str -> if cond then begin ctxt.printf lvl str end) fmt let debug ~ctxt fmt = generic_message ~ctxt `Debug fmt let info ~ctxt fmt = generic_message ~ctxt `Info fmt let warning ~ctxt fmt = generic_message ~ctxt `Warning fmt let error ~ctxt fmt = generic_message ~ctxt `Error fmt end module OASISVersion = struct (* # 22 "src/oasis/OASISVersion.ml" *) open OASISGettext type s = string type t = string type comparator = | VGreater of t | VGreaterEqual of t | VEqual of t | VLesser of t | VLesserEqual of t | VOr of comparator * comparator | VAnd of comparator * comparator (* Range of allowed characters *) let is_digit c = '0' <= c && c <= '9' let is_alpha c = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') let is_special = function | '.' | '+' | '-' | '~' -> true | _ -> false let rec version_compare v1 v2 = if v1 <> "" || v2 <> "" then begin (* Compare ascii string, using special meaning for version * related char *) let val_ascii c = if c = '~' then -1 else if is_digit c then 0 else if c = '\000' then 0 else if is_alpha c then Char.code c else (Char.code c) + 256 in let len1 = String.length v1 in let len2 = String.length v2 in let p = ref 0 in (** Compare ascii part *) let compare_vascii () = let cmp = ref 0 in while !cmp = 0 && !p < len1 && !p < len2 && not (is_digit v1.[!p] && is_digit v2.[!p]) do cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); incr p done; if !cmp = 0 && !p < len1 && !p = len2 then val_ascii v1.[!p] else if !cmp = 0 && !p = len1 && !p < len2 then - (val_ascii v2.[!p]) else !cmp in (** Compare digit part *) let compare_digit () = let extract_int v p = let start_p = !p in while !p < String.length v && is_digit v.[!p] do incr p done; let substr = String.sub v !p ((String.length v) - !p) in let res = match String.sub v start_p (!p - start_p) with | "" -> 0 | s -> int_of_string s in res, substr in let i1, tl1 = extract_int v1 (ref !p) in let i2, tl2 = extract_int v2 (ref !p) in i1 - i2, tl1, tl2 in match compare_vascii () with | 0 -> begin match compare_digit () with | 0, tl1, tl2 -> if tl1 <> "" && is_digit tl1.[0] then 1 else if tl2 <> "" && is_digit tl2.[0] then -1 else version_compare tl1 tl2 | n, _, _ -> n end | n -> n end else begin 0 end let version_of_string str = str let string_of_version t = t let version_compare_string s1 s2 = version_compare (version_of_string s1) (version_of_string s2) let chop t = try let pos = String.rindex t '.' in String.sub t 0 pos with Not_found -> t let rec comparator_apply v op = match op with | VGreater cv -> (version_compare v cv) > 0 | VGreaterEqual cv -> (version_compare v cv) >= 0 | VLesser cv -> (version_compare v cv) < 0 | VLesserEqual cv -> (version_compare v cv) <= 0 | VEqual cv -> (version_compare v cv) = 0 | VOr (op1, op2) -> (comparator_apply v op1) || (comparator_apply v op2) | VAnd (op1, op2) -> (comparator_apply v op1) && (comparator_apply v op2) let rec string_of_comparator = function | VGreater v -> "> "^(string_of_version v) | VEqual v -> "= "^(string_of_version v) | VLesser v -> "< "^(string_of_version v) | VGreaterEqual v -> ">= "^(string_of_version v) | VLesserEqual v -> "<= "^(string_of_version v) | VOr (c1, c2) -> (string_of_comparator c1)^" || "^(string_of_comparator c2) | VAnd (c1, c2) -> (string_of_comparator c1)^" && "^(string_of_comparator c2) let rec varname_of_comparator = let concat p v = OASISUtils.varname_concat p (OASISUtils.varname_of_string (string_of_version v)) in function | VGreater v -> concat "gt" v | VLesser v -> concat "lt" v | VEqual v -> concat "eq" v | VGreaterEqual v -> concat "ge" v | VLesserEqual v -> concat "le" v | VOr (c1, c2) -> (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) | VAnd (c1, c2) -> (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) let rec comparator_ge v' = let cmp v = version_compare v v' >= 0 in function | VEqual v | VGreaterEqual v | VGreater v -> cmp v | VLesserEqual _ | VLesser _ -> false | VOr (c1, c2) -> comparator_ge v' c1 || comparator_ge v' c2 | VAnd (c1, c2) -> comparator_ge v' c1 && comparator_ge v' c2 end module OASISLicense = struct (* # 22 "src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall *) type license = string type license_exception = string type license_version = | Version of OASISVersion.t | VersionOrLater of OASISVersion.t | NoVersion type license_dep_5_unit = { license: license; excption: license_exception option; version: license_version; } type license_dep_5 = | DEP5Unit of license_dep_5_unit | DEP5Or of license_dep_5 list | DEP5And of license_dep_5 list type t = | DEP5License of license_dep_5 | OtherLicense of string (* URL *) end module OASISExpr = struct (* # 22 "src/oasis/OASISExpr.ml" *) open OASISGettext type test = string type flag = string type t = | EBool of bool | ENot of t | EAnd of t * t | EOr of t * t | EFlag of flag | ETest of test * string type 'a choices = (t * 'a) list let eval var_get t = let rec eval' = function | EBool b -> b | ENot e -> not (eval' e) | EAnd (e1, e2) -> (eval' e1) && (eval' e2) | EOr (e1, e2) -> (eval' e1) || (eval' e2) | EFlag nm -> let v = var_get nm in assert(v = "true" || v = "false"); (v = "true") | ETest (nm, vl) -> let v = var_get nm in (v = vl) in eval' t let choose ?printer ?name var_get lst = let rec choose_aux = function | (cond, vl) :: tl -> if eval var_get cond then vl else choose_aux tl | [] -> let str_lst = if lst = [] then s_ "" else String.concat (s_ ", ") (List.map (fun (cond, vl) -> match printer with | Some p -> p vl | None -> s_ "") lst) in match name with | Some nm -> failwith (Printf.sprintf (f_ "No result for the choice list '%s': %s") nm str_lst) | None -> failwith (Printf.sprintf (f_ "No result for a choice list: %s") str_lst) in choose_aux (List.rev lst) end module OASISText = struct (* # 22 "src/oasis/OASISText.ml" *) type elt = | Para of string | Verbatim of string | BlankLine type t = elt list end module OASISTypes = struct (* # 22 "src/oasis/OASISTypes.ml" *) type name = string type package_name = string type url = string type unix_dirname = string type unix_filename = string type host_dirname = string type host_filename = string type prog = string type arg = string type args = string list type command_line = (prog * arg list) type findlib_name = string type findlib_full = string type compiled_object = | Byte | Native | Best type dependency = | FindlibPackage of findlib_full * OASISVersion.comparator option | InternalLibrary of name type tool = | ExternalTool of name | InternalExecutable of name type vcs = | Darcs | Git | Svn | Cvs | Hg | Bzr | Arch | Monotone | OtherVCS of url type plugin_kind = [ `Configure | `Build | `Doc | `Test | `Install | `Extra ] type plugin_data_purpose = [ `Configure | `Build | `Install | `Clean | `Distclean | `Install | `Uninstall | `Test | `Doc | `Extra | `Other of string ] type 'a plugin = 'a * name * OASISVersion.t option type all_plugin = plugin_kind plugin type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list (* # 115 "src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices type custom = { pre_command: (command_line option) conditional; post_command: (command_line option) conditional; } type common_section = { cs_name: name; cs_data: PropList.Data.t; cs_plugin_data: plugin_data; } type build_section = { bs_build: bool conditional; bs_install: bool conditional; bs_path: unix_dirname; bs_compiled_object: compiled_object; bs_build_depends: dependency list; bs_build_tools: tool list; bs_c_sources: unix_filename list; bs_data_files: (unix_filename * unix_filename option) list; bs_ccopt: args conditional; bs_cclib: args conditional; bs_dlllib: args conditional; bs_dllpath: args conditional; bs_byteopt: args conditional; bs_nativeopt: args conditional; } type library = { lib_modules: string list; lib_pack: bool; lib_internal_modules: string list; lib_findlib_parent: findlib_name option; lib_findlib_name: findlib_name option; lib_findlib_containers: findlib_name list; } type object_ = { obj_modules: string list; obj_findlib_fullname: findlib_name list option; } type executable = { exec_custom: bool; exec_main_is: unix_filename; } type flag = { flag_description: string option; flag_default: bool conditional; } type source_repository = { src_repo_type: vcs; src_repo_location: url; src_repo_browser: url option; src_repo_module: string option; src_repo_branch: string option; src_repo_tag: string option; src_repo_subdir: unix_filename option; } type test = { test_type: [`Test] plugin; test_command: command_line conditional; test_custom: custom; test_working_directory: unix_filename option; test_run: bool conditional; test_tools: tool list; } type doc_format = | HTML of unix_filename | DocText | PDF | PostScript | Info of unix_filename | DVI | OtherDoc type doc = { doc_type: [`Doc] plugin; doc_custom: custom; doc_build: bool conditional; doc_install: bool conditional; doc_install_dir: unix_filename; doc_title: string; doc_authors: string list; doc_abstract: string option; doc_format: doc_format; doc_data_files: (unix_filename * unix_filename option) list; doc_build_tools: tool list; } type section = | Library of common_section * build_section * library | Object of common_section * build_section * object_ | Executable of common_section * build_section * executable | Flag of common_section * flag | SrcRepo of common_section * source_repository | Test of common_section * test | Doc of common_section * doc type section_kind = [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] type package = { oasis_version: OASISVersion.t; ocaml_version: OASISVersion.comparator option; findlib_version: OASISVersion.comparator option; alpha_features: string list; beta_features: string list; name: package_name; version: OASISVersion.t; license: OASISLicense.t; license_file: unix_filename option; copyrights: string list; maintainers: string list; authors: string list; homepage: url option; synopsis: string; description: OASISText.t option; categories: url list; conf_type: [`Configure] plugin; conf_custom: custom; build_type: [`Build] plugin; build_custom: custom; install_type: [`Install] plugin; install_custom: custom; uninstall_custom: custom; clean_custom: custom; distclean_custom: custom; files_ab: unix_filename list; sections: section list; plugins: [`Extra] plugin list; disable_oasis_section: unix_filename list; schema_data: PropList.Data.t; plugin_data: plugin_data; } end module OASISFeatures = struct (* # 22 "src/oasis/OASISFeatures.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISVersion module MapPlugin = Map.Make (struct type t = plugin_kind * name let compare = Pervasives.compare end) module Data = struct type t = { oasis_version: OASISVersion.t; plugin_versions: OASISVersion.t option MapPlugin.t; alpha_features: string list; beta_features: string list; } let create oasis_version alpha_features beta_features = { oasis_version = oasis_version; plugin_versions = MapPlugin.empty; alpha_features = alpha_features; beta_features = beta_features } let of_package pkg = create pkg.OASISTypes.oasis_version pkg.OASISTypes.alpha_features pkg.OASISTypes.beta_features let add_plugin (plugin_kind, plugin_name, plugin_version) t = {t with plugin_versions = MapPlugin.add (plugin_kind, plugin_name) plugin_version t.plugin_versions} let plugin_version plugin_kind plugin_name t = MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions let to_string t = Printf.sprintf "oasis_version: %s; alpha_features: %s; beta_features: %s; \ plugins_version: %s" (OASISVersion.string_of_version t.oasis_version) (String.concat ", " t.alpha_features) (String.concat ", " t.beta_features) (String.concat ", " (MapPlugin.fold (fun (_, plg) ver_opt acc -> (plg^ (match ver_opt with | Some v -> " "^(OASISVersion.string_of_version v) | None -> "")) :: acc) t.plugin_versions [])) end type origin = | Field of string * string | Section of string | NoOrigin type stage = Alpha | Beta let string_of_stage = function | Alpha -> "alpha" | Beta -> "beta" let field_of_stage = function | Alpha -> "AlphaFeatures" | Beta -> "BetaFeatures" type publication = InDev of stage | SinceVersion of OASISVersion.t type t = { name: string; plugin: all_plugin option; publication: publication; description: unit -> string; } (* TODO: mutex protect this. *) let all_features = Hashtbl.create 13 let since_version ver_str = SinceVersion (version_of_string ver_str) let alpha = InDev Alpha let beta = InDev Beta let to_string t = Printf.sprintf "feature: %s; plugin: %s; publication: %s" t.name (match t.plugin with | None -> "" | Some (_, nm, _) -> nm) (match t.publication with | InDev stage -> string_of_stage stage | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) let data_check t data origin = let no_message = "no message" in let check_feature features stage = let has_feature = List.mem t.name features in if not has_feature then match origin with | Field (fld, where) -> Some (Printf.sprintf (f_ "Field %s in %s is only available when feature %s \ is in field %s.") fld where t.name (field_of_stage stage)) | Section sct -> Some (Printf.sprintf (f_ "Section %s is only available when features %s \ is in field %s.") sct t.name (field_of_stage stage)) | NoOrigin -> Some no_message else None in let version_is_good ~min_version version fmt = let version_is_good = OASISVersion.comparator_apply version (OASISVersion.VGreaterEqual min_version) in Printf.ksprintf (fun str -> if version_is_good then None else Some str) fmt in match origin, t.plugin, t.publication with | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha | _, _, InDev Beta -> check_feature data.Data.beta_features Beta | Field(fld, where), None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version (f_ "Field %s in %s is only valid since OASIS v%s, update \ OASISFormat field from '%s' to '%s' after checking \ OASIS changelog.") fld where (string_of_version min_version) (string_of_version data.Data.oasis_version) (string_of_version min_version) | Field(fld, where), Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = try match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> failwithf (f_ "Field %s in %s is only valid for the OASIS \ plugin %s since v%s, but no plugin version is \ defined in the _oasis file, change '%s' to \ '%s (%s)' in your _oasis file.") fld where plugin_name (string_of_version min_version) plugin_name plugin_name (string_of_version min_version) with Not_found -> failwithf (f_ "Field %s in %s is only valid when the OASIS plugin %s \ is defined.") fld where plugin_name in version_is_good ~min_version plugin_version_current (f_ "Field %s in %s is only valid for the OASIS plugin %s \ since v%s, update your plugin from '%s (%s)' to \ '%s (%s)' after checking the plugin's changelog.") fld where plugin_name (string_of_version min_version) plugin_name (string_of_version plugin_version_current) plugin_name (string_of_version min_version) with Failure msg -> Some msg end | Section sct, None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version (f_ "Section %s is only valid for since OASIS v%s, update \ OASISFormat field from '%s' to '%s' after checking OASIS \ changelog.") sct (string_of_version min_version) (string_of_version data.Data.oasis_version) (string_of_version min_version) | Section sct, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = try match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> failwithf (f_ "Section %s is only valid for the OASIS \ plugin %s since v%s, but no plugin version is \ defined in the _oasis file, change '%s' to \ '%s (%s)' in your _oasis file.") sct plugin_name (string_of_version min_version) plugin_name plugin_name (string_of_version min_version) with Not_found -> failwithf (f_ "Section %s is only valid when the OASIS plugin %s \ is defined.") sct plugin_name in version_is_good ~min_version plugin_version_current (f_ "Section %s is only valid for the OASIS plugin %s \ since v%s, update your plugin from '%s (%s)' to \ '%s (%s)' after checking the plugin's changelog.") sct plugin_name (string_of_version min_version) plugin_name (string_of_version plugin_version_current) plugin_name (string_of_version min_version) with Failure msg -> Some msg end | NoOrigin, None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version "%s" no_message | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> raise Not_found in version_is_good ~min_version plugin_version_current "%s" no_message with Not_found -> Some no_message end let data_assert t data origin = match data_check t data origin with | None -> () | Some str -> failwith str let data_test t data = match data_check t data NoOrigin with | None -> true | Some str -> false let package_test t pkg = data_test t (Data.of_package pkg) let create ?plugin name publication description = let () = if Hashtbl.mem all_features name then failwithf "Feature '%s' is already declared." name in let t = { name = name; plugin = plugin; publication = publication; description = description; } in Hashtbl.add all_features name t; t let get_stage name = try (Hashtbl.find all_features name).publication with Not_found -> failwithf (f_ "Feature %s doesn't exist.") name let list () = Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] (* * Real flags. *) let features = create "features_fields" (since_version "0.4") (fun () -> s_ "Enable to experiment not yet official features.") let flag_docs = create "flag_docs" (since_version "0.3") (fun () -> s_ "Building docs require '-docs' flag at configure.") let flag_tests = create "flag_tests" (since_version "0.3") (fun () -> s_ "Running tests require '-tests' flag at configure.") let pack = create "pack" (since_version "0.3") (fun () -> s_ "Allow to create packed library.") let section_object = create "section_object" beta (fun () -> s_ "Implement an object section.") let dynrun_for_release = create "dynrun_for_release" alpha (fun () -> s_ "Make '-setup-update dynamic' suitable for releasing project.") let compiled_setup_ml = create "compiled_setup_ml" alpha (fun () -> s_ "It compiles the setup.ml and speed-up actions done with it.") let disable_oasis_section = create "disable_oasis_section" alpha (fun () -> s_ "Allows the OASIS section comments and digest to be omitted in \ generated files.") let no_automatic_syntax = create "no_automatic_syntax" alpha (fun () -> s_ "Disable the automatic inclusion of -syntax camlp4o for packages \ that matches the internal heuristic (if a dependency ends with \ a .syntax or is a well known syntax).") end module OASISUnixPath = struct (* # 22 "src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string type host_filename = string type host_dirname = string let current_dir_name = "." let parent_dir_name = ".." let is_current_dir fn = fn = current_dir_name || fn = "" let concat f1 f2 = if is_current_dir f1 then f2 else let f1' = try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 in f1'^"/"^f2 let make = function | hd :: tl -> List.fold_left (fun f p -> concat f p) hd tl | [] -> invalid_arg "OASISUnixPath.make" let dirname f = try String.sub f 0 (String.rindex f '/') with Not_found -> current_dir_name let basename f = try let pos_start = (String.rindex f '/') + 1 in String.sub f pos_start ((String.length f) - pos_start) with Not_found -> f let chop_extension f = try let last_dot = String.rindex f '.' in let sub = String.sub f 0 last_dot in try let last_slash = String.rindex f '/' in if last_slash < last_dot then sub else f with Not_found -> sub with Not_found -> f let capitalize_file f = let dir = dirname f in let base = basename f in concat dir (OASISString.capitalize_ascii base) let uncapitalize_file f = let dir = dirname f in let base = basename f in concat dir (OASISString.uncapitalize_ascii base) end module OASISHostPath = struct (* # 22 "src/oasis/OASISHostPath.ml" *) open Filename module Unix = OASISUnixPath let make = function | [] -> invalid_arg "OASISHostPath.make" | hd :: tl -> List.fold_left Filename.concat hd tl let of_unix ufn = if Sys.os_type = "Unix" then ufn else make (List.map (fun p -> if p = Unix.current_dir_name then current_dir_name else if p = Unix.parent_dir_name then parent_dir_name else p) (OASISString.nsplit ufn '/')) end module OASISSection = struct (* # 22 "src/oasis/OASISSection.ml" *) open OASISTypes let section_kind_common = function | Library (cs, _, _) -> `Library, cs | Object (cs, _, _) -> `Object, cs | Executable (cs, _, _) -> `Executable, cs | Flag (cs, _) -> `Flag, cs | SrcRepo (cs, _) -> `SrcRepo, cs | Test (cs, _) -> `Test, cs | Doc (cs, _) -> `Doc, cs let section_common sct = snd (section_kind_common sct) let section_common_set cs = function | Library (_, bs, lib) -> Library (cs, bs, lib) | Object (_, bs, obj) -> Object (cs, bs, obj) | Executable (_, bs, exec) -> Executable (cs, bs, exec) | Flag (_, flg) -> Flag (cs, flg) | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) | Test (_, tst) -> Test (cs, tst) | Doc (_, doc) -> Doc (cs, doc) (** Key used to identify section *) let section_id sct = let k, cs = section_kind_common sct in k, cs.cs_name let string_of_section sct = let k, nm = section_id sct in (match k with | `Library -> "library" | `Object -> "object" | `Executable -> "executable" | `Flag -> "flag" | `SrcRepo -> "src repository" | `Test -> "test" | `Doc -> "doc") ^" "^nm let section_find id scts = List.find (fun sct -> id = section_id sct) scts module CSection = struct type t = section let id = section_id let compare t1 t2 = compare (id t1) (id t2) let equal t1 t2 = (id t1) = (id t2) let hash t = Hashtbl.hash (id t) end module MapSection = Map.Make(CSection) module SetSection = Set.Make(CSection) end module OASISBuildSection = struct (* # 22 "src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct (* # 22 "src/oasis/OASISExecutable.ml" *) open OASISTypes let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = let dir = OASISUnixPath.concat bs.bs_path (OASISUnixPath.dirname exec.exec_main_is) in let is_native_exec = match bs.bs_compiled_object with | Native -> true | Best -> is_native () | Byte -> false in OASISUnixPath.concat dir (cs.cs_name^(suffix_program ())), if not is_native_exec && not exec.exec_custom && bs.bs_c_sources <> [] then Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) else None end module OASISLibrary = struct (* # 22 "src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISSection (* Look for a module file, considering capitalization or not. *) let find_module source_file_exists bs modul = let possible_base_fn = List.map (OASISUnixPath.concat bs.bs_path) [modul; OASISUnixPath.uncapitalize_file modul; OASISUnixPath.capitalize_file modul] in (* TODO: we should be able to be able to determine the source for every * files. Hence we should introduce a Module(source: fn) for the fields * Modules and InternalModules *) List.fold_left (fun acc base_fn -> match acc with | `No_sources _ -> begin let file_found = List.fold_left (fun acc ext -> if source_file_exists (base_fn^ext) then (base_fn^ext) :: acc else acc) [] [".ml"; ".mli"; ".mll"; ".mly"] in match file_found with | [] -> acc | lst -> `Sources (base_fn, lst) end | `Sources _ -> acc) (`No_sources possible_base_fn) possible_base_fn let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = List.fold_left (fun acc modul -> match find_module source_file_exists bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; acc) [] (lib.lib_modules @ lib.lib_internal_modules) let generated_unix_files ~ctxt ~is_native ~has_native_dynlink ~ext_lib ~ext_dll ~source_file_exists (cs, bs, lib) = let find_modules lst ext = let find_module modul = match find_module source_file_exists bs modul with | `Sources (base_fn, [fn]) when ext <> "cmi" && Filename.check_suffix fn ".mli" -> None (* No implementation files for pure interface. *) | `Sources (base_fn, _) -> Some [base_fn] | `No_sources lst -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; Some lst in List.fold_left (fun acc nm -> match find_module nm with | None -> acc | Some base_fns -> List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) [] lst in (* The .cmx that be compiled along *) let cmxs = let should_be_built = match bs.bs_compiled_object with | Native -> true | Best -> is_native | Byte -> false in if should_be_built then if lib.lib_pack then find_modules [cs.cs_name] "cmx" else find_modules (lib.lib_modules @ lib.lib_internal_modules) "cmx" else [] in let acc_nopath = [] in (* The headers and annot/cmt files that should be compiled along *) let headers = let sufx = if lib.lib_pack then [".cmti"; ".cmt"; ".annot"] else [".cmi"; ".cmti"; ".cmt"; ".annot"] in List.map begin List.fold_left begin fun accu s -> let dot = String.rindex s '.' in let base = String.sub s 0 dot in List.map ((^) base) sufx @ accu end [] end (find_modules lib.lib_modules "cmi") in (* Compute what libraries should be built *) let acc_nopath = (* Add the packed header file if required *) let add_pack_header acc = if lib.lib_pack then [cs.cs_name^".cmi"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: acc else acc in let byte acc = add_pack_header ([cs.cs_name^".cma"] :: acc) in let native acc = let acc = add_pack_header (if has_native_dynlink then [cs.cs_name^".cmxs"] :: acc else acc) in [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc in match bs.bs_compiled_object with | Native -> byte (native acc_nopath) | Best when is_native -> byte (native acc_nopath) | Byte | Best -> byte acc_nopath in (* Add C library to be built *) let acc_nopath = if bs.bs_c_sources <> [] then begin ["lib"^cs.cs_name^"_stubs"^ext_lib] :: ["dll"^cs.cs_name^"_stubs"^ext_dll] :: acc_nopath end else acc_nopath in (* All the files generated *) List.rev_append (List.rev_map (List.rev_map (OASISUnixPath.concat bs.bs_path)) acc_nopath) (headers @ cmxs) end module OASISObject = struct (* # 22 "src/oasis/OASISObject.ml" *) open OASISTypes open OASISGettext let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = List.fold_left (fun acc modul -> match OASISLibrary.find_module source_file_exists bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in object %s") modul cs.cs_name; acc) [] obj.obj_modules let generated_unix_files ~ctxt ~is_native ~source_file_exists (cs, bs, obj) = let find_module ext modul = match OASISLibrary.find_module source_file_exists bs modul with | `Sources (base_fn, _) -> [base_fn ^ ext] | `No_sources lst -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in object %s") modul cs.cs_name ; lst in let header, byte, native, c_object, f = match obj.obj_modules with | [ m ] -> (find_module ".cmi" m, find_module ".cmo" m, find_module ".cmx" m, find_module ".o" m, fun x -> x) | _ -> ([cs.cs_name ^ ".cmi"], [cs.cs_name ^ ".cmo"], [cs.cs_name ^ ".cmx"], [cs.cs_name ^ ".o"], OASISUnixPath.concat bs.bs_path) in List.map (List.map f) ( match bs.bs_compiled_object with | Native -> native :: c_object :: byte :: header :: [] | Best when is_native -> native :: c_object :: byte :: header :: [] | Byte | Best -> byte :: header :: []) end module OASISFindlib = struct (* # 22 "src/oasis/OASISFindlib.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISSection type library_name = name type findlib_part_name = name type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t exception InternalLibraryNotFound of library_name exception FindlibPackageNotFound of findlib_name type group_t = | Container of findlib_name * group_t list | Package of (findlib_name * common_section * build_section * [`Library of library | `Object of object_] * group_t list) type data = common_section * build_section * [`Library of library | `Object of object_] type tree = | Node of (data option) * (tree MapString.t) | Leaf of data let findlib_mapping pkg = (* Map from library name to either full findlib name or parts + parent. *) let fndlb_parts_of_lib_name = let fndlb_parts cs lib = let name = match lib.lib_findlib_name with | Some nm -> nm | None -> cs.cs_name in let name = String.concat "." (lib.lib_findlib_containers @ [name]) in name in List.fold_left (fun mp -> function | Library (cs, _, lib) -> begin let lib_name = cs.cs_name in let fndlb_parts = fndlb_parts cs lib in if MapString.mem lib_name mp then failwithf (f_ "The library name '%s' is used more than once.") lib_name; match lib.lib_findlib_parent with | Some lib_name_parent -> MapString.add lib_name (`Unsolved (lib_name_parent, fndlb_parts)) mp | None -> MapString.add lib_name (`Solved fndlb_parts) mp end | Object (cs, _, obj) -> begin let obj_name = cs.cs_name in if MapString.mem obj_name mp then failwithf (f_ "The object name '%s' is used more than once.") obj_name; let findlib_full_name = match obj.obj_findlib_fullname with | Some ns -> String.concat "." ns | None -> obj_name in MapString.add obj_name (`Solved findlib_full_name) mp end | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> mp) MapString.empty pkg.sections in (* Solve the above graph to be only library name to full findlib name. *) let fndlb_name_of_lib_name = let rec solve visited mp lib_name lib_name_child = if SetString.mem lib_name visited then failwithf (f_ "Library '%s' is involved in a cycle \ with regard to findlib naming.") lib_name; let visited = SetString.add lib_name visited in try match MapString.find lib_name mp with | `Solved fndlb_nm -> fndlb_nm, mp | `Unsolved (lib_nm_parent, post_fndlb_nm) -> let pre_fndlb_nm, mp = solve visited mp lib_nm_parent lib_name in let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp with Not_found -> failwithf (f_ "Library '%s', which is defined as the findlib parent of \ library '%s', doesn't exist.") lib_name lib_name_child in let mp = MapString.fold (fun lib_name status mp -> match status with | `Solved _ -> (* Solved initialy, no need to go further *) mp | `Unsolved _ -> let _, mp = solve SetString.empty mp lib_name "" in mp) fndlb_parts_of_lib_name fndlb_parts_of_lib_name in MapString.map (function | `Solved fndlb_nm -> fndlb_nm | `Unsolved _ -> assert false) mp in (* Convert an internal library name to a findlib name. *) let findlib_name_of_library_name lib_nm = try MapString.find lib_nm fndlb_name_of_lib_name with Not_found -> raise (InternalLibraryNotFound lib_nm) in (* Add a library to the tree. *) let add sct mp = let fndlb_fullname = let cs, _, _ = sct in let lib_name = cs.cs_name in findlib_name_of_library_name lib_name in let rec add_children nm_lst (children: tree MapString.t) = match nm_lst with | (hd :: tl) -> begin let node = try add_node tl (MapString.find hd children) with Not_found -> (* New node *) new_node tl in MapString.add hd node children end | [] -> (* Should not have a nameless library. *) assert false and add_node tl node = if tl = [] then begin match node with | Node (None, children) -> Node (Some sct, children) | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> (* TODO: allow to merge Package, i.e. * archive(byte) = "foo.cma foo_init.cmo" *) let cs, _, _ = sct in failwithf (f_ "Library '%s' and '%s' have the same findlib name '%s'") cs.cs_name cs'.cs_name fndlb_fullname end else begin match node with | Leaf data -> Node (Some data, add_children tl MapString.empty) | Node (data_opt, children) -> Node (data_opt, add_children tl children) end and new_node = function | [] -> Leaf sct | hd :: tl -> Node (None, MapString.add hd (new_node tl) MapString.empty) in add_children (OASISString.nsplit fndlb_fullname '.') mp in let rec group_of_tree mp = MapString.fold (fun nm node acc -> let cur = match node with | Node (Some (cs, bs, lib), children) -> Package (nm, cs, bs, lib, group_of_tree children) | Node (None, children) -> Container (nm, group_of_tree children) | Leaf (cs, bs, lib) -> Package (nm, cs, bs, lib, []) in cur :: acc) mp [] in let group_mp = List.fold_left (fun mp -> function | Library (cs, bs, lib) -> add (cs, bs, `Library lib) mp | Object (cs, bs, obj) -> add (cs, bs, `Object obj) mp | _ -> mp) MapString.empty pkg.sections in let groups = group_of_tree group_mp in let library_name_of_findlib_name = lazy begin (* Revert findlib_name_of_library_name. *) MapString.fold (fun k v mp -> MapString.add v k mp) fndlb_name_of_lib_name MapString.empty end in let library_name_of_findlib_name fndlb_nm = try MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) with Not_found -> raise (FindlibPackageNotFound fndlb_nm) in groups, findlib_name_of_library_name, library_name_of_findlib_name let findlib_of_group = function | Container (fndlb_nm, _) | Package (fndlb_nm, _, _, _, _) -> fndlb_nm let root_of_group grp = let rec root_lib_aux = (* We do a DFS in the group. *) function | Container (_, children) -> List.fold_left (fun res grp -> if res = None then root_lib_aux grp else res) None children | Package (_, cs, bs, lib, _) -> Some (cs, bs, lib) in match root_lib_aux grp with | Some res -> res | None -> failwithf (f_ "Unable to determine root library of findlib library '%s'") (findlib_of_group grp) end module OASISFlag = struct (* # 22 "src/oasis/OASISFlag.ml" *) end module OASISPackage = struct (* # 22 "src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct (* # 22 "src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct (* # 22 "src/oasis/OASISTest.ml" *) end module OASISDocument = struct (* # 22 "src/oasis/OASISDocument.ml" *) end module OASISExec = struct (* # 22 "src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils open OASISMessage (* TODO: I don't like this quote, it is there because $(rm) foo expands to * 'rm -f' foo... *) let run ~ctxt ?f_exit_code ?(quote=true) cmd args = let cmd = if quote then if Sys.os_type = "Win32" then if String.contains cmd ' ' then (* Double the 1st double quote... win32... sigh *) "\""^(Filename.quote cmd) else cmd else Filename.quote cmd else cmd in let cmdline = String.concat " " (cmd :: args) in info ~ctxt (f_ "Running command '%s'") cmdline; match f_exit_code, Sys.command cmdline with | None, 0 -> () | None, i -> failwithf (f_ "Command '%s' terminated with error code %d") cmdline i | Some f, i -> f i let run_read_output ~ctxt ?f_exit_code cmd args = let fn = Filename.temp_file "oasis-" ".txt" in try begin let () = run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) in let chn = open_in fn in let routput = ref [] in begin try while true do routput := (input_line chn) :: !routput done with End_of_file -> () end; close_in chn; Sys.remove fn; List.rev !routput end with e -> (try Sys.remove fn with _ -> ()); raise e let run_read_one_line ~ctxt ?f_exit_code cmd args = match run_read_output ~ctxt ?f_exit_code cmd args with | [fst] -> fst | lst -> failwithf (f_ "Command return unexpected output %S") (String.concat "\n" lst) end module OASISFileUtil = struct (* # 22 "src/oasis/OASISFileUtil.ml" *) open OASISGettext let file_exists_case fn = let dirname = Filename.dirname fn in let basename = Filename.basename fn in if Sys.file_exists dirname then if basename = Filename.current_dir_name then true else List.mem basename (Array.to_list (Sys.readdir dirname)) else false let find_file ?(case_sensitive=true) paths exts = (* Cardinal product of two list *) let ( * ) lst1 lst2 = List.flatten (List.map (fun a -> List.map (fun b -> a, b) lst2) lst1) in let rec combined_paths lst = match lst with | p1 :: p2 :: tl -> let acc = (List.map (fun (a, b) -> Filename.concat a b) (p1 * p2)) in combined_paths (acc :: tl) | [e] -> e | [] -> [] in let alternatives = List.map (fun (p, e) -> if String.length e > 0 && e.[0] <> '.' then p ^ "." ^ e else p ^ e) ((combined_paths paths) * exts) in List.find (fun file -> (if case_sensitive then file_exists_case file else Sys.file_exists file) && not (Sys.is_directory file) ) alternatives let which ~ctxt prg = let path_sep = match Sys.os_type with | "Win32" -> ';' | _ -> ':' in let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in let exec_ext = match Sys.os_type with | "Win32" -> "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) | _ -> [""] in find_file ~case_sensitive:false [path_lst; [prg]] exec_ext (**/**) let rec fix_dir dn = (* Windows hack because Sys.file_exists "src\\" = false when * Sys.file_exists "src" = true *) let ln = String.length dn in if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then fix_dir (String.sub dn 0 (ln - 1)) else dn let q = Filename.quote (**/**) let cp ~ctxt ?(recurse=false) src tgt = if recurse then match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "xcopy" [q src; q tgt; "/E"] | _ -> OASISExec.run ~ctxt "cp" ["-r"; q src; q tgt] else OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "copy" | _ -> "cp") [q src; q tgt] let mkdir ~ctxt tgt = OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "md" | _ -> "mkdir") [q tgt] let rec mkdir_parent ~ctxt f tgt = let tgt = fix_dir tgt in if Sys.file_exists tgt then begin if not (Sys.is_directory tgt) then OASISUtils.failwithf (f_ "Cannot create directory '%s', a file of the same name already \ exists") tgt end else begin mkdir_parent ~ctxt f (Filename.dirname tgt); if not (Sys.file_exists tgt) then begin f tgt; mkdir ~ctxt tgt end end let rmdir ~ctxt tgt = if Sys.readdir tgt = [||] then begin match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "rd" [q tgt] | _ -> OASISExec.run ~ctxt "rm" ["-r"; q tgt] end else begin OASISMessage.error ~ctxt (f_ "Cannot remove directory '%s': not empty.") tgt end let glob ~ctxt fn = let basename = Filename.basename fn in if String.length basename >= 2 && basename.[0] = '*' && basename.[1] = '.' then begin let ext_len = (String.length basename) - 2 in let ext = String.sub basename 2 ext_len in let dirname = Filename.dirname fn in Array.fold_left (fun acc fn -> try let fn_ext = String.sub fn ((String.length fn) - ext_len) ext_len in if fn_ext = ext then (Filename.concat dirname fn) :: acc else acc with Invalid_argument _ -> acc) [] (Sys.readdir dirname) end else begin if file_exists_case fn then [fn] else [] end end # 2916 "setup.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) type t = string MapString.t let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" let load ?(allow_empty=false) ?(filename=default_filename) () = if Sys.file_exists filename then begin let chn = open_in_bin filename in let st = Stream.of_channel chn in let line = ref 1 in let st_line = Stream.from (fun _ -> try match Stream.next st with | '\n' -> incr line; Some '\n' | c -> Some c with Stream.Failure -> None) in let lexer = Genlex.make_lexer ["="] st_line in let rec read_file mp = match Stream.npeek 3 lexer with | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> Stream.junk lexer; Stream.junk lexer; Stream.junk lexer; read_file (MapString.add nm value mp) | [] -> mp | _ -> failwith (Printf.sprintf "Malformed data file '%s' line %d" filename !line) in let mp = read_file MapString.empty in close_in chn; mp end else if allow_empty then begin MapString.empty end else begin failwith (Printf.sprintf "Unable to load environment, the file '%s' doesn't exist." filename) end let rec var_expand str env = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) env with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff let var_get name env = var_expand (MapString.find name env) env let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end # 3021 "setup.ml" module BaseContext = struct (* # 22 "src/base/BaseContext.ml" *) (* TODO: get rid of this module. *) open OASISContext let args () = fst (fspecs ()) let default = default end module BaseMessage = struct (* # 22 "src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall *) open OASISMessage open BaseContext let debug fmt = debug ~ctxt:!default fmt let info fmt = info ~ctxt:!default fmt let warning fmt = warning ~ctxt:!default fmt let error fmt = error ~ctxt:!default fmt end module BaseEnv = struct (* # 22 "src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils open PropList module MapString = BaseEnvLight.MapString type origin_t = | ODefault | OGetEnv | OFileLoad | OCommandLine type cli_handle_t = | CLINone | CLIAuto | CLIWith | CLIEnable | CLIUser of (Arg.key * Arg.spec * Arg.doc) list type definition_t = { hide: bool; dump: bool; cli: cli_handle_t; arg_help: string option; group: string option; } let schema = Schema.create "environment" (* Environment data *) let env = Data.create () (* Environment data from file *) let env_from_file = ref MapString.empty (* Lexer for var *) let var_lxr = Genlex.make_lexer [] let rec var_expand str = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try (* TODO: this is a quick hack to allow calling Test.Command * without defining executable name really. I.e. if there is * an exec Executable toto, then $(toto) should be replace * by its real name. It is however useful to have this function * for other variable that depend on the host and should be * written better than that. *) let st = var_lxr (Stream.of_string var) in match Stream.npeek 3 st with | [Genlex.Ident "utoh"; Genlex.Ident nm] -> OASISHostPath.of_unix (var_get nm) | [Genlex.Ident "utoh"; Genlex.String s] -> OASISHostPath.of_unix s | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> String.escaped (var_get nm) | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> String.escaped s | [Genlex.Ident nm] -> var_get nm | _ -> failwithf (f_ "Unknown expression '%s' in variable expansion of %s.") var str with | Unknown_field (_, _) -> failwithf (f_ "No variable %s defined when trying to expand %S.") var str | Stream.Error e -> failwithf (f_ "Syntax error when parsing '%s' when trying to \ expand %S: %s") var str e) str; Buffer.contents buff and var_get name = let vl = try Schema.get schema env name with Unknown_field _ as e -> begin try MapString.find name !env_from_file with Not_found -> raise e end in var_expand vl let var_choose ?printer ?name lst = OASISExpr.choose ?printer ?name var_get lst let var_protect vl = let buff = Buffer.create (String.length vl) in String.iter (function | '$' -> Buffer.add_string buff "\\$" | c -> Buffer.add_char buff c) vl; Buffer.contents buff let var_define ?(hide=false) ?(dump=true) ?short_desc ?(cli=CLINone) ?arg_help ?group name (* TODO: type constraint on the fact that name must be a valid OCaml id *) dflt = let default = [ OFileLoad, (fun () -> MapString.find name !env_from_file); ODefault, dflt; OGetEnv, (fun () -> Sys.getenv name); ] in let extra = { hide = hide; dump = dump; cli = cli; arg_help = arg_help; group = group; } in (* Try to find a value that can be defined *) let var_get_low lst = let errors, res = List.fold_left (fun (errors, res) (o, v) -> if res = None then begin try errors, Some (v ()) with | Not_found -> errors, res | Failure rsn -> (rsn :: errors), res | e -> (Printexc.to_string e) :: errors, res end else errors, res) ([], None) (List.sort (fun (o1, _) (o2, _) -> Pervasives.compare o2 o1) lst) in match res, errors with | Some v, _ -> v | None, [] -> raise (Not_set (name, None)) | None, lst -> raise (Not_set (name, Some (String.concat (s_ ", ") lst))) in let help = match short_desc with | Some fs -> Some fs | None -> None in let var_get_lst = FieldRO.create ~schema ~name ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) ~print:var_get_low ~default ~update:(fun ?context x old_x -> x @ old_x) ?help extra in fun () -> var_expand (var_get_low (var_get_lst env)) let var_redefine ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt = if Schema.mem schema name then begin (* TODO: look suspsicious, we want to memorize dflt not dflt () *) Schema.set schema env ~context:ODefault name (dflt ()); fun () -> var_get name end else begin var_define ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt end let var_ignore (e: unit -> string) = () let print_hidden = var_define ~hide:true ~dump:false ~cli:CLIAuto ~arg_help:"Print even non-printable variable. (debug)" "print_hidden" (fun () -> "false") let var_all () = List.rev (Schema.fold (fun acc nm def _ -> if not def.hide || bool_of_string (print_hidden ()) then nm :: acc else acc) [] schema) let default_filename = BaseEnvLight.default_filename let load ?allow_empty ?filename () = env_from_file := BaseEnvLight.load ?allow_empty ?filename () let unload () = env_from_file := MapString.empty; Data.clear env let dump ?(filename=default_filename) () = let chn = open_out_bin filename in let output nm value = Printf.fprintf chn "%s=%S\n" nm value in let mp_todo = (* Dump data from schema *) Schema.fold (fun mp_todo nm def _ -> if def.dump then begin try let value = Schema.get schema env nm in output nm value with Not_set _ -> () end; MapString.remove nm mp_todo) !env_from_file schema in (* Dump data defined outside of schema *) MapString.iter output mp_todo; (* End of the dump *) close_out chn let print () = let printable_vars = Schema.fold (fun acc nm def short_descr_opt -> if not def.hide || bool_of_string (print_hidden ()) then begin try let value = Schema.get schema env nm in let txt = match short_descr_opt with | Some s -> s () | None -> nm in (txt, value) :: acc with Not_set _ -> acc end else acc) [] schema in let max_length = List.fold_left max 0 (List.rev_map String.length (List.rev_map fst printable_vars)) in let dot_pad str = String.make ((max_length - (String.length str)) + 3) '.' in Printf.printf "\nConfiguration: \n"; List.iter (fun (name, value) -> Printf.printf "%s: %s %s\n" name (dot_pad name) value) (List.rev printable_vars); Printf.printf "\n%!" let args () = let arg_concat = OASISUtils.varname_concat ~hyphen:'-' in [ "--override", Arg.Tuple ( let rvr = ref "" in let rvl = ref "" in [ Arg.Set_string rvr; Arg.Set_string rvl; Arg.Unit (fun () -> Schema.set schema env ~context:OCommandLine !rvr !rvl) ] ), "var+val Override any configuration variable."; ] @ List.flatten (Schema.fold (fun acc name def short_descr_opt -> let var_set s = Schema.set schema env ~context:OCommandLine name s in let arg_name = OASISUtils.varname_of_string ~hyphen:'-' name in let hlp = match short_descr_opt with | Some txt -> txt () | None -> "" in let arg_hlp = match def.arg_help with | Some s -> s | None -> "str" in let default_value = try Printf.sprintf (f_ " [%s]") (Schema.get schema env name) with Not_set _ -> "" in let args = match def.cli with | CLINone -> [] | CLIAuto -> [ arg_concat "--" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIWith -> [ arg_concat "--with-" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIEnable -> let dflt = if default_value = " [true]" then s_ " [default: enabled]" else s_ " [default: disabled]" in [ arg_concat "--enable-" arg_name, Arg.Unit (fun () -> var_set "true"), Printf.sprintf (f_ " %s%s") hlp dflt; arg_concat "--disable-" arg_name, Arg.Unit (fun () -> var_set "false"), Printf.sprintf (f_ " %s%s") hlp dflt ] | CLIUser lst -> lst in args :: acc) [] schema) end module BaseArgExt = struct (* # 22 "src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext let parse argv args = (* Simulate command line for Arg *) let current = ref 0 in try Arg.parse_argv ~current:current (Array.concat [[|"none"|]; argv]) (Arg.align args) (failwithf (f_ "Don't know what to do with arguments: '%s'")) (s_ "configure options:") with | Arg.Help txt -> print_endline txt; exit 0 | Arg.Bad txt -> prerr_endline txt; exit 1 end module BaseCheck = struct (* # 22 "src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage open OASISUtils open OASISGettext let prog_best prg prg_lst = var_redefine prg (fun () -> let alternate = List.fold_left (fun res e -> match res with | Some _ -> res | None -> try Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) with Not_found -> None) None prg_lst in match alternate with | Some prg -> prg | None -> raise Not_found) let prog prg = prog_best prg [prg] let prog_opt prg = prog_best prg [prg^".opt"; prg] let ocamlfind = prog "ocamlfind" let version var_prefix cmp fversion () = (* Really compare version provided *) let var = var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) in var_redefine ~hide:true var (fun () -> let version_str = match fversion () with | "[Distributed with OCaml]" -> begin try (var_get "ocaml_version") with Not_found -> warning (f_ "Variable ocaml_version not defined, fallback \ to default"); Sys.ocaml_version end | res -> res in let version = OASISVersion.version_of_string version_str in if OASISVersion.comparator_apply version cmp then version_str else failwithf (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") var_prefix (OASISVersion.string_of_comparator cmp) version_str) () let package_version pkg = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%v"; pkg] let package ?version_comparator pkg () = let var = OASISUtils.varname_concat "pkg_" (OASISUtils.varname_of_string pkg) in let findlib_dir pkg = let dir = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%d"; pkg] in if Sys.file_exists dir && Sys.is_directory dir then dir else failwithf (f_ "When looking for findlib package %s, \ directory %s return doesn't exist") pkg dir in let vl = var_redefine var (fun () -> findlib_dir pkg) () in ( match version_comparator with | Some ver_cmp -> ignore (version var ver_cmp (fun _ -> package_version pkg) ()) | None -> () ); vl end module BaseOCamlcConfig = struct (* # 22 "src/base/BaseOCamlcConfig.ml" *) open BaseEnv open OASISUtils open OASISGettext module SMap = Map.Make(String) let ocamlc = BaseCheck.prog_opt "ocamlc" let ocamlc_config_map = (* Map name to value for ocamlc -config output (name ^": "^value) *) let rec split_field mp lst = match lst with | line :: tl -> let mp = try let pos_semicolon = String.index line ':' in if pos_semicolon > 1 then ( let name = String.sub line 0 pos_semicolon in let linelen = String.length line in let value = if linelen > pos_semicolon + 2 then String.sub line (pos_semicolon + 2) (linelen - pos_semicolon - 2) else "" in SMap.add name value mp ) else ( mp ) with Not_found -> ( mp ) in split_field mp tl | [] -> mp in let cache = lazy (var_protect (Marshal.to_string (split_field SMap.empty (OASISExec.run_read_output ~ctxt:!BaseContext.default (ocamlc ()) ["-config"])) [])) in var_redefine "ocamlc_config_map" ~hide:true ~dump:false (fun () -> (* TODO: update if ocamlc change !!! *) Lazy.force cache) let var_define nm = (* Extract data from ocamlc -config *) let avlbl_config_get () = Marshal.from_string (ocamlc_config_map ()) 0 in let chop_version_suffix s = try String.sub s 0 (String.index s '+') with _ -> s in let nm_config, value_config = match nm with | "ocaml_version" -> "version", chop_version_suffix | _ -> nm, (fun x -> x) in var_redefine nm (fun () -> try let map = avlbl_config_get () in let value = SMap.find nm_config map in value_config value with Not_found -> failwithf (f_ "Cannot find field '%s' in '%s -config' output") nm (ocamlc ())) end module BaseStandardVar = struct (* # 22 "src/base/BaseStandardVar.ml" *) open OASISGettext open OASISTypes open OASISExpr open BaseCheck open BaseEnv let ocamlfind = BaseCheck.ocamlfind let ocamlc = BaseOCamlcConfig.ocamlc let ocamlopt = prog_opt "ocamlopt" let ocamlbuild = prog "ocamlbuild" (**/**) let rpkg = ref None let pkg_get () = match !rpkg with | Some pkg -> pkg | None -> failwith (s_ "OASIS Package is not set") let var_cond = ref [] let var_define_cond ~since_version f dflt = let holder = ref (fun () -> dflt) in let since_version = OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) in var_cond := (fun ver -> if OASISVersion.comparator_apply ver since_version then holder := f ()) :: !var_cond; fun () -> !holder () (**/**) let pkg_name = var_define ~short_desc:(fun () -> s_ "Package name") "pkg_name" (fun () -> (pkg_get ()).name) let pkg_version = var_define ~short_desc:(fun () -> s_ "Package version") "pkg_version" (fun () -> (OASISVersion.string_of_version (pkg_get ()).version)) let c = BaseOCamlcConfig.var_define let os_type = c "os_type" let system = c "system" let architecture = c "architecture" let ccomp_type = c "ccomp_type" let ocaml_version = c "ocaml_version" (* TODO: Check standard variable presence at runtime *) let standard_library_default = c "standard_library_default" let standard_library = c "standard_library" let standard_runtime = c "standard_runtime" let bytecomp_c_compiler = c "bytecomp_c_compiler" let native_c_compiler = c "native_c_compiler" let model = c "model" let ext_obj = c "ext_obj" let ext_asm = c "ext_asm" let ext_lib = c "ext_lib" let ext_dll = c "ext_dll" let default_executable_name = c "default_executable_name" let systhread_supported = c "systhread_supported" let flexlink = BaseCheck.prog "flexlink" let flexdll_version = var_define ~short_desc:(fun () -> "FlexDLL version (Win32)") "flexdll_version" (fun () -> let lst = OASISExec.run_read_output ~ctxt:!BaseContext.default (flexlink ()) ["-help"] in match lst with | line :: _ -> Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) | [] -> raise Not_found) (**/**) let p name hlp dflt = var_define ~short_desc:hlp ~cli:CLIAuto ~arg_help:"dir" name dflt let (/) a b = if os_type () = Sys.os_type then Filename.concat a b else if os_type () = "Unix" then OASISUnixPath.concat a b else OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") (os_type ()) (**/**) let prefix = p "prefix" (fun () -> s_ "Install architecture-independent files dir") (fun () -> match os_type () with | "Win32" -> let program_files = Sys.getenv "PROGRAMFILES" in program_files/(pkg_name ()) | _ -> "/usr/local") let exec_prefix = p "exec_prefix" (fun () -> s_ "Install architecture-dependent files in dir") (fun () -> "$prefix") let bindir = p "bindir" (fun () -> s_ "User executables") (fun () -> "$exec_prefix"/"bin") let sbindir = p "sbindir" (fun () -> s_ "System admin executables") (fun () -> "$exec_prefix"/"sbin") let libexecdir = p "libexecdir" (fun () -> s_ "Program executables") (fun () -> "$exec_prefix"/"libexec") let sysconfdir = p "sysconfdir" (fun () -> s_ "Read-only single-machine data") (fun () -> "$prefix"/"etc") let sharedstatedir = p "sharedstatedir" (fun () -> s_ "Modifiable architecture-independent data") (fun () -> "$prefix"/"com") let localstatedir = p "localstatedir" (fun () -> s_ "Modifiable single-machine data") (fun () -> "$prefix"/"var") let libdir = p "libdir" (fun () -> s_ "Object code libraries") (fun () -> "$exec_prefix"/"lib") let datarootdir = p "datarootdir" (fun () -> s_ "Read-only arch-independent data root") (fun () -> "$prefix"/"share") let datadir = p "datadir" (fun () -> s_ "Read-only architecture-independent data") (fun () -> "$datarootdir") let infodir = p "infodir" (fun () -> s_ "Info documentation") (fun () -> "$datarootdir"/"info") let localedir = p "localedir" (fun () -> s_ "Locale-dependent data") (fun () -> "$datarootdir"/"locale") let mandir = p "mandir" (fun () -> s_ "Man documentation") (fun () -> "$datarootdir"/"man") let docdir = p "docdir" (fun () -> s_ "Documentation root") (fun () -> "$datarootdir"/"doc"/"$pkg_name") let htmldir = p "htmldir" (fun () -> s_ "HTML documentation") (fun () -> "$docdir") let dvidir = p "dvidir" (fun () -> s_ "DVI documentation") (fun () -> "$docdir") let pdfdir = p "pdfdir" (fun () -> s_ "PDF documentation") (fun () -> "$docdir") let psdir = p "psdir" (fun () -> s_ "PS documentation") (fun () -> "$docdir") let destdir = p "destdir" (fun () -> s_ "Prepend a path when installing package") (fun () -> raise (PropList.Not_set ("destdir", Some (s_ "undefined by construct")))) let findlib_version = var_define "findlib_version" (fun () -> BaseCheck.package_version "findlib") let is_native = var_define "is_native" (fun () -> try let _s: string = ocamlopt () in "true" with PropList.Not_set _ -> let _s: string = ocamlc () in "false") let ext_program = var_define "suffix_program" (fun () -> match os_type () with | "Win32" | "Cygwin" -> ".exe" | _ -> "") let rm = var_define ~short_desc:(fun () -> s_ "Remove a file.") "rm" (fun () -> match os_type () with | "Win32" -> "del" | _ -> "rm -f") let rmdir = var_define ~short_desc:(fun () -> s_ "Remove a directory.") "rmdir" (fun () -> match os_type () with | "Win32" -> "rd" | _ -> "rm -rf") let debug = var_define ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") ~cli:CLIEnable "debug" (fun () -> "true") let profile = var_define ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") ~cli:CLIEnable "profile" (fun () -> "false") let tests = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Compile tests executable and library and run them") ~cli:CLIEnable "tests" (fun () -> "false")) "true" let docs = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Create documentations") ~cli:CLIEnable "docs" (fun () -> "true")) "true" let native_dynlink = var_define ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") ~cli:CLINone "native_dynlink" (fun () -> let res = let ocaml_lt_312 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (ocaml_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "3.12.0")) in let flexdll_lt_030 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (flexdll_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "0.30")) in let has_native_dynlink = let ocamlfind = ocamlfind () in try let fn = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ocamlfind ["query"; "-predicates"; "native"; "dynlink"; "-format"; "%d/%a"] in Sys.file_exists fn with _ -> false in if not has_native_dynlink then false else if ocaml_lt_312 () then false else if (os_type () = "Win32" || os_type () = "Cygwin") && flexdll_lt_030 () then begin BaseMessage.warning (f_ ".cmxs generation disabled because FlexDLL needs to be \ at least 0.30. Please upgrade FlexDLL from %s to 0.30.") (flexdll_version ()); false end else true in string_of_bool res) let init pkg = rpkg := Some pkg; List.iter (fun f -> f pkg.oasis_version) !var_cond end module BaseFileAB = struct (* # 22 "src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext open BaseMessage let to_filename fn = let fn = OASISHostPath.of_unix fn in if not (Filename.check_suffix fn ".ab") then warning (f_ "File '%s' doesn't have '.ab' extension") fn; Filename.chop_extension fn let replace fn_lst = let buff = Buffer.create 13 in List.iter (fun fn -> let fn = OASISHostPath.of_unix fn in let chn_in = open_in fn in let chn_out = open_out (to_filename fn) in ( try while true do Buffer.add_string buff (var_expand (input_line chn_in)); Buffer.add_char buff '\n' done with End_of_file -> () ); Buffer.output_buffer chn_out buff; Buffer.clear buff; close_in chn_in; close_out chn_out) fn_lst end module BaseLog = struct (* # 22 "src/base/BaseLog.ml" *) open OASISUtils let default_filename = Filename.concat (Filename.dirname BaseEnv.default_filename) "setup.log" module SetTupleString = Set.Make (struct type t = string * string let compare (s11, s12) (s21, s22) = match String.compare s11 s21 with | 0 -> String.compare s12 s22 | n -> n end) let load () = if Sys.file_exists default_filename then begin let chn = open_in default_filename in let scbuf = Scanf.Scanning.from_file default_filename in let rec read_aux (st, lst) = if not (Scanf.Scanning.end_of_input scbuf) then begin let acc = try Scanf.bscanf scbuf "%S %S\n" (fun e d -> let t = e, d in if SetTupleString.mem t st then st, lst else SetTupleString.add t st, t :: lst) with Scanf.Scan_failure _ -> failwith (Scanf.bscanf scbuf "%l" (fun line -> Printf.sprintf "Malformed log file '%s' at line %d" default_filename line)) in read_aux acc end else begin close_in chn; List.rev lst end in read_aux (SetTupleString.empty, []) end else begin [] end let register event data = let chn_out = open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename in Printf.fprintf chn_out "%S %S\n" event data; close_out chn_out let unregister event data = if Sys.file_exists default_filename then begin let lst = load () in let chn_out = open_out default_filename in let write_something = ref false in List.iter (fun (e, d) -> if e <> event || d <> data then begin write_something := true; Printf.fprintf chn_out "%S %S\n" e d end) lst; close_out chn_out; if not !write_something then Sys.remove default_filename end let filter events = let st_events = List.fold_left (fun st e -> SetString.add e st) SetString.empty events in List.filter (fun (e, _) -> SetString.mem e st_events) (load ()) let exists event data = List.exists (fun v -> (event, data) = v) (load ()) end module BaseBuilt = struct (* # 22 "src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext open BaseStandardVar open BaseMessage type t = | BExec (* Executable *) | BExecLib (* Library coming with executable *) | BLib (* Library *) | BObj (* Library *) | BDoc (* Document *) let to_log_event_file t nm = "built_"^ (match t with | BExec -> "exec" | BExecLib -> "exec_lib" | BLib -> "lib" | BObj -> "obj" | BDoc -> "doc")^ "_"^nm let to_log_event_done t nm = "is_"^(to_log_event_file t nm) let register t nm lst = BaseLog.register (to_log_event_done t nm) "true"; List.iter (fun alt -> let registered = List.fold_left (fun registered fn -> if OASISFileUtil.file_exists_case fn then begin BaseLog.register (to_log_event_file t nm) (if Filename.is_relative fn then Filename.concat (Sys.getcwd ()) fn else fn); true end else registered) false alt in if not registered then warning (f_ "Cannot find an existing alternative files among: %s") (String.concat (s_ ", ") alt)) lst let unregister t nm = List.iter (fun (e, d) -> BaseLog.unregister e d) (BaseLog.filter [to_log_event_file t nm; to_log_event_done t nm]) let fold t nm f acc = List.fold_left (fun acc (_, fn) -> if OASISFileUtil.file_exists_case fn then begin f acc fn end else begin warning (f_ "File '%s' has been marked as built \ for %s but doesn't exist") fn (Printf.sprintf (match t with | BExec | BExecLib -> (f_ "executable %s") | BLib -> (f_ "library %s") | BObj -> (f_ "object %s") | BDoc -> (f_ "documentation %s")) nm); acc end) acc (BaseLog.filter [to_log_event_file t nm]) let is_built t nm = List.fold_left (fun is_built (_, d) -> (try bool_of_string d with _ -> false)) false (BaseLog.filter [to_log_event_done t nm]) let of_executable ffn (cs, bs, exec) = let unix_exec_is, unix_dll_opt = OASISExecutable.unix_exec_is (cs, bs, exec) (fun () -> bool_of_string (is_native ())) ext_dll ext_program in let evs = (BExec, cs.cs_name, [[ffn unix_exec_is]]) :: (match unix_dll_opt with | Some fn -> [BExecLib, cs.cs_name, [[ffn fn]]] | None -> []) in evs, unix_exec_is, unix_dll_opt let of_library ffn (cs, bs, lib) = let unix_lst = OASISLibrary.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) ~has_native_dynlink:(bool_of_string (native_dynlink ())) ~ext_lib:(ext_lib ()) ~ext_dll:(ext_dll ()) (cs, bs, lib) in let evs = [BLib, cs.cs_name, List.map (List.map ffn) unix_lst] in evs, unix_lst let of_object ffn (cs, bs, obj) = let unix_lst = OASISObject.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) (cs, bs, obj) in let evs = [BObj, cs.cs_name, List.map (List.map ffn) unix_lst] in evs, unix_lst end module BaseCustom = struct (* # 22 "src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let run cmd args extra_args = OASISExec.run ~ctxt:!BaseContext.default ~quote:false (var_expand cmd) (List.map var_expand (args @ (Array.to_list extra_args))) let hook ?(failsafe=false) cstm f e = let optional_command lst = let printer = function | Some (cmd, args) -> String.concat " " (cmd :: args) | None -> s_ "No command" in match var_choose ~name:(s_ "Pre/Post Command") ~printer lst with | Some (cmd, args) -> begin try run cmd args [||] with e when failsafe -> warning (f_ "Command '%s' fail with error: %s") (String.concat " " (cmd :: args)) (match e with | Failure msg -> msg | e -> Printexc.to_string e) end | None -> () in let res = optional_command cstm.pre_command; f e in optional_command cstm.post_command; res end module BaseDynVar = struct (* # 22 "src/base/BaseDynVar.ml" *) open OASISTypes open OASISGettext open BaseEnv open BaseBuilt let init pkg = (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) (* TODO: provide compile option for library libary_byte_args_VARNAME... *) List.iter (function | Executable (cs, bs, exec) -> if var_choose bs.bs_build then var_ignore (var_redefine (* We don't save this variable *) ~dump:false ~short_desc:(fun () -> Printf.sprintf (f_ "Filename of executable '%s'") cs.cs_name) (OASISUtils.varname_of_string cs.cs_name) (fun () -> let fn_opt = fold BExec cs.cs_name (fun _ fn -> Some fn) None in match fn_opt with | Some fn -> fn | None -> raise (PropList.Not_set (cs.cs_name, Some (Printf.sprintf (f_ "Executable '%s' not yet built.") cs.cs_name))))) | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> ()) pkg.sections end module BaseTest = struct (* # 22 "src/base/BaseTest.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISExpr open OASISGettext let test lst pkg extra_args = let one_test (failure, n) (test_plugin, cs, test) = if var_choose ~name:(Printf.sprintf (f_ "test %s run") cs.cs_name) ~printer:string_of_bool test.test_run then begin let () = info (f_ "Running test '%s'") cs.cs_name in let back_cwd = match test.test_working_directory with | Some dir -> let cwd = Sys.getcwd () in let chdir d = info (f_ "Changing directory to '%s'") d; Sys.chdir d in chdir dir; fun () -> chdir cwd | None -> fun () -> () in try let failure_percent = BaseCustom.hook test.test_custom (test_plugin pkg (cs, test)) extra_args in back_cwd (); (failure_percent +. failure, n + 1) with e -> begin back_cwd (); raise e end end else begin info (f_ "Skipping test '%s'") cs.cs_name; (failure, n) end in let failed, n = List.fold_left one_test (0.0, 0) lst in let failure_percent = if n = 0 then 0.0 else failed /. (float_of_int n) in let msg = Printf.sprintf (f_ "Tests had a %.2f%% failure rate") (100. *. failure_percent) in if failure_percent > 0.0 then failwith msg else info "%s" msg; (* Possible explanation why the tests where not run. *) if OASISFeatures.package_test OASISFeatures.flag_tests pkg && not (bool_of_string (BaseStandardVar.tests ())) && lst <> [] then BaseMessage.warning "Tests are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-tests'" end module BaseDoc = struct (* # 22 "src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let doc lst pkg extra_args = let one_doc (doc_plugin, cs, doc) = if var_choose ~name:(Printf.sprintf (f_ "documentation %s build") cs.cs_name) ~printer:string_of_bool doc.doc_build then begin info (f_ "Building documentation '%s'") cs.cs_name; BaseCustom.hook doc.doc_custom (doc_plugin pkg (cs, doc)) extra_args end in List.iter one_doc lst; if OASISFeatures.package_test OASISFeatures.flag_docs pkg && not (bool_of_string (BaseStandardVar.docs ())) && lst <> [] then BaseMessage.warning "Docs are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-docs'" end module BaseSetup = struct (* # 22 "src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISSection open OASISGettext open OASISUtils type std_args_fun = package -> string array -> unit type ('a, 'b) section_args_fun = name * (package -> (common_section * 'a) -> string array -> 'b) type t = { configure: std_args_fun; build: std_args_fun; doc: ((doc, unit) section_args_fun) list; test: ((test, float) section_args_fun) list; install: std_args_fun; uninstall: std_args_fun; clean: std_args_fun list; clean_doc: (doc, unit) section_args_fun list; clean_test: (test, unit) section_args_fun list; distclean: std_args_fun list; distclean_doc: (doc, unit) section_args_fun list; distclean_test: (test, unit) section_args_fun list; package: package; oasis_fn: string option; oasis_version: string; oasis_digest: Digest.t option; oasis_exec: string option; oasis_setup_args: string list; setup_update: bool; } (* Associate a plugin function with data from package *) let join_plugin_sections filter_map lst = List.rev (List.fold_left (fun acc sct -> match filter_map sct with | Some e -> e :: acc | None -> acc) [] lst) (* Search for plugin data associated with a section name *) let lookup_plugin_section plugin action nm lst = try List.assoc nm lst with Not_found -> failwithf (f_ "Cannot find plugin %s matching section %s for %s action") plugin nm action let configure t args = (* Run configure *) BaseCustom.hook t.package.conf_custom (fun () -> (* Reload if preconf has changed it *) begin try unload (); load (); with _ -> () end; (* Run plugin's configure *) t.configure t.package args; (* Dump to allow postconf to change it *) dump ()) (); (* Reload environment *) unload (); load (); (* Save environment *) print (); (* Replace data in file *) BaseFileAB.replace t.package.files_ab let build t args = BaseCustom.hook t.package.build_custom (t.build t.package) args let doc t args = BaseDoc.doc (join_plugin_sections (function | Doc (cs, e) -> Some (lookup_plugin_section "documentation" (s_ "build") cs.cs_name t.doc, cs, e) | _ -> None) t.package.sections) t.package args let test t args = BaseTest.test (join_plugin_sections (function | Test (cs, e) -> Some (lookup_plugin_section "test" (s_ "run") cs.cs_name t.test, cs, e) | _ -> None) t.package.sections) t.package args let all t args = let rno_doc = ref false in let rno_test = ref false in let arg_rest = ref [] in Arg.parse_argv ~current:(ref 0) (Array.of_list ((Sys.executable_name^" all") :: (Array.to_list args))) [ "-no-doc", Arg.Set rno_doc, s_ "Don't run doc target"; "-no-test", Arg.Set rno_test, s_ "Don't run test target"; "--", Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), s_ "All arguments for configure."; ] (failwithf (f_ "Don't know what to do with '%s'")) ""; info "Running configure step"; configure t (Array.of_list (List.rev !arg_rest)); info "Running build step"; build t [||]; (* Load setup.log dynamic variables *) BaseDynVar.init t.package; if not !rno_doc then begin info "Running doc step"; doc t [||]; end else begin info "Skipping doc step" end; if not !rno_test then begin info "Running test step"; test t [||] end else begin info "Skipping test step" end let install t args = BaseCustom.hook t.package.install_custom (t.install t.package) args let uninstall t args = BaseCustom.hook t.package.uninstall_custom (t.uninstall t.package) args let reinstall t args = uninstall t args; install t args let clean, distclean = let failsafe f a = try f a with e -> warning (f_ "Action fail with error: %s") (match e with | Failure msg -> msg | e -> Printexc.to_string e) in let generic_clean t cstm mains docs tests args = BaseCustom.hook ~failsafe:true cstm (fun () -> (* Clean section *) List.iter (function | Test (cs, test) -> let f = try List.assoc cs.cs_name tests with Not_found -> fun _ _ _ -> () in failsafe (f t.package (cs, test)) args | Doc (cs, doc) -> let f = try List.assoc cs.cs_name docs with Not_found -> fun _ _ _ -> () in failsafe (f t.package (cs, doc)) args | Library _ | Object _ | Executable _ | Flag _ | SrcRepo _ -> ()) t.package.sections; (* Clean whole package *) List.iter (fun f -> failsafe (f t.package) args) mains) () in let clean t args = generic_clean t t.package.clean_custom t.clean t.clean_doc t.clean_test args in let distclean t args = (* Call clean *) clean t args; (* Call distclean code *) generic_clean t t.package.distclean_custom t.distclean t.distclean_doc t.distclean_test args; (* Remove generated file *) List.iter (fun fn -> if Sys.file_exists fn then begin info (f_ "Remove '%s'") fn; Sys.remove fn end) (BaseEnv.default_filename :: BaseLog.default_filename :: (List.rev_map BaseFileAB.to_filename t.package.files_ab)) in clean, distclean let version t _ = print_endline t.oasis_version let update_setup_ml, no_update_setup_ml_cli = let b = ref true in b, ("-no-update-setup-ml", Arg.Clear b, s_ " Don't try to update setup.ml, even if _oasis has changed.") let default_oasis_fn = "_oasis" let update_setup_ml t = let oasis_fn = match t.oasis_fn with | Some fn -> fn | None -> default_oasis_fn in let oasis_exec = match t.oasis_exec with | Some fn -> fn | None -> "oasis" in let ocaml = Sys.executable_name in let setup_ml, args = match Array.to_list Sys.argv with | setup_ml :: args -> setup_ml, args | [] -> failwith (s_ "Expecting non-empty command line arguments.") in let ocaml, setup_ml = if Sys.executable_name = Sys.argv.(0) then (* We are not running in standard mode, probably the script * is precompiled. *) "ocaml", "setup.ml" else ocaml, setup_ml in let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in let do_update () = let oasis_exec_version = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ~f_exit_code: (function | 0 -> () | 1 -> failwithf (f_ "Executable '%s' is probably an old version \ of oasis (< 0.3.0), please update to version \ v%s.") oasis_exec t.oasis_version | 127 -> failwithf (f_ "Cannot find executable '%s', please install \ oasis v%s.") oasis_exec t.oasis_version | n -> failwithf (f_ "Command '%s version' exited with code %d.") oasis_exec n) oasis_exec ["version"] in if OASISVersion.comparator_apply (OASISVersion.version_of_string oasis_exec_version) (OASISVersion.VGreaterEqual (OASISVersion.version_of_string t.oasis_version)) then begin (* We have a version >= for the executable oasis, proceed with * update. *) (* TODO: delegate this check to 'oasis setup'. *) if Sys.os_type = "Win32" then failwithf (f_ "It is not possible to update the running script \ setup.ml on Windows. Please update setup.ml by \ running '%s'.") (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) else begin OASISExec.run ~ctxt:!BaseContext.default ~f_exit_code: (function | 0 -> () | n -> failwithf (f_ "Unable to update setup.ml using '%s', \ please fix the problem and retry.") oasis_exec) oasis_exec ("setup" :: t.oasis_setup_args); OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) end end else failwithf (f_ "The version of '%s' (v%s) doesn't match the version of \ oasis used to generate the %s file. Please install at \ least oasis v%s.") oasis_exec oasis_exec_version setup_ml t.oasis_version in if !update_setup_ml then begin try match t.oasis_digest with | Some dgst -> if Sys.file_exists oasis_fn && dgst <> Digest.file default_oasis_fn then begin do_update (); true end else false | None -> false with e -> error (f_ "Error when updating setup.ml. If you want to avoid this error, \ you can bypass the update of %s by running '%s %s %s %s'") setup_ml ocaml setup_ml no_update_setup_ml_cli (String.concat " " args); raise e end else false let setup t = let catch_exn = ref true in try let act_ref = ref (fun _ -> failwithf (f_ "No action defined, run '%s %s -help'") Sys.executable_name Sys.argv.(0)) in let extra_args_ref = ref [] in let allow_empty_env_ref = ref false in let arg_handle ?(allow_empty_env=false) act = Arg.Tuple [ Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); Arg.Unit (fun () -> allow_empty_env_ref := allow_empty_env; act_ref := act); ] in Arg.parse (Arg.align ([ "-configure", arg_handle ~allow_empty_env:true configure, s_ "[options*] Configure the whole build process."; "-build", arg_handle build, s_ "[options*] Build executables and libraries."; "-doc", arg_handle doc, s_ "[options*] Build documents."; "-test", arg_handle test, s_ "[options*] Run tests."; "-all", arg_handle ~allow_empty_env:true all, s_ "[options*] Run configure, build, doc and test targets."; "-install", arg_handle install, s_ "[options*] Install libraries, data, executables \ and documents."; "-uninstall", arg_handle uninstall, s_ "[options*] Uninstall libraries, data, executables \ and documents."; "-reinstall", arg_handle reinstall, s_ "[options*] Uninstall and install libraries, data, \ executables and documents."; "-clean", arg_handle ~allow_empty_env:true clean, s_ "[options*] Clean files generated by a build."; "-distclean", arg_handle ~allow_empty_env:true distclean, s_ "[options*] Clean files generated by a build and configure."; "-version", arg_handle ~allow_empty_env:true version, s_ " Display version of OASIS used to generate this setup.ml."; "-no-catch-exn", Arg.Clear catch_exn, s_ " Don't catch exception, useful for debugging."; ] @ (if t.setup_update then [no_update_setup_ml_cli] else []) @ (BaseContext.args ()))) (failwithf (f_ "Don't know what to do with '%s'")) (s_ "Setup and run build process current package\n"); (* Build initial environment *) load ~allow_empty:!allow_empty_env_ref (); (** Initialize flags *) List.iter (function | Flag (cs, {flag_description = hlp; flag_default = choices}) -> begin let apply ?short_desc () = var_ignore (var_define ~cli:CLIEnable ?short_desc (OASISUtils.varname_of_string cs.cs_name) (fun () -> string_of_bool (var_choose ~name:(Printf.sprintf (f_ "default value of flag %s") cs.cs_name) ~printer:string_of_bool choices))) in match hlp with | Some hlp -> apply ~short_desc:(fun () -> hlp) () | None -> apply () end | _ -> ()) t.package.sections; BaseStandardVar.init t.package; BaseDynVar.init t.package; if t.setup_update && update_setup_ml t then () else !act_ref t (Array.of_list (List.rev !extra_args_ref)) with e when !catch_exn -> error "%s" (Printexc.to_string e); exit 1 end # 5432 "setup.ml" module InternalConfigurePlugin = struct (* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall *) open BaseEnv open OASISTypes open OASISUtils open OASISGettext open BaseMessage (** Configure build using provided series of check to be done * and then output corresponding file. *) let configure pkg argv = let var_ignore_eval var = let _s: string = var () in () in let errors = ref SetString.empty in let buff = Buffer.create 13 in let add_errors fmt = Printf.kbprintf (fun b -> errors := SetString.add (Buffer.contents b) !errors; Buffer.clear b) buff fmt in let warn_exception e = warning "%s" (Printexc.to_string e) in (* Check tools *) let check_tools lst = List.iter (function | ExternalTool tool -> begin try var_ignore_eval (BaseCheck.prog tool) with e -> warn_exception e; add_errors (f_ "Cannot find external tool '%s'") tool end | InternalExecutable nm1 -> (* Check that matching tool is built *) List.iter (function | Executable ({cs_name = nm2}, {bs_build = build}, _) when nm1 = nm2 -> if not (var_choose build) then add_errors (f_ "Cannot find buildable internal executable \ '%s' when checking build depends") nm1 | _ -> ()) pkg.sections) lst in let build_checks sct bs = if var_choose bs.bs_build then begin if bs.bs_compiled_object = Native then begin try var_ignore_eval BaseStandardVar.ocamlopt with e -> warn_exception e; add_errors (f_ "Section %s requires native compilation") (OASISSection.string_of_section sct) end; (* Check tools *) check_tools bs.bs_build_tools; (* Check depends *) List.iter (function | FindlibPackage (findlib_pkg, version_comparator) -> begin try var_ignore_eval (BaseCheck.package ?version_comparator findlib_pkg) with e -> warn_exception e; match version_comparator with | None -> add_errors (f_ "Cannot find findlib package %s") findlib_pkg | Some ver_cmp -> add_errors (f_ "Cannot find findlib package %s (%s)") findlib_pkg (OASISVersion.string_of_comparator ver_cmp) end | InternalLibrary nm1 -> (* Check that matching library is built *) List.iter (function | Library ({cs_name = nm2}, {bs_build = build}, _) when nm1 = nm2 -> if not (var_choose build) then add_errors (f_ "Cannot find buildable internal library \ '%s' when checking build depends") nm1 | _ -> ()) pkg.sections) bs.bs_build_depends end in (* Parse command line *) BaseArgExt.parse argv (BaseEnv.args ()); (* OCaml version *) begin match pkg.ocaml_version with | Some ver_cmp -> begin try var_ignore_eval (BaseCheck.version "ocaml" ver_cmp BaseStandardVar.ocaml_version) with e -> warn_exception e; add_errors (f_ "OCaml version %s doesn't match version constraint %s") (BaseStandardVar.ocaml_version ()) (OASISVersion.string_of_comparator ver_cmp) end | None -> () end; (* Findlib version *) begin match pkg.findlib_version with | Some ver_cmp -> begin try var_ignore_eval (BaseCheck.version "findlib" ver_cmp BaseStandardVar.findlib_version) with e -> warn_exception e; add_errors (f_ "Findlib version %s doesn't match version constraint %s") (BaseStandardVar.findlib_version ()) (OASISVersion.string_of_comparator ver_cmp) end | None -> () end; (* Make sure the findlib version is fine for the OCaml compiler. *) begin let ocaml_ge4 = OASISVersion.version_compare (OASISVersion.version_of_string (BaseStandardVar.ocaml_version())) (OASISVersion.version_of_string "4.0.0") >= 0 in if ocaml_ge4 then let findlib_lt132 = OASISVersion.version_compare (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) (OASISVersion.version_of_string "1.3.2") < 0 in if findlib_lt132 then add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" end; (* FlexDLL *) if BaseStandardVar.os_type () = "Win32" || BaseStandardVar.os_type () = "Cygwin" then begin try var_ignore_eval BaseStandardVar.flexlink with e -> warn_exception e; add_errors (f_ "Cannot find 'flexlink'") end; (* Check build depends *) List.iter (function | Executable (_, bs, _) | Library (_, bs, _) as sct -> build_checks sct bs | Doc (_, doc) -> if var_choose doc.doc_build then check_tools doc.doc_build_tools | Test (_, test) -> if var_choose test.test_run then check_tools test.test_tools | _ -> ()) pkg.sections; (* Check if we need native dynlink (presence of libraries that compile to * native) *) begin let has_cmxa = List.exists (function | Library (_, bs, _) -> var_choose bs.bs_build && (bs.bs_compiled_object = Native || (bs.bs_compiled_object = Best && bool_of_string (BaseStandardVar.is_native ()))) | _ -> false) pkg.sections in if has_cmxa then var_ignore_eval BaseStandardVar.native_dynlink end; (* Check errors *) if SetString.empty != !errors then begin List.iter (fun e -> error "%s" e) (SetString.elements !errors); failwithf (fn_ "%d configuration error" "%d configuration errors" (SetString.cardinal !errors)) (SetString.cardinal !errors) end end module InternalInstallPlugin = struct (* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall *) open BaseEnv open BaseStandardVar open BaseMessage open OASISTypes open OASISFindlib open OASISGettext open OASISUtils let exec_hook = ref (fun (cs, bs, exec) -> cs, bs, exec) let lib_hook = ref (fun (cs, bs, lib) -> cs, bs, lib, []) let obj_hook = ref (fun (cs, bs, obj) -> cs, bs, obj, []) let doc_hook = ref (fun (cs, doc) -> cs, doc) let install_file_ev = "install-file" let install_dir_ev = "install-dir" let install_findlib_ev = "install-findlib" let win32_max_command_line_length = 8000 let split_install_command ocamlfind findlib_name meta files = if Sys.os_type = "Win32" then (* Arguments for the first command: *) let first_args = ["install"; findlib_name; meta] in (* Arguments for remaining commands: *) let other_args = ["install"; findlib_name; "-add"] in (* Extract as much files as possible from [files], [len] is the current command line length: *) let rec get_files len acc files = match files with | [] -> (List.rev acc, []) | file :: rest -> let len = len + 1 + String.length file in if len > win32_max_command_line_length then (List.rev acc, files) else get_files len (file :: acc) rest in (* Split the command into several commands. *) let rec split args files = match files with | [] -> [] | _ -> (* Length of "ocamlfind install [META|-add]" *) let len = List.fold_left (fun len arg -> len + 1 (* for the space *) + String.length arg) (String.length ocamlfind) args in match get_files len [] files with | ([], _) -> failwith (s_ "Command line too long.") | (firsts, others) -> let cmd = args @ firsts in (* Use -add for remaining commands: *) let () = let findlib_ge_132 = OASISVersion.comparator_apply (OASISVersion.version_of_string (BaseStandardVar.findlib_version ())) (OASISVersion.VGreaterEqual (OASISVersion.version_of_string "1.3.2")) in if not findlib_ge_132 then failwithf (f_ "Installing the library %s require to use the \ flag '-add' of ocamlfind because the command \ line is too long. This flag is only available \ for findlib 1.3.2. Please upgrade findlib from \ %s to 1.3.2") findlib_name (BaseStandardVar.findlib_version ()) in let cmds = split other_args others in cmd :: cmds in (* The first command does not use -add: *) split first_args files else ["install" :: findlib_name :: meta :: files] let install pkg argv = let in_destdir = try let destdir = destdir () in (* Practically speaking destdir is prepended * at the beginning of the target filename *) fun fn -> destdir^fn with PropList.Not_set _ -> fun fn -> fn in let install_file ?tgt_fn src_file envdir = let tgt_dir = in_destdir (envdir ()) in let tgt_file = Filename.concat tgt_dir (match tgt_fn with | Some fn -> fn | None -> Filename.basename src_file) in (* Create target directory if needed *) OASISFileUtil.mkdir_parent ~ctxt:!BaseContext.default (fun dn -> info (f_ "Creating directory '%s'") dn; BaseLog.register install_dir_ev dn) tgt_dir; (* Really install files *) info (f_ "Copying file '%s' to '%s'") src_file tgt_file; OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file; BaseLog.register install_file_ev tgt_file in (* Install data into defined directory *) let install_data srcdir lst tgtdir = let tgtdir = OASISHostPath.of_unix (var_expand tgtdir) in List.iter (fun (src, tgt_opt) -> let real_srcs = OASISFileUtil.glob ~ctxt:!BaseContext.default (Filename.concat srcdir src) in if real_srcs = [] then failwithf (f_ "Wildcard '%s' doesn't match any files") src; List.iter (fun fn -> install_file fn (fun () -> match tgt_opt with | Some s -> OASISHostPath.of_unix (var_expand s) | None -> tgtdir)) real_srcs) lst in let make_fnames modul sufx = List.fold_right begin fun sufx accu -> (OASISString.capitalize_ascii modul ^ sufx) :: (OASISString.uncapitalize_ascii modul ^ sufx) :: accu end sufx [] in (** Install all libraries *) let install_libs pkg = let files_of_library (f_data, acc) data_lib = let cs, bs, lib, lib_extra = !lib_hook data_lib in if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then begin let acc = (* Start with acc + lib_extra *) List.rev_append lib_extra acc in let acc = (* Add uncompiled header from the source tree *) let path = OASISHostPath.of_unix bs.bs_path in List.fold_left begin fun acc modul -> begin try [List.find OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".mli"; ".ml"]))] with Not_found -> warning (f_ "Cannot find source header for module %s \ in library %s") modul cs.cs_name; [] end @ List.filter OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".annot";".cmti";".cmt"])) @ acc end acc lib.lib_modules in let acc = (* Get generated files *) BaseBuilt.fold BaseBuilt.BLib cs.cs_name (fun acc fn -> fn :: acc) acc in let f_data () = (* Install data associated with the library *) install_data bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name); f_data () in (f_data, acc) end else begin (f_data, acc) end and files_of_object (f_data, acc) data_obj = let cs, bs, obj, obj_extra = !obj_hook data_obj in if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BObj cs.cs_name then begin let acc = (* Start with acc + obj_extra *) List.rev_append obj_extra acc in let acc = (* Add uncompiled header from the source tree *) let path = OASISHostPath.of_unix bs.bs_path in List.fold_left begin fun acc modul -> begin try [List.find OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".mli"; ".ml"]))] with Not_found -> warning (f_ "Cannot find source header for module %s \ in object %s") modul cs.cs_name; [] end @ List.filter OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".annot";".cmti";".cmt"])) @ acc end acc obj.obj_modules in let acc = (* Get generated files *) BaseBuilt.fold BaseBuilt.BObj cs.cs_name (fun acc fn -> fn :: acc) acc in let f_data () = (* Install data associated with the object *) install_data bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name); f_data () in (f_data, acc) end else begin (f_data, acc) end in (* Install one group of library *) let install_group_lib grp = (* Iterate through all group nodes *) let rec install_group_lib_aux data_and_files grp = let data_and_files, children = match grp with | Container (_, children) -> data_and_files, children | Package (_, cs, bs, `Library lib, children) -> files_of_library data_and_files (cs, bs, lib), children | Package (_, cs, bs, `Object obj, children) -> files_of_object data_and_files (cs, bs, obj), children in List.fold_left install_group_lib_aux data_and_files children in (* Findlib name of the root library *) let findlib_name = findlib_of_group grp in (* Determine root library *) let root_lib = root_of_group grp in (* All files to install for this library *) let f_data, files = install_group_lib_aux (ignore, []) grp in (* Really install, if there is something to install *) if files = [] then begin warning (f_ "Nothing to install for findlib library '%s'") findlib_name end else begin let meta = (* Search META file *) let _, bs, _ = root_lib in let res = Filename.concat bs.bs_path "META" in if not (OASISFileUtil.file_exists_case res) then failwithf (f_ "Cannot find file '%s' for findlib library %s") res findlib_name; res in let files = (* Make filename shorter to avoid hitting command max line length * too early, esp. on Windows. *) let remove_prefix p n = let plen = String.length p in let nlen = String.length n in if plen <= nlen && String.sub n 0 plen = p then begin let fn_sep = if Sys.os_type = "Win32" then '\\' else '/' in let cutpoint = plen + (if plen < nlen && n.[plen] = fn_sep then 1 else 0) in String.sub n cutpoint (nlen - cutpoint) end else n in List.map (remove_prefix (Sys.getcwd ())) files in info (f_ "Installing findlib library '%s'") findlib_name; let ocamlfind = ocamlfind () in let commands = split_install_command ocamlfind findlib_name meta files in List.iter (OASISExec.run ~ctxt:!BaseContext.default ocamlfind) commands; BaseLog.register install_findlib_ev findlib_name end; (* Install data files *) f_data (); in let group_libs, _, _ = findlib_mapping pkg in (* We install libraries in groups *) List.iter install_group_lib group_libs in let install_execs pkg = let install_exec data_exec = let cs, bs, exec = !exec_hook data_exec in if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then begin let exec_libdir () = Filename.concat (libdir ()) pkg.name in BaseBuilt.fold BaseBuilt.BExec cs.cs_name (fun () fn -> install_file ~tgt_fn:(cs.cs_name ^ ext_program ()) fn bindir) (); BaseBuilt.fold BaseBuilt.BExecLib cs.cs_name (fun () fn -> install_file fn exec_libdir) (); install_data bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name) end in List.iter (function | Executable (cs, bs, exec)-> install_exec (cs, bs, exec) | _ -> ()) pkg.sections in let install_docs pkg = let install_doc data = let cs, doc = !doc_hook data in if var_choose doc.doc_install && BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then begin let tgt_dir = OASISHostPath.of_unix (var_expand doc.doc_install_dir) in BaseBuilt.fold BaseBuilt.BDoc cs.cs_name (fun () fn -> install_file fn (fun () -> tgt_dir)) (); install_data Filename.current_dir_name doc.doc_data_files doc.doc_install_dir end in List.iter (function | Doc (cs, doc) -> install_doc (cs, doc) | _ -> ()) pkg.sections in install_libs pkg; install_execs pkg; install_docs pkg (* Uninstall already installed data *) let uninstall _ argv = List.iter (fun (ev, data) -> if ev = install_file_ev then begin if OASISFileUtil.file_exists_case data then begin info (f_ "Removing file '%s'") data; Sys.remove data end else begin warning (f_ "File '%s' doesn't exist anymore") data end end else if ev = install_dir_ev then begin if Sys.file_exists data && Sys.is_directory data then begin if Sys.readdir data = [||] then begin info (f_ "Removing directory '%s'") data; OASISFileUtil.rmdir ~ctxt:!BaseContext.default data end else begin warning (f_ "Directory '%s' is not empty (%s)") data (String.concat ", " (Array.to_list (Sys.readdir data))) end end else begin warning (f_ "Directory '%s' doesn't exist anymore") data end end else if ev = install_findlib_ev then begin info (f_ "Removing findlib library '%s'") data; OASISExec.run ~ctxt:!BaseContext.default (ocamlfind ()) ["remove"; data] end else failwithf (f_ "Unknown log event '%s'") ev; BaseLog.unregister ev data) (* We process event in reverse order *) (List.rev (BaseLog.filter [install_file_ev; install_dir_ev; install_findlib_ev])) end # 6296 "setup.ml" module OCamlbuildCommon = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) open OASISGettext open BaseEnv open BaseStandardVar open OASISTypes type extra_args = string list let ocamlbuild_clean_ev = "ocamlbuild-clean" let ocamlbuildflags = var_define ~short_desc:(fun () -> "OCamlbuild additional flags") "ocamlbuildflags" (fun () -> "") (** Fix special arguments depending on environment *) let fix_args args extra_argv = List.flatten [ if (os_type ()) = "Win32" then [ "-classic-display"; "-no-log"; "-no-links"; "-install-lib-dir"; (Filename.concat (standard_library ()) "ocamlbuild") ] else []; if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then [ "-byte-plugin" ] else []; args; if bool_of_string (debug ()) then ["-tag"; "debug"] else []; if bool_of_string (tests ()) then ["-tag"; "tests"] else []; if bool_of_string (profile ()) then ["-tag"; "profile"] else []; OASISString.nsplit (ocamlbuildflags ()) ' '; Array.to_list extra_argv; ] (** Run 'ocamlbuild -clean' if not already done *) let run_clean extra_argv = let extra_cli = String.concat " " (Array.to_list extra_argv) in (* Run if never called with these args *) if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then begin OASISExec.run ~ctxt:!BaseContext.default (ocamlbuild ()) (fix_args ["-clean"] extra_argv); BaseLog.register ocamlbuild_clean_ev extra_cli; at_exit (fun () -> try BaseLog.unregister ocamlbuild_clean_ev extra_cli with _ -> ()) end (** Run ocamlbuild, unregister all clean events *) let run_ocamlbuild args extra_argv = (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html *) OASISExec.run ~ctxt:!BaseContext.default (ocamlbuild ()) (fix_args args extra_argv); (* Remove any clean event, we must run it again *) List.iter (fun (e, d) -> BaseLog.unregister e d) (BaseLog.filter [ocamlbuild_clean_ev]) (** Determine real build directory *) let build_dir extra_argv = let rec search_args dir = function | "-build-dir" :: dir :: tl -> search_args dir tl | _ :: tl -> search_args dir tl | [] -> dir in search_args "_build" (fix_args [] extra_argv) end module OCamlbuildPlugin = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall *) open OASISTypes open OASISGettext open OASISUtils open OASISString open BaseEnv open OCamlbuildCommon open BaseStandardVar open BaseMessage let cond_targets_hook = ref (fun lst -> lst) let build extra_args pkg argv = (* Return the filename in build directory *) let in_build_dir fn = Filename.concat (build_dir argv) fn in (* Return the unix filename in host build directory *) let in_build_dir_of_unix fn = in_build_dir (OASISHostPath.of_unix fn) in let cond_targets = List.fold_left (fun acc -> function | Library (cs, bs, lib) when var_choose bs.bs_build -> begin let evs, unix_files = BaseBuilt.of_library in_build_dir_of_unix (cs, bs, lib) in let tgts = List.flatten (List.filter (fun l -> l <> []) (List.map (List.filter (fun fn -> ends_with ~what:".cma" fn || ends_with ~what:".cmxs" fn || ends_with ~what:".cmxa" fn || ends_with ~what:(ext_lib ()) fn || ends_with ~what:(ext_dll ()) fn)) unix_files)) in match tgts with | _ :: _ -> (evs, tgts) :: acc | [] -> failwithf (f_ "No possible ocamlbuild targets for library %s") cs.cs_name end | Object (cs, bs, obj) when var_choose bs.bs_build -> begin let evs, unix_files = BaseBuilt.of_object in_build_dir_of_unix (cs, bs, obj) in let tgts = List.flatten (List.filter (fun l -> l <> []) (List.map (List.filter (fun fn -> ends_with ".cmo" fn || ends_with ".cmx" fn)) unix_files)) in match tgts with | _ :: _ -> (evs, tgts) :: acc | [] -> failwithf (f_ "No possible ocamlbuild targets for object %s") cs.cs_name end | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin let evs, unix_exec_is, unix_dll_opt = BaseBuilt.of_executable in_build_dir_of_unix (cs, bs, exec) in let target ext = let unix_tgt = (OASISUnixPath.concat bs.bs_path (OASISUnixPath.chop_extension exec.exec_main_is))^ext in let evs = (* Fix evs, we want to use the unix_tgt, without copying *) List.map (function | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> BaseBuilt.BExec, nm, [[in_build_dir_of_unix unix_tgt]] | ev -> ev) evs in evs, [unix_tgt] in (* Add executable *) let acc = match bs.bs_compiled_object with | Native -> (target ".native") :: acc | Best when bool_of_string (is_native ()) -> (target ".native") :: acc | Byte | Best -> (target ".byte") :: acc in acc end | Library _ | Object _ | Executable _ | Test _ | SrcRepo _ | Flag _ | Doc _ -> acc) [] (* Keep the pkg.sections ordered *) (List.rev pkg.sections); in (* Check and register built files *) let check_and_register (bt, bnm, lst) = List.iter (fun fns -> if not (List.exists OASISFileUtil.file_exists_case fns) then failwithf (fn_ "Expected built file %s doesn't exist." "None of expected built files %s exists." (List.length fns)) (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) lst; (BaseBuilt.register bt bnm lst) in (* Run the hook *) let cond_targets = !cond_targets_hook cond_targets in (* Run a list of target... *) run_ocamlbuild (List.flatten (List.map snd cond_targets) @ extra_args) argv; (* ... and register events *) List.iter check_and_register (List.flatten (List.map fst cond_targets)) let clean pkg extra_args = run_clean extra_args; List.iter (function | Library (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BLib cs.cs_name | Executable (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name | _ -> ()) pkg.sections end module OCamlbuildDocPlugin = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall *) open OASISTypes open OASISGettext open OASISMessage open OCamlbuildCommon open BaseStandardVar type run_t = { extra_args: string list; run_path: unix_filename; } let doc_build run pkg (cs, doc) argv = let index_html = OASISUnixPath.make [ run.run_path; cs.cs_name^".docdir"; "index.html"; ] in let tgt_dir = OASISHostPath.make [ build_dir argv; OASISHostPath.of_unix run.run_path; cs.cs_name^".docdir"; ] in run_ocamlbuild (index_html :: run.extra_args) argv; List.iter (fun glb -> BaseBuilt.register BaseBuilt.BDoc cs.cs_name [OASISFileUtil.glob ~ctxt:!BaseContext.default (Filename.concat tgt_dir glb)]) ["*.html"; "*.css"] let doc_clean run pkg (cs, doc) argv = run_clean argv; BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name end # 6674 "setup.ml" module CustomPlugin = struct (* # 22 "src/plugins/custom/CustomPlugin.ml" *) (** Generate custom configure/build/doc/test/install system @author *) open BaseEnv open OASISGettext open OASISTypes type t = { cmd_main: command_line conditional; cmd_clean: (command_line option) conditional; cmd_distclean: (command_line option) conditional; } let run = BaseCustom.run let main t _ extra_args = let cmd, args = var_choose ~name:(s_ "main command") t.cmd_main in run cmd args extra_args let clean t pkg extra_args = match var_choose t.cmd_clean with | Some (cmd, args) -> run cmd args extra_args | _ -> () let distclean t pkg extra_args = match var_choose t.cmd_distclean with | Some (cmd, args) -> run cmd args extra_args | _ -> () module Build = struct let main t pkg extra_args = main t pkg extra_args; List.iter (fun sct -> let evs = match sct with | Library (cs, bs, lib) when var_choose bs.bs_build -> begin let evs, _ = BaseBuilt.of_library OASISHostPath.of_unix (cs, bs, lib) in evs end | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin let evs, _, _ = BaseBuilt.of_executable OASISHostPath.of_unix (cs, bs, exec) in evs end | _ -> [] in List.iter (fun (bt, bnm, lst) -> BaseBuilt.register bt bnm lst) evs) pkg.sections let clean t pkg extra_args = clean t pkg extra_args; (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild * considering moving this to BaseSetup? *) List.iter (function | Library (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BLib cs.cs_name | Executable (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name | _ -> ()) pkg.sections let distclean t pkg extra_args = distclean t pkg extra_args end module Test = struct let main t pkg (cs, test) extra_args = try main t pkg extra_args; 0.0 with Failure s -> BaseMessage.warning (f_ "Test '%s' fails: %s") cs.cs_name s; 1.0 let clean t pkg (cs, test) extra_args = clean t pkg extra_args let distclean t pkg (cs, test) extra_args = distclean t pkg extra_args end module Doc = struct let main t pkg (cs, _) extra_args = main t pkg extra_args; BaseBuilt.register BaseBuilt.BDoc cs.cs_name [] let clean t pkg (cs, _) extra_args = clean t pkg extra_args; BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name let distclean t pkg (cs, _) extra_args = distclean t pkg extra_args end end # 6822 "setup.ml" open OASISTypes;; let setup_t = { BaseSetup.configure = InternalConfigurePlugin.configure; build = OCamlbuildPlugin.build ["-use-ocamlfind"; "-plugin-tags"; "'package(cppo_ocamlbuild)'"]; test = []; doc = [ ("utop-api", OCamlbuildDocPlugin.doc_build { OCamlbuildDocPlugin.extra_args = [ "-use-ocamlfind"; "-docflag -t -docflag 'API reference for utop' -docflags '-colorize-code -short-functors -charset utf-8 -css-style style.css'" ]; run_path = "./" }); ("utop-man", CustomPlugin.Doc.main { CustomPlugin.cmd_main = [ (OASISExpr.EBool true, ("$gzip", ["-c"; "man/utop.1"; ">"; "man/utop.1.gz"])) ]; cmd_clean = [(OASISExpr.EBool true, Some (("$rm", ["man/utop.1.gz"]))) ]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("utop-full-man", CustomPlugin.Doc.main { CustomPlugin.cmd_main = [ (OASISExpr.EBool true, ("$gzip", ["-c"; "man/utop-full.1"; ">"; "man/utop-full.1.gz" ])) ]; cmd_clean = [ (OASISExpr.EBool true, Some (("$rm", ["man/utop-full.1.gz"]))) ]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("utoprc-man", CustomPlugin.Doc.main { CustomPlugin.cmd_main = [ (OASISExpr.EBool true, ("$gzip", ["-c"; "man/utoprc.5"; ">"; "man/utoprc.5.gz"])) ]; cmd_clean = [ (OASISExpr.EBool true, Some (("$rm", ["man/utoprc.5.gz"]))) ]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("utoprcs", CustomPlugin.Doc.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("true", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) ]; install = InternalInstallPlugin.install; uninstall = InternalInstallPlugin.uninstall; clean = [OCamlbuildPlugin.clean]; clean_test = []; clean_doc = [ ("utop-api", OCamlbuildDocPlugin.doc_clean { OCamlbuildDocPlugin.extra_args = [ "-use-ocamlfind"; "-docflag -t -docflag 'API reference for utop' -docflags '-colorize-code -short-functors -charset utf-8 -css-style style.css'" ]; run_path = "./" }); ("utop-man", CustomPlugin.Doc.clean { CustomPlugin.cmd_main = [ (OASISExpr.EBool true, ("$gzip", ["-c"; "man/utop.1"; ">"; "man/utop.1.gz"])) ]; cmd_clean = [(OASISExpr.EBool true, Some (("$rm", ["man/utop.1.gz"]))) ]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("utop-full-man", CustomPlugin.Doc.clean { CustomPlugin.cmd_main = [ (OASISExpr.EBool true, ("$gzip", ["-c"; "man/utop-full.1"; ">"; "man/utop-full.1.gz" ])) ]; cmd_clean = [ (OASISExpr.EBool true, Some (("$rm", ["man/utop-full.1.gz"]))) ]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("utoprc-man", CustomPlugin.Doc.clean { CustomPlugin.cmd_main = [ (OASISExpr.EBool true, ("$gzip", ["-c"; "man/utoprc.5"; ">"; "man/utoprc.5.gz"])) ]; cmd_clean = [ (OASISExpr.EBool true, Some (("$rm", ["man/utoprc.5.gz"]))) ]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("utoprcs", CustomPlugin.Doc.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("true", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) ]; distclean = []; distclean_test = []; distclean_doc = [ ("utop-man", CustomPlugin.Doc.distclean { CustomPlugin.cmd_main = [ (OASISExpr.EBool true, ("$gzip", ["-c"; "man/utop.1"; ">"; "man/utop.1.gz"])) ]; cmd_clean = [(OASISExpr.EBool true, Some (("$rm", ["man/utop.1.gz"]))) ]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("utop-full-man", CustomPlugin.Doc.distclean { CustomPlugin.cmd_main = [ (OASISExpr.EBool true, ("$gzip", ["-c"; "man/utop-full.1"; ">"; "man/utop-full.1.gz" ])) ]; cmd_clean = [ (OASISExpr.EBool true, Some (("$rm", ["man/utop-full.1.gz"]))) ]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("utoprc-man", CustomPlugin.Doc.distclean { CustomPlugin.cmd_main = [ (OASISExpr.EBool true, ("$gzip", ["-c"; "man/utoprc.5"; ">"; "man/utoprc.5.gz"])) ]; cmd_clean = [ (OASISExpr.EBool true, Some (("$rm", ["man/utoprc.5.gz"]))) ]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("utoprcs", CustomPlugin.Doc.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("true", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) ]; package = { oasis_version = "0.4"; ocaml_version = Some (OASISVersion.VGreaterEqual "4.01"); findlib_version = None; alpha_features = ["ocamlbuild_more_args"]; beta_features = []; name = "utop"; version = "1.19.3"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit { OASISLicense.license = "BSD-3-clause"; excption = None; version = OASISLicense.NoVersion }); license_file = Some "LICENSE"; copyrights = []; maintainers = ["Jeremie Dimino "]; authors = ["Jeremie Dimino"]; homepage = Some "https://github.com/diml/utop"; synopsis = "Universal toplevel for OCaml"; description = Some [ OASISText.Para "utop is an improved toplevel for OCaml. It can run in a terminal or in Emacs. It supports line edition, history, real-time and context sensitive completion, colors, and more."; OASISText.Para "It integrates with the tuareg mode in Emacs." ]; categories = []; conf_type = (`Configure, "internal", Some "0.4"); conf_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; build_type = (`Build, "ocamlbuild", Some "0.4"); build_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; install_type = (`Install, "internal", Some "0.4"); install_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; uninstall_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; clean_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; distclean_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; files_ab = ["src/lib/uTop_version.ml.ab"]; sections = [ Flag ({ cs_name = "camlp4"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "camlp4 support"; flag_default = [(OASISExpr.EBool true, false)] }); Flag ({ cs_name = "interact"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "enable UTop_main.interact (requires ppx_tools)"; flag_default = [(OASISExpr.EBool true, false)] }); Library ({ cs_name = "utop"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/lib"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("threads", None); FindlibPackage ("findlib", None); FindlibPackage ("lambda-term", Some (OASISVersion.VGreaterEqual "1.2")) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = ["UTop"; "UTop_main"]; lib_pack = false; lib_internal_modules = [ "UTop_private"; "UTop_version"; "UTop_lexer"; "UTop_token"; "UTop_complete"; "UTop_styles"; "UTop_cmt_lifter" ]; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "utop-camlp4"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "camlp4", true) ]; bs_install = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "camlp4", true) ]; bs_path = "src/camlp4"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "utop"; FindlibPackage ("camlp4", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = ["UTop_camlp4"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "utop"; lib_findlib_name = Some "camlp4"; lib_findlib_containers = [] }); Executable ({ cs_name = "utop"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/top"; bs_compiled_object = Byte; bs_build_depends = [ FindlibPackage ("threads", None); FindlibPackage ("findlib", None); FindlibPackage ("lambda-term", None); InternalLibrary "utop" ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = [("utop.el", Some "$datadir/emacs/site-lisp")]; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, {exec_custom = false; exec_main_is = "uTop_top.ml"}); Executable ({ cs_name = "utop-full"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/top"; bs_compiled_object = Byte; bs_build_depends = [ FindlibPackage ("threads", None); FindlibPackage ("findlib", None); FindlibPackage ("lambda-term", None); InternalLibrary "utop" ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = [("utop.el", Some "$datadir/emacs/site-lisp")]; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, {exec_custom = false; exec_main_is = "uTop_top_full.ml"}); Doc ({ cs_name = "utop-api"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { doc_type = (`Doc, "ocamlbuild", Some "0.3"); doc_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; doc_build = [ (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); (OASISExpr.EFlag "docs", true) ]; doc_install = [(OASISExpr.EBool true, true)]; doc_install_dir = "$htmldir/api"; doc_title = "API reference for utop"; doc_authors = []; doc_abstract = None; doc_format = OtherDoc; doc_data_files = [("style.css", None)]; doc_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] }); Doc ({ cs_name = "utop-man"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { doc_type = (`Doc, "custom", Some "0.3"); doc_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; doc_build = [ (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); (OASISExpr.EFlag "docs", true) ]; doc_install = [(OASISExpr.EBool true, true)]; doc_install_dir = "$mandir/man1"; doc_title = "Man page for utop"; doc_authors = []; doc_abstract = None; doc_format = OtherDoc; doc_data_files = [("man/utop.1.gz", None)]; doc_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "gzip"] }); Doc ({ cs_name = "utop-full-man"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { doc_type = (`Doc, "custom", Some "0.3"); doc_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; doc_build = [ (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); (OASISExpr.EFlag "docs", true) ]; doc_install = [(OASISExpr.EBool true, true)]; doc_install_dir = "$mandir/man1"; doc_title = "Man page for utop"; doc_authors = []; doc_abstract = None; doc_format = OtherDoc; doc_data_files = [("man/utop-full.1.gz", None)]; doc_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "gzip"] }); Doc ({ cs_name = "utoprc-man"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { doc_type = (`Doc, "custom", Some "0.3"); doc_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; doc_build = [ (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); (OASISExpr.EFlag "docs", true) ]; doc_install = [(OASISExpr.EBool true, true)]; doc_install_dir = "$mandir/man5"; doc_title = "Man page for utoprc"; doc_authors = []; doc_abstract = None; doc_format = OtherDoc; doc_data_files = [("man/utoprc.5.gz", None)]; doc_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "gzip"] }); Doc ({ cs_name = "utoprcs"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { doc_type = (`Doc, "custom", Some "0.3"); doc_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; doc_build = [ (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); (OASISExpr.EFlag "docs", true) ]; doc_install = [(OASISExpr.EBool true, true)]; doc_install_dir = "$docdir"; doc_title = "utoprc examples"; doc_authors = []; doc_abstract = None; doc_format = OtherDoc; doc_data_files = [("utoprc-dark", None); ("utoprc-light", None)]; doc_build_tools = [ExternalTool "ocamlbuild"] }); SrcRepo ({ cs_name = "head"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { src_repo_type = Git; src_repo_location = "https://github.com/diml/utop.git"; src_repo_browser = Some "https://github.com/diml/utop"; src_repo_module = None; src_repo_branch = None; src_repo_tag = None; src_repo_subdir = None }) ]; plugins = [(`Extra, "DevFiles", Some "0.3"); (`Extra, "META", Some "0.3")]; disable_oasis_section = []; schema_data = PropList.Data.create (); plugin_data = [] }; oasis_fn = Some "_oasis"; oasis_version = "0.4.6"; oasis_digest = Some "\127i\169Qp,p\139\"u\1626-A\155\222"; oasis_exec = None; oasis_setup_args = []; setup_update = false };; let setup () = BaseSetup.setup setup_t;; # 7439 "setup.ml" (* OASIS_STOP *) let search_compiler_libs () = prerr_endline "I: Searching for OCaml compiler libraries"; let stdlib = BaseEnv.var_get "standard_library" in let ( / ) = Filename.concat in try List.find (fun path -> Sys.file_exists (path / "types.cmi") || Sys.file_exists (path / "typing" / "types.cmi")) [ stdlib; stdlib / "compiler-libs"; stdlib / "compiler-lib"; stdlib / ".." / "compiler-libs"; stdlib / ".." / "compiler-lib"; ] with Not_found -> prerr_endline "E: Cannot find compiler libraries! See the README for details."; exit 1 let compiler_libs = BaseEnv.var_define ~short_desc:(fun () -> "compiler libraries") "compiler_libs" search_compiler_libs let () = setup () utop-1.19.3/src/000077500000000000000000000000001275431303000133615ustar00rootroot00000000000000utop-1.19.3/src/camlp4/000077500000000000000000000000001275431303000145415ustar00rootroot00000000000000utop-1.19.3/src/camlp4/uTop_camlp4.cppo.ml000066400000000000000000000072721275431303000202320ustar00rootroot00000000000000(* * uTop_camlp4.ml * -------------- * Copyright : (c) 2012, Jeremie Dimino * Licence : BSD3 * * This file is a part of utop. *) open Lexing open Camlp4 open Camlp4.PreCast module Ast2pt = Camlp4.Struct.Camlp4Ast2OCamlAst.Make(Ast) #if OCAML_VERSION < (4, 02, 0) external cast_toplevel_phrase : Camlp4_import.Parsetree.toplevel_phrase -> Parsetree.toplevel_phrase = "%identity" #else let cast_toplevel_phrase x = x #endif let print_camlp4_error pp exn = Format.fprintf pp "@[<0>%a@]" Camlp4.ErrorHandler.print exn; Format.pp_print_flush pp () let get_camlp4_error_message exn = let loc, exn = match exn with | Loc.Exc_located (loc, exn) -> ((Loc.start_off loc, Loc.stop_off loc), exn) | exn -> ((0, 0), exn) in let msg = UTop.get_message print_camlp4_error exn in (* Camlp4 sometimes generate several empty lines at the end... *) let idx = ref (String.length msg - 1) in while !idx > 0 && msg.[!idx] = '\n' do decr idx done; if !idx + 1 < String.length msg then (loc, String.sub msg 0 (!idx + 1)) else (loc, msg) let convert_camlp4_toplevel_phrase ast = try UTop.Value (cast_toplevel_phrase (Ast2pt.phrase ast)) with exn -> let loc, msg = get_camlp4_error_message exn in UTop.Error ([loc], msg) let parse_camlp4 syntax str eos_is_error = (* Execute delayed actions now. *) Register.iter_and_take_callbacks (fun (_, f) -> f ()); let eof = ref false in try let len = String.length str in let char_stream = Stream.from (fun i -> if i >= len then begin eof := true; None end else Some str.[i]) in let token_stream = Gram.filter (Gram.lex (Loc.mk UTop.input_name) char_stream) in UTop.Value (Gram.parse_tokens_after_filter syntax token_stream) with exn -> if !eof && not eos_is_error then raise UTop.Need_more else let loc, msg = get_camlp4_error_message exn in UTop.Error ([loc], msg) let filter phrase = try UTop.Value (AstFilters.fold_topphrase_filters (fun t filter -> filter t) phrase) with exn -> let loc, msg = get_camlp4_error_message exn in UTop.Error ([loc], msg) ;; let parse_toplevel_phrase_camlp4 str eos_is_error = match parse_camlp4 Syntax.top_phrase str eos_is_error with | UTop.Value None -> raise UTop.Need_more | UTop.Value (Some ast) -> filter ast | UTop.Error (locs, msg) -> UTop.Error (locs, msg) let parse_toplevel_phrase str eos_is_error = match parse_toplevel_phrase_camlp4 str eos_is_error with | UTop.Value ast -> convert_camlp4_toplevel_phrase ast | UTop.Error (locs, msg) -> UTop.Error (locs, msg) let parse_use_file str eos_is_error = match parse_camlp4 Syntax.use_file str eos_is_error with | UTop.Value ([], _) -> raise UTop.Need_more | UTop.Value (asts, _) -> let rec loop phrases = function | [] -> UTop.Value (List.rev phrases) | (ast::more_asts) -> match filter ast with | UTop.Error _ as e -> e | UTop.Value ast -> match convert_camlp4_toplevel_phrase ast with | UTop.Error _ as e -> e | UTop.Value y -> loop (y::phrases) more_asts in loop [] asts | UTop.Error (locs, msg) -> UTop.Error (locs, msg) let () = UTop.parse_toplevel_phrase := parse_toplevel_phrase; UTop.parse_use_file := parse_use_file; (* So that camlp4 doesn't display its welcome message. *) let interactive = !Sys.interactive in Sys.interactive := false; let () = try ignore (!Toploop.parse_toplevel_phrase (Lexing.from_string "")) with _ -> () in Sys.interactive := interactive utop-1.19.3/src/camlp4/uTop_camlp4.mli000066400000000000000000000017751275431303000174450ustar00rootroot00000000000000(* * uTop_camlp4.mli * --------------- * Copyright : (c) 2012, Jeremie Dimino * Licence : BSD3 * * This file is a part of utop. *) val parse_toplevel_phrase : string -> bool -> Parsetree.toplevel_phrase UTop.result (** Toplevel phrase parser for utop using camlp4. *) val parse_toplevel_phrase_camlp4 : string -> bool -> Camlp4.PreCast.Ast.str_item UTop.result (** Camlp4 toplevel phrase parser. Same as {!parse_toplevel_phrase} but the result is not converted to an OCaml ast. *) val convert_camlp4_toplevel_phrase : Camlp4.PreCast.Ast.str_item -> Parsetree.toplevel_phrase UTop.result (** Converts a camlp4 toplevel phrase into a standard OCaml toplevel phrase. Note that a camlp4 ast may not be convertible to an OCaml one, in which case it returns {!UTop.Error}. *) val get_camlp4_error_message : exn -> UTop.location * string (** [get_camlp4_error_message exn] returns the location and error message for the exception [exn] as printed by camlp4. *) utop-1.19.3/src/camlp4/utop-camlp4.mldylib000066400000000000000000000001401275431303000202570ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 63197c0a81fb6c5d0585e84940b752af) UTop_camlp4 # OASIS_STOP utop-1.19.3/src/camlp4/utop-camlp4.mllib000066400000000000000000000001401275431303000177220ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 63197c0a81fb6c5d0585e84940b752af) UTop_camlp4 # OASIS_STOP utop-1.19.3/src/camlp5/000077500000000000000000000000001275431303000145425ustar00rootroot00000000000000utop-1.19.3/src/camlp5/uTop_camlp5.ml000066400000000000000000000035161275431303000172710ustar00rootroot00000000000000(* * uTop_camlp5.ml * -------------- * Copyright : (c) 2012, Wojciech Meyer * Licence : BSD3 * * This file is a part of utop. *) open Lexing let print_camlp5_error pp exn = let save = Format.get_formatter_output_functions () in Format.set_formatter_output_functions (fun str s e -> Format.pp_print_string pp (String.sub str s e)) (fun () -> Format.pp_print_flush pp ()); Format.printf "@[<0>%a@]@." (fun _ -> Pcaml.report_error) exn; Format.set_formatter_output_functions (fst save) (snd save) let get_camlp5_error_message exn = let loc, exn = match exn with | Ploc.Exc (loc, exn) -> ((Ploc.first_pos loc, Ploc.last_pos loc), exn) | exn -> ((0, 0), exn) in let msg = UTop.get_message print_camlp5_error exn in loc, msg let convert_camlp5_toplevel_phrase ast = try UTop.Value (Ast2pt.phrase ast) with exn -> let loc, msg = get_camlp5_error_message exn in UTop.Error ([loc], msg) let parse_toplevel_phrase_camlp5 str eos_is_error = try let token_stream = Stream.of_string str in match Grammar.Entry.parse Pcaml.top_phrase token_stream with | Some ast -> UTop.Value ast | None -> raise UTop.Need_more with exn -> if not eos_is_error then raise UTop.Need_more else let loc, msg = get_camlp5_error_message exn in UTop.Error ([loc], msg) let parse_toplevel_phrase str eos_is_error = match parse_toplevel_phrase_camlp5 str eos_is_error with | UTop.Value ast -> convert_camlp5_toplevel_phrase ast | UTop.Error (locs, msg) -> UTop.Error (locs, msg) let () = UTop.parse_toplevel_phrase := parse_toplevel_phrase; (* Force camlp5 to display its welcome message. *) try ignore (!Toploop.parse_toplevel_phrase (Lexing.from_string "")) with _ -> () utop-1.19.3/src/camlp5/uTop_camlp5.mli000066400000000000000000000017471275431303000174460ustar00rootroot00000000000000(* * uTop_camlp5.mli * --------------- * Copyright : (c) 2012, Wojciech Meyer * Licence : BSD3 * * This file is a part of utop. *) val parse_toplevel_phrase : string -> bool -> Parsetree.toplevel_phrase UTop.result (** Toplevel phrase parser for utop using camlp5. *) val parse_toplevel_phrase_camlp5 : string -> bool -> MLast.str_item UTop.result (** Camlp5 toplevel phrase parser. Same as {!parse_toplevel_phrase} but the result is not converted to an OCaml ast. *) val convert_camlp5_toplevel_phrase : MLast.str_item -> Parsetree.toplevel_phrase UTop.result (** Converts a camlp5 toplevel phrase into a standard OCaml toplevel phrase. Note that a camlp5 ast may not be convertible to an OCaml one, in which case it returns {!UTop.Error}. *) val get_camlp5_error_message : exn -> UTop.location * string (** [get_camlp5_error_message exn] returns the location and error message for the exception [exn] as printed by camlp5. *) utop-1.19.3/src/lib/000077500000000000000000000000001275431303000141275ustar00rootroot00000000000000utop-1.19.3/src/lib/META000066400000000000000000000012541275431303000146020ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: caf72eeee0d14b56758efd7d92090083) version = "1.19.3" description = "utop configuration" requires = "findlib lambda-term" archive(byte) = "utop.cma" archive(byte, plugin) = "utop.cma" archive(native) = "utop.cmxa" archive(native, plugin) = "utop.cmxs" exists_if = "utop.cma" package "camlp4" ( version = "1.19.3" description = "Camlp4 integration" requires = "utop camlp4" archive(syntax, preprocessor) = "utop-camlp4.cma" archive(syntax, toploop) = "utop-camlp4.cma" archive(syntax, preprocessor, native) = "utop-camlp4.cmxa" archive(syntax, preprocessor, native, plugin) = "utop-camlp4.cmxs" exists_if = "utop-camlp4.cma" ) # OASIS_STOP utop-1.19.3/src/lib/uTop.cppo.ml000066400000000000000000000642541275431303000163630ustar00rootroot00000000000000(* * uTop.ml * ------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of utop. *) open CamomileLibraryDyn.Camomile open Lwt_react open LTerm_text open LTerm_geom open LTerm_style let (>>=) = Lwt.(>>=) module String_set = Set.Make(String) let version = UTop_version.version (* +-----------------------------------------------------------------+ | History | +-----------------------------------------------------------------+ *) let history = LTerm_history.create [] let history_file_name = ref (Some (Filename.concat LTerm_resources.home ".utop-history")) let history_file_max_size = ref None let history_file_max_entries = ref None (* +-----------------------------------------------------------------+ | Hooks | +-----------------------------------------------------------------+ *) let new_command_hooks = Lwt_sequence.create () let at_new_command f = ignore (Lwt_sequence.add_l f new_command_hooks) (* +-----------------------------------------------------------------+ | Config | +-----------------------------------------------------------------+ *) type ui = UTop_private.ui = Console | Emacs let get_ui () = S.value UTop_private.ui type profile = Dark | Light let profile, set_profile = S.create Dark let set_profile p = set_profile p let size = UTop_private.size let key_sequence = UTop_private.key_sequence let count = UTop_private.count let time = ref (Unix.time ()) let () = at_new_command (fun () -> time := Unix.time ()) let make_variable ?eq x = let signal, set = S.create ?eq x in let set v = set v in (signal, (fun () -> S.value signal), set) type syntax = | Normal | Camlp4o | Camlp4r let hide_reserved, get_hide_reserved, set_hide_reserved = make_variable true let show_box, get_show_box, set_show_box = make_variable true let syntax, get_syntax, set_syntax = make_variable Normal let phrase_terminator, get_phrase_terminator, set_phrase_terminator = make_variable ";;" let auto_run_lwt, get_auto_run_lwt, set_auto_run_lwt = make_variable true let auto_run_async, get_auto_run_async, set_auto_run_async = make_variable true let topfind_verbose, get_topfind_verbose, set_topfind_verbose = make_variable false let external_editor, get_external_editor, set_external_editor = make_variable (try Sys.getenv "EDITOR" with Not_found -> "vi") (* Ugly hack until the action system of lambda-term is improved *) let end_and_accept_current_phrase : LTerm_read_line.action = Edit (Custom (fun () -> assert false)) let set_margin_function f = UTop_private.set_margin_function f (* +-----------------------------------------------------------------+ | Keywords | +-----------------------------------------------------------------+ *) let default_keywords = [ "and"; "as"; "assert"; "begin"; "class"; "constraint"; "do"; "done"; "downto"; "else"; "end"; "exception"; "external"; "for"; "fun"; "function"; "functor"; "if"; "in"; "include"; "inherit"; "initializer"; "lazy"; "let"; "match"; "method"; "module"; "mutable"; "new"; "object"; "of"; "open"; "private"; "rec"; "sig"; "struct"; "then"; "to"; "try"; "type"; "val"; "virtual"; "when"; "while"; "with"; "try_lwt"; "finally"; "for_lwt"; "lwt"; ] let keywords = ref (List.fold_right String_set.add default_keywords String_set.empty) let add_keyword kwd = keywords := String_set.add kwd !keywords (* +-----------------------------------------------------------------+ | Error reporting | +-----------------------------------------------------------------+ *) let get_message func x = let buffer = Buffer.create 1024 in let pp = Format.formatter_of_buffer buffer in UTop_private.set_margin pp; func pp x; Format.pp_print_flush pp (); Buffer.contents buffer let get_ocaml_error_message exn = let buffer = Buffer.create 1024 in let pp = Format.formatter_of_buffer buffer in UTop_private.set_margin pp; Errors.report_error pp exn; Format.pp_print_flush pp (); let str = Buffer.contents buffer in try Scanf.sscanf str "Characters %d-%d:\n%[\000-\255]" (fun start stop msg -> ((start, stop), msg)) with _ -> ((0, 0), str) let collect_formatters buf pps f = (* First flush all formatters. *) List.iter (fun pp -> Format.pp_print_flush pp ()) pps; (* Save all formatter functions. *) let save = List.map (fun pp -> Format.pp_get_formatter_out_functions pp ()) pps in let restore () = List.iter2 (fun pp out_functions -> Format.pp_print_flush pp (); Format.pp_set_formatter_out_functions pp out_functions) pps save in (* Output functions. *) let out_string str ofs len = Buffer.add_substring buf str ofs len and out_flush = ignore and out_newline () = Buffer.add_char buf '\n' and out_spaces n = for i = 1 to n do Buffer.add_char buf ' ' done in let out_functions = { Format.out_string; out_flush; out_newline; out_spaces } in (* Replace formatter functions. *) List.iter (fun pp -> UTop_private.set_margin pp; Format.pp_set_formatter_out_functions pp out_functions) pps; try let x = f () in restore (); x with exn -> restore (); raise exn let discard_formatters pps f = (* First flush all formatters. *) List.iter (fun pp -> Format.pp_print_flush pp ()) pps; (* Save all formatter functions. *) let save = List.map (fun pp -> Format.pp_get_formatter_out_functions pp ()) pps in let restore () = List.iter2 (fun pp out_functions -> Format.pp_print_flush pp (); Format.pp_set_formatter_out_functions pp out_functions) pps save in (* Output functions. *) let out_functions = { Format.out_string = (fun _ _ _ -> ()); out_flush = ignore; out_newline = ignore; out_spaces = ignore; } in (* Replace formatter functions. *) List.iter (fun pp -> Format.pp_set_formatter_out_functions pp out_functions) pps; try let x = f () in restore (); x with exn -> restore (); raise exn (* +-----------------------------------------------------------------+ | Parsing | +-----------------------------------------------------------------+ *) type location = int * int type 'a result = | Value of 'a | Error of location list * string exception Need_more let input_name = "//toplevel//" let lexbuf_of_string eof str = let pos = ref 0 in let lexbuf = Lexing.from_function (fun buf len -> if !pos = String.length str then begin eof := true; 0 end else begin let len = min len (String.length str - !pos) in String.blit str !pos buf 0 len; pos := !pos + len; len end) in Location.init lexbuf input_name; lexbuf let mkloc loc = (loc.Location.loc_start.Lexing.pos_cnum, loc.Location.loc_end.Lexing.pos_cnum) let parse_default parse str eos_is_error = let eof = ref false in let lexbuf = lexbuf_of_string eof str in try (* Try to parse the phrase. *) let phrase = parse lexbuf in Value phrase with | _ when !eof && not eos_is_error -> (* This is not an error, we just need more input. *) raise Need_more | End_of_file -> (* If the string is empty, do not report an error. *) raise Need_more | Lexer.Error (error, loc) -> Error ([mkloc loc], get_message Lexer.report_error error) | Syntaxerr.Error error -> begin match error with | Syntaxerr.Unclosed (opening_loc, opening, closing_loc, closing) -> Error ([mkloc opening_loc; mkloc closing_loc], Printf.sprintf "Syntax error: '%s' expected, the highlighted '%s' might be unmatched" closing opening) | Syntaxerr.Applicative_path loc -> Error ([mkloc loc], "Syntax error: applicative paths of the form F(X).t are not supported when the option -no-app-funct is set.") | Syntaxerr.Other loc -> Error ([mkloc loc], "Syntax error") | Syntaxerr.Expecting (loc, nonterm) -> Error ([mkloc loc], Printf.sprintf "Syntax error: %s expected." nonterm) | Syntaxerr.Variable_in_scope (loc, var) -> Error ([mkloc loc], Printf.sprintf "In this scoped type, variable '%s is reserved for the local type %s." var var) #if OCAML_VERSION >= (4, 02, 0) | Syntaxerr.Not_expecting (loc, nonterm) -> Error ([mkloc loc], Printf.sprintf "Syntax error: %s not expected" nonterm) | Syntaxerr.Ill_formed_ast (loc, s) -> Error ([mkloc loc], Printf.sprintf "Error: broken invariant in parsetree: %s" s) #endif #if OCAML_VERSION >= (4, 03, 0) | Syntaxerr.Invalid_package_type (loc, s) -> Error ([mkloc loc], Printf.sprintf "Invalid package type: %s" s) #endif end | Syntaxerr.Escape_error | Parsing.Parse_error -> Error ([mkloc (Location.curr lexbuf)], "Syntax error") | exn -> Error ([], "Unknown parsing error (please report it to the utop project): " ^ Printexc.to_string exn) let parse_toplevel_phrase_default = parse_default Parse.toplevel_phrase let parse_toplevel_phrase = ref parse_toplevel_phrase_default let parse_use_file_default = parse_default Parse.use_file let parse_use_file = ref parse_use_file_default (* +-----------------------------------------------------------------+ | Safety checking | +-----------------------------------------------------------------+ *) let null = Format.make_formatter (fun str ofs len -> ()) ignore let rec last head tail = match tail with | [] -> head | head :: tail -> last head tail let with_loc loc str = { Location.txt = str; Location.loc = loc; } #if OCAML_VERSION >= (4, 03, 0) let nolabel = Asttypes.Nolabel #else let nolabel = "" #endif (* Check that the given phrase can be evaluated without typing/compile errors. *) let check_phrase phrase = let open Parsetree in match phrase with | Ptop_dir _ -> None | Ptop_def [] -> None | Ptop_def (item :: items) -> let loc = { Location.loc_start = item.pstr_loc.Location.loc_start; Location.loc_end = (last item items).pstr_loc.Location.loc_end; Location.loc_ghost = false; } in (* Backup. *) let snap = Btype.snapshot () in let env = !Toploop.toplevel_env in (* Construct "let _ () = let module _ = struct end in ()" in order to test the typing and compilation of [items] without evaluating them. *) let unit = with_loc loc (Longident.Lident "()") in #if OCAML_VERSION < (4, 02, 0) let structure = { pmod_loc = loc; pmod_desc = Pmod_structure (item :: items); } in let unit_expr = { pexp_desc = Pexp_construct (unit, None, false); pexp_loc = loc; } in let unit_patt = { ppat_desc = Ppat_construct (unit, None, false); ppat_loc = loc; } in let letmodule = { pexp_desc = Pexp_letmodule (with_loc loc "_", structure, unit_expr); pexp_loc = loc; } in let func = { pexp_desc = Pexp_function ("", None, [(unit_patt, letmodule)]); pexp_loc = loc; } in let top_def = { pstr_desc = Pstr_value (Asttypes.Nonrecursive, [({ ppat_desc = Ppat_var (with_loc loc "_"); ppat_loc = loc }, func)]); pstr_loc = loc; } in #else let top_def = let open Ast_helper in with_default_loc loc (fun () -> Str.eval (Exp.fun_ nolabel None (Pat.construct unit None) (Exp.letmodule (with_loc loc "_") (Mod.structure (item :: items)) (Exp.construct unit None)))) in #endif let check_phrase = Ptop_def [top_def] in try let _ = discard_formatters [Format.err_formatter] (fun () -> Env.reset_cache_toplevel (); Toploop.execute_phrase false null check_phrase) in (* The phrase is safe. *) Toploop.toplevel_env := env; Btype.backtrack snap; None with exn -> (* The phrase contains errors. *) let loc, msg = get_ocaml_error_message exn in Toploop.toplevel_env := env; Btype.backtrack snap; Some ([loc], msg) (* +-----------------------------------------------------------------+ | Prompt | +-----------------------------------------------------------------+ *) let make_prompt ui profile count size key_sequence (recording, macro_count, macro_counter) = let tm = Unix.localtime !time in let color dark light = match profile with | Dark -> dark | Light -> light in match ui with | Emacs -> [||] | Console -> let bold = profile = Dark in let txta = if key_sequence = [] then eval [ B_bold bold; B_fg (color lcyan blue); S "─( "; B_fg (color lmagenta magenta); S (Printf.sprintf "%02d:%02d:%02d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec); E_fg; S " )─< "; B_fg (color lyellow yellow); S (Printf.sprintf "command %d" count); E_fg; S " >─"; ] else eval [ B_bold bold; B_fg (color lcyan blue); S "─( "; B_fg (color lmagenta magenta); S (Printf.sprintf "%02d:%02d:%02d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec); E_fg; S " )─< "; B_fg (color lyellow yellow); S (Printf.sprintf "command %d" count); E_fg; S " >─[ "; B_fg (color lgreen green); S (String.concat " " (List.map LTerm_key.to_string_compact key_sequence)); E_fg; S " ]─"; ] in let txtb = if recording then eval [ B_bold bold; B_fg (color lcyan blue); S "{ "; B_fg (color lwhite black); S (Printf.sprintf "counter: %d" macro_counter); E_fg; S " }─[ "; B_fg (color lwhite black); S (Printf.sprintf "macro: %d" macro_count); E_fg; S " ]─"; ] else eval [ B_bold bold; B_fg (color lcyan blue); S "{ "; B_fg (color lwhite black); S (Printf.sprintf "counter: %d" macro_counter); E_fg; S " }─"; ] in let second_line = eval [ S "\n"; B_bold bold; B_fg (rgb 0xe3 0xaa 0x73); S "utop"; B_fg (color lgreen green); S " # "; ] in Array.append ( if Array.length txta + Array.length txtb > size.cols then Array.sub (Array.append txta txtb) 0 size.cols else Array.concat [ txta; Array.make (size.cols - Array.length txta - Array.length txtb) (UChar.of_int 0x2500, { none with foreground = Some (color lcyan blue); bold = Some bold }); txtb; ] ) second_line let default_prompt = S.l6 make_prompt UTop_private.ui profile count size key_sequence (S.l3 (fun x y z -> (x, y, z)) (Zed_macro.recording LTerm_read_line.macro) (Zed_macro.count LTerm_read_line.macro) (Zed_macro.counter LTerm_read_line.macro)) let prompt = ref default_prompt let () = Hashtbl.add Toploop.directive_table "utop_prompt_simple" (Toploop.Directive_none (fun () -> prompt := S.map (Printf.ksprintf LTerm_text.of_string "utop [%d]: ") count)); Hashtbl.add Toploop.directive_table "utop_prompt_dummy" (Toploop.Directive_none (fun () -> prompt := S.const (LTerm_text.of_string "# "))); Hashtbl.add Toploop.directive_table "utop_prompt_fancy_light" (Toploop.Directive_none (fun () -> set_profile Light; prompt := default_prompt)); Hashtbl.add Toploop.directive_table "utop_prompt_fancy_dark" (Toploop.Directive_none (fun () -> set_profile Dark; prompt := default_prompt)) (* +-----------------------------------------------------------------+ | Help | +-----------------------------------------------------------------+ *) module Bindings = Zed_input.Make (LTerm_key) module Keys_map = Map.Make (struct type t = LTerm_key.t list let compare = compare end) let name_of_action action = if action == end_and_accept_current_phrase then "end-and-accept-current-phrase" else LTerm_read_line.name_of_action action let doc_of_action action = if action == end_and_accept_current_phrase then "end the current phrase with the phrase terminator (;;) and evaluate it" else LTerm_read_line.doc_of_action action let () = Hashtbl.add Toploop.directive_table "utop_help" (Toploop.Directive_none (fun () -> print_endline "If you can't see the prompt properly try: #utop_prompt_simple utop defines the following directives: #utop_bindings : list all the current key bindings #utop_macro : display the currently recorded macro #topfind_log : display messages recorded from findlib since the beginning of the session #topfind_verbose : enable/disable topfind verbosity For a complete description of utop, look at the utop(1) manual page.")); Hashtbl.add Toploop.directive_table "utop_bindings" (Toploop.Directive_none (fun () -> let make_lines keys actions acc = match actions with | [] -> (String.concat " " (List.map LTerm_key.to_string_compact keys), "", "does nothing") :: acc | action :: actions -> let rec loop actions acc = match actions with | [] -> acc | action :: actions -> loop actions (("", name_of_action action, doc_of_action action) :: acc) in loop actions ((String.concat " " (List.map LTerm_key.to_string_compact keys), name_of_action action, doc_of_action action) :: acc) in let bindings = Bindings.fold (fun key actions map -> Keys_map.add key (List.map (fun action -> (LTerm_read_line.Edit action)) actions) map) !LTerm_edit.bindings Keys_map.empty in let bindings = Bindings.fold Keys_map.add !LTerm_read_line.bindings bindings in let table = List.rev (Keys_map.fold (fun keys action acc -> make_lines keys action acc) bindings []) in let size_key, size_name, size_doc = List.fold_left (fun (size_key, size_name, size_doc) (key, name, doc) -> (max (String.length key) size_key, max (String.length name) size_name, max (String.length doc) size_doc)) (0, 0, 0) table in let buf = Buffer.create 128 in let format_line (key, name, doc) = Buffer.clear buf; Buffer.add_string buf key; while Buffer.length buf < size_key do Buffer.add_char buf ' ' done; Buffer.add_string buf " : "; Buffer.add_string buf name; while Buffer.length buf < size_key + size_name + 3 do Buffer.add_char buf ' ' done; Buffer.add_string buf " -> "; Buffer.add_string buf doc; Buffer.add_char buf '\n'; output_string stdout (Buffer.contents buf) in List.iter format_line table; flush stdout)); Hashtbl.add Toploop.directive_table "utop_macro" (Toploop.Directive_none (fun () -> let macro = Zed_macro.contents LTerm_read_line.macro in List.iter (fun action -> output_string stdout (name_of_action action); output_char stdout '\n') macro; flush stdout)) let () = Hashtbl.add Toploop.directive_table "pwd" (Toploop.Directive_none (fun () -> print_endline (Sys.getcwd ()))) (* +-----------------------------------------------------------------+ | Camlp4 | +-----------------------------------------------------------------+ *) let print_error msg = Lazy.force LTerm.stdout >>= fun term -> LTerm.set_style term !UTop_private.error_style >>= fun () -> Lwt_io.print msg >>= fun () -> LTerm.set_style term LTerm_style.none >>= fun () -> LTerm.flush term let handle_findlib_error = function | Failure msg -> Lwt_main.run (print_error msg) | Fl_package_base.No_such_package(pkg, reason) -> Lwt_main.run (print_error (Printf.sprintf "No such package: %s%s\n" pkg (if reason <> "" then " - " ^ reason else ""))) | Fl_package_base.Package_loop pkg -> Lwt_main.run (print_error (Printf.sprintf "Package requires itself: %s\n" pkg)) | exn -> raise exn let check_for_camlp4_support () = try ignore (Fl_package_base.query "utop.camlp4"); true with Fl_package_base.No_such_package("utop.camlp4", "") -> Lwt_main.run (print_error "utop was built without camlp4 support.\n"); false let set_syntax syntax = match get_syntax (), syntax with | Normal, Normal | Camlp4o, Camlp4o | Camlp4r, Camlp4r -> () | (Camlp4o | Camlp4r), _ -> Lwt_main.run (print_error "Camlp4 already loaded, you cannot change the syntax now.\n") | Normal, Camlp4o -> if check_for_camlp4_support () then begin Topfind.syntax "camlp4o"; Topfind.load_deeply ["utop.camlp4"]; set_syntax Camlp4o; set_phrase_terminator ";;" end | Normal, Camlp4r -> if check_for_camlp4_support () then begin Topfind.syntax "camlp4r"; Topfind.load_deeply ["utop.camlp4"]; set_syntax Camlp4r; set_phrase_terminator ";"; add_keyword "value" end let () = Hashtbl.add Toploop.directive_table "camlp4o" (Toploop.Directive_none (fun () -> set_syntax Camlp4o)); Hashtbl.add Toploop.directive_table "camlp4r" (Toploop.Directive_none (fun () -> set_syntax Camlp4r)) (* +-----------------------------------------------------------------+ | Findlib stuff | +-----------------------------------------------------------------+ *) let topfind_log, set_topfind_log = S.create ~eq:(fun _ _ -> false) [] let () = let real_log = !Topfind.log in Topfind.log := fun str -> set_topfind_log (str :: S.value topfind_log); if S.value topfind_verbose then real_log str let () = Hashtbl.add Toploop.directive_table "topfind_log" (Toploop.Directive_none (fun () -> List.iter (fun str -> print_string str; print_char '\n') (S.value topfind_log); flush stdout)); Hashtbl.add Toploop.directive_table "topfind_verbose" (Toploop.Directive_bool set_topfind_verbose) let split_words str = let len = String.length str in let is_sep = function | ' ' | '\t' | '\r' | '\n' | ',' -> true | _ -> false in let rec skip i = if i = len then [] else if is_sep str.[i] then skip (i + 1) else extract i (i + 1) and extract i j = if j = len then [String.sub str i (j - i)] else if is_sep str.[j] then String.sub str i (j - i) :: skip (j + 1) else extract i (j + 1) in skip 0 let require packages = try let eff_packages = Findlib.package_deep_ancestors !Topfind.predicates packages in if get_syntax () = Normal && List.mem "camlp4" eff_packages then begin set_syntax Camlp4o; Topfind.load_deeply packages end else Topfind.load eff_packages with exn -> handle_findlib_error exn let () = Hashtbl.add Toploop.directive_table "require" (Toploop.Directive_string (fun str -> require (split_words str))) (* +-----------------------------------------------------------------+ | Initialization | +-----------------------------------------------------------------+ *) let () = (* "utop" is an internal library so it is not passed as "-package" to "ocamlfind ocamlmktop". *) Topfind.don't_load ["utop"]; Topfind.add_predicates ["byte"; "toploop"]; (* Add findlib path so Topfind is available and it won't be initialized twice if the user does [#use "topfind"]. *) Topdirs.dir_directory (Findlib.package_directory "findlib"); (* Make UTop accessible. *) Topdirs.dir_directory (Findlib.package_directory "utop") (* +-----------------------------------------------------------------+ | Compiler-libs re-exports | +-----------------------------------------------------------------+ *) let load_path = Config.load_path (* +-----------------------------------------------------------------+ | Deprecated | +-----------------------------------------------------------------+ *) let smart_accept = ref true let new_prompt_hooks = Lwt_sequence.create () let at_new_prompt f = ignore (Lwt_sequence.add_l f new_prompt_hooks) let prompt_continue = ref (S.const [| |]) let prompt_comment = ref (S.const [| |]) utop-1.19.3/src/lib/uTop.mli000066400000000000000000000250451275431303000155670ustar00rootroot00000000000000(* * uTop.mli * -------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of utop. *) (** UTop configuration. *) open React val version : string (** Version of utop. *) val count : int React.signal (** The number of commands already executed. *) val keywords : Set.Make(String).t ref (** The set of OCaml keywords. *) val add_keyword : string -> unit (** Add a new OCaml keyword. *) val require : string list -> unit (** Load all the given findlib packages *) type ui = Console | Emacs (** The user interface in use. *) val get_ui : unit -> ui (** Returns the user interface in use. *) val hide_reserved : bool signal (** If [true] (the default) identifiers starting with a '_' will be hidden from the output. i.e. the following phrase won't produces any output: {[ let _x = 1 ]} This is for hidding variables created by code generators for internal use. It can also be set/unset by the command line options [-hide-reserved] and [-show-reserved]. *) val get_hide_reserved : unit -> bool (** Returns the value of {!hide_reserved}. *) val set_hide_reserved : bool -> unit (** Modifies {!hide_reserved}. *) val topfind_verbose : bool signal (** If [false] (the default) messages from findlib are hidden. This is only effective with findlib >= 1.4. *) val get_topfind_verbose : unit -> bool (** Returns the value of {!topfind_verbose}. *) val set_topfind_verbose : bool -> unit (** Modifies {!topfind_verbose}. *) val topfind_log : string list signal (** List of messages logged by findlib since the beginning of the session. This requires findlib >= 1.4. *) val show_box : bool signal (** If [true] (the default) the completion bar is displayed. *) val get_show_box : unit -> bool (** Returns the value of {!show_box}. *) val set_show_box : bool -> unit (** Modifies {!show_box}. *) val set_margin_function : (LTerm_geom.size -> int option) -> unit (** Margin of the standard and error formatters as a function of the screen size. The default is: {[ fun size -> Some (max 80 size.cols) ]} *) (** Syntax. *) type syntax = | Normal (** No camlp4. *) | Camlp4o (** Camlp4, original syntax. *) | Camlp4r (** Camlp4, revised syntax. *) val syntax : syntax signal (** The syntax in use. If it is {!Camlp4o} or {!Camlp4r} quotations are recognized. It is modified when you type [#camlp4o] or [#camlp4r]. At the beginning it is {!Normal}. *) val get_syntax : unit -> syntax (** Returns the current value of {!syntax}. *) val set_syntax : syntax -> unit (** Changes the syntax used in utop. If the syntax is the same as the current one, it does nothing. Otherwise it loads camlp4 and setup several configuration variables. Notes: - the syntax can only be changed once. Once you set it to {!Camlp4o} or {!Camlp4r} you cannot change it again. - Typing [#camlp4o] is the same as calling [set_syntax Camlp4o]. - Typing [#camlp4r] is the same as calling [set_syntax Camlp4r]. *) val phrase_terminator : string signal (** The phrase terminator. It is ";;" by default and ";" when you use revised syntax. *) val get_phrase_terminator : unit -> string (** Returns the value of {!phrase_terminator}. *) val set_phrase_terminator : string -> unit (** Modifies {!phrase_terminator}. *) val auto_run_lwt : bool signal (** If [true] (the default) toplevel lwt expressions are automatically run with [Lwt_main.run]. i.e. if you type: {[ Lwt_io.printl "Hello, world" ]} this will be replaced by: {[ Lwt_main.run (Lwt_io.printl "Hello, world") ]} *) val get_auto_run_lwt : unit -> bool (** Returns the value of {!auto_run_lwt}. *) val set_auto_run_lwt : bool -> unit (** Modifies {!auto_run_lwt}. *) val auto_run_async : bool signal (** If [true] (the default) toplevel Async expressions are automatically run with in a separate thread with [Thread_safe.block_on_async_exn]. i.e. if you type: {[ after (Time.Span.of_s 1.0) ]} this will be replaced by: {[ Thread_safe.block_on_async_exn (fun () -> after (Time.Span.of_s 1.0)) ]} *) val get_auto_run_async : unit -> bool (** Returns the value of {!auto_run_async}. *) val set_auto_run_async : bool -> unit (** Modifies {!auto_run_async}. *) val end_and_accept_current_phrase : LTerm_read_line.action (** Action that add the phrase terminator at the end of the current phrase and accepts it. For instance to avoid typing [;;], add this to your ~/.ocamlinit: {[ #require "lambda-term";; LTerm_read_line.bind [ { control = false; meta = false; shift = false; code = Enter } ] [ UTop.end_and_accept_current_phrase ] ]} *) (** External editor command. [None] for default. *) val external_editor : string signal val set_external_editor : string -> unit val get_external_editor : unit -> string (** {6 History} *) val history : LTerm_history.t (** The history used by utop. You can configure limits using the [LTerm_history] module. For example if you want to limit the history to 1000 line, add these lines to your ~/.ocamlinit file: {[ #require "lambda-term";; LTerm_history.set_max_entries UTop.history 1000;; ]} *) val history_file_name : string option ref (** Name of the history file. If [None], no history will be loaded or saved. *) val history_file_max_size : int option ref (** Maximum size of the history file. If [None] (the default) the maximum size of [history] will be used. *) val history_file_max_entries : int option ref (** Maximum entries to store in the history file. If [None] (the default) the maximum number of entries if [history] will be used. *) (** {6 Console specific configuration} *) type profile = Dark | Light (** Profile for colors. *) val profile : profile React.signal (** The color profile. It defaults to {!Dark}. This is used by the default prompt to choose colors. *) val set_profile : profile -> unit (** Sets the color profile. *) val size : LTerm_geom.size React.signal (** The current size of the terminal. This is used only in the console UI. *) val key_sequence : LTerm_key.t list React.signal (** The current key sequence entered by the user. This is used only in the console UI. *) val time : float ref (** The time of the beginning of the current command. *) val prompt : LTerm_text.t React.signal ref (** The prompt. *) (** {6 Hooks} *) val new_command_hooks : (unit -> unit) Lwt_sequence.t (** Functions called before each new command. *) val at_new_command : (unit -> unit) -> unit (** [at_new_command f] adds [f] to the hooks executed before each new commands. *) (** {6 Parsing} *) type location = int * int (** Type of a string-location. It is composed of a start and stop offsets (in bytes). *) (** Result of a function processing a programx. *) type 'a result = | Value of 'a (** The function succeeded and returned this value. *) | Error of location list * string (** The function failed. Arguments are a list of locations to highlight in the source and an error message. *) exception Need_more (** Exception raised by a parser when it need more data. *) val parse_use_file : (string -> bool -> Parsetree.toplevel_phrase list result) ref val parse_use_file_default : string -> bool -> Parsetree.toplevel_phrase list result (** The default parser for toplevel regions. It uses the standard ocaml parser. *) val parse_toplevel_phrase : (string -> bool -> Parsetree.toplevel_phrase result) ref (** [parse_toplevel_phrase] is the function used to parse a phrase typed in the toplevel. Its arguments are: - [input]: the string to parse - [eos_is_error] If [eos_is_error] is [true] and the parser reach the end of input, then {!Parse_failure} should be returned. If [eos_is_error] is [false] and the parser reach the end of input, the exception {!Need_more} must be thrown. Except for {!Need_more}, the function must not raise any exception. *) val parse_toplevel_phrase_default : string -> bool -> Parsetree.toplevel_phrase result (** The default parser for toplevel phrases. It uses the standard ocaml parser. *) val parse_default : (Lexing.lexbuf -> 'a) -> string -> bool -> 'a result (** The default parser. It uses the standard ocaml parser. *) val input_name : string (** The name you must use in location to let ocaml know that it is from the toplevel. *) val lexbuf_of_string : bool ref -> string -> Lexing.lexbuf (** [lexbuf_of_string eof str] is the same as [Lexing.from_string str] except that if the lexer reach the end of [str] then [eof] is set to [true]. *) (** {6 Helpers} *) val get_message : (Format.formatter -> 'a -> unit) -> 'a -> string (** [get_message printer x] applies [printer] on [x] and returns everything it prints as a string. *) val get_ocaml_error_message : exn -> location * string (** [get_ocaml_error_message exn] returns the location and error message for the exception [exn] which must be an exception from the compiler. *) val check_phrase : Parsetree.toplevel_phrase -> (location list * string) option (** [check_phrase phrase] checks that [phrase] can be executed without typing or compilation errors. It returns [None] if [phrase] is OK and an error message otherwise. If the result is [None] it is guaranteed that [Toploop.execute_phrase] won't raise any exception. *) val collect_formatters : Buffer.t -> Format.formatter list -> (unit -> 'a) -> 'a (** [collect_formatters buf pps f] executes [f] and redirect everything it prints on [pps] to [buf]. *) val discard_formatters : Format.formatter list -> (unit -> 'a) -> 'a (** [discard_formatters pps f] executes [f], dropping everything it prints on [pps]. *) val split_words : string -> string list (** {6 compiler-libs reexports} *) val load_path : string list ref (** [load_path] is an alias of [Config.load_path], normally hidden in toplevel. It contains the list of directories added by findlib-required packages and [#directory] directives. *) (**/**) (* These variables are not used and deprecated: *) val prompt_continue : LTerm_text.t React.signal ref val prompt_comment : LTerm_text.t React.signal ref val smart_accept : bool ref val new_prompt_hooks : (unit -> unit) Lwt_sequence.t val at_new_prompt : (unit -> unit) -> unit utop-1.19.3/src/lib/uTop_complete.cppo.ml000066400000000000000000001161511275431303000202450ustar00rootroot00000000000000(* * uTop_complete.ml * ---------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of utop. *) open Types open LTerm_read_line open UTop_token module String_set = Set.Make(String) module String_map = Map.Make(String) let set_of_list = List.fold_left (fun set x -> String_set.add x set) String_set.empty (* +-----------------------------------------------------------------+ | Utils | +-----------------------------------------------------------------+ *) (* Transform a non-empty list of strings into a long-identifier. *) let longident_of_list = function | [] -> invalid_arg "UTop_complete.longident_of_list" | component :: rest -> let rec loop acc = function | [] -> acc | component :: rest -> loop (Longident.Ldot(acc, component)) rest in loop (Longident.Lident component) rest (* Check whether an identifier is a valid one. *) let is_valid_identifier id = id <> "" && (match id.[0] with | 'A' .. 'Z' | 'a' .. 'z' | '_' -> true | _ -> false) let add id set = if is_valid_identifier id then String_set.add id set else set let lookup_env f x env = try Some (f x env) with Not_found | Env.Error _ -> None (* +-----------------------------------------------------------------+ | Parsing | +-----------------------------------------------------------------+ *) (* The following functions takes a list of tokens in reverse order. *) type value_or_field = Value | Field (* Either a value, or a record field. *) (* Parse something of the form [M1.M2. ... .Mn.id] or [field.M1.M2. ... .Mn.id] *) let parse_longident tokens = let rec loop acc tokens = match tokens with | (Symbol ".", _) :: (Uident id, _) :: tokens -> loop (id :: acc) tokens | (Symbol ".", _) :: (Lident id, _) :: tokens -> (Field, match acc with | [] -> None | l -> Some (longident_of_list l)) | _ -> (Value, match acc with | [] -> None | l -> Some (longident_of_list l)) in match tokens with | ((Comment (_, false) | String (_, false) | Quotation (_, false)), _) :: _ -> (* An unterminated command, string, or quotation. *) None | ((Uident id | Lident id), { idx1 = start }) :: tokens -> (* An identifier. *) let kind, path = loop [] tokens in Some (kind, path, start, id) | (Blanks, { idx2 = stop }) :: tokens -> (* Some blanks at the end. *) let kind, path = loop [] tokens in Some (kind, path, stop, "") | (_, { idx2 = stop }) :: _ -> (* Otherwise complete after the last token. *) let kind, path = loop [] tokens in Some (kind, path, stop, "") | [] -> None (* Parse something of the form [M1.M2. ... .Mn.id#m1#m2# ... #mp#m] *) let parse_method tokens = (* Collect [M1.M2. ... .Mn.id] and returns the corresponding longidentifier. *) let rec loop_uidents acc tokens = match tokens with | (Symbol ".", _) :: (Uident id, _) :: tokens -> loop_uidents (id :: acc) tokens | _ -> longident_of_list acc in (* Collect [m1#m2# ... #mp] *) let rec loop_methods acc tokens = match tokens with | (Lident meth, _) :: (Symbol "#", _) :: tokens -> loop_methods (meth :: acc) tokens | (Lident id, _) :: tokens -> Some (loop_uidents [id] tokens, acc) | _ -> None in match tokens with | (Lident meth, { idx1 = start }) :: (Symbol "#", _) :: tokens -> begin match loop_methods [] tokens with | None -> None | Some (path, meths) -> Some (path, meths, start, meth) end | (Symbol "#", { idx2 = stop }) :: tokens | (Blanks, { idx2 = stop }) :: (Symbol "#", _) :: tokens -> begin match loop_methods [] tokens with | None -> None | Some (path, meths) -> Some (path, meths, stop, "") end | _ -> None type label_kind = Required | Optional (* Kind of labels: required or optional. *) type fun_or_new = Fun | New (* Either a function application, either an object creation. *) (* Parse something of the form [M1.M2. ... .Mn.id#m1#m2# ... #mp expr1 ... exprq ~label] or [new M1.M2. ... .Mn.id expr1 ... exprq ~label] *) let parse_label tokens = (* Collect [M1.M2. ... .Mn] *) let rec loop_uidents acc_uidents acc_methods tokens = match tokens with | (Lident "new", _) :: _ -> Some (New, longident_of_list acc_uidents, acc_methods) | ((Lident id | Uident id), _) :: _ when String_set.mem id !UTop.keywords -> Some (Fun, longident_of_list acc_uidents, acc_methods) | (Symbol ".", _) :: (Uident id, _) :: tokens -> loop_uidents (id :: acc_uidents) acc_methods tokens | (Symbol ("~" | "?" | ":" | "." | "#" | "!" | "`"), _) :: tokens -> search tokens | (Symbol ")", _) :: tokens -> skip tokens "(" [] | (Symbol "}", _) :: tokens -> skip tokens "{" [] | (Symbol "]", _) :: tokens -> skip tokens "[" [] | (Symbol _, _) :: _ -> Some (Fun, longident_of_list acc_uidents, acc_methods) | [] -> Some (Fun, longident_of_list acc_uidents, acc_methods) | _ -> search tokens and loop_methods acc tokens = match tokens with | ((Lident id | Uident id), _) :: _ when String_set.mem id !UTop.keywords -> None | (Symbol ("~" | "?" | ":" | "." | "#" | "!" | "`"), _) :: tokens -> search tokens | (Symbol ")", _) :: tokens -> skip tokens "(" [] | (Symbol "}", _) :: tokens -> skip tokens "{" [] | (Symbol "]", _) :: tokens -> skip tokens "[" [] | (Symbol _, _) :: _ -> None | (Lident id, _) :: (Symbol "#", _) :: tokens -> loop_methods (id :: acc) tokens | (Lident id, _) :: tokens -> loop_uidents [id] acc tokens | [] -> None | _ -> search tokens and search tokens = match tokens with | ((Lident id | Uident id), _) :: _ when String_set.mem id !UTop.keywords -> None | (Symbol ("~" | "?" | ":" | "." | "#" | "!" | "`"), _) :: tokens -> search tokens | (Symbol ")", _) :: tokens -> skip tokens "(" [] | (Symbol "}", _) :: tokens -> skip tokens "{" [] | (Symbol "]", _) :: tokens -> skip tokens "[" [] | (Symbol _, _) :: _ -> None | (Lident id, _) :: (Symbol "#", _) :: tokens -> loop_methods [id] tokens | (Lident id, _) :: tokens -> loop_uidents [id] [] tokens | _ :: tokens -> search tokens | [] -> None and skip tokens top stack = match tokens with | (Symbol symbol, _) :: tokens when symbol = top -> begin match stack with | [] -> search tokens | top :: stack -> skip tokens top stack end | (Symbol ")", _) :: tokens -> skip tokens "(" (top :: stack) | (Symbol "}", _) :: tokens -> skip tokens "{" (top :: stack) | (Symbol "]", _) :: tokens -> skip tokens "[" (top :: stack) | _ :: tokens -> skip tokens top stack | [] -> None in match tokens with | (Lident label, { idx1 = start }) :: (Symbol "~", _) :: tokens -> begin match search tokens with | None -> None | Some (kind, id, meths) -> Some (kind, id, meths, Required, start, label) end | (Symbol "~", { idx2 = stop }) :: tokens -> begin match search tokens with | None -> None | Some (kind, id, meths) -> Some (kind, id, meths, Required, stop, "") end | (Lident label, { idx1 = start }) :: (Symbol "?", _) :: tokens -> begin match search tokens with | None -> None | Some (kind, id, meths) -> Some (kind, id, meths, Optional, start, label) end | (Symbol "?", { idx2 = stop }) :: tokens -> begin match search tokens with | None -> None | Some (kind, id, meths) -> Some (kind, id, meths, Optional, stop, "") end | _ -> None (* +-----------------------------------------------------------------+ | Directive listing | +-----------------------------------------------------------------+ *) let list_directives phrase_terminator = String_map.bindings (Hashtbl.fold (fun dir kind map -> let suffix = match kind with | Toploop.Directive_none _ -> phrase_terminator | Toploop.Directive_string _ -> " \"" | Toploop.Directive_bool _ | Toploop.Directive_int _ | Toploop.Directive_ident _ -> " " in String_map.add dir suffix map) Toploop.directive_table String_map.empty) (* +-----------------------------------------------------------------+ | File listing | +-----------------------------------------------------------------+ *) type file_kind = Directory | File let basename name = let name' = Filename.basename name in if name' = "." && not (Zed_utf8.ends_with name ".") then "" else name' let add_files filter acc dir = Array.fold_left (fun map name -> let absolute_name = Filename.concat dir name in if try Sys.is_directory absolute_name with Sys_error _ -> false then String_map.add (Filename.concat name "") Directory map else if filter name then String_map.add name File map else map) acc (try Sys.readdir dir with Sys_error _ -> [||]) let list_directories dir = String_set.elements (Array.fold_left (fun set name -> let absolute_name = Filename.concat dir name in if try Sys.is_directory absolute_name with Sys_error _ -> false then String_set.add name set else set) String_set.empty (try Sys.readdir (if dir = "" then Filename.current_dir_name else dir) with Sys_error _ -> [||])) #if OCAML_VERSION >= (4, 02, 0) let path () = let path_separator = match Sys.os_type with | "Unix" | "Cygwin" -> ':' | "Win32" -> ';' | _ -> assert false in let split str sep = let rec split_rec pos = if pos >= String.length str then [] else begin match try Some (String.index_from str pos sep) with Not_found -> None with | Some newpos -> String.sub str pos (newpos - pos) :: split_rec (newpos + 1) | None -> [String.sub str pos (String.length str - pos)] end in split_rec 0 in try split (Sys.getenv "PATH") path_separator with Not_found -> [] #endif (* +-----------------------------------------------------------------+ | Names listing | +-----------------------------------------------------------------+ *) module Path_map = Map.Make(struct type t = Path.t let compare = compare end) module Longident_map = Map.Make(struct type t = Longident.t let compare = compare end) (* All names accessible without a path. *) let global_names = ref None let global_names_revised = ref None (* All names accessible with a path, by path. *) let local_names_by_path = ref Path_map.empty (* All names accessible with a path, by long identifier. *) let local_names_by_longident = ref Longident_map.empty (* All record fields accessible without a path. *) let global_fields = ref None (* All record fields accessible with a path, by path. *) let local_fields_by_path = ref Path_map.empty (* All record fields accessible with a path, by long identifier. *) let local_fields_by_longident = ref Longident_map.empty (* All visible modules according to Config.load_path. *) let visible_modules = ref None let reset () = visible_modules := None; global_names := None; global_names_revised := None; local_names_by_path := Path_map.empty; local_names_by_longident := Longident_map.empty; global_fields := None; local_fields_by_path := Path_map.empty; local_fields_by_longident := Longident_map.empty let get_cached var f = match !var with | Some x -> x | None -> let x = f () in var := Some x; x (* List all visible modules. *) let visible_modules () = get_cached visible_modules (fun () -> List.fold_left (fun acc dir -> try Array.fold_left (fun acc fname -> if Filename.check_suffix fname ".cmi" then String_set.add (String.capitalize (Filename.chop_suffix fname ".cmi")) acc else acc) acc (Sys.readdir (if dir = "" then Filename.current_dir_name else dir)) with Sys_error _ -> acc) String_set.empty !Config.load_path) #if OCAML_VERSION >= (4, 02, 0) let field_name { ld_id = id } = Ident.name id let constructor_name { cd_id = id } = Ident.name id #else let field_name (id, _, _) = Ident.name id let constructor_name (id, _, _) = Ident.name id #endif let add_fields_of_type decl acc = match decl.type_kind with | Type_variant constructors -> acc | Type_record (fields, _) -> List.fold_left (fun acc field -> add (field_name field) acc) acc fields | Type_abstract -> acc #if OCAML_VERSION >= (4, 02, 0) | Type_open -> acc #endif let add_names_of_type decl acc = match decl.type_kind with | Type_variant constructors -> List.fold_left (fun acc cstr -> add (constructor_name cstr) acc) acc constructors | Type_record (fields, _) -> List.fold_left (fun acc field -> add (field_name field) acc) acc fields | Type_abstract -> acc #if OCAML_VERSION >= (4, 02, 0) | Type_open -> acc #endif #if OCAML_VERSION >= (4, 04, 0) let path_of_mty_alias = function | Mty_alias (_, path) -> path | _ -> assert false #elif OCAML_VERSION >= (4, 02, 0) let path_of_mty_alias = function | Mty_alias path -> path | _ -> assert false #endif let rec names_of_module_type = function | Mty_signature decls -> List.fold_left (fun acc decl -> match decl with | Sig_value (id, _) #if OCAML_VERSION >= (4, 02, 0) | Sig_typext (id, _, _) #else | Sig_exception (id, _) #endif | Sig_module (id, _, _) | Sig_modtype (id, _) | Sig_class (id, _, _) | Sig_class_type (id, _, _) -> add (Ident.name id) acc | Sig_type (id, decl, _) -> add_names_of_type decl (add (Ident.name id) acc)) String_set.empty decls | Mty_ident path -> begin match lookup_env Env.find_modtype path !Toploop.toplevel_env with #if OCAML_VERSION < (4, 02, 0) | Some Modtype_abstract -> String_set.empty | Some Modtype_manifest module_type -> names_of_module_type module_type #else | Some { mtd_type = None } -> String_set.empty | Some { mtd_type = Some module_type } -> names_of_module_type module_type #endif | None -> String_set.empty end #if OCAML_VERSION >= (4, 02, 0) | Mty_alias _ as mty_alias -> begin let path = path_of_mty_alias mty_alias in match lookup_env Env.find_module path !Toploop.toplevel_env with | None -> String_set.empty | Some { md_type = module_type } -> names_of_module_type module_type end #endif | _ -> String_set.empty let rec fields_of_module_type = function | Mty_signature decls -> List.fold_left (fun acc decl -> match decl with | Sig_value (id, _) #if OCAML_VERSION >= (4, 02, 0) | Sig_typext (id, _, _) #else | Sig_exception (id, _) #endif | Sig_module (id, _, _) | Sig_modtype (id, _) | Sig_class (id, _, _) | Sig_class_type (id, _, _) -> acc | Sig_type (id, decl, _) -> add_fields_of_type decl acc) String_set.empty decls | Mty_ident path -> begin match lookup_env Env.find_modtype path !Toploop.toplevel_env with #if OCAML_VERSION < (4, 02, 0) | Some Modtype_abstract -> String_set.empty | Some Modtype_manifest module_type -> fields_of_module_type module_type #else | Some { mtd_type = None } -> String_set.empty | Some { mtd_type = Some module_type } -> fields_of_module_type module_type #endif | None -> String_set.empty end #if OCAML_VERSION >= (4, 02, 0) | Mty_alias _ as mty_alias -> begin let path = path_of_mty_alias mty_alias in match lookup_env Env.find_module path !Toploop.toplevel_env with | None -> String_set.empty | Some { md_type = module_type } -> fields_of_module_type module_type end #endif | _ -> String_set.empty #if OCAML_VERSION < (4, 02, 0) let lookup_module = Env.lookup_module let find_module = Env.find_module #else let lookup_module id env = let path = Env.lookup_module id env ~load:true in (path, (Env.find_module path env).md_type) let find_module path env = (Env.find_module path env).md_type #endif let names_of_module longident = try Longident_map.find longident !local_names_by_longident with Not_found -> match lookup_env lookup_module longident !Toploop.toplevel_env with | Some(path, module_type) -> let names = names_of_module_type module_type in local_names_by_path := Path_map.add path names !local_names_by_path; local_names_by_longident := Longident_map.add longident names !local_names_by_longident; names | None -> local_names_by_longident := Longident_map.add longident String_set.empty !local_names_by_longident; String_set.empty let fields_of_module longident = try Longident_map.find longident !local_fields_by_longident with Not_found -> match lookup_env lookup_module longident !Toploop.toplevel_env with | Some(path, module_type) -> let fields = fields_of_module_type module_type in local_fields_by_path := Path_map.add path fields !local_fields_by_path; local_fields_by_longident := Longident_map.add longident fields !local_fields_by_longident; fields | None -> local_fields_by_longident := Longident_map.add longident String_set.empty !local_fields_by_longident; String_set.empty let list_global_names () = let rec loop acc = function | Env.Env_empty -> acc | Env.Env_value(summary, id, _) -> loop (add (Ident.name id) acc) summary | Env.Env_type(summary, id, decl) -> loop (add_names_of_type decl (add (Ident.name id) acc)) summary #if OCAML_VERSION >= (4, 02, 0) | Env.Env_extension(summary, id, _) -> #else | Env.Env_exception(summary, id, _) -> #endif loop (add (Ident.name id) acc) summary | Env.Env_module(summary, id, _) -> loop (add (Ident.name id) acc) summary | Env.Env_modtype(summary, id, _) -> loop (add (Ident.name id) acc) summary | Env.Env_class(summary, id, _) -> loop (add (Ident.name id) acc) summary | Env.Env_cltype(summary, id, _) -> loop (add (Ident.name id) acc) summary #if OCAML_VERSION >= (4, 02, 0) | Env.Env_functor_arg(summary, id) -> loop (add (Ident.name id) acc) summary #endif #if OCAML_VERSION >= (4, 04, 0) | Env.Env_constraints (summary, _) -> loop acc summary #endif | Env.Env_open(summary, path) -> match try Some (Path_map.find path !local_names_by_path) with Not_found -> None with | Some names -> loop (String_set.union acc names) summary | None -> match lookup_env find_module path !Toploop.toplevel_env with | Some module_type -> let names = names_of_module_type module_type in local_names_by_path := Path_map.add path names !local_names_by_path; loop (String_set.union acc names) summary | None -> local_names_by_path := Path_map.add path String_set.empty !local_names_by_path; loop acc summary in (* Add names of the environment: *) let acc = loop String_set.empty (Env.summary !Toploop.toplevel_env) in (* Add accessible modules: *) String_set.union acc (visible_modules ()) let global_names () = get_cached global_names list_global_names let replace x y set = if String_set.mem x set then String_set.add y (String_set.remove x set) else set let global_names_revised () = get_cached global_names_revised (fun () -> let set = global_names () in replace "true" "True" (replace "false" "False" set)) let global_names syntax = match syntax with | UTop.Normal | UTop.Camlp4o -> global_names () | UTop.Camlp4r -> global_names_revised () let list_global_fields () = let rec loop acc = function | Env.Env_empty -> acc | Env.Env_value(summary, id, _) -> loop (add (Ident.name id) acc) summary | Env.Env_type(summary, id, decl) -> loop (add_fields_of_type decl (add (Ident.name id) acc)) summary #if OCAML_VERSION >= (4, 02, 0) | Env.Env_extension(summary, id, _) -> #else | Env.Env_exception(summary, id, _) -> #endif loop (add (Ident.name id) acc) summary | Env.Env_module(summary, id, _) -> loop (add (Ident.name id) acc) summary #if OCAML_VERSION >= (4, 02, 0) | Env.Env_functor_arg(summary, id) -> loop (add (Ident.name id) acc) summary #endif | Env.Env_modtype(summary, id, _) -> loop (add (Ident.name id) acc) summary | Env.Env_class(summary, id, _) -> loop (add (Ident.name id) acc) summary | Env.Env_cltype(summary, id, _) -> loop (add (Ident.name id) acc) summary #if OCAML_VERSION >= (4, 04, 0) | Env.Env_constraints (summary, _) -> loop acc summary #endif | Env.Env_open(summary, path) -> match try Some (Path_map.find path !local_fields_by_path) with Not_found -> None with | Some fields -> loop (String_set.union acc fields) summary | None -> match lookup_env find_module path !Toploop.toplevel_env with | Some module_type -> let fields = fields_of_module_type module_type in local_fields_by_path := Path_map.add path fields !local_fields_by_path; loop (String_set.union acc fields) summary | None -> local_fields_by_path := Path_map.add path String_set.empty !local_fields_by_path; loop acc summary in (* Add fields of the environment: *) let acc = loop String_set.empty (Env.summary !Toploop.toplevel_env) in (* Add accessible modules: *) String_set.union acc (visible_modules ()) let global_fields () = get_cached global_fields list_global_fields (* +-----------------------------------------------------------------+ | Listing methods | +-----------------------------------------------------------------+ *) let rec find_method meth type_expr = match type_expr.desc with | Tlink type_expr -> find_method meth type_expr | Tobject (type_expr, _) -> find_method meth type_expr | Tfield (name, _, type_expr, rest) -> if name = meth then Some type_expr else find_method meth rest | Tpoly (type_expr, _) -> find_method meth type_expr | Tconstr (path, _, _) -> begin match lookup_env Env.find_type path !Toploop.toplevel_env with | None | Some { type_manifest = None } -> None | Some { type_manifest = Some type_expr } -> find_method meth type_expr end | _ -> None let rec methods_of_type acc type_expr = match type_expr.desc with | Tlink type_expr -> methods_of_type acc type_expr | Tobject (type_expr, _) -> methods_of_type acc type_expr | Tfield (name, _, _, rest) -> methods_of_type (add name acc) rest | Tpoly (type_expr, _) -> methods_of_type acc type_expr | Tconstr (path, _, _) -> begin match lookup_env Env.find_type path !Toploop.toplevel_env with | None | Some { type_manifest = None } -> acc | Some { type_manifest = Some type_expr } -> methods_of_type acc type_expr end | _ -> acc let rec find_object meths type_expr = match meths with | [] -> Some type_expr | meth :: meths -> match find_method meth type_expr with | Some type_expr -> find_object meths type_expr | None -> None let methods_of_object longident meths = match lookup_env Env.lookup_value longident !Toploop.toplevel_env with | None -> [] | Some (path, { val_type = type_expr }) -> match find_object meths type_expr with | None -> [] | Some type_expr -> String_set.elements (methods_of_type String_set.empty type_expr) (* +-----------------------------------------------------------------+ | Listing labels | +-----------------------------------------------------------------+ *) let rec labels_of_type acc type_expr = match type_expr.desc with | Tlink te -> labels_of_type acc te | Tpoly (te, _) -> labels_of_type acc te | Tarrow(label, _, te, _) -> #if OCAML_VERSION < (4, 03, 0) if label = "" then labels_of_type acc te else if label.[0] = '?' then labels_of_type (String_map.add (String.sub label 1 (String.length label - 1)) Optional acc) te else labels_of_type (String_map.add label Required acc) te #else (match label with | Nolabel -> labels_of_type acc te | Optional label -> labels_of_type (String_map.add label Optional acc) te | Labelled label -> labels_of_type (String_map.add label Required acc) te) #endif | Tconstr(path, _, _) -> begin match lookup_env Env.find_type path !Toploop.toplevel_env with | None | Some { type_manifest = None } -> String_map.bindings acc | Some { type_manifest = Some type_expr } -> labels_of_type acc type_expr end | _ -> String_map.bindings acc let labels_of_function longident meths = match lookup_env Env.lookup_value longident !Toploop.toplevel_env with | None -> [] | Some (path, { val_type = type_expr }) -> match find_object meths type_expr with | None -> [] | Some type_expr -> labels_of_type String_map.empty type_expr let labels_of_newclass longident = match lookup_env Env.lookup_class longident !Toploop.toplevel_env with | None -> [] | Some (path, { cty_new = None }) -> [] | Some (path, { cty_new = Some type_expr }) -> labels_of_type String_map.empty type_expr (* +-----------------------------------------------------------------+ | Tokens processing | +-----------------------------------------------------------------+ *) (* Filter blanks and comments except for the last token. *) let rec filter tokens = match tokens with | [] -> [] | [((Blanks | Comment (_, true)), loc)] -> [(Blanks, loc)] | ((Blanks | Comment (_, true)), _) :: rest -> filter rest | x :: rest -> x :: filter rest (* Reverse and filter blanks and comments except for the last token. *) let rec rev_filter acc tokens = match tokens with | [] -> acc | [((Blanks | Comment (_, true)), loc)] -> (Blanks, loc) :: acc | ((Blanks | Comment (_, true)), _) :: rest -> rev_filter acc rest | x :: rest -> rev_filter (x :: acc) rest (* Find the current context. *) let rec find_context tokens = function | [] -> Some (rev_filter [] tokens) | [(Quotation (items, false), _)] -> find_context_in_quotation items | _ :: rest -> find_context tokens rest and find_context_in_quotation = function | [] -> None | [(Quot_anti { a_closing = None; a_contents = tokens }, _)] -> find_context tokens tokens | _ :: rest -> find_context_in_quotation rest (* +-----------------------------------------------------------------+ | Completion | +-----------------------------------------------------------------+ *) let complete ~syntax ~phrase_terminator ~input = let true_name, false_name = match syntax with | UTop.Normal | UTop.Camlp4o -> ("true", "false") | UTop.Camlp4r -> ("True", "False") in let tokens = UTop_lexer.lex_string syntax input in (* Filter blanks and comments. *) let tokens = filter tokens in match tokens with (* Completion on directive names. *) | [(Symbol "#", { idx2 = stop })] | [(Symbol "#", _); (Blanks, { idx2 = stop })] -> (stop, list_directives phrase_terminator) | [(Symbol "#", _); ((Lident src | Uident src), { idx1 = start })] -> (start, lookup_assoc src (list_directives phrase_terminator)) (* Complete with ";;" when possible. *) | [(Symbol "#", _); ((Lident _ | Uident _), _); (String (_, true), { idx2 = stop })] | [(Symbol "#", _); ((Lident _ | Uident _), _); (String (_, true), _); (Blanks, { idx2 = stop })] -> (stop, [(phrase_terminator, "")]) | [(Symbol "#", _); ((Lident _ | Uident _), _); (String (_, true), _); (Symbol sym, { idx1 = start })] -> if Zed_utf8.starts_with phrase_terminator sym then (start, [(phrase_terminator, "")]) else (0, []) (* Completion on #require. *) | [(Symbol "#", _); (Lident "require", _); (String (tlen, false), loc)] -> let pkg = String.sub input (loc.ofs1 + tlen) (String.length input - loc.ofs1 - tlen) in let pkgs = lookup pkg (Fl_package_base.list_packages ()) in (loc.idx1 + 1, List.map (fun pkg -> (pkg, "\"" ^ phrase_terminator)) (List.sort compare pkgs)) | [(Symbol "#", _); (Lident "typeof", _); (String (tlen, false), loc)] -> let prefix = String.sub input (loc.ofs1 + tlen) (String.length input - loc.ofs1 - tlen) in begin match Longident.parse prefix with | Longident.Ldot (lident, last_prefix) -> let set = names_of_module lident in let compls = lookup last_prefix (String_set.elements set) in let start = loc.idx1 + 1 + (String.length prefix - String.length last_prefix) in (start, List.map (fun w -> (w, "")) compls) | _ -> let set = global_names syntax in let compls = lookup prefix (String_set.elements set) in (loc.idx1 + 1, List.map (fun w -> (w, "")) compls) end (* Completion on #load. *) | [(Symbol "#", _); (Lident ("load" | "load_rec"), _); (String (tlen, false), loc)] -> let file = String.sub input (loc.ofs1 + tlen) (String.length input - loc.ofs1 - tlen) in let filter name = Filename.check_suffix name ".cma" || Filename.check_suffix name ".cmo" in let map = if Filename.is_relative file then let dir = Filename.dirname file in List.fold_left (fun acc d -> add_files filter acc (Filename.concat d dir)) String_map.empty (Filename.current_dir_name :: !Config.load_path) else add_files filter String_map.empty (Filename.dirname file) in let list = String_map.bindings map in let name = basename file in let result = lookup_assoc name list in (loc.idx2 - Zed_utf8.length name, List.map (function (w, Directory) -> (w, "") | (w, File) -> (w, "\"" ^ phrase_terminator)) result) #if OCAML_VERSION >= (4, 02, 0) (* Completion on #ppx. *) | [(Symbol "#", _); (Lident ("ppx"), _); (String (tlen, false), loc)] -> let file = String.sub input (loc.ofs1 + tlen) (String.length input - loc.ofs1 - tlen) in let filter ~dir_ok name = try Unix.access name [Unix.X_OK]; let kind = (Unix.stat name).Unix.st_kind in let basename = Filename.basename name in (kind = Unix.S_REG && String.length basename >= 4 && String.sub basename 0 4 = "ppx_") || (dir_ok && kind = Unix.S_DIR) with Unix.Unix_error _ -> false in let map = if Filename.dirname file = "." && not (Filename.is_implicit file) then let dir = Filename.dirname file in add_files (filter ~dir_ok:true) String_map.empty dir else List.fold_left (fun acc dir -> add_files (fun name -> filter ~dir_ok:false (Filename.concat dir name)) acc dir) String_map.empty (path ()) in let list = String_map.bindings map in let name = basename file in let result = lookup_assoc name list in (loc.idx2 - Zed_utf8.length name, List.map (function (w, Directory) -> (w, "") | (w, File) -> (w, "\"" ^ phrase_terminator)) result) #endif (* Completion on #use. *) | [(Symbol "#", _); (Lident "use", _); (String (tlen, false), loc)] -> let file = String.sub input (loc.ofs1 + tlen) (String.length input - loc.ofs1 - tlen) in let filter name = match try Some (String.rindex name '.') with Not_found -> None with | None -> true | Some idx -> let ext = String.sub name (idx + 1) (String.length name - (idx + 1)) in ext = "ml" in let map = if Filename.is_relative file then let dir = Filename.dirname file in List.fold_left (fun acc d -> add_files filter acc (Filename.concat d dir)) String_map.empty (Filename.current_dir_name :: !Config.load_path) else add_files filter String_map.empty (Filename.dirname file) in let list = String_map.bindings map in let name = basename file in let result = lookup_assoc name list in (loc.idx2 - Zed_utf8.length name, List.map (function (w, Directory) -> (w, "") | (w, File) -> (w, "\"" ^ phrase_terminator)) result) (* Completion on #directory and #cd. *) | [(Symbol "#", _); (Lident ("cd" | "directory"), _); (String (tlen, false), loc)] -> let file = String.sub input (loc.ofs1 + tlen) (String.length input - loc.ofs1 - tlen) in let list = list_directories (Filename.dirname file) in let name = basename file in let result = lookup name list in (loc.idx2 - Zed_utf8.length name, List.map (function dir -> (dir, "")) result) (* Generic completion on directives. *) | [(Symbol "#", _); ((Lident dir | Uident dir), _); (Blanks, { idx2 = stop })] -> (stop, match try Some (Hashtbl.find Toploop.directive_table dir) with Not_found -> None with | Some (Toploop.Directive_none _) -> [(phrase_terminator, "")] | Some (Toploop.Directive_string _) -> [(" \"", "")] | Some (Toploop.Directive_bool _) -> [(true_name, phrase_terminator); (false_name, phrase_terminator)] | Some (Toploop.Directive_int _) -> [] | Some (Toploop.Directive_ident _) -> List.map (fun w -> (w, "")) (String_set.elements (global_names syntax)) | None -> []) | (Symbol "#", _) :: ((Lident dir | Uident dir), _) :: tokens -> begin match try Some (Hashtbl.find Toploop.directive_table dir) with Not_found -> None with | Some (Toploop.Directive_none _) -> (0, []) | Some (Toploop.Directive_string _) -> (0, []) | Some (Toploop.Directive_bool _) -> begin match tokens with | [(Lident id, { idx1 = start })] -> (start, lookup_assoc id [(true_name, phrase_terminator); (false_name, phrase_terminator)]) | _ -> (0, []) end | Some (Toploop.Directive_int _) -> (0, []) | Some (Toploop.Directive_ident _) -> begin match parse_longident (List.rev tokens) with | Some (Value, None, start, id) -> (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (global_names syntax)))) | Some (Value, Some longident, start, id) -> (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (names_of_module longident)))) | _ -> (0, []) end | None -> (0, []) end (* Completion on identifiers. *) | _ -> match find_context tokens tokens with | None -> (0, []) | Some [] -> (0, List.map (fun w -> (w, "")) (String_set.elements (String_set.union !UTop.keywords (global_names syntax)))) | Some tokens -> match parse_method tokens with | Some (longident, meths, start, meth) -> (start, List.map (fun w -> (w, "")) (lookup meth (methods_of_object longident meths))) | None -> match parse_label tokens with | Some (Fun, longident, meths, Optional, start, label) -> (start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (List.filter (function (w, Optional) -> true | (w, Required) -> false) (labels_of_function longident meths)))) | Some (Fun, longident, meths, Required, start, label) -> (start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (labels_of_function longident meths))) | Some (New, longident, meths, Optional, start, label) -> (start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (List.filter (function (w, Optional) -> true | (w, Required) -> false) (labels_of_newclass longident)))) | Some (New, longident, meths, Required, start, label) -> (start, List.map (fun (w, kind) -> (w, ":")) (lookup_assoc label (labels_of_newclass longident))) | None -> match parse_longident tokens with | None -> (0, []) | Some (Value, None, start, id) -> (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (String_set.union !UTop.keywords (global_names syntax))))) | Some (Value, Some longident, start, id) -> (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (names_of_module longident)))) | Some (Field, None, start, id) -> (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (global_fields ())))) | Some (Field, Some longident, start, id) -> (start, List.map (fun w -> (w, "")) (lookup id (String_set.elements (fields_of_module longident)))) let complete ~syntax ~phrase_terminator ~input = try (complete ~syntax ~phrase_terminator ~input : int * (string * string) list) with Cmi_format.Error _ -> (0, []) utop-1.19.3/src/lib/uTop_complete.mli000066400000000000000000000011251275431303000174500ustar00rootroot00000000000000(* * uTop_complete.mli * ----------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of utop. *) (** OCaml completion. *) val complete : syntax : UTop.syntax -> phrase_terminator : string -> input : string -> int * (string * string) list (** [complete ~syntax ~phrase_terminator ~input] returns the start of the completed word in [input] and the list of possible completions with their suffixes. *) val reset : unit -> unit (** Reset global cache. It must be called before each interactive read line. *) utop-1.19.3/src/lib/uTop_lexer.mli000066400000000000000000000005061275431303000167610ustar00rootroot00000000000000(* * uTop_lexer.mli * -------------- * Copyright : (c) 2012, Jeremie Dimino * Licence : BSD3 * * This file is a part of utop. *) val lex_string : UTop.syntax -> string -> (UTop_token.t * UTop_token.location) list (** [lex_string syntax str] returns all the tokens contained in [str]. *) utop-1.19.3/src/lib/uTop_lexer.mll000066400000000000000000000224361275431303000167720ustar00rootroot00000000000000(* * uTop_lexer.mll * -------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of utop. *) (* Lexer for the OCaml language. *) { open Lexing open UTop_token (* Return the size in bytes. *) let lexeme_size lexbuf = lexeme_end lexbuf - lexeme_start lexbuf let mkloc idx1 idx2 ofs1 ofs2 = { idx1 = idx1; idx2 = idx2; ofs1 = ofs1; ofs2 = ofs2; } (* Only for ascii-only lexemes. *) let lexeme_loc idx lexbuf = let ofs1 = lexeme_start lexbuf and ofs2 = lexeme_end lexbuf in { idx1 = idx; idx2 = idx + (ofs2 - ofs1); ofs1 = ofs1; ofs2 = ofs2; } let merge_loc l1 l2 = { idx1 = l1.idx1; idx2 = l2.idx2; ofs1 = l1.ofs1; ofs2 = l2.ofs2; } type context = | Toplevel | Antiquot } let uchar = ['\x00' - '\x7f'] | _ [ '\x80' - '\xbf' ]* let blank = [' ' '\009' '\012'] let lowercase = ['a'-'z' '_'] let uppercase = ['A'-'Z'] let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9'] let lident = lowercase identchar* let uident = uppercase identchar* let ident = (lowercase|uppercase) identchar* let hexa_char = ['0'-'9' 'A'-'F' 'a'-'f'] let decimal_literal = ['0'-'9'] ['0'-'9' '_']* let hex_literal = '0' ['x' 'X'] hexa_char ['0'-'9' 'A'-'F' 'a'-'f' '_']* let oct_literal = '0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']* let bin_literal = '0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']* let int_literal = decimal_literal | hex_literal | oct_literal | bin_literal let float_literal = ['0'-'9'] ['0'-'9' '_']* ('.' ['0'-'9' '_']* )? (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)? let symbolchar = ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] rule tokens syntax context idx acc = parse | eof { (idx, None, List.rev acc) } | ('\n' | blank)+ { let loc = lexeme_loc idx lexbuf in tokens syntax context loc.idx2 ((Blanks, loc) :: acc) lexbuf } | lident { let src = lexeme lexbuf in let loc = lexeme_loc idx lexbuf in let tok = match syntax, src with | (UTop.Normal | UTop.Camlp4o), ("true" | "false") -> Constant src | _ -> Lident src in tokens syntax context loc.idx2 ((tok, loc) :: acc) lexbuf } | uident { let src = lexeme lexbuf in let loc = lexeme_loc idx lexbuf in let tok = match syntax, src with | UTop.Camlp4r, "True" -> Constant "true" | UTop.Camlp4r, "False" -> Constant "false" | _ -> Uident src in tokens syntax context loc.idx2 ((tok, loc) :: acc) lexbuf } | int_literal "l" | int_literal "L" | int_literal "n" | int_literal | float_literal { let loc = lexeme_loc idx lexbuf in let tok = Constant (lexeme lexbuf) in tokens syntax context loc.idx2 ((tok, loc) :: acc) lexbuf } | '"' { let ofs = lexeme_start lexbuf in let idx2, terminated = string (idx + 1) lexbuf in let loc = mkloc idx idx2 ofs (lexeme_end lexbuf) in tokens syntax context idx2 ((String (1, terminated), loc) :: acc) lexbuf } | '{' (lowercase* as tag) '|' { let ofs = lexeme_start lexbuf in let delim_len = String.length tag + 2 in let idx2, terminated = quoted_string (idx + delim_len) tag lexbuf in let loc = mkloc idx idx2 ofs (lexeme_end lexbuf) in tokens syntax context idx2 ((String (delim_len, terminated), loc) :: acc) lexbuf } | "'" [^'\'' '\\'] "'" | "'\\" ['\\' '"' 'n' 't' 'b' 'r' ' ' '\'' 'x' '0'-'9'] eof | "'\\" ['\\' '"' 'n' 't' 'b' 'r' ' ' '\''] "'" | "'\\" (['0'-'9'] ['0'-'9'] | 'x' hexa_char) eof | "'\\" (['0'-'9'] ['0'-'9'] ['0'-'9'] | 'x' hexa_char hexa_char) eof | "'\\" (['0'-'9'] ['0'-'9'] ['0'-'9'] | 'x' hexa_char hexa_char) "'" { let loc = lexeme_loc idx lexbuf in tokens syntax context loc.idx2 ((Char, loc) :: acc) lexbuf } | "'\\" uchar { let loc = mkloc idx (idx + 3) (lexeme_start lexbuf) (lexeme_end lexbuf) in tokens syntax context loc.idx2 ((Error, loc) :: acc) lexbuf } | "(*)" { let loc = lexeme_loc idx lexbuf in tokens syntax context loc.idx2 ((Comment (Comment_reg, true), loc) :: acc) lexbuf } | "(**)" { let loc = lexeme_loc idx lexbuf in tokens syntax context loc.idx2 ((Comment (Comment_doc, true), loc) :: acc) lexbuf } | "(**" { let ofs = lexeme_start lexbuf in let idx2, terminated = comment (idx + 3) 0 lexbuf in let loc = mkloc idx idx2 ofs (lexeme_end lexbuf) in tokens syntax context idx2 ((Comment (Comment_doc, terminated), loc) :: acc) lexbuf } | "(*" { let ofs = lexeme_start lexbuf in let idx2, terminated = comment (idx + 2) 0 lexbuf in let loc = mkloc idx idx2 ofs (lexeme_end lexbuf) in tokens syntax context idx2 ((Comment (Comment_reg, terminated), loc) :: acc) lexbuf } | "" { if syntax = UTop.Normal then symbol syntax context idx acc lexbuf else match context with | Toplevel -> camlp4_toplevel syntax context idx acc lexbuf | Antiquot -> camlp4_antiquot syntax context idx acc lexbuf } and symbol syntax context idx acc = parse | "(" | ")" | "[" | "]" | "{" | "}" | "`" | "#" | "," | ";" | ";;" | symbolchar+ { let loc = lexeme_loc idx lexbuf in let tok = Symbol (lexeme lexbuf) in tokens syntax context loc.idx2 ((tok, loc) :: acc) lexbuf } | uchar { let loc = mkloc idx (idx + 1) (lexeme_start lexbuf) (lexeme_end lexbuf) in tokens syntax context loc.idx2 ((Error, loc) :: acc) lexbuf } and camlp4_toplevel syntax context idx acc = parse | '<' (':' ident)? ('@' lident)? '<' { let ofs = lexeme_start lexbuf in let idx2, items, terminated = quotation syntax 0 idx (idx + lexeme_size lexbuf) (lexeme_start lexbuf) lexbuf in let ofs2 = lexeme_end lexbuf in tokens syntax context idx2 ((Quotation (items, terminated), mkloc idx idx2 ofs ofs2) :: acc) lexbuf } | "" { symbol syntax context idx acc lexbuf } and camlp4_antiquot syntax context idx acc = parse | '$' { (idx + 1, Some (lexeme_loc idx lexbuf), List.rev acc) } | "" { camlp4_toplevel syntax context idx acc lexbuf } and comment idx depth = parse | "(*" { comment (idx + 2) (depth + 1) lexbuf } | "*)" { if depth = 0 then (idx + 2, true) else comment (idx + 2) (depth - 1) lexbuf } | '"' { let idx, terminated = string (idx + 1) lexbuf in if terminated then comment idx depth lexbuf else (idx, false) } | uchar { comment (idx + 1) depth lexbuf } | eof { (idx, false) } and string idx = parse | '"' { (idx + 1, true) } | "\\\"" { string (idx + 2) lexbuf } | uchar { string (idx + 1) lexbuf } | eof { (idx, false) } and quoted_string idx tag = parse | '|' (lowercase* as tag2) '}' { let idx = idx + 2 + String.length tag2 in if tag = tag2 then (idx, true) else quoted_string idx tag lexbuf } | eof { (idx, false) } | uchar { quoted_string (idx + 1) tag lexbuf } and quotation syntax depth idx1 idx2 ofs1 = parse | '<' (':' ident)? ('@' lident)? '<' { quotation syntax (depth + 1) idx1 (idx2 + lexeme_size lexbuf) ofs1 lexbuf } | ">>" { if depth = 0 then let loc = mkloc idx1 (idx2 + 2) ofs1 (lexeme_end lexbuf) in (idx2 + 2, [(Quot_data, loc)], true) else quotation syntax (depth - 1) idx1 (idx2 + 2) ofs1 lexbuf } | '$' { let quot_data_loc = if idx1 = idx2 then None else Some (mkloc idx1 idx2 ofs1 (lexeme_start lexbuf)) in let opening_loc = lexeme_loc idx2 lexbuf in let idx, name = quotation_name (idx2 + 1) lexbuf in let idx, closing_loc, items = tokens syntax Antiquot idx [] lexbuf in let anti = { a_opening = opening_loc; a_closing = closing_loc; a_name = name; a_contents = items; } in let ofs = lexeme_end lexbuf in let loc = mkloc opening_loc.idx1 idx opening_loc.ofs2 ofs in let idx, quot_items, terminated = quotation syntax depth idx idx ofs lexbuf in let quot_items = (Quot_anti anti, loc) :: quot_items in match quot_data_loc with | Some loc -> (idx, (Quot_data, loc) :: quot_items, terminated) | None -> (idx, quot_items, terminated) } | uchar { quotation syntax depth idx1 (idx2 + 1) ofs1 lexbuf } | eof { if idx1 = idx2 then (idx2, [], false) else let loc = mkloc idx1 idx2 ofs1 (lexeme_end lexbuf) in (idx2, [(Quot_data, loc)], false) } and quotation_name idx = parse | '`'? (identchar*|['.' '!']+) ':' { let len = lexeme_size lexbuf in let ofs = lexeme_start lexbuf in (idx + len, Some (mkloc idx (idx + len - 1) ofs (ofs + len - 1), mkloc (idx + len - 1) (idx + len) (ofs + len - 1) (ofs + len))) } | "" { (idx, None) } { let lex_string syntax str = let _, _, items = tokens syntax Toplevel 0 [] (Lexing.from_string str) in items } utop-1.19.3/src/lib/uTop_main.cppo.ml000066400000000000000000001443411275431303000173630ustar00rootroot00000000000000(* * uTop_main.ml * ------------ * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of utop. *) open CamomileLibraryDyn.Camomile open Lwt_react open LTerm_text open LTerm_geom open UTop_token open UTop_styles open UTop_private let return, (>>=) = Lwt.return, Lwt.(>>=) module String_set = Set.Make(String) exception Term of int (* +-----------------------------------------------------------------+ | History | +-----------------------------------------------------------------+ *) let save_history () = match !UTop.history_file_name with | None -> return () | Some fn -> Lwt.catch (fun () -> LTerm_history.save UTop.history ?max_size:!UTop.history_file_max_size ?max_entries:!UTop.history_file_max_entries fn) (function | Unix.Unix_error (error, func, arg) -> Lwt_log.error_f "cannot save history to %S: %s: %s" fn func (Unix.error_message error) | exn -> Lwt.fail exn) let init_history () = (* Save history on exit. *) Lwt_main.at_exit save_history; (* Load history. *) match !UTop.history_file_name with | None -> return () | Some fn -> Lwt.catch (fun () -> LTerm_history.load UTop.history fn) (function | Unix.Unix_error (error, func, arg) -> Lwt_log.error_f "cannot load history from %S: %s: %s" fn func (Unix.error_message error) | exn -> Lwt.fail exn) (* +-----------------------------------------------------------------+ | offset --> index | +-----------------------------------------------------------------+ *) (* Return the index (in unicode characters) of the character starting a offset (in bytes) [ofs] in [str]. *) let index_of_offset src ofs = let rec aux idx ofs' = if ofs' = ofs then idx else if ofs' > ofs then idx - 1 else if ofs' = String.length src then -1 else aux (idx + 1) (Zed_utf8.unsafe_next src ofs') in aux 0 0 let convert_locs str locs = List.map (fun (a, b) -> (index_of_offset str a, index_of_offset str b)) locs (* +-----------------------------------------------------------------+ | The read-line class | +-----------------------------------------------------------------+ *) let parse_input_multi input = let buf = Buffer.create 32 in let result = UTop.collect_formatters buf [Format.err_formatter] (fun () -> match !UTop.parse_use_file input false with | UTop.Error (locs, msg) -> UTop.Error (convert_locs input locs, "Error: " ^ msg ^ "\n") | UTop.Value phrases -> (UTop.Value phrases)) in (result, Buffer.contents buf) #if OCAML_VERSION >= (4, 04, 0) let ast_impl_kind = Pparse.Structure #elif OCAML_VERSION >= (4, 02, 0) let ast_impl_kind = Config.ast_impl_magic_number #endif let parse_and_check input eos_is_error = let buf = Buffer.create 32 in let preprocess input = match input with #if OCAML_VERSION >= (4, 02, 0) | UTop.Value (Parsetree.Ptop_def pstr) -> begin try let pstr = Pparse.apply_rewriters ~tool_name:"ocaml" ast_impl_kind pstr in UTop.Value (Parsetree.Ptop_def pstr) with Pparse.Error error -> Pparse.report_error Format.str_formatter error; UTop.Error ([], Format.flush_str_formatter ()) end #endif | _ -> input in let result = UTop.collect_formatters buf [Format.err_formatter] (fun () -> match preprocess (!UTop.parse_toplevel_phrase input eos_is_error) with | UTop.Error (locs, msg) -> UTop.Error (convert_locs input locs, "Error: " ^ msg ^ "\n") | UTop.Value phrase -> match UTop.check_phrase phrase with | None -> UTop.Value phrase | Some (locs, msg) -> UTop.Error (convert_locs input locs, msg)) in (result, Buffer.contents buf) let add_terminator s = let terminator = UTop.get_phrase_terminator () in if Zed_utf8.ends_with s terminator then s else s ^ terminator let is_accept : LTerm_read_line.action -> bool = function | Accept -> true | action -> action == UTop.end_and_accept_current_phrase (* Read a phrase. If the result is a value, it is guaranteed to be a valid phrase (i.e. typable and compilable). It also returns warnings printed parsing. *) class read_phrase ~term = object(self) inherit [Parsetree.toplevel_phrase UTop.result * string] LTerm_read_line.engine ~history:(LTerm_history.contents UTop.history) () as super inherit [Parsetree.toplevel_phrase UTop.result * string] LTerm_read_line.term term as super_term method create_temporary_file_for_external_editor = Filename.temp_file "utop" ".ml" method external_editor = UTop.get_external_editor () val mutable return_value = None method eval = match return_value with | Some x -> x | None -> assert false method! send_action action = let action : LTerm_read_line.action = if is_accept action && S.value self#mode <> LTerm_read_line.Edition then Accept else action in super#send_action action method! exec = function | action :: actions when S.value self#mode = LTerm_read_line.Edition && is_accept action -> begin Zed_macro.add self#macro action; let input = Zed_rope.to_string (Zed_edit.text self#edit) in let input = if action == UTop.end_and_accept_current_phrase then add_terminator input else input in (* Toploop does that: *) Location.reset (); let eos_is_error = not !UTop.smart_accept in try let result = parse_and_check input eos_is_error in return_value <- Some result; LTerm_history.add UTop.history input; return result with UTop.Need_more -> (* Input not finished, continue. *) self#insert (UChar.of_char '\n'); self#exec actions end | actions -> super_term#exec actions method! stylise last = let styled, position = super#stylise last in (* Syntax highlighting *) let stylise loc token_style = for i = loc.idx1 to loc.idx2 - 1 do let ch, style = styled.(i) in styled.(i) <- (ch, LTerm_style.merge token_style style) done in UTop_styles.stylise stylise (UTop_lexer.lex_string (UTop.get_syntax ()) (LTerm_text.to_string styled)); if not last then (* Parenthesis matching. *) LTerm_text.stylise_parenthesis styled position styles.style_paren else begin match return_value with | Some (UTop.Error (locs, _), _) -> (* Highlight error locations. *) List.iter (fun (start, stop) -> for i = max 0 start to min (Array.length styled) stop - 1 do let ch, style = styled.(i) in styled.(i) <- (ch, { style with LTerm_style.underline = Some true }) done) locs | _ -> () end; (styled, position) method! completion = let pos, words = UTop_complete.complete ~syntax:(UTop.get_syntax ()) ~phrase_terminator:(UTop.get_phrase_terminator ()) ~input:(Zed_rope.to_string self#input_prev) in self#set_completion pos words method! show_box = S.value self#mode <> LTerm_read_line.Edition || UTop.get_show_box () initializer (* Set the source signal for the size of the terminal. *) UTop_private.set_size self#size; (* Set the source signal for the key sequence. *) UTop_private.set_key_sequence self#key_sequence; (* Set the prompt. *) self#set_prompt !UTop.prompt end (* +-----------------------------------------------------------------+ | Out phrase printing | +-----------------------------------------------------------------+ *) let fix_string str = let len = String.length str in let ofs, _, _ = Zed_utf8.next_error str 0 in if ofs = len then str else begin let buf = Buffer.create (len + 128) in if ofs > 0 then Buffer.add_substring buf str 0 ofs; let rec loop ofs = Zed_utf8.add buf (UChar.of_char str.[ofs]); let ofs1 = ofs + 1 in let ofs2, _, _ = Zed_utf8.next_error str ofs1 in if ofs1 < ofs2 then Buffer.add_substring buf str ofs1 (ofs2 - ofs1); if ofs2 < len then loop ofs2 else Buffer.contents buf in loop ofs end let render_out_phrase term string = if String.length string >= 100 * 1024 then LTerm.fprint term string else begin let string = fix_string string in let styled = LTerm_text.of_string string in let stylise loc token_style = for i = loc.idx1 to loc.idx2 - 1 do let ch, style = styled.(i) in styled.(i) <- (ch, LTerm_style.merge token_style style) done in UTop_styles.stylise stylise (UTop_lexer.lex_string (UTop.get_syntax ()) string); LTerm.fprints term styled end let orig_print_out_signature = !Toploop.print_out_signature let orig_print_out_phrase = !Toploop.print_out_phrase let rec map_items unwrap wrap items = match items with | [] -> [] | item :: items -> let sig_item, _ = unwrap item in let name, rec_status = match sig_item with | Outcometree.Osig_class (_, name, _, _, rs) | Outcometree.Osig_class_type (_, name, _, _, rs) | Outcometree.Osig_module (name, _, rs) #if OCAML_VERSION >= (4, 02, 0) | Outcometree.Osig_type ({ Outcometree.otype_name = name }, rs) -> #else | Outcometree.Osig_type ((name, _, _, _, _), rs) -> #endif (name, rs) #if OCAML_VERSION >= (4, 02, 0) | Outcometree.Osig_typext ({ Outcometree.oext_name = name}, _) #else | Outcometree.Osig_exception (name, _) #endif | Outcometree.Osig_modtype (name, _) #if OCAML_VERSION < (4, 03, 0) | Outcometree.Osig_value (name, _, _) -> (name, Outcometree.Orec_not) #else | Outcometree.Osig_value { oval_name = name; _ } -> (name, Outcometree.Orec_not) | Outcometree.Osig_ellipsis -> ("", Outcometree.Orec_not) #endif in let keep = name = "" || name.[0] <> '_' in if keep then item :: map_items unwrap wrap items else (* Replace the [Orec_next] at the head of items by [Orec_first] *) let items = match items with | [] -> [] | item :: items' -> let sig_item, extra = unwrap item in match sig_item with | Outcometree.Osig_class (a, name, b, c, rs) -> if rs = Outcometree.Orec_next then wrap (Outcometree.Osig_class (a, name, b, c, Outcometree.Orec_first)) extra :: items' else items | Outcometree.Osig_class_type (a, name, b, c, rs) -> if rs = Outcometree.Orec_next then wrap (Outcometree.Osig_class_type (a, name, b, c, Outcometree.Orec_first)) extra :: items' else items | Outcometree.Osig_module (name, a, rs) -> if rs = Outcometree.Orec_next then wrap (Outcometree.Osig_module (name, a, Outcometree.Orec_first)) extra :: items' else items | Outcometree.Osig_type (oty, rs) -> if rs = Outcometree.Orec_next then wrap (Outcometree.Osig_type (oty, Outcometree.Orec_first)) extra :: items' else items #if OCAML_VERSION >= (4, 02, 0) | Outcometree.Osig_typext _ #else | Outcometree.Osig_exception _ #endif #if OCAML_VERSION >= (4, 03, 0) | Outcometree.Osig_ellipsis #endif | Outcometree.Osig_modtype _ | Outcometree.Osig_value _ -> items in map_items unwrap wrap items let print_out_signature pp items = if UTop.get_hide_reserved () then orig_print_out_signature pp (map_items (fun x -> (x, ())) (fun x () -> x) items) else orig_print_out_signature pp items let print_out_phrase pp phrase = if UTop.get_hide_reserved () then let phrase = match phrase with | Outcometree.Ophr_eval _ | Outcometree.Ophr_exception _ -> phrase | Outcometree.Ophr_signature items -> Outcometree.Ophr_signature (map_items (fun x -> x) (fun x y -> (x, y)) items) in orig_print_out_phrase pp phrase else orig_print_out_phrase pp phrase let () = Toploop.print_out_signature := print_out_signature; Toploop.print_out_phrase := print_out_phrase (* +-----------------------------------------------------------------+ | Toplevel expression rewriting | +-----------------------------------------------------------------+ *) let with_loc loc str = { Location.txt = str; Location.loc = loc; } (* A rule for rewriting a toplevel expression. *) type rewrite_rule = { type_to_rewrite : Longident.t; mutable path_to_rewrite : Path.t option; required_values : Longident.t list; (* Values that must exist and be persistent for the rule to apply. *) rewrite : Location.t -> Parsetree.expression -> Parsetree.expression; (* The rewrite function. *) enabled : bool React.signal; (* Whether the rule is enabled or not. *) } let longident_lwt_main_run = Longident.Ldot (Longident.Lident "Lwt_main", "run") let longident_async_thread_safe_block_on_async_exn = Longident.parse "Async.Std.Thread_safe.block_on_async_exn" let longident_unit = Longident.Lident "()" #if OCAML_VERSION < (4, 02, 0) (* Wrap into: fun () -> *) let wrap_unit loc e = let i = with_loc loc longident_unit in let p = { Parsetree.ppat_desc = Parsetree.Ppat_construct (i, None, false); Parsetree.ppat_loc = loc; } in { Parsetree.pexp_desc = Parsetree.Pexp_function ("", None, [(p, e)]); Parsetree.pexp_loc = loc; } #endif #if OCAML_VERSION >= (4, 03, 0) let nolabel = Asttypes.Nolabel #else let nolabel = "" #endif let rewrite_rules = [ (* Rewrite Lwt.t expressions to Lwt_main.run *) { type_to_rewrite = Longident.parse "Lwt.t"; path_to_rewrite = None; required_values = [longident_lwt_main_run]; rewrite = (fun loc e -> #if OCAML_VERSION < (4, 02, 0) { Parsetree.pexp_desc = Parsetree.Pexp_apply ({ Parsetree.pexp_desc = Parsetree.Pexp_ident (with_loc loc longident_lwt_main_run); Parsetree.pexp_loc = loc }, [("", e)]) ; Parsetree.pexp_loc = loc } #else let open Ast_helper in with_default_loc loc (fun () -> Exp.apply (Exp.ident (with_loc loc longident_lwt_main_run)) [(nolabel, e)] ) #endif ); enabled = UTop.auto_run_lwt; }; (* Rewrite Async.Std.Defered.t expressions to Async.Std.Thread_safe.block_on_async_exn (fun () -> ). *) { type_to_rewrite = Longident.parse "Async.Std.Deferred.t"; path_to_rewrite = None; required_values = [longident_async_thread_safe_block_on_async_exn]; rewrite = (fun loc e -> #if OCAML_VERSION < (4, 02, 0) { Parsetree.pexp_desc = Parsetree.Pexp_apply ({ Parsetree.pexp_desc = Parsetree.Pexp_ident (with_loc loc longident_async_thread_safe_block_on_async_exn); Parsetree.pexp_loc = loc }, [("", wrap_unit loc e)]) ; Parsetree.pexp_loc = loc } #else let open Ast_helper in let punit = Pat.construct (with_loc loc (Longident.Lident "()")) None in with_default_loc loc (fun () -> Exp.apply (Exp.ident (with_loc loc longident_async_thread_safe_block_on_async_exn)) [(nolabel, Exp.fun_ nolabel None punit e)] ) #endif ); enabled = UTop.auto_run_async; } ] #if OCAML_VERSION >= (4, 04, 0) let lookup_type longident env = let path = Env.lookup_type longident env in (path, Env.find_type path env) #else let lookup_type = Env.lookup_type #endif let rule_path rule = match rule.path_to_rewrite with | Some _ as x -> x | None -> try let env = !Toploop.toplevel_env in let path = match lookup_type rule.type_to_rewrite env with | path, { Types.type_kind = Types.Type_abstract ; Types.type_private = Asttypes.Public ; Types.type_manifest = Some ty } -> begin match Ctype.expand_head env ty with | { Types.desc = Types.Tconstr (path, _, _) } -> path | _ -> path end | path, _ -> path in let opt = Some path in rule.path_to_rewrite <- opt; opt with _ -> None (* Returns whether the given path is persistent. *) let rec is_persistent_path = function | Path.Pident id -> Ident.persistent id | Path.Pdot (p, _, _) -> is_persistent_path p | Path.Papply (_, p) -> is_persistent_path p (* Check that the given long identifier is present in the environment and is persistent. *) let is_persistent_in_env longident = try is_persistent_path (fst (Env.lookup_value longident !Toploop.toplevel_env)) with Not_found -> false let rule_matches rule path = React.S.value rule.enabled && (match rule_path rule with | None -> false | Some path' -> Path.same path path') && List.for_all is_persistent_in_env rule.required_values (* Returns whether the argument is a toplevel expression. *) let is_eval = function | { Parsetree.pstr_desc = Parsetree.Pstr_eval _ } -> true | _ -> false (* Returns the rewrite rule associated to a type, if any. *) let rec rule_of_type typ = match (Ctype.expand_head !Toploop.toplevel_env typ).Types.desc with | Types.Tconstr (path, _, _) -> begin try Some (List.find (fun rule -> rule_matches rule path) rewrite_rules) with _ -> None end | _ -> None #if OCAML_VERSION < (4, 02, 0) let rewrite_str_item pstr_item tstr_item = match pstr_item, tstr_item.Typedtree.str_desc with | ({ Parsetree.pstr_desc = Parsetree.Pstr_eval e; Parsetree.pstr_loc = loc }, Typedtree.Tstr_eval { Typedtree.exp_type = typ }) -> begin match rule_of_type typ with | Some rule -> { Parsetree.pstr_desc = Parsetree.Pstr_eval (rule.rewrite loc e); Parsetree.pstr_loc = loc } | None -> pstr_item end | _ -> pstr_item #else let rewrite_str_item pstr_item tstr_item = match pstr_item, tstr_item.Typedtree.str_desc with | ({ Parsetree.pstr_desc = Parsetree.Pstr_eval (e, _); Parsetree.pstr_loc = loc }, Typedtree.Tstr_eval ({ Typedtree.exp_type = typ }, _)) -> begin match rule_of_type typ with | Some rule -> { Parsetree.pstr_desc = Parsetree.Pstr_eval (rule.rewrite loc e, []); Parsetree.pstr_loc = loc } | None -> pstr_item end | _ -> pstr_item #endif let rewrite phrase = match phrase with | Parsetree.Ptop_def pstr -> if (UTop.get_auto_run_lwt () || UTop.get_auto_run_async ()) && List.exists is_eval pstr then let tstr, _, _ = Typemod.type_structure !Toploop.toplevel_env pstr Location.none in Parsetree.Ptop_def (List.map2 rewrite_str_item pstr tstr.Typedtree.str_items) else Parsetree.Ptop_def pstr | Parsetree.Ptop_dir _ -> phrase (* +-----------------------------------------------------------------+ | Main loop | +-----------------------------------------------------------------+ *) let rec read_phrase term = Lwt.catch (fun () -> (new read_phrase ~term)#run) (function | Sys.Break -> LTerm.fprintl term "Interrupted." >>= fun () -> read_phrase term | exn -> Lwt.fail exn) let print_error term msg = LTerm.set_style term styles.style_error >>= fun () -> Lwt_io.print msg >>= fun () -> LTerm.set_style term LTerm_style.none >>= fun () -> LTerm.flush term let rec loop term = (* Reset completion. *) UTop_complete.reset (); (* increment the command counter. *) UTop_private.set_count (S.value UTop_private.count + 1); (* Call hooks. *) Lwt_sequence.iter_l (fun f -> f ()) UTop.new_command_hooks; (* Read interactively user input. *) let phrase_opt = Lwt_main.run ( Lwt.finalize (fun () -> read_phrase term >>= fun (result, warnings) -> (* Print warnings before errors. *) Lwt_io.print warnings >>= fun () -> match result with | UTop.Value phrase -> return (Some phrase) | UTop.Error (_, msg) -> print_error term msg >>= fun () -> return None) (fun () -> LTerm.flush term) ) in match phrase_opt with | Some phrase -> (* Rewrite toplevel expressions. *) let phrase = rewrite phrase in (* Set the margin of standard formatters. *) UTop_private.set_margin Format.std_formatter; UTop_private.set_margin Format.err_formatter; (* Formatter to get the output phrase. *) let buffer = Buffer.create 1024 in let pp = Format.formatter_of_buffer buffer in UTop_private.set_margin pp; (try Env.reset_cache_toplevel (); if !Clflags.dump_parsetree then Printast.top_phrase pp phrase; if !Clflags.dump_source then Pprintast.top_phrase pp phrase; ignore (Toploop.execute_phrase true pp phrase); (* Flush everything. *) Format.pp_print_flush Format.std_formatter (); Format.pp_print_flush Format.err_formatter (); flush stdout; flush stderr; (* Get the string printed. *) Format.pp_print_flush pp (); let string = Buffer.contents buffer in match phrase with | Parsetree.Ptop_def _ -> (* The string is an output phrase, colorize it. *) Lwt_main.run (render_out_phrase term string) | Parsetree.Ptop_dir _ -> (* The string is an error message. *) Lwt_main.run (print_error term string) with exn -> (* The only possible errors are directive errors. *) let msg = UTop.get_message Errors.report_error exn in (* Skip the dumb location. *) let msg = try let idx = String.index msg '\n' + 1 in String.sub msg idx (String.length msg - idx) with Not_found -> msg in Lwt_main.run (print_error term msg)); loop term | None -> loop term (* +-----------------------------------------------------------------+ | Welcome message | +-----------------------------------------------------------------+ *) let welcome term = (* Create a context to render the welcome message. *) let size = LTerm.size term in let size = { rows = 3; cols = size.cols } in let matrix = LTerm_draw.make_matrix size in let ctx = LTerm_draw.context matrix size in (* Draw the message in a box. *) let message = Printf.sprintf "Welcome to utop version %s (using OCaml version %s)!" UTop.version Sys.ocaml_version in LTerm_draw.fill_style ctx LTerm_style.({ none with foreground = Some lcyan }); LTerm_draw.draw_hline ctx 0 0 size.cols LTerm_draw.Light; LTerm_draw.draw_frame ctx { row1 = 0; row2 = 3; col1 = (size.cols - (String.length message + 4)) / 2; col2 = (size.cols + (String.length message + 4)) / 2; } LTerm_draw.Light; LTerm_draw.draw_styled ctx 1 ((size.cols - String.length message) / 2) (eval [B_fg LTerm_style.yellow; S message]); (* Render to the screen. *) LTerm.print_box term matrix >>= fun () -> (* Move to after the box. *) LTerm.fprint term "\n" >>= fun () -> LTerm.flush term (* +-----------------------------------------------------------------+ | Classic mode | +-----------------------------------------------------------------+ *) let read_input_classic prompt buffer len = let rec loop i = if i = len then return (i, false) else Lwt_io.read_char_opt Lwt_io.stdin >>= function | Some c -> #if OCAML_VERSION >= (4, 02, 0) Bytes.set buffer i c; #else buffer.[i] <- c; #endif if c = '\n' then return (i + 1, false) else loop (i + 1) | None -> return (i, true) in Lwt_main.run (Lwt_io.write Lwt_io.stdout prompt >>= fun () -> loop 0) (* +-----------------------------------------------------------------+ | Emacs mode | +-----------------------------------------------------------------+ *) module Emacs(M : sig end) = struct (* Copy standard output, which will be used to send commands. *) let command_oc = Unix.out_channel_of_descr (Unix.dup Unix.stdout) let split_at ?(trim=false) ch str = let rec aux i j = if j = String.length str then if trim && i = j then [] else [String.sub str i (j - i)] else if str.[j] = ch then String.sub str i (j - i) :: aux (j + 1) (j + 1) else aux i (j + 1) in aux 0 0 (* +---------------------------------------------------------------+ | Sending commands to Emacs | +---------------------------------------------------------------+ *) (* Mutex used to send commands to Emacs. *) let command_mutex = Mutex.create () let send command argument = Mutex.lock command_mutex; output_string command_oc command; output_char command_oc ':'; output_string command_oc argument; output_char command_oc '\n'; flush command_oc; Mutex.unlock command_mutex (* Keep the [utop-phrase-terminator] variable of the emacs part in sync. *) let () = S.keep (S.map (send "phrase-terminator") UTop.phrase_terminator) (* +---------------------------------------------------------------+ | Standard outputs redirection | +---------------------------------------------------------------+ *) (* The output of ocaml (stdout and stderr) is redirected so the emacs parts of utop can recognize it. *) (* Continuously copy the output of ocaml to Emacs. *) let rec copy_output which ic = let line = input_line ic in send which line; copy_output which ic (* Create a thread which redirect the given output: *) let redirect which fd = let fdr, fdw = Unix.pipe () in Unix.dup2 fdw fd; Unix.close fdw; Thread.create (copy_output which) (Unix.in_channel_of_descr fdr) (* Redirects stdout and stderr: *) let _ = redirect "stdout" Unix.stdout let _ = redirect "stderr" Unix.stderr (* +---------------------------------------------------------------+ | Loop | +---------------------------------------------------------------+ *) let read_line () = let behavior = Sys.signal Sys.sigint Sys.Signal_ignore in try let line = Lwt_main.run (Lwt_io.read_line_opt Lwt_io.stdin) in Sys.set_signal Sys.sigint behavior; line with exn -> Sys.set_signal Sys.sigint behavior; raise exn let read_command () = match read_line () with | None -> None | Some line -> match try Some (String.index line ':') with Not_found -> None with | None -> send "stderr" "':' missing!"; exit 1 | Some idx -> Some (String.sub line 0 idx, String.sub line (idx + 1) (String.length line - (idx + 1))) let read_data () = let buf = Buffer.create 1024 in let rec loop first = match read_command () with | None -> send "stderr" "'end' command missing!"; exit 1 | Some ("data", data) -> if not first then Buffer.add_char buf '\n'; Buffer.add_string buf data; loop false | Some ("end", _) -> Buffer.contents buf | Some (command, argument) -> Printf.ksprintf (send "stderr") "'data' or 'end' command expected, got %S!" command; exit 1 in loop true let process_checked_phrase phrase = (* Rewrite toplevel expressions. *) let phrase = rewrite phrase in try #if OCAML_VERSION > (4, 00, 1) Env.reset_cache_toplevel (); #endif ignore (Toploop.execute_phrase true Format.std_formatter phrase); true with exn -> (* The only possible errors are directive errors. *) let msg = UTop.get_message Errors.report_error exn in (* Skip the dumb location. *) let msg = try let idx = String.index msg '\n' + 1 in String.sub msg idx (String.length msg - idx) with Not_found -> msg in List.iter (send "stderr") (split_at ~trim:true '\n' msg); false let process_input add_to_history eos_is_error = let input = read_data () in let result, warnings = parse_and_check input eos_is_error in match result with | UTop.Value phrase -> send "accept" ""; List.iter (send "stderr") (split_at ~trim:true '\n' warnings); if add_to_history then LTerm_history.add UTop.history input; ignore (process_checked_phrase phrase) | UTop.Error (locs, msg) -> send "accept" (String.concat "," (List.map (fun (a, b) -> Printf.sprintf "%d,%d" a b) locs)); List.iter (send "stderr") (split_at ~trim:true '\n' warnings); if add_to_history then LTerm_history.add UTop.history input; List.iter (send "stderr") (split_at ~trim:true '\n' msg) let send_error locs msg warnings = send "accept" (String.concat "," (List.map (fun (a, b) -> Printf.sprintf "%d,%d" a b) locs)); match warnings with | Some warnings -> List.iter (send "stderr") (split_at ~trim:true '\n' warnings) | None -> (); List.iter (send "stderr") (split_at ~trim:true '\n' msg) let process_input_multi () = let input = read_data () in let result, warnings = parse_input_multi input in let typecheck phrase = match UTop.check_phrase phrase with | None -> None | Some (locs, msg) -> Some (convert_locs input locs, msg) (* FIXME *) in match result with | UTop.Value phrases -> send "accept" ""; List.iter (send "stderr") (split_at ~trim:true '\n' warnings); let rec loop = function | (phrase::more_phrases) -> begin match typecheck phrase with | Some (locs, msg) -> send_error locs msg None | None -> let success = process_checked_phrase phrase in if success then loop more_phrases else () end | [] -> () in loop phrases | UTop.Error (locs, msg) -> send_error locs msg (Some warnings) let rec loop () = (* Reset completion. *) UTop_complete.reset (); (* Increment the command counter. *) UTop_private.set_count (S.value UTop_private.count + 1); (* Call hooks. *) Lwt_sequence.iter_l (fun f -> f ()) UTop.new_command_hooks; (* Tell emacs we are ready. *) send "prompt" ""; loop_commands (LTerm_history.contents UTop.history) [] and loop_commands history_prev history_next = match read_command () with | None -> () | Some ("input", arg) -> let args = split_at ',' arg in let allow_incomplete = List.mem "allow-incomplete" args and add_to_history = List.mem "add-to-history" args in let continue = try process_input add_to_history (not allow_incomplete); false with UTop.Need_more -> send "continue" ""; true in if continue then loop_commands history_prev history_next else loop () | Some ("input-multi", _) -> let continue = try process_input_multi (); false with UTop.Need_more -> send "continue" ""; true in if continue then loop_commands history_prev history_next else loop () | Some ("complete", _) -> let input = read_data () in let start, words = UTop_complete.complete ~syntax:(UTop.get_syntax ()) ~phrase_terminator:(UTop.get_phrase_terminator ()) ~input in let words = List.map fst words in let prefix = LTerm_read_line.common_prefix words in let index = String.length input - start in let suffix = if index > 0 && index <= String.length prefix then String.sub prefix index (String.length prefix - index) else "" in if suffix = "" then begin send "completion-start" ""; List.iter (send "completion") words; send "completion-stop" ""; end else send "completion-word" suffix; loop_commands history_prev history_next | Some ("history-prev", _) -> begin let input = read_data () in match history_prev with | [] -> send "history-bound" ""; loop_commands history_prev history_next | entry :: history_prev -> List.iter (send "history-data") (split_at '\n' entry); send "history-end" ""; loop_commands history_prev (input :: history_next) end | Some ("history-next", _) -> begin let input = read_data () in match history_next with | [] -> send "history-bound" ""; loop_commands history_prev history_next | entry :: history_next -> List.iter (send "history-data") (split_at '\n' entry); send "history-end" ""; loop_commands (input :: history_prev) history_next end | Some ("exit", code) -> exit (int_of_string code) | Some ("save-history", code) -> Lwt_main.run (save_history ()); loop_commands history_prev history_next | Some ("require", package) -> begin try Topfind.load_deeply [package] with Fl_package_base.No_such_package(pkg, reason) -> send "no-such-package" pkg end; loop_commands history_prev history_next | Some (command, _) -> Printf.ksprintf (send "stderr") "unrecognized command %S!" command; exit 1 end (* +-----------------------------------------------------------------+ | Extra macros | +-----------------------------------------------------------------+ *) let typeof sid = let id = Longident.parse sid in let env = !Toploop.toplevel_env in let from_type_desc = function | Types.Tconstr (path, _, _) -> let typ_decl = Env.find_type path env in path, typ_decl | _ -> assert false in let out_sig_item = try let (path, ty_decl) = lookup_type id env in let id = Ident.create (Path.name path) in Some (Printtyp.tree_of_type_declaration id ty_decl Types.Trec_not) with Not_found -> try let (path, val_descr) = Env.lookup_value id env in let id = Ident.create (Path.name path) in Some (Printtyp.tree_of_value_description id val_descr) with Not_found -> try let lbl_desc = Env.lookup_label id env in let (path, ty_decl) = from_type_desc lbl_desc.Types.lbl_res.Types.desc in let id = Ident.create (Path.name path) in Some (Printtyp.tree_of_type_declaration id ty_decl Types.Trec_not) with Not_found -> try #if OCAML_VERSION < (4, 02, 0) let (path, mod_typ) = Env.lookup_module id env in #else let path = Env.lookup_module id env ~load:true in let mod_typ = (Env.find_module path env).Types.md_type in #endif let id = Ident.create (Path.name path) in Some (Printtyp.tree_of_module id mod_typ Types.Trec_not) with Not_found -> try let (path, mty_decl) = Env.lookup_modtype id env in let id = Ident.create (Path.name path) in Some (Printtyp.tree_of_modtype_declaration id mty_decl) with Not_found -> try let cstr_desc = Env.lookup_constructor id env in match cstr_desc.Types.cstr_tag with #if OCAML_VERSION < (4, 02, 0) | Types.Cstr_exception (_path, loc) -> let path, exn_decl = Typedecl.transl_exn_rebind env loc id in let id = Ident.create (Path.name path) in Some (Printtyp.tree_of_exception_declaration id exn_decl) #endif | _ -> let (path, ty_decl) = from_type_desc cstr_desc.Types.cstr_res.Types.desc in let id = Ident.create (Path.name path) in Some (Printtyp.tree_of_type_declaration id ty_decl Types.Trec_not) with Not_found -> None in match out_sig_item with | None -> Lwt_main.run (Lazy.force LTerm.stdout >>= fun term -> print_error term "Unknown type\n") | Some osig -> let buf = Buffer.create 128 in let pp = Format.formatter_of_buffer buf in !Toploop.print_out_signature pp [osig]; Format.pp_print_newline pp (); let str = Buffer.contents buf in Lwt_main.run (Lazy.force LTerm.stdout >>= fun term -> render_out_phrase term str) let () = Hashtbl.add Toploop.directive_table "typeof" (Toploop.Directive_string typeof) (* +-----------------------------------------------------------------+ | Entry point | +-----------------------------------------------------------------+ *) let emacs_mode = ref false let preload = ref [] let prepare () = Toploop.set_paths (); try let ok = List.for_all (function | `Packages l -> UTop.require l; true | `Object fn -> Topdirs.load_file Format.err_formatter fn) (List.rev !preload) in if ok then !Toploop.toplevel_startup_hook (); ok with exn -> try Errors.report_error Format.err_formatter exn; false with exn -> Format.eprintf "Uncaught exception: %s\n" (Printexc.to_string exn); false let run_script name = (* To prevent message from camlp4 *) Sys.interactive := false; if not (prepare ()) then exit 2; let len = Array.length Sys.argv - !Arg.current in Array.blit Sys.argv !Arg.current Sys.argv 0 len; Obj.truncate (Obj.repr Sys.argv) len; Arg.current := 0; Toploop.initialize_toplevel_env (); Location.input_name := UTop.input_name; if Toploop.use_silently Format.err_formatter name then exit 0 else exit 2 let file_argument name = if Filename.check_suffix name ".cmo" || Filename.check_suffix name ".cma" then preload := `Object name :: !preload else run_script name let print_version () = Printf.printf "The universal toplevel for OCaml, version %s, compiled for OCaml version %s\n" UTop.version Sys.ocaml_version; exit 0 let print_version_num () = Printf.printf "%s\n" UTop.version (* Config from command line *) let autoload = ref true let args = Arg.align [ "-absname", Arg.Set Location.absname, " Show absolute filenames in error message"; "-I", Arg.String (fun dir -> Clflags.include_dirs := Misc.expand_directory Config.standard_library dir :: !Clflags.include_dirs), " Add to the list of include directories"; "-init", Arg.String (fun s -> Clflags.init_file := Some s), " Load instead of default init file"; "-labels", Arg.Clear Clflags.classic, " Use commuting label mode"; "-no-app-funct", Arg.Clear Clflags.applicative_functors, " Deactivate applicative functors"; "-noassert", Arg.Set Clflags.noassert, " Do not compile assertion checks"; "-nolabels", Arg.Set Clflags.classic, " Ignore non-optional labels in types"; "-nostdlib", Arg.Set Clflags.no_std_include, " Do not add default directory to the list of include directories"; #if OCAML_VERSION >= (4, 02, 0) "-ppx", Arg.String (fun ppx -> Clflags.all_ppx := ppx :: !Clflags.all_ppx), " Pipe abstract syntax trees through preprocessor "; #endif "-principal", Arg.Set Clflags.principal, " Check principality of type inference"; #if OCAML_VERSION >= (4, 02, 0) "-safe-string", Arg.Clear Clflags.unsafe_string, " Make strings immutable"; #endif "-short-paths", Arg.Clear Clflags.real_paths, " Shorten paths in types (the default)"; "-no-short-paths", Arg.Set Clflags.real_paths, " Do not shorten paths in types"; "-rectypes", Arg.Set Clflags.recursive_types, " Allow arbitrary recursive types"; "-stdin", Arg.Unit (fun () -> run_script ""), " Read script from standard input"; "-strict-sequence", Arg.Set Clflags.strict_sequence, " Left-hand part of a sequence must have type unit"; "-unsafe", Arg.Set Clflags.fast, " Do not compile bounds checking on array and string access"; "-version", Arg.Unit print_version, " Print version and exit"; "-vnum", Arg.Unit print_version_num, " Print version number and exit"; "-w", Arg.String (Warnings.parse_options false), Printf.sprintf " Enable or disable warnings according to :\n\ \ + enable warnings in \n\ \ - disable warnings in \n\ \ @ enable warnings in and treat them as errors\n\ \ can be:\n\ \ a single warning number\n\ \ .. a range of consecutive warning numbers\n\ \ a predefined set\n\ \ default setting is %S" Warnings.defaults_w; "-warn-error", Arg.String (Warnings.parse_options true), Printf.sprintf " Enable or disable error status for warnings according to \n\ \ See option -w for the syntax of .\n\ \ Default setting is %S" Warnings.defaults_warn_error; "-warn-help", Arg.Unit Warnings.help_warnings, " Show description of warning numbers"; "-emacs", Arg.Set emacs_mode, " Run in emacs mode"; "-hide-reserved", Arg.Unit (fun () -> UTop.set_hide_reserved true), " Hide identifiers starting with a '_' (the default)"; "-show-reserved", Arg.Unit (fun () -> UTop.set_hide_reserved false), " Show identifiers starting with a '_'"; "-no-autoload", Arg.Clear autoload, " Disable autoloading of files in $OCAML_TOPLEVEL_PATH/autoload"; "-require", Arg.String (fun s -> preload := `Packages (UTop.split_words s) :: !preload), " Load this package"; "-dparsetree", Arg.Set Clflags.dump_parsetree, " Dump OCaml AST after rewriting"; "-dsource", Arg.Set Clflags.dump_source, " Dump OCaml source after rewriting"; ] let () = Clflags.real_paths := false let app_name = Filename.basename Sys.executable_name let usage = Printf.sprintf "Usage: %s [script-file [arguments]]\noptions are:" app_name let load_init_files dir = let files = Sys.readdir dir in Array.sort String.compare files; Array.iter (fun fn -> if Filename.check_suffix fn ".ml" then ignore (Toploop.use_silently Format.err_formatter (Filename.concat dir fn) : bool)) files ;; let common_init ~initial_env = (* Initializes toplevel environment. *) (match initial_env with | None -> Toploop.initialize_toplevel_env () | Some env -> Toploop.toplevel_env := env); (* Set the global input name. *) Location.input_name := UTop.input_name; (* Make sure SIGINT is catched while executing OCaml code. *) Sys.catch_break true; (* Load system init files. *) (match try Some (Sys.getenv "OCAML_TOPLEVEL_PATH") with Not_found -> None with | Some dir -> Topdirs.dir_directory dir; let autoload_dir = Filename.concat dir "autoload" in if !autoload && !UTop_private.autoload && Sys.file_exists autoload_dir then load_init_files autoload_dir | None -> ()); (* Load user's .ocamlinit file. *) (match !Clflags.init_file with | Some fn -> if Sys.file_exists fn then ignore (Toploop.use_silently Format.err_formatter fn : bool) else Printf.eprintf "Init file not found: \"%s\".\n" fn | None -> if Sys.file_exists ".ocamlinit" then ignore (Toploop.use_silently Format.err_formatter ".ocamlinit" : bool) else let fn = Filename.concat LTerm_resources.home ".ocamlinit" in if Sys.file_exists fn then ignore (Toploop.use_silently Format.err_formatter fn)); (* Load history after the initialization file so the user can change the history file name. *) Lwt_main.run (init_history ()); (* Install signal handlers. *) let behavior = Sys.Signal_handle (fun signo -> raise (Term signo)) in let catch signo = try Sys.set_signal signo behavior with _ -> (* All signals may not be supported on some OS. *) () in (* We lost the terminal. *) catch Sys.sighup; (* Termination request. *) catch Sys.sigterm let load_inputrc () = Lwt.catch LTerm_inputrc.load (function | Unix.Unix_error (error, func, arg) -> Lwt_log.error_f "cannot load key bindings from %S: %s: %s" LTerm_inputrc.default func (Unix.error_message error) | LTerm_inputrc.Parse_error (fname, line, msg) -> Lwt_log.error_f "error in key bindings file %S, line %d: %s" fname line msg | exn -> Lwt.fail exn) let main_aux ~initial_env = Arg.parse args file_argument usage; if not (prepare ()) then exit 2; if !emacs_mode then begin UTop_private.set_ui UTop_private.Emacs; let module Emacs = Emacs (struct end) in Printf.printf "Welcome to utop version %s (using OCaml version %s)!\n\n%!" UTop.version Sys.ocaml_version; common_init ~initial_env; Emacs.loop () end else begin UTop_private.set_ui UTop_private.Console; let term = Lwt_main.run (Lazy.force LTerm.stdout) in if LTerm.incoming_is_a_tty term && LTerm.outgoing_is_a_tty term then begin (* Set the initial size. *) UTop_private.set_size (S.const (LTerm.size term)); (* Load user data. *) Lwt_main.run (Lwt.join [UTop_styles.load (); load_inputrc ()]); (* Display a welcome message. *) Lwt_main.run (welcome term); (* Common initialization. *) common_init ~initial_env; (* Print help message. *) print_string "\nType #utop_help for help about using utop.\n\n"; flush stdout; (* Main loop. *) try loop term with LTerm_read_line.Interrupt -> () end else begin (* Use the standard toplevel. Just make sure that Lwt threads can run while reading phrases. *) Toploop.read_interactive_input := read_input_classic; Toploop.loop Format.std_formatter end end; (* Don't let the standard toplevel run... *) exit 0 let main_internal ~initial_env = try main_aux ~initial_env with exn -> (match exn with | Unix.Unix_error (error, func, "") -> Printf.eprintf "%s: %s: %s\n" app_name func (Unix.error_message error) | Unix.Unix_error (error, func, arg) -> Printf.eprintf "%s: %s(%S): %s\n" app_name func arg (Unix.error_message error) | exn -> Printf.eprintf "Fatal error: exception %s\n" (Printexc.to_string exn)); Printexc.print_backtrace stderr; flush stderr; exit 2 let main () = main_internal ~initial_env:None type value = V : string * _ -> value #if OCAML_VERSION < (4, 02, 0) let interact ~search_path ~unit ~loc:(fname, lnum, cnum, _) ~values = failwith "UTop_main.interact is not supported on OCaml 4.01" #elif not defined ENABLE_INTERACT let interact ~search_path ~unit ~loc:(fname, lnum, cnum, _) ~values = failwith "\ UTop_main.interact wasn't enabled at compile time. If you installed utop through opam, just do this to enable this feature: $ opam install ppx_tools" #else exception Found of Env.t let interact ~search_path ~unit ~loc:(fname, lnum, cnum, _) ~values = let cmt_fname = try Misc.find_in_path_uncap search_path (unit ^ ".cmt") with Not_found -> Printf.ksprintf failwith "%s.cmt not found in search path!" fname in let cmt_infos = Cmt_format.read_cmt cmt_fname in let search = object(self) inherit [unit] UTop_cmt_lifter.lifter as super method! lift_Typedtree_expression e = super#lift_Typedtree_expression e; match e.exp_desc with | Texp_apply (_, args) -> begin try match #if OCAML_VERSION >= (4, 03, 0) List.find (fun (lab, _) -> lab = Asttypes.Labelled "loc" ) args, List.find (fun (lab, _) -> lab = Asttypes.Labelled "values") args #else List.find (fun (lab, _, _) -> lab = "loc" ) args, List.find (fun (lab, _, _) -> lab = "values") args #endif with #if OCAML_VERSION >= (4, 03, 0) | (Asttypes.Labelled _, Some l), (Asttypes.Labelled _, Some v) -> #else | (_, Some l, Required), (_, Some v, Required) -> #endif let pos = l.exp_loc.loc_start in if pos.pos_fname = fname && pos.pos_lnum = lnum && pos.pos_cnum - pos.pos_bol = cnum then raise (Found v.exp_env) | _ -> () with Not_found -> () end | _ -> () method! lift_Types_label_description _ = () method! lift_Types_type_declaration _ = () method tuple _ = () method string _ = () method record _ _ = () method nativeint _ = () method list _ = () method lift_Types_Vars_t _ _ = () method lift_Types_Variance_t _ = () method lift_Types_Meths_t _ _ = () method lift_Types_Concr_t _ = () method lift_Env_t _ = () method int64 _ = () method int32 _ = () method int _ = () method constr _ _ = () method char _ = () method array _ = () end in try search#lift_Cmt_format_cmt_infos cmt_infos; failwith "Couldn't find location in cmt file" with Found env -> try List.iter Topdirs.dir_directory (search_path @ cmt_infos.cmt_loadpath); let env = Envaux.env_of_only_summary env in List.iter (fun (V (name, v)) -> Toploop.setvalue name (Obj.repr v)) values; main_internal ~initial_env:(Some env) with exn -> Location.report_exception Format.err_formatter exn; exit 2 let () = Location.register_error_of_exn (function | Envaux.Error err -> Some (Location.error_of_printer_file Envaux.report_error err) | _ -> None ) #endif utop-1.19.3/src/lib/uTop_main.mli000066400000000000000000000011161275431303000165640ustar00rootroot00000000000000(* * uTop_main.mli * ------------- * Copyright : (c) 2012, Jeremie Dimino * Licence : BSD3 * * This file is a part of utop. *) val main : unit -> unit (** Start utop. *) exception Term of int (** Exception raised when a signal that should terminate the process is received. The argument is the signal number. utop raises this exception for SIGHUP and SIGTERM by default. *) type value = V : string * _ -> value val interact : search_path:string list -> unit:string -> loc:(string * int * int * int) -> values:value list -> unit utop-1.19.3/src/lib/uTop_private.ml000066400000000000000000000020341275431303000171410ustar00rootroot00000000000000(* * uTop_private.ml * --------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of utop. *) open Lwt_react let size, set_size = let ev, set_size = E.create () in let init = S.const { LTerm_geom.rows = 25; LTerm_geom.cols = 80 } in (S.switch (S.hold ~eq:( == ) init ev), set_size) let key_sequence, set_key_sequence = let ev, set_key_sequence = E.create () in let init = (S.const ([] : LTerm_key.t list)) in (S.switch (S.hold ~eq:( == ) init ev), set_key_sequence) let count, set_count = S.create (-1) type ui = Console | Emacs let ui, set_ui = S.create Console let error_style = ref LTerm_style.none (* Config from ~/.utoprc *) let autoload = ref true let margin_function, set_margin_function = S.create ~eq:( == ) (fun (size : LTerm_geom.size) -> Some (min 80 size.cols)) let margin = S.app margin_function size let set_margin pp = match S.value margin with | None -> () | Some n -> if Format.pp_get_margin pp () <> n then Format.pp_set_margin pp n utop-1.19.3/src/lib/uTop_styles.ml000066400000000000000000000164151275431303000170220ustar00rootroot00000000000000(* * uTop_styles.ml * -------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of utop. *) open UTop_token let return, (>>=) = Lwt.return, Lwt.(>>=) module String_set = Set.Make (String) type styles = { mutable style_keyword : LTerm_style.t; mutable style_symbol : LTerm_style.t; mutable style_ident : LTerm_style.t; mutable style_module : LTerm_style.t; mutable style_constant : LTerm_style.t; mutable style_char : LTerm_style.t; mutable style_string : LTerm_style.t; mutable style_quotation : LTerm_style.t; mutable style_comment : LTerm_style.t; mutable style_doc : LTerm_style.t; mutable style_blanks : LTerm_style.t; mutable style_error : LTerm_style.t; mutable style_directive : LTerm_style.t; mutable style_paren : LTerm_style.t; mutable style_font : string option; mutable style_foreground : LTerm_style.color option; mutable style_background : LTerm_style.color option; mutable style_cursor : LTerm_style.color option; } let styles = { style_keyword = LTerm_style.none; style_symbol = LTerm_style.none; style_ident = LTerm_style.none; style_module = LTerm_style.none; style_constant = LTerm_style.none; style_char = LTerm_style.none; style_string = LTerm_style.none; style_quotation = LTerm_style.none; style_comment = LTerm_style.none; style_doc = LTerm_style.none; style_blanks = LTerm_style.none; style_error = LTerm_style.none; style_directive = LTerm_style.none; style_paren = LTerm_style.none; style_font = None; style_foreground = None; style_background = None; style_cursor = None; } let load () = let fn = Filename.concat LTerm_resources.home ".utoprc" in Lwt.catch (fun () -> LTerm_resources.load fn >>= fun res -> styles.style_keyword <- LTerm_resources.get_style "keyword" res; styles.style_symbol <- LTerm_resources.get_style "symbol" res; styles.style_ident <- LTerm_resources.get_style "identifier" res; styles.style_module <- LTerm_resources.get_style "module" res; styles.style_constant <- LTerm_resources.get_style "constant" res; styles.style_char <- LTerm_resources.get_style "char" res; styles.style_string <- LTerm_resources.get_style "string" res; styles.style_quotation <- LTerm_resources.get_style "quotation" res; styles.style_comment <- LTerm_resources.get_style "comment" res; styles.style_doc <- LTerm_resources.get_style "doc" res; styles.style_blanks <- LTerm_resources.get_style "blanks" res; styles.style_error <- LTerm_resources.get_style "error" res; styles.style_directive <- LTerm_resources.get_style "directive" res; styles.style_paren <- LTerm_resources.get_style "parenthesis" res; styles.style_font <- (match LTerm_resources.get "font" res with | "" -> None | str -> Some str); styles.style_foreground <- LTerm_resources.get_color "foreground" res; styles.style_background <- LTerm_resources.get_color "background" res; styles.style_cursor <- LTerm_resources.get_color "cursor" res; (match String.lowercase (LTerm_resources.get "profile" res) with | "light" -> UTop.set_profile UTop.Light | "dark" -> UTop.set_profile UTop.Dark | "" -> () | str -> raise (LTerm_resources.Error (Printf.sprintf "invalid profile %S" str))); UTop_private.error_style := styles.style_error; UTop_private.autoload := LTerm_resources.get_bool "autoload" res <> Some false; (match LTerm_resources.get "external-editor" res with | "" -> () | s -> UTop.set_external_editor s); return ()) (function | Unix.Unix_error(Unix.ENOENT, _, _) -> return () | Unix.Unix_error (error, func, arg) -> Lwt_log.error_f "cannot load styles from %S: %s: %s" fn func (Unix.error_message error) | exn -> Lwt.fail exn) let rec stylise_filter_layout stylise tokens = match tokens with | [] -> [] | (Comment (Comment_reg, _), loc) :: tokens -> stylise loc styles.style_comment; stylise_filter_layout stylise tokens | (Comment (Comment_doc, _), loc) :: tokens -> stylise loc styles.style_doc; stylise_filter_layout stylise tokens | (Blanks, loc) :: tokens -> stylise loc styles.style_blanks; stylise_filter_layout stylise tokens | x :: tokens -> x :: stylise_filter_layout stylise tokens let rec stylise_rec stylise tokens = match tokens with | [] -> () | (Symbol _, loc) :: tokens -> stylise loc styles.style_symbol; stylise_rec stylise tokens | (Lident id, loc) :: tokens -> stylise loc (if String_set.mem id !UTop.keywords then styles.style_keyword else styles.style_ident); stylise_rec stylise tokens | (Uident id, loc) :: tokens when String_set.mem id !UTop.keywords -> stylise loc styles.style_keyword; stylise_rec stylise tokens | (Uident id, loc1) :: (Symbol ".", loc2) :: tokens -> stylise loc1 styles.style_module; stylise loc2 styles.style_symbol; stylise_rec stylise tokens | (Uident id, loc) :: tokens -> stylise loc styles.style_ident; stylise_rec stylise tokens | (Constant _, loc) :: tokens -> stylise loc styles.style_constant; stylise_rec stylise tokens | (Char, loc) :: tokens -> stylise loc styles.style_char; stylise_rec stylise tokens | (String _, loc) :: tokens -> stylise loc styles.style_string; stylise_rec stylise tokens | (Quotation (items, _), _) :: tokens -> stylise_quotation_items stylise items; stylise_rec stylise tokens | (Error, loc) :: tokens -> stylise loc styles.style_error; stylise_rec stylise tokens | ((Comment _ | Blanks), _) :: _ -> assert false and stylise_quotation_items stylise items = match items with | [] -> () | (Quot_data, loc) :: items -> stylise loc styles.style_quotation; stylise_quotation_items stylise items | (Quot_anti anti, _) :: items -> stylise anti.a_opening styles.style_symbol; (match anti.a_name with | None -> () | Some (loc1, loc2) -> stylise loc1 styles.style_module; stylise loc2 styles.style_symbol); let tokens = stylise_filter_layout stylise anti.a_contents in stylise_rec stylise tokens; (match anti.a_closing with | None -> () | Some loc -> stylise loc styles.style_symbol); stylise_quotation_items stylise items let stylise stylise tokens = let tokens = stylise_filter_layout stylise tokens in match tokens with | (Symbol "#", loc) :: tokens -> begin stylise loc styles.style_directive; match tokens with | ((Lident id | Uident id), loc) :: tokens -> stylise loc (if String_set.mem id !UTop.keywords then styles.style_keyword else styles.style_directive); stylise_rec stylise tokens | tokens -> stylise_rec stylise tokens end | tokens -> stylise_rec stylise tokens utop-1.19.3/src/lib/uTop_styles.mli000066400000000000000000000024761275431303000171750ustar00rootroot00000000000000(* * uTop_styles.mli * --------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of utop. *) (** Styled loaded from ~/.utoprc *) (** Type of utop styles. *) type styles = { mutable style_keyword : LTerm_style.t; mutable style_symbol : LTerm_style.t; mutable style_ident : LTerm_style.t; mutable style_module : LTerm_style.t; mutable style_constant : LTerm_style.t; mutable style_char : LTerm_style.t; mutable style_string : LTerm_style.t; mutable style_quotation : LTerm_style.t; mutable style_comment : LTerm_style.t; mutable style_doc : LTerm_style.t; mutable style_blanks : LTerm_style.t; mutable style_error : LTerm_style.t; mutable style_directive : LTerm_style.t; mutable style_paren : LTerm_style.t; mutable style_font : string option; mutable style_foreground : LTerm_style.color option; mutable style_background : LTerm_style.color option; mutable style_cursor : LTerm_style.color option; } val styles : styles (** The styles in use. *) val load : unit -> unit Lwt.t (** Load resources into [styles]. *) val stylise : (UTop_token.location -> LTerm_style.t -> unit) -> (UTop_token.t * UTop_token.location) list -> unit (** [stylise apply tokens] calls [apply] on all token locations with the associated style. *) utop-1.19.3/src/lib/uTop_token.ml000066400000000000000000000027161275431303000166160ustar00rootroot00000000000000(* * uTop_token.ml * ------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of utop. *) (** Tokens. The type of tokens is semi-structured: parentheses construct and quotations are nested and others tokens are flat list. *) (** Locations in the source string, which is encoded in UTF-8. *) type location = { idx1 : int; (** Start position in unicode characters. *) idx2 : int; (** Stop position in unicode characters. *) ofs1 : int; (** Start position in bytes. *) ofs2 : int; (** Stop position in bytes. *) } type t = | Symbol of string | Lident of string | Uident of string | Constant of string | Char | String of int * bool (** [String (quote_size, terminated)]. *) | Comment of comment_kind * bool (** [Comment (kind, terminated)]. *) | Blanks | Error | Quotation of (quotation_item * location) list * bool (** [Quotation (items, terminated)]. *) and comment_kind = | Comment_reg (** Regular comment. *) | Comment_doc (** Documentation comment. *) and quotation_item = | Quot_data | Quot_anti of antiquotation and antiquotation = { a_opening : location; (** Location of the opening [$]. *) a_closing : location option; (** Location of the closing [$]. *) a_name : (location * location) option; (** Location of the name and colon if any. *) a_contents : (t * location) list; (** Contents of the location. *) } utop-1.19.3/src/lib/uTop_version.ml.ab000066400000000000000000000003071275431303000175360ustar00rootroot00000000000000(* * uTop_version.ml.ab * ------------------ * Copyright : (c) 2012, Jeremie Dimino * Licence : BSD3 * * This file is a part of utop. *) let version = "$(pkg_version)" utop-1.19.3/src/lib/utop.mldylib000066400000000000000000000002751275431303000165000ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: d62f40e4cd0c0d25556b0323c9db3fef) UTop UTop_main UTop_private UTop_version UTop_lexer UTop_token UTop_complete UTop_styles UTop_cmt_lifter # OASIS_STOP utop-1.19.3/src/lib/utop.mllib000066400000000000000000000002751275431303000161430ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: d62f40e4cd0c0d25556b0323c9db3fef) UTop UTop_main UTop_private UTop_version UTop_lexer UTop_token UTop_complete UTop_styles UTop_cmt_lifter # OASIS_STOP utop-1.19.3/src/top/000077500000000000000000000000001275431303000141635ustar00rootroot00000000000000utop-1.19.3/src/top/uTop_start.ml000066400000000000000000000002711275431303000166610ustar00rootroot00000000000000(* * uTop_start.ml * ------------- * Copyright : (c) 2012, Jeremie Dimino * Licence : BSD3 * * This file is a part of utop. *) let () = UTop_main.main () utop-1.19.3/src/top/uTop_top.mltop000066400000000000000000000000131275431303000170430ustar00rootroot00000000000000UTop_start utop-1.19.3/src/top/utop.el000066400000000000000000001312321275431303000154760ustar00rootroot00000000000000;;; utop.el --- Universal toplevel for OCaml ;; Copyright: (c) 2011, Jeremie Dimino ;; Author: Jeremie Dimino ;; URL: https://github.com/diml/utop ;; Licence: BSD3 ;; Version: 1.11 ;; Package-Requires: ((emacs "24")) ;; Keywords: ocaml languages ;; This file is a part of utop. ;;; Commentary: ;; See the README for more info; ;; https://github.com/diml/utop ;;; Code: (require 'easymenu) ;; tabulated-list is a part of Emacs 24 (require 'tabulated-list nil t) ;; +-----------------------------------------------------------------+ ;; | License | ;; +-----------------------------------------------------------------+ (defconst utop-license "BSD3" "Copyright (c) 2011, Jeremie Dimino 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 Jeremie Dimino 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.") ;; +-----------------------------------------------------------------+ ;; | Customizable variables | ;; +-----------------------------------------------------------------+ (defgroup utop nil "A toplevel for the ocaml programming language which interact with Emacs to provide an enhanced environment." :tag "The Caml Emacs-Lisp Toplevel" :version "1.0" :group 'applications) (defcustom utop-command "utop -emacs" "The command to execute for utop." :type 'string :group 'utop) (defcustom utop-edit-command t "Whether to read the command from the minibuffer before running utop. If nil, `utop-command' will be used without modification." :type 'boolean :group 'utop) (defcustom utop-prompt 'utop-default-prompt "The function which create the prompt for utop." :type 'function :group 'utop) (defcustom utop-mode-hook nil "A hook that gets run when `utop-mode' is entered." :type 'hook :group 'utop) (defcustom utop-exit-hook nil "A hook that is run whenever `utop' is exited. This hook is only run if exiting actually kills the buffer." :type 'hook :group 'utop) (defcustom utop-load-packages-without-asking nil "Load packages from file local variables without asking" :type 'boolean :group 'utop) (defface utop-prompt '((((background dark)) (:foreground "Cyan1")) (((background light)) (:foreground "blue"))) "The face used to highlight the prompt." :group 'utop) (defface utop-stdout nil "The face used to highlight messages comming from stdout." :group 'utop) (defface utop-stderr nil "The face used to highlight messages comming from stderr." :group 'utop) (defface utop-frozen '((t (:bold t))) "The face used to highlight text that has been sent to utop.") (defface utop-error '((t (:foreground "#ff4040" :bold t :underline t))) "The face used to highlight errors in phrases." :group 'utop) ;; +-----------------------------------------------------------------+ ;; | Constants | ;; +-----------------------------------------------------------------+ (defconst utop-buffer-name "*utop*" "The name of the buffer utop is running on.") (defconst utop-non-editable-properties '(read-only t rear-nonsticky (read-only face)) "List of text properties for the non-editable part of the buffer") ;; +-----------------------------------------------------------------+ ;; | Variables | ;; +-----------------------------------------------------------------+ (defvar utop-process nil "The Lisp-object for the utop sub-process") (defvar utop-mode-map (let ((map (make-sparse-keymap))) (define-key map [return] 'utop-eval-input-or-newline) (define-key map [(control ?m)] 'utop-eval-input-or-newline) (define-key map [(control ?j)] 'utop-eval-input-auto-end) (define-key map [home] 'utop-bol) (define-key map [(control ?a)] 'utop-bol) (define-key map [(meta ?p)] 'utop-history-goto-prev) (define-key map [(meta ?n)] 'utop-history-goto-next) (define-key map (kbd "TAB") 'utop-complete) (define-key map [(control ?c) (control ?c)] 'utop-interrupt) (define-key map [(control ?c) (control ?i)] 'utop-interrupt) (define-key map [(control ?c) (control ?k)] 'utop-kill) (define-key map [(control ?c) (control ?g)] 'utop-exit) (define-key map [(control ?c) (control ?s)] 'utop) (define-key map [(control ?c) ?m] 'utop-copy-old-input) map) "The utop local keymap.") (defvar utop-prompt-min 0 "The point at the beginning of the current prompt.") (defvar utop-prompt-max 0 "The point at the end of the current prompt.") (defvar utop-input-prompt-max 0 "The point at the end of the last input prompt.") (defvar utop-output "" "The output of the utop sub-process not yet processed.") (defvar utop-command-number 0 "The number of the current command.") (defvar utop-completion nil "Current completion.") (defvar utop-inhibit-check nil "When set to a non-nil value, always insert text, even if it is before the end of prompt.") (defvar utop-state nil "State of utop. It is one of: - edit: the user is typing a command - comp: waiting for completion - hist: waiting for history - wait: ocaml is evaluating a phrase - done: ocaml has died.") (defvar utop-complete-buffer nil "The buffer that requested completion.") (defvar utop-initial-command nil "Initial phrase to evaluate.") (defvar utop-initial-mode nil "Mode to evaluate utop-initial-command in (nil or :multi).") (defvar utop-phrase-terminator ";;" "The OCaml phrase terminator.") (defvar utop-pending-entry nil "History entry") (defvar utop-pending-position nil "The position of the cursor in the phrase sent to OCaml (where to add the newline character if it is not accepted).") (make-variable-buffer-local (defvar utop-package-list nil "List of packages to load when visiting OCaml buffer. Useful as file variable.")) (make-variable-buffer-local (defvar utop-ocaml-preprocessor nil "Name of preprocesor. Currently supported camlp4o, camlp4r. Useful as file variable.")) (defvar utop-skip-blank-and-comments 'utop-compat-skip-blank-and-comments "The function used to skip blanks and comments.") (defvar utop-skip-to-end-of-phrase 'utop-compat-skip-to-end-of-phrase "The function used to find the end of a phrase") (defvar utop-discover-phrase 'utop-compat-discover-phrase "The function used to discover a phrase") (defvar utop-skip-after-eval-phrase t "Whether to skip to next phrase after evaluation. Non-nil means skip to the end of the phrase after evaluation in the Caml toplevel") ;; +-----------------------------------------------------------------+ ;; | Compability with different ocaml major modes | ;; +-----------------------------------------------------------------+ (defun utop-compat-resolve (choices) "Resolve a symbol based on the current major mode. CHOICES is a list of 3 function symbols: (tuareg-symbol typerex-symbol caml-symbol)." (cond ((eq major-mode 'tuareg-mode ) (nth 0 choices)) ((eq major-mode 'typerex-mode ) (nth 1 choices)) ((eq major-mode 'caml-mode ) (nth 2 choices)) (t (error (format "utop doesn't support the major mode \"%s\". It supports caml, tuareg and typerex modes by default. For other modes you need to set these variables: - `utop-skip-blank-and-comments' - `utop-skip-to-end-of-phrase' - `utop-discover-phrase' " (symbol-name major-mode)))))) (defun utop-compat-skip-blank-and-comments () (funcall (utop-compat-resolve '(tuareg-skip-blank-and-comments typerex-skip-blank-and-comments caml-skip-blank-and-comments)))) (defun utop-compat-skip-to-end-of-phrase () (funcall (utop-compat-resolve '(tuareg-skip-to-end-of-phrase typerex-skip-to-end-of-phrase caml-skip-to-end-of-phrase)))) (defun utop-compat-discover-phrase () (funcall (utop-compat-resolve '(tuareg-discover-phrase typerex-discover-phrase caml-discover-phrase)))) ;; +-----------------------------------------------------------------+ ;; | Compability with previous emacs version | ;; +-----------------------------------------------------------------+ (unless (featurep 'tabulated-list) ;; tabulated-list.el is part of Emacs 24 ;; This is a thin layer building compability with previous versions (defvar tabulated-list-format nil) (defvar tabulated-list-sort-key nil) (defvar tabulated-list-printer nil) (defvar tabulated-list-revert-hook nil) (defvar tabulated-list-entries nil) (define-derived-mode tabulated-list-mode special-mode "Mini-tabulated list mode" "Tabulated list" (make-local-variable 'tabulated-list-format) (make-local-variable 'tabulated-list-sort-key) (make-local-variable 'tabulated-list-printer) (set (make-local-variable 'revert-buffer-function) 'tabulated-list-revert) (defun tabulated-list-init-header () (save-excursion (let ((inhibit-read-only t)) (mapc (lambda (entry) (let* ((name (nth 0 entry)) (size (length name)) (padding (- (nth 1 entry) size))) (insert name) (insert-char ?\s padding) )) tabulated-list-format) (insert "\n")))) (defun tabulated-list-print (dummy) (save-excursion (let ((inhibit-read-only t)) (mapc (lambda (entry) (goto-char (point-max)) (apply tabulated-list-printer entry)) tabulated-list-entries)) t)) (defun tabulated-list-revert (ignore-auto noconfirm) (let ((inhibit-read-only t)) (delete-region (point-min) (point-max)) (tabulated-list-init-header) (tabulated-list-print t)))) ) ;; +-----------------------------------------------------------------+ ;; | Utils | ;; +-----------------------------------------------------------------+ (defmacro utop-perform (&rest actions) "Execute the given actions while checks are inhibited." `(let ((utop-inhibit-check t) (inhibit-read-only t)) (progn ,@actions))) (defun utop-send-string (str) "Send a string to the utop process. This function can only be called in the utop buffer and while the state is not 'done." (process-send-string utop-process str)) (defun utop-send-command (str) "Send a command to utop. If utop is not running or has exited, it is started." (let ((buf (get-buffer utop-buffer-name))) (unless buf (setq buf (save-excursion (utop)))) (with-current-buffer buf (when (eq utop-state 'done) (utop-restart)) (process-send-string utop-process str)))) (defun utop-insert (&rest args) "Insert text with checks inhibited." (utop-perform (apply 'insert args))) (defun utop-goto-point-max-all-windows () "Move the point to the end of buffer in all utop windows." (let ((buffer (get-buffer utop-buffer-name))) (walk-windows (lambda (window) (when (eq (window-buffer window) buffer) (select-window window) (goto-char (point-max))))))) (defun utop-set-state (state) "Change the utop state and mode-line-process." (setq utop-state state) (setq mode-line-process (cond ((eq state 'edit) ": idle") ((eq state 'comp) ": completion") ((eq state 'hist) ": history") ((eq state 'wait) ": running") ((eq state 'copy) ": copying") ((eq state 'done) (let ((status (process-status utop-process)) (code (process-exit-status utop-process))) (cond ((and (eq status 'exit) (= code 0)) ": exited[0]") ((eq status 'exit) (let ((msg (concat ": exited[" (int-to-string code) "]"))) (add-text-properties 0 (length msg) '(face bold) msg) msg)) ((eq status 'signal) (let ((msg (concat ": killed[" (int-to-string code) "]"))) (add-text-properties 0 (length msg) '(face bold) msg) msg)) (t ": unknown")))) (t ": unknown")))) (defun utop-send-data (cmd) "Send current input to utop" (let ((lines (split-string (buffer-substring-no-properties utop-prompt-max (point-max)) "\n"))) (setq utop-input-prompt-max utop-prompt-max) ;; Send all lines to utop (utop-send-string cmd) (while lines ;; Send the line (utop-send-string (concat "data:" (car lines) "\n")) ;; Remove it and continue (setq lines (cdr lines))) (utop-send-string "end:\n"))) (defun utop-last-type () "Extract last inferred type from the uTop toplevel" (with-current-buffer utop-buffer-name (save-excursion (goto-char utop-prompt-min) (forward-line -1) (let ((line (buffer-substring-no-properties (line-beginning-position) (line-end-position)))) (message line))))) ;; Poor man's identifier at point (defun utop-ident-looking (backward) "Find limits of an OCaml identifier" (save-excursion (skip-chars-forward " \n\t") (let ((iterating t) (start-pos (point)) end-pos) (while iterating (setq end-pos (point)) (if (not backward) (progn (right-word 1) (setq iterating (not (looking-back "[ \t\r\n].*" start-pos)))) (progn (left-word 1) (setq iterating (not (save-excursion (search-forward-regexp "[ \t\r\n].*" start-pos t))))))) end-pos))) (defun utop-ident-at-point () "Identifier at point" (let ((start-pos (utop-ident-looking t)) (end-pos (utop-ident-looking nil))) (buffer-substring-no-properties start-pos end-pos))) ; Currently not working - the communication is asynchronous so how to ; make sure without implementing another state that the type ; information has been already printed? (defun utop-type-at-point () "Find type of an identifier at point from uTop" (utop-eval-string (utop-ident-at-point)) ; (utop-last-type) ) ;; +-----------------------------------------------------------------+ ;; | Edition control | ;; +-----------------------------------------------------------------+ (defun utop-cannot-edit () (cond ((eq utop-state 'wait) (signal 'text-read-only '("You cannot edit the buffer while ocaml is evaluating a phrase"))) ((eq utop-state 'done) (signal 'text-read-only '("You cannot edit the buffer when ocaml is not running"))) ((eq utop-state 'comp) (signal 'text-read-only '("You cannot edit the buffer while waiting for completion"))) ((eq utop-state 'copy) (signal 'text-read-only '("You cannot edit the buffer while waiting for copy of last input"))) ((eq utop-state 'hist) (signal 'text-read-only '("You cannot edit the buffer while waiting for history"))))) (defun utop-before-change (start stop) (unless utop-inhibit-check (cond ((not (eq utop-state 'edit)) (add-hook 'post-command-hook 'utop-add-change nil t) (utop-cannot-edit)) ((< stop utop-prompt-max) (add-hook 'post-command-hook 'utop-add-change nil t) (signal 'text-read-only '("You cannot edit this part of the buffer")))))) (defun utop-add-change () (remove-hook 'post-command-hook 'utop-add-change t) (add-hook 'before-change-functions 'utop-before-change nil t)) (defun utop-copy-old-input () (interactive) (with-current-buffer utop-buffer-name (when (eq utop-state 'edit) (utop-set-state 'copy) (setq utop-pending-entry nil) (utop-send-data "history-prev:\n")))) ;; +-----------------------------------------------------------------+ ;; | Prompt | ;; +-----------------------------------------------------------------+ (defun utop-default-prompt () "The default prompt function." (let ((prompt (format "utop[%d]> " utop-command-number))) (add-text-properties 0 (length prompt) '(face utop-prompt) prompt) prompt)) ;; +-----------------------------------------------------------------+ ;; | History | ;; +-----------------------------------------------------------------+ (defun utop-history-goto-prev () "Go to the previous entry of the history." (interactive) (with-current-buffer utop-buffer-name (when (eq utop-state 'edit) (utop-set-state 'hist) (setq utop-pending-entry nil) (utop-send-data "history-prev:\n")))) (defun utop-history-goto-next () "Go to the next entry of the history." (interactive) (with-current-buffer utop-buffer-name (when (eq utop-state 'edit) (utop-set-state 'hist) (setq utop-pending-entry nil) (utop-send-data "history-next:\n")))) (defun utop-save-history () "Save history to the history file." (interactive) (with-current-buffer utop-buffer-name (unless (eq utop-state 'done) (utop-send-string "save-history:\n")))) ;; +-----------------------------------------------------------------+ ;; | Receiving input from the utop sub-process | ;; +-----------------------------------------------------------------+ (defun utop-insert-output (output &optional face) "Insert the given output before the prompt." (let ((current-max (point-max))) (save-excursion (let ((line (concat output "\n"))) ;; Apply the given face if provided (when face (add-text-properties 0 (length line) (list 'face face) line)) ;; Goto before the prompt (goto-char utop-prompt-min) ;; Insert the output (insert line) ;; Advance the prompt (setq utop-prompt-min (+ utop-prompt-min (length line))) (setq utop-prompt-max (+ utop-prompt-max (length line))) ;; Make everything before the end prompt read-only (add-text-properties (point-min) utop-prompt-max utop-non-editable-properties))) ;; If OCaml is executing a phrase, follow its output (when (eq utop-state 'wait) (let ((buffer (get-buffer utop-buffer-name))) (walk-windows (lambda (window) (when (eq (window-buffer window) buffer) (select-window window) ;; Only move the point if we were at the end of the ;; buffer (when (eq (point) current-max) (goto-char (point-max)))))))))) (defun utop-insert-prompt (prompt) "Insert the given prompt." ;; Goto the end of the buffer (goto-char (point-max)) ;; Make it the start of the prompt (setq utop-prompt-min (point)) ;; Insert the prompt (insert prompt) ;; Set the end of prompt (setq utop-prompt-max (point)) ;; Make everything before the end prompt read-only (add-text-properties (point-min) utop-prompt-max utop-non-editable-properties) ;; We are now editing (utop-set-state 'edit) ;; Move the point to the end of buffer in all utop windows (utop-goto-point-max-all-windows)) (defun utop-insert-phrase-terminator () "Insert the phrase terminator at the end of buffer." ;; Search the longest suffix of the input which is a prefix of the ;; phrase terminator (let* ((end (point-max)) (pos (max utop-prompt-max (- end (length utop-phrase-terminator))))) (while (not (string-prefix-p (buffer-substring-no-properties pos end) utop-phrase-terminator)) (setq pos (1+ pos))) ;; Insert only the missing part (insert (substring utop-phrase-terminator (- end pos))))) (defun utop-process-line (line) "Process one line from the utop sub-process." ;; Extract the command and its argument (string-match "\\`\\([a-z-]*\\):\\(.*\\)\\'" line) (let ((command (match-string 1 line)) (argument (match-string 2 line))) (cond ;; Output on stdout ((string= command "stdout") (utop-insert-output argument 'utop-stdout)) ;; Output on stderr ((string= command "stderr") (utop-insert-output argument 'utop-stderr)) ;; Synchronisation of the phrase terminator ((string= command "phrase-terminator") (setq utop-phrase-terminator argument)) ;; A new prompt ((string= command "prompt") (let ((prompt (apply utop-prompt ()))) ;; Insert the new prompt (utop-insert-prompt prompt) ;; Increment the command number (setq utop-command-number (+ utop-command-number 1)) ;; Send the initial command if any (when utop-initial-command (goto-char (point-max)) (insert utop-initial-command) (setq utop-initial-command nil) (utop-eval-input nil t nil utop-initial-mode) (setq utop-initial-mode nil)))) ;; Input has been accepted ((string= command "accept") ;; Add a newline character at the end of the buffer (goto-char (point-max)) (insert "\n") ;; Make input frozen (add-text-properties utop-prompt-max (point-max) '(face utop-frozen)) ;; Highlight errors (let ((offsets (split-string argument "," t))) (while offsets (let ((a (string-to-number (car offsets))) (b (string-to-number (cadr offsets)))) (add-text-properties (min (point-max) (+ utop-input-prompt-max a)) (min (point-max) (+ utop-input-prompt-max b)) '(face utop-error)) (setq offsets (cdr (cdr offsets)))))) ;; Make everything read-only (add-text-properties (point-min) (point-max) utop-non-editable-properties) ;; Advance the prompt (setq utop-prompt-min (point-max)) (setq utop-prompt-max (point-max))) ;; Continue editiong ((string= command "continue") ;; Add a newline character at the position where the user ;; pressed enter (when utop-pending-position (goto-char (+ utop-prompt-max utop-pending-position)) (insert "\n")) ;; Reset the state (utop-set-state 'edit)) ;; Part of a history entry ((string= command "history-data") (cond (utop-pending-entry (setq utop-pending-entry (concat utop-pending-entry "\n" argument))) (t (setq utop-pending-entry argument)))) ;; End of history data ((string= command "history-end") (progn (cond ((eq utop-state 'copy) (kill-new utop-pending-entry)) (t (goto-char utop-prompt-max) ;; Delete current input (delete-region utop-prompt-max (point-max)) ;; Insert entry (insert utop-pending-entry))) ;; Resume edition (utop-set-state 'edit))) ;; We are at a bound of history ((string= command "history-bound") ;; Just resume edition (utop-set-state 'edit)) ;; Complete with a word ((string= command "completion-word") (utop-set-state 'edit) (with-current-buffer utop-complete-buffer (insert argument)) ;; Hide completion (minibuffer-hide-completions)) ;; Start of completion ((string= command "completion-start") (setq utop-completion nil)) ;; A new possible completion ((string= command "completion") (push argument utop-completion)) ;; End of completion ((string= command "completion-stop") (utop-set-state 'edit) (if (> (length utop-completion) 1) (with-current-buffer utop-complete-buffer (with-output-to-temp-buffer "*Completions*" (display-completion-list (nreverse utop-completion)))) (minibuffer-hide-completions)) (setq utop-completion nil))))) (defun utop-process-output (process output) "Process the output of utop" (with-current-buffer utop-buffer-name (utop-perform ;; Concatenate the output with the output not yet processed (setq utop-output (concat utop-output output)) ;; Split lines. Each line contains exactly one command (let ((lines (split-string utop-output "\n"))) (while (>= (length lines) 2) ;; Process the first line (utop-process-line (car lines)) ;; Remove it and continue (setq lines (cdr lines))) ;; When the list contains only one element, then this is either ;; the end of commands, either an unterminated one, so we save ;; it for later (setq utop-output (car lines)))))) ;; +-----------------------------------------------------------------+ ;; | Sending data to the utop sub-process | ;; +-----------------------------------------------------------------+ (defun utop-eval-input (&optional allow-incomplete auto-end add-to-history input-multi) "Send the current input to the utop process and let ocaml evaluate it. If ALLOW-INCOMPLETE is non-nil and the phrase is not terminated, then a newline character will be inserted and edition will continue. If AUTO-END is non-nill then ALLOW-INCOMPLETE is ignored and a phrase terminator (;; or ; if using revised syntax) will be automatically inserted by utop. If ADD-TO-HISTORY is t then the input will be added to history." (interactive) (with-current-buffer utop-buffer-name (when (eq utop-state 'edit) ;; Clear saved pending position (setq utop-pending-position nil) ;; Insert the phrase terminator if requested (cond (auto-end (utop-insert-phrase-terminator)) (allow-incomplete ;; Save cursor position (setq utop-pending-position (- (point) utop-prompt-max)) ;; If the point is before the prompt, insert the newline ;; character at the end (when (< utop-pending-position 0) (setq utop-pending-position (- (point-max) utop-prompt-max))))) ;; We are now waiting for ocaml (utop-set-state 'wait) (utop-send-data (cond ((eq input-multi :multi) "input-multi:\n") ((and allow-incomplete (not auto-end) add-to-history) "input:allow-incomplete,add-to-history\n") (add-to-history "input:add-to-history\n") (t "input:\n")))))) (defun utop-eval-input-or-newline () "Same as (`utop-eval-input' t nil t)." (interactive) (utop-eval-input t nil t)) (defun utop-eval-input-auto-end () "Same as (`utop-eval-input' nil t t)." (interactive) (utop-eval-input nil t t)) ;; +-----------------------------------------------------------------+ ;; | Completion | ;; +-----------------------------------------------------------------+ (defun utop-complete-input (input) "Send input to complete to utop." ;; Split it (let ((lines (split-string input "\n"))) ;; We are now waiting for completion (utop-set-state 'comp) ;; Send all lines to utop (utop-send-string "complete:\n") (while lines ;; Send the line (utop-send-string (concat "data:" (car lines) "\n")) ;; Remove it and continue (setq lines (cdr lines))) (utop-send-string "end:\n"))) (defun utop-complete () "Complete current input." (interactive) ;; Complete only if the cursor is after the prompt (when (and (eq utop-state 'edit) (>= (point) utop-prompt-max)) ;; Use this buffer (setq utop-complete-buffer (current-buffer)) ;; Send the input before the cursor (utop-complete-input (buffer-substring-no-properties utop-prompt-max (point))))) ;; +-----------------------------------------------------------------+ ;; | Eval | ;; +-----------------------------------------------------------------+ (defun utop-prepare-for-eval () "Prepare utop for evaluation." (save-excursion (let ((buf (get-buffer utop-buffer-name))) (cond (buf ;; Make the buffer appear (display-buffer buf) (with-current-buffer buf (cond ((eq utop-state 'done) ;; UTop exited, restart it (utop-restart)) ((not (eq utop-state 'edit)) ;; Edition cannot be performed right now (utop-cannot-edit))))) (t ;; The buffer does not exist, read arguments before creating ;; it so the user can cancel starting utop (utop-query-arguments) ;; Create the buffer (setq buf (get-buffer-create utop-buffer-name)) ;; Make it appear (display-buffer buf) ;; Put it in utop mode (with-current-buffer buf (utop-mode))))))) (defun utop-eval-string (string &optional mode) (with-current-buffer utop-buffer-name (cond ((eq utop-state 'edit) ;; Insert it at the end of the utop buffer (goto-char (point-max)) (insert string) ;; Send input to utop now, telling it to automatically add the ;; phrase terminator (utop-eval-input nil t nil mode)) ((eq utop-state 'wait) ;; utop is starting, save the initial command to send (setq utop-initial-command string) (setq utop-initial-mode mode))))) (defun utop-eval (start end &optional mode) "Eval the given region in utop." ;; Select the text of the region (let ((text (save-excursion ;; Search the start and end of the current paragraph (goto-char start) (funcall utop-skip-blank-and-comments) (setq start (point)) (goto-char end) (funcall utop-skip-to-end-of-phrase) (setq end (point)) (buffer-substring-no-properties start end)))) (utop-eval-string text mode))) (defun utop-eval-region (start end) "Eval the current region in utop." (interactive "r") (utop-prepare-for-eval) (utop-eval start end :multi)) (defun utop-eval-phrase () "Eval the surrounding Caml phrase (or block) in utop." (interactive) (utop-prepare-for-eval) (let ((end)) (save-excursion (let ((pair (funcall utop-discover-phrase))) (setq end (nth 2 pair)) (utop-eval (nth 0 pair) (nth 1 pair)))) (if utop-skip-after-eval-phrase (goto-char end)))) (defun utop-eval-buffer () "Send the buffer to utop." (interactive) (utop-prepare-for-eval) (utop-eval (point-min) (point-max) :multi)) (defun utop-edit-complete () "Completion in a caml/tuareg/typerex." (interactive) ;; Find the start of the current phrase (save-excursion (let* ((end (point)) (start (nth 0 (funcall utop-discover-phrase))) (input (buffer-substring-no-properties start end)) (edit-buffer (current-buffer))) ;; Start utop if needed (let ((utop-buffer (get-buffer utop-buffer-name))) (unless utop-buffer ;; The buffer does not exist, read arguments before creating ;; it so the user can cancel starting utop (utop-query-arguments) ;; Create the buffer (setq utop-buffer (get-buffer-create utop-buffer-name)) ;; Put it in utop mode (with-current-buffer utop-buffer (utop-mode))) (with-current-buffer utop-buffer ;; Complete only if we are in edition mode (when (eq utop-state 'edit) ;; Use this buffer for completion (setq utop-complete-buffer edit-buffer) ;; Send the phrase to complete (utop-complete-input input))))))) ;; +-----------------------------------------------------------------+ ;; | Edition functions | ;; +-----------------------------------------------------------------+ (defun utop-bol () "Go to the beginning of line or to the end of the prompt." (interactive) (with-current-buffer utop-buffer-name (if (= (point-at-bol) utop-prompt-min) (goto-char utop-prompt-max) (move-beginning-of-line 1)))) ;; +-----------------------------------------------------------------+ ;; | Process control | ;; +-----------------------------------------------------------------+ (defun utop-interrupt () "Interrupt utop." (interactive) (with-current-buffer utop-buffer-name (interrupt-process utop-process))) (defun utop-kill () "Kill utop." (interactive) (with-current-buffer utop-buffer-name (kill-process utop-process))) (defun utop-exit (&optional exit-code) "Try to gracefully exit utop. EXIT-CODE is the exit code that shoud be returned by utop. It defaults to 0." (interactive) (with-current-buffer utop-buffer-name (unless (eq utop-state 'done) (utop-send-string (format "exit:%d\n" (or exit-code 0)))))) (defun utop-sentinel (process msg) "Callback for process' state change." (let ((buffer (get-buffer utop-buffer-name))) ;; Do nothing if the buffer does not exist anymore (when buffer (with-current-buffer utop-buffer-name (let ((status (process-status utop-process))) (when (or (eq status 'exit) (eq status 'signal)) ;; The process is terminated (utop-set-state 'done) (let ((exit-code (process-exit-status utop-process))) (utop-perform ;; Insert a message at the end (goto-char (point-max)) (cond ((eq status 'exit) (insert "\n\nProcess utop exited with code " (number-to-string exit-code) "\n")) ((eq status 'signal) (insert "\n\nProcess utop has been killed by signal " (number-to-string exit-code) "\n"))) ;; Go to the end of the buffer (goto-char (point-max)) ;; Make the whole buffer read-only (add-text-properties (point-min) (point-max) utop-non-editable-properties))))))))) ;; +-----------------------------------------------------------------+ ;; | ocamlfind package loading | ;; +-----------------------------------------------------------------+ (defun utop-ocamlfind-list-packages () "Return the list of all findlib packages with their version." (let ((lines (split-string (shell-command-to-string "ocamlfind list") "[ \t]*\r?\n"))) (let ((packages)) ;; Split lines and extract package names and versions (mapc (lambda (line) (when (string-match "\\([^ \t(]*\\)[ \t]*(version:[ \t]*\\([^)]*\\))" line) (push (cons (match-string 1 line) (match-string 2 line)) packages))) lines) (nreverse packages)))) (define-derived-mode utop-list-packages-mode tabulated-list-mode "OCaml package list" "Major mode for listing the findlib OCaml packages." (setq tabulated-list-format [("Name" 32 t) ("Version" 32 t)]) (setq tabulated-list-sort-key (cons "Name" nil)) (setq tabulated-list-printer 'utop-package-printer) (add-hook 'tabulated-list-revert-hook 'utop-list-packages--refresh nil t) (tabulated-list-init-header)) (defun utop-list-packages--refresh () "Refresh the list of findlib packages." (interactive) ;; Clear up list of entries (setq tabulated-list-entries nil) ;; Get the list of packages (let* ((packages (utop-ocamlfind-list-packages)) (max-name-length 0)) ;; Find the longest package name (mapc (lambda (package) (setq max-name-length (max max-name-length (length (car package))))) packages) ;; Minimal size of the name entry shall be 16 characters (setq max-name-length (1+ (max max-name-length 16))) ;; Set the header column size to the maximal length (setcdr (elt tabulated-list-format 0) (list max-name-length t)) ;; Build a list, accumulating in tabulated-list-entries (while packages (let* ((package (car packages)) (name (car package)) (version (cdr package))) (push (list package (vector name version)) tabulated-list-entries)) (setq packages (cdr packages)))) (setq tabulated-list-entries (nreverse tabulated-list-entries))) (defun utop-package-printer (id cols) "Print one findlib package entry." (let ((width (cadr (elt tabulated-list-format 0)))) (insert-text-button (elt cols 0) 'follow-link t 'action 'utop-require-package-button-action) (insert-char ?\s (- width (length (elt cols 0)))) (insert (elt cols 1) "\n"))) (defun utop-load-package (package) (when (or utop-load-packages-without-asking (y-or-n-p (format "Load package `%s'? " package))) ;; Load it (utop-send-command (format "require:%s\n" package)))) (defun utop-require-package-button-action (button) (utop-load-package (button-label button))) (defun utop-list-ocaml-packages (&optional buffer) "Display a list of all ocaml findlib packages" (interactive) (unless (bufferp buffer) (setq buffer (get-buffer-create "*Findlib packages*"))) (with-current-buffer buffer (utop-list-packages-mode) (utop-list-packages--refresh) (tabulated-list-print t) (display-buffer buffer))) (defun utop-query-load-package-list () "Load packages defined in utop-package-list buffer local variable." (when (and utop-package-list (y-or-n-p "You've defined utop-package-list variable, but uTop toplevel is not running, would you like me to start the toplevel?")) (with-current-buffer (utop)) (mapc 'utop-load-package utop-package-list) (message "uTop: OCaml packages loaded by file local variables"))) (defun utop-hack-local-variables () "Perform actions defined by local variables" (when utop-ocaml-preprocessor (with-current-buffer (utop)) (utop-eval-string (format "#%s" utop-ocaml-preprocessor)) (message (format "uTop: %s OCaml preprocessor loaded" utop-ocaml-preprocessor))) (utop-query-load-package-list)) ;; +-----------------------------------------------------------------+ ;; | Menu | ;; +-----------------------------------------------------------------+ (defun utop-is-running () (let ((buf (get-buffer utop-buffer-name))) (when buf (with-current-buffer buf (and utop-process (eq (process-status utop-process) 'run)))))) (defun utop-about () (interactive) (describe-variable 'utop-license)) (defun utop-help () (interactive) (describe-function 'utop)) (easy-menu-define utop-menu utop-mode-map "utop menu." '("utop" ["Start OCaml" utop t] ["Interrupt OCaml" utop-interrupt :active (utop-is-running)] ["Kill OCaml" utop-kill :active (utop-is-running)] ["Exit utop gracefully" utop-exit :active (utop-is-running)] ["Evaluate Phrase" utop-eval-input-auto-end :active (and (utop-is-running) (eq utop-state 'edit))] "---" ["Customize utop" (customize-group 'utop) t] "---" ["About" utop-about t] ["Help" utop-help t])) ;; +-----------------------------------------------------------------+ ;; | The mode | ;; +-----------------------------------------------------------------+ (defun utop-arguments () "Get argument list from the given command line of utop" ;; Split the command line (let ((arguments (split-string-and-unquote utop-command))) ;; Ensure it contains at least one argument (when (not arguments) (error "The utop command line is empty")) arguments)) (defun utop-query-arguments () "Returns the arguments of the utop command to run." ;; Read the command to run (when utop-edit-command (setq utop-command (read-shell-command "utop command line: " utop-command)) (utop-arguments))) (defun utop-start (arguments) "Start utop." ;; Reset variables (setq utop-prompt-min (point-max)) (setq utop-prompt-max (point-max)) (setq utop-input-prompt-max (point-max)) (setq utop-output "") (setq utop-command-number 0) (setq utop-completion nil) ;; Set the state to done to allow utop to be restarted if ;; start-process fails (setq utop-state 'done) ;; Create the sub-process (setq utop-process (apply 'start-process "utop" (current-buffer) (car arguments) (cdr arguments))) ;; Set the initial state: we are waiting for ocaml to send the ;; initial prompt (utop-set-state 'wait) ;; Filter the output of the sub-process with our filter function (set-process-filter utop-process 'utop-process-output) ;; Set the process sentinel (set-process-sentinel utop-process 'utop-sentinel)) (defun utop-restart () "Restart utop." (let ((arguments (utop-query-arguments))) (goto-char (point-max)) (utop-insert "\nRestarting...\n\n") (utop-start arguments))) (defun utop-setup-ocaml-buffer () "Deprecated" (error "`utop-setup-ocaml-buffer' is deprecated, you need to replace it by `utop-minor-mode'. See https://github.com/diml/utop for configuration information.")) ;;;###autoload (define-minor-mode utop-minor-mode "Minor mode for utop." :lighter " utop" :keymap (let ((map (make-sparse-keymap))) (define-key map (kbd "C-c C-s") 'utop) (define-key map (kbd "C-x C-e") 'utop-eval-phrase) (define-key map (kbd "C-x C-r") 'utop-eval-region) (define-key map (kbd "C-c C-b") 'utop-eval-buffer) (define-key map (kbd "C-c C-k") 'utop-kill) map) ;; Load local file variables (add-hook 'hack-local-variables-hook 'utop-hack-local-variables)) ;;;###autoload (define-derived-mode utop-mode fundamental-mode "utop" "Set the buffer mode to utop." ;; Local variables (make-local-variable 'utop-process) (make-local-variable 'utop-prompt-min) (make-local-variable 'utop-prompt-max) (make-local-variable 'utop-input-prompt-max) (make-local-variable 'utop-last-prompt) (make-local-variable 'utop-output) (make-local-variable 'utop-command-number) (make-local-variable 'utop-inhibit-check) (make-local-variable 'utop-state) (make-local-variable 'utop-complete-buffer) (make-local-variable 'utop-initial-command) (make-local-variable 'utop-initial-mode) (make-local-variable 'utop-phrase-terminator) (make-local-variable 'utop-pending-position) (make-local-variable 'utop-pending-entry) ;; Set the hook to call before changing the buffer (add-hook 'before-change-functions 'utop-before-change nil t) ;; Register the exit hook (add-hook 'kill-buffer-hook (lambda () (run-hooks 'utop-exit-hook)) t t) ;; Save history before killing the buffer (add-hook 'kill-buffer-query-functions (lambda () (utop-save-history) t) nil t) ;; Start utop (utop-start (utop-arguments))) ;; +-----------------------------------------------------------------+ ;; | Starting utop | ;; +-----------------------------------------------------------------+ ;;;###autoload (defun utop () "A universal toplevel for OCaml. url: https://forge.ocamlcore.org/projects/utop/ utop is a enhanced toplevel for OCaml with many features, including context sensitive completion. This is the emacs frontend for utop. You can use the utop buffer as a standard OCaml toplevel. To complete an identifier, simply press TAB. Special keys for utop: \\{utop-mode-map}" (interactive) (let ((buf (get-buffer utop-buffer-name))) (cond (buf ;; Jump to the buffer (pop-to-buffer buf) ;; Restart utop if it exited (when (eq utop-state 'done) (utop-restart))) (t ;; The buffer does not exist, read the command line before ;; creating it so if the user quit it won't be created (utop-query-arguments) ;; Create the buffer (setq buf (get-buffer-create utop-buffer-name)) ;; Jump to the buffer - If utop-command is used as a ;; buffer-local variable we pass the value along to the utop ;; buffer. (let ((cmd utop-command)) (pop-to-buffer buf) (setq utop-command cmd) ;; Put it in utop mode (with-current-buffer buf (utop-mode))))) buf)) (provide 'utop-minor-mode) (provide 'utop) ;;; utop.el ends here utop-1.19.3/style.css000066400000000000000000000064421275431303000144520ustar00rootroot00000000000000/* A style for ocamldoc. Daniel C. Buenzli */ /* Reset a few things. */ html,body,div,span,applet,object,iframe,h1,h2,h3,h4,h5,h6,p,blockquote,pre, a,abbr,acronym,address,big,cite,code,del,dfn,em,font,img,ins,kbd,q,s,samp, small,strike,strong,sub,sup,tt,var,b,u,i,center,dl,dt,dd,ol,ul,li,fieldset, form,label,legend,table,caption,tbody,tfoot,thead,tr,th,td { margin: 0; padding: 0; border: 0 none; outline: 0; font-size: 100%; font-weight: inherit; font-style:inherit; font-family:inherit; line-height: inherit; vertical-align: baseline; text-align:inherit; color:inherit; background: transparent; } table { border-collapse: collapse; border-spacing: 0; } /* Basic page layout */ body { font: normal 10pt/1.375em helvetica, arial, sans-serif; text-align:left; margin: 1.375em 10%; min-width: 40ex; max-width: 72ex; color: black; background: transparent /* url(line-height-22.gif) */; } b { font-weight: bold } em { font-style: italic } tt, code, pre { font-family: WorkAroundWebKitAndMozilla, monospace; font-size: 1em; } pre code { font-size : inherit; } .codepre { margin-bottom:1.375em /* after code example we introduce space. */ } .superscript,.subscript { font-size : 0.813em; line-height:0; margin-left:0.4ex;} .superscript { vertical-align: super; } .subscript { vertical-align: sub; } /* ocamldoc markup workaround hacks */ hr, hr + br, div + br, center + br, span + br, ul + br, ol + br, pre + br { display: none } /* annoying */ div.info + br { display:block} .codepre br + br { display: none } h1 + pre { margin-bottom:1.375em} /* Toplevel module description */ /* Sections and document divisions */ /* .navbar { margin-bottom: -1.375em } */ h1 { font-weight: bold; font-size: 1.5em; /* margin-top:1.833em; */ margin-top:0.917em; padding-top:0.875em; border-top-style:solid; border-width:1px; border-color:#AAA; } h2 { font-weight: bold; font-size: 1.313em; margin-top: 1.048em } h3 { font-weight: bold; font-size: 1.125em; margin-top: 1.222em } h3 { font-weight: bold; font-size: 1em; margin-top: 1.375em} h4 { font-style: italic; } /* Used by OCaml's own library documentation. */ h6 { font-weight: bold; font-size: 1.125em; margin-top: 1.222em } .h7 { font-weight: bold; font-size: 1em; margin-top: 1.375em } p { margin-top: 1.375em } pre { margin-top: 1.375em } .info { margin: 0.458em 0em -0.458em 2em;}/* Description of types values etc. */ td .info { margin:0; padding:0; margin-left: 2em;} /* Description in indexes */ ul, ol { margin-top:0.688em; padding-bottom:0.687em; list-style-position:outside} ul + p, ol + p { margin-top: 0em } ul { list-style-type: square } /* h2 + ul, h3 + ul, p + ul { } */ ul > li { margin-left: 1.375em; } ol > li { margin-left: 1.7em; } /* Links */ a, a:link, a:visited, a:active, a:hover { color : #00B; text-decoration: none } a:hover { text-decoration : underline } *:target {background-color: #FFFF99;} /* anchor highlight */ /* Code */ .keyword { font-weight: bold; } .comment { color : red } .constructor { color : green } .string { color : brown } .warning { color : red ; font-weight : bold } /* Functors */ .paramstable { border-style : hidden ; padding-bottom:1.375em} .paramstable code { margin-left: 1ex; margin-right: 1ex } .sig_block {margin-left: 1em} /* Images */ img { margin-top: 1.375em } utop-1.19.3/utop-api.odocl000066400000000000000000000001631275431303000153520ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: ea647067f386e3b838ebcff41e686f51) src/lib/UTop src/lib/UTop_main # OASIS_STOP utop-1.19.3/utoprc-dark000066400000000000000000000012201275431303000147430ustar00rootroot00000000000000! -*- conf-xdefaults -*- ! Copy this file to ~/.utoprc ! Common resources profile: dark identifier.foreground: none module.foreground: x-palegreen comment.foreground: x-chocolate1 doc.foreground: x-light-salmon constant.foreground: x-aquamarine keyword.foreground: x-cyan1 symbol.foreground: x-cyan1 string.foreground: x-light-salmon char.foreground: x-light-salmon quotation.foreground: x-purple error.foreground: red directive.foreground: x-lightsteelblue parenthesis.background: blue ! uncomment the next line to disable autoload files ! autoload: false utop-1.19.3/utoprc-light000066400000000000000000000012211275431303000151320ustar00rootroot00000000000000! -*- conf-xdefaults -*- ! Copy this file to ~/.utoprc ! Common resources profile: light identifier.foreground: none module.foreground: x-forestgreen comment.foreground: x-firebrick doc.foreground: x-violetred4 constant.foreground: x-darkcyan keyword.foreground: x-purple symbol.foreground: x-purple string.foreground: x-violetred4 char.foreground: x-violetred4 quotation.foreground: x-purple error.foreground: red directive.foreground: x-mediumorchid4 parenthesis.background: light-blue ! uncomment the next line to disable autoload files ! autoload: false