pax_global_header00006660000000000000000000000064125422263200014510gustar00rootroot0000000000000052 comment=e2375abd3d70e0cf48d81ecade5834a782dc5681 lambda-term-1.9/000077500000000000000000000000001254222632000135465ustar00rootroot00000000000000lambda-term-1.9/.gitignore000066400000000000000000000002241254222632000155340ustar00rootroot00000000000000_build/ /lambda-term-*.tar.gz /setup.data /setup.log /setup.exe /setup-dev.exe /man/*.gz /src/lTerm_config.h *.swp *.native /lambda-term-api.docdir lambda-term-1.9/.merlin000066400000000000000000000002251254222632000150340ustar00rootroot00000000000000S src/ S src/widget_impl/ S examples/ B _build/src B _build/src/widget_impl/ B _build/examples PKG lwt PKG lwt.unix PKG lwt.react PKG zed EXT lwt lambda-term-1.9/CHANGES.md000066400000000000000000000035641254222632000151500ustar00rootroot000000000000001.9 (2015-06-23) ---------------- * add repl example (Martin DeMello) * add support for custom and local bindings 1.8 (2015-01-07) ---------------- * remove use of deprecated Lwt functions * add some iTerm2 keys * fix some invalid use of react 1.7 (2014-10-20) ---------------- * removed hard dependency on camlp4 (thanks to Peter Zotov) * added styled formatters (thanks to Gabriel Radanne) * doc fixes * Extended widget support (thanks to Alexey Vyskubov): - added modal frames - added radiobutton and checkbutton 1.6 (2014-04-21) ---------------- * Support for React 1.0.0 * fix OpenBSD builds 1.5 (2013-08-07) --------------- * workaround camomile raising the wrong exception for encoding failures * add more default keybindings 1.4 (2013-03-26) ---------------- * added `C-b`, `C-f`, `C-h`, `M-p`, `M-n` by default * fix a segfault when running utop in an emacs terminal buffer 1.3 (2012-10-08) ---------------- * fix the bindings for `C-n` and `C-p` * binds `C-h` to delete-prev-char 1.2 (2012-07-30) ---------------- * better handling of newlines in read-line (avoid square selection bug) * add a module for managing history * use camomile for character encoding (remove iconv dependency) * include generated tables for color mappings to speed up the build * Windows fixes * use unicode version of IO console functions * better rendering method for read-line 1.1 (2011-08-06) ---------------- * fix a blinking problem on OS-X * bind the `kill-{prev,next}-word` editing actions * bind the undo action * add doc for edition actions * add `LTerm_key.to_string_compact` to print keys like emacs * use `Zed_input` for key bindings instead of hash tables * add support for macros * add the break action to interrupt read-line * add manual pages * allow to get the current pending key sequence in read-line * make the `LTerm_read_line.term` class more flexible lambda-term-1.9/LICENSE000066400000000000000000000027561254222632000145650ustar00rootroot00000000000000Copyright (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. lambda-term-1.9/Makefile000066400000000000000000000026621254222632000152140ustar00rootroot00000000000000# 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 -o $@ $< || ocamlopt -o $@ $< || ocamlc -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) test: $(SETUP) setup.data build ./$(SETUP) -test $(TESTFLAGS) all: $(SETUP) ./$(SETUP) -all $(ALLFLAGS) install: $(SETUP) setup.data ./$(SETUP) -install $(INSTALLFLAGS) uninstall: $(SETUP) setup.data ./$(SETUP) -uninstall $(UNINSTALLFLAGS) reinstall: $(SETUP) setup.data ./$(SETUP) -reinstall $(REINSTALLFLAGS) clean: $(SETUP) ./$(SETUP) -clean $(CLEANFLAGS) distclean: $(SETUP) ./$(SETUP) -distclean $(DISTCLEANFLAGS) configure: $(SETUP) ./$(SETUP) -configure $(CONFIGUREFLAGS) setup.data: $(SETUP) ./$(SETUP) -configure $(CONFIGUREFLAGS) .PHONY: default build doc test all install uninstall reinstall clean distclean configure lambda-term-1.9/README.md000066400000000000000000000055221254222632000150310ustar00rootroot00000000000000Lambda-Term =========== Lambda-Term is a cross-platform library for manipulating the terminal. It provides an abstraction for keys, mouse events, colors, as well as a set of widgets to write curses-like applications. The main objective of Lambda-Term is to provide a higher level functional interface to terminal manipulation than, for example, ncurses, by providing a native OCaml interface instead of bindings to a C library. Lambda-Term integrates with zed to provide text edition facilities in console applications. Dependencies ------------ * [OCaml](http://caml.inria.fr/ocaml/) (>= 3.12) * [findlib](http://projects.camlcity.org/projects/findlib.html) * [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) For building the development version, you also need to install [oasis](http://oasis.forge.ocamlcore.org/) (>= 0.3.0). Installation ------------ To build and install Lambda-Term: $ ./configure $ make $ make install ### Documentation and manual pages _(optional)_ To build the documentation: $ make doc It will then be installed by `make install`. ### Tests _(optionnal)_ To build and execute tests: $ ./configure --enable-tests $ make test Terminal emulators compatibility -------------------------------- All terminal emulators behave differently, especially regarding how keystrokes are reported to the application on its standard input. Lambda-Term tries to handle all of them, but it may happen that a particular key of combination of keys is not recognized by Lambda-Term, and thus does not produce the expected effect (for example: arrow keys or backspace not working). To check what is reported by your terminal you can run the script `print_sequences.ml` which at the root of the repository: $ ocaml print_sequences.ml press 'q' to quit \027[A \027[D \027[C \027[A \027[D a z e q You can then send the result to jeremie@dimino.org, including: * the application you are using as terminal emulator, * the contents of the `TERM` environment variable inside the terminal (`echo $TERM`), * the output of `print_sequences.ml` with, for each line, the keystroke. Main modules ------------ * `LTerm`: basic interface to the terminal, it allows to put the terminal in _raw_ mode, hide the cursor, render an offscreen array of points, ... * `LTerm_draw`: drawing functions, for rendering in an offscreen array. * `LTerm_read_line`: line edition. * `LTerm_inputrc`: parsing of configurations files for key bindings. * `LTerm_history`: history and history file management. * `LTerm_ui`: helpers for writing full-screen applications. * `LTerm_widget`: widget system (not stable). * `LTerm_resources`: resources loading for widgets. lambda-term-1.9/_oasis000066400000000000000000000200041254222632000147420ustar00rootroot00000000000000# +-------------------------------------------------------------------+ # | Package parameters | # +-------------------------------------------------------------------+ OASISFormat: 0.4 OCamlVersion: >= 3.12 Name: lambda-term Version: 1.9 LicenseFile: LICENSE License: BSD-3-CLAUSE Authors: Jeremie Dimino Maintainers: Jeremie Dimino Homepage: http://lambda-term.forge.ocamlcore.org/ BuildTools: ocamlbuild Plugins: DevFiles (0.4), META (0.4) XDevFilesEnableMakefile: false Synopsis: Terminal manipulation library for OCaml Description: Lambda-term is a cross-platform library for manipulating the terminal. It provides an abstraction for keys, mouse events, colors, as well as a set of widgets to write curses-like applications. . The main objective of lambda-term is to provide a higher level functional interface to terminal manipulation than, for example, ncurses, by providing a native OCaml interface instead of bindings to a C library. . Lambda-term integrates with zed to provide text edition facilities in console applications. FilesAB: src/lTerm_config.h.ab # +-------------------------------------------------------------------+ # | The library | # +-------------------------------------------------------------------+ Flag camlp4 Description: camlp4 support Default: false Library "lambda-term" FindlibName: lambda-term BuildDepends: lwt (>= 2.4.0), lwt.unix, lwt.react, zed (>= 1.2) XMETADescription: Cross-platform library for terminal manipulation Path: src Install: true Modules: LTerm, LTerm_key, LTerm_event, LTerm_unix, LTerm_windows, LTerm_style, LTerm_geom, LTerm_draw, LTerm_mouse, LTerm_widget, LTerm_widget_callbacks, LTerm_edit, LTerm_read_line, LTerm_text, LTerm_ui, LTerm_resources, LTerm_inputrc, LTerm_history InternalModules: LTerm_color_mappings, LTerm_resource_lexer, widget_impl/LTerm_widget_base_impl, widget_impl/LTerm_buttons_impl, widget_impl/LTerm_containers_impl, widget_impl/LTerm_running_impl, widget_impl/LTerm_toplevel_impl CSources: lTerm_config.h, lTerm_term_stubs.c, lTerm_unix_stubs.c, lTerm_windows_stubs.c CCOpt: -I$pkg_lwt if system(openbsd) CCOpt+: -I/usr/local/include CCLib: -L/usr/local/lib -lcharset # +-------------------------------------------------------------------+ # | Examples | # +-------------------------------------------------------------------+ Executable events Path: examples Build$: flag(camlp4) Install: false CompiledObject: best MainIs: events.ml BuildDepends: lambda-term, lwt.syntax Executable colors Path: examples Build$: flag(camlp4) Install: false CompiledObject: best MainIs: colors.ml BuildDepends: lambda-term, lwt.syntax Executable colors_256 Path: examples Build$: flag(camlp4) Install: false CompiledObject: best MainIs: colors_256.ml BuildDepends: lambda-term, lwt.syntax Executable rgb Path: examples Build$: flag(camlp4) Install: false CompiledObject: best MainIs: rgb.ml BuildDepends: lambda-term, lwt.syntax Executable move Path: examples Build$: flag(camlp4) Install: false CompiledObject: best MainIs: move.ml BuildDepends: lambda-term, lwt.syntax Executable hello Path: examples Build$: flag(camlp4) Install: false CompiledObject: best MainIs: hello.ml BuildDepends: lambda-term, lwt.syntax Executable clock Path: examples Build$: flag(camlp4) Install: false CompiledObject: best MainIs: clock.ml BuildDepends: lambda-term, lwt.syntax Executable buttons Path: examples Build$: flag(camlp4) Install: false CompiledObject: best MainIs: buttons.ml BuildDepends: lambda-term, lwt.syntax Executable checkbuttons Path: examples Build$: flag(camlp4) Install: false CompiledObject: best MainIs: checkbuttons.ml BuildDepends: lambda-term, lwt.syntax Executable radiobuttons Path: examples Build$: flag(camlp4) Install: false CompiledObject: best MainIs: radiobuttons.ml BuildDepends: lambda-term, lwt.syntax Executable shell Path: examples Build$: flag(camlp4) Install: false CompiledObject: best MainIs: shell.ml BuildDepends: lambda-term, lwt.syntax, str Executable repl Path: examples Build$: flag(camlp4) Install: false CompiledObject: best MainIs: repl.ml BuildDepends: lambda-term, lwt.syntax Executable modal Path: examples Build$: flag(camlp4) Install: false CompiledObject: best MainIs: modal.ml BuildDepends: lambda-term, lwt.syntax Executable "read-password" Path: examples Build$: flag(camlp4) Install: false CompiledObject: best MainIs: read_password.ml BuildDepends: lambda-term, lwt.syntax Executable "read-yes-no" Path: examples Build$: flag(camlp4) Install: false CompiledObject: best MainIs: read_yes_no.ml BuildDepends: lambda-term, lwt.syntax Executable "editor" Path: examples Build$: flag(camlp4) Install: false CompiledObject: best MainIs: editor.ml BuildDepends: lambda-term, lwt.syntax # +-------------------------------------------------------------------+ # | Utils | # +-------------------------------------------------------------------+ Executable "lambda-term-actions" Path: tools Install: true CompiledObject: best MainIs: lambda_term_actions.ml BuildDepends: lambda-term # +-------------------------------------------------------------------+ # | Tests | # +-------------------------------------------------------------------+ Executable "history-stress-test" Path: tests Install: false CompiledObject: best MainIs: history_stress_test.ml BuildDepends: lambda-term # +-------------------------------------------------------------------+ # | Doc | # +-------------------------------------------------------------------+ Document "lambda-term-api" Title: API reference for Lambda-Term Type: ocamlbuild (0.4) Install: true InstallDir: $htmldir/api DataFiles: style.css BuildTools: ocamldoc XOCamlbuildPath: ./ XOCamlbuildLibraries: lambda-term # +-------------------------------------------------------------------+ # | Manual pages | # +-------------------------------------------------------------------+ Document "lambda-term-actions-man" Type: custom (0.4) Title: Man page for lambda-term-actions Install: true BuildTools: gzip XCustom: $gzip -c man/lambda-term-actions.1 > man/lambda-term-actions.1.gz XCustomClean: $rm man/lambda-term-actions.1.gz DataFiles: man/lambda-term-actions.1.gz InstallDir: $mandir/man1 Document "lambda-term-inputrc-man" Type: custom (0.4) Title: Man page for ~/.lambda-term-inputrc Install: true BuildTools: gzip XCustom: $gzip -c man/lambda-term-inputrc.5 > man/lambda-term-inputrc.5.gz XCustomClean: $rm man/lambda-term-inputrc.5.gz DataFiles: man/lambda-term-inputrc.5.gz InstallDir: $mandir/man5 # +-------------------------------------------------------------------+ # | Configuration examples | # +-------------------------------------------------------------------+ Document "lamda-term-inputrc" Type: custom (0.4) Title: lambda-term-inputrc example XCustom: true Install: true DataFiles: lambda-term-inputrc Document "lambda-termrc" Type: custom (0.4) Title: lambda-term resource file example XCustom: true Install: true DataFiles: lambda-termrc # +-------------------------------------------------------------------+ # | Misc | # +-------------------------------------------------------------------+ SourceRepository head Type: git Location: https://github.com/diml/lambda-term.git Browser: https://github.com/diml/lambda-term lambda-term-1.9/_tags000066400000000000000000000174351254222632000146000ustar00rootroot00000000000000true: bin_annot # OASIS_START # DO NOT EDIT (digest: 024eec249c8fc3da91bc96da8b4088e5) # 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 lambda-term "src/lambda-term.cmxs": use_lambda-term : oasis_library_lambda_term_ccopt : oasis_library_lambda_term_ccopt "src/lTerm_term_stubs.c": oasis_library_lambda_term_ccopt "src/lTerm_unix_stubs.c": oasis_library_lambda_term_ccopt "src/lTerm_windows_stubs.c": oasis_library_lambda_term_ccopt : oasis_library_lambda_term_cclib "src/liblambda-term_stubs.lib": oasis_library_lambda_term_cclib "src/dlllambda-term_stubs.dll": oasis_library_lambda_term_cclib "src/liblambda-term_stubs.a": oasis_library_lambda_term_cclib "src/dlllambda-term_stubs.so": oasis_library_lambda_term_cclib : use_liblambda-term_stubs : pkg_lwt : pkg_lwt.react : pkg_lwt.unix : pkg_zed : pkg_lwt : pkg_lwt.react : pkg_lwt.unix : pkg_zed "src/lTerm_term_stubs.c": pkg_lwt "src/lTerm_term_stubs.c": pkg_lwt.react "src/lTerm_term_stubs.c": pkg_lwt.unix "src/lTerm_term_stubs.c": pkg_zed "src/lTerm_unix_stubs.c": pkg_lwt "src/lTerm_unix_stubs.c": pkg_lwt.react "src/lTerm_unix_stubs.c": pkg_lwt.unix "src/lTerm_unix_stubs.c": pkg_zed "src/lTerm_windows_stubs.c": pkg_lwt "src/lTerm_windows_stubs.c": pkg_lwt.react "src/lTerm_windows_stubs.c": pkg_lwt.unix "src/lTerm_windows_stubs.c": pkg_zed # Executable events : pkg_lwt : pkg_lwt.react : pkg_lwt.syntax : pkg_lwt.unix : pkg_zed : use_lambda-term # Executable colors : pkg_lwt : pkg_lwt.react : pkg_lwt.syntax : pkg_lwt.unix : pkg_zed : use_lambda-term # Executable colors_256 : pkg_lwt : pkg_lwt.react : pkg_lwt.syntax : pkg_lwt.unix : pkg_zed : use_lambda-term # Executable rgb : pkg_lwt : pkg_lwt.react : pkg_lwt.syntax : pkg_lwt.unix : pkg_zed : use_lambda-term # Executable move : pkg_lwt : pkg_lwt.react : pkg_lwt.syntax : pkg_lwt.unix : pkg_zed : use_lambda-term # Executable hello : pkg_lwt : pkg_lwt.react : pkg_lwt.syntax : pkg_lwt.unix : pkg_zed : use_lambda-term # Executable clock : pkg_lwt : pkg_lwt.react : pkg_lwt.syntax : pkg_lwt.unix : pkg_zed : use_lambda-term # Executable buttons : pkg_lwt : pkg_lwt.react : pkg_lwt.syntax : pkg_lwt.unix : pkg_zed : use_lambda-term # Executable checkbuttons : pkg_lwt : pkg_lwt.react : pkg_lwt.syntax : pkg_lwt.unix : pkg_zed : use_lambda-term # Executable radiobuttons : pkg_lwt : pkg_lwt.react : pkg_lwt.syntax : pkg_lwt.unix : pkg_zed : use_lambda-term # Executable shell : pkg_lwt : pkg_lwt.react : pkg_lwt.syntax : pkg_lwt.unix : pkg_str : pkg_zed : use_lambda-term : pkg_str # Executable repl : pkg_lwt : pkg_lwt.react : pkg_lwt.syntax : pkg_lwt.unix : pkg_zed : use_lambda-term # Executable modal : pkg_lwt : pkg_lwt.react : pkg_lwt.syntax : pkg_lwt.unix : pkg_zed : use_lambda-term # Executable read-password : pkg_lwt : pkg_lwt.react : pkg_lwt.syntax : pkg_lwt.unix : pkg_zed : use_lambda-term # Executable read-yes-no : pkg_lwt : pkg_lwt.react : pkg_lwt.syntax : pkg_lwt.unix : pkg_zed : use_lambda-term # Executable editor : pkg_lwt : pkg_lwt.react : pkg_lwt.syntax : pkg_lwt.unix : pkg_zed : use_lambda-term : pkg_lwt : pkg_lwt.react : pkg_lwt.syntax : pkg_lwt.unix : pkg_zed : use_lambda-term # Executable lambda-term-actions : pkg_lwt : pkg_lwt.react : pkg_lwt.unix : pkg_zed : use_lambda-term : pkg_lwt : pkg_lwt.react : pkg_lwt.unix : pkg_zed : use_lambda-term # Executable history-stress-test : pkg_lwt : pkg_lwt.react : pkg_lwt.unix : pkg_zed : use_lambda-term : pkg_lwt : pkg_lwt.react : pkg_lwt.unix : pkg_zed : use_lambda-term # OASIS_STOP lambda-term-1.9/configure000077500000000000000000000005531254222632000154600ustar00rootroot00000000000000#!/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 lambda-term-1.9/examples/000077500000000000000000000000001254222632000153645ustar00rootroot00000000000000lambda-term-1.9/examples/buttons.ml000066400000000000000000000015231254222632000174150ustar00rootroot00000000000000(* * buttons.ml * ---------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) open Lwt open LTerm_widget lwt () = let waiter, wakener = wait () in let vbox = new vbox in let button = new button "exit" in button#on_click (wakeup wakener); vbox#add button; for i = 0 to 2 do let hbox = new hbox in hbox#add (new button ("button" ^ string_of_int (i * 3 + 1))); hbox#add ~expand:false (new vline); hbox#add (new button ("button" ^ string_of_int (i * 3 + 2))); hbox#add ~expand:false (new vline); hbox#add (new button ("button" ^ string_of_int (i * 3 + 3))); vbox#add ~expand:false (new hline); vbox#add hbox done; let frame = new frame in frame#set vbox; lwt term = Lazy.force LTerm.stdout in run term frame waiter lambda-term-1.9/examples/checkbuttons.ml000066400000000000000000000026001254222632000204100ustar00rootroot00000000000000(* * checkbuttons.ml * ---------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) open Lwt open LTerm_widget lwt () = let waiter, wakener = wait () in let vbox = new vbox in let checked_label = (new label "") in let create_button n = new checkbutton ("button" ^ (string_of_int n)) false in let checkbuttons = Array.init 9 create_button in let callback () = let new_label = ref "" in for i = 0 to 8 do if checkbuttons.(i)#state then new_label := !new_label ^ " " ^ string_of_int i else () done; checked_label#set_text !new_label in let button = new button "exit" in button#on_click (wakeup wakener); vbox#add ~expand:false button; vbox#add ~expand:false (new hline); let use_checkbutton n = let cb = checkbuttons.(n) in cb#on_click callback; cb in for i = 0 to 2 do let hbox = new hbox in hbox#add (use_checkbutton i); hbox#add ~expand:false (new vline); hbox#add (use_checkbutton (i + 3)); hbox#add ~expand:false (new vline); hbox#add (use_checkbutton (i + 6)); vbox#add ~expand:false hbox done; vbox#add ~expand:false (new hline); vbox#add ~expand:false checked_label; vbox#add (new t "glue") ; let frame = new frame in frame#set vbox; lwt term = Lazy.force LTerm.stdout in run term frame waiter lambda-term-1.9/examples/clock.ml000066400000000000000000000015461254222632000170170ustar00rootroot00000000000000(* * clock.ml * -------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) open Lwt_react open Lwt open LTerm_widget let get_time () = let localtime = Unix.localtime (Unix.time ()) in Printf.sprintf "%02u:%02u:%02u" localtime.Unix.tm_hour localtime.Unix.tm_min localtime.Unix.tm_sec lwt () = let waiter, wakener = wait () in let vbox = new vbox in let clock = new label (get_time ()) in let button = new button "exit" in vbox#add clock; vbox#add button; (* Update the time every second. *) ignore (Lwt_engine.on_timer 1.0 true (fun _ -> clock#set_text (get_time ()))); (* Quit when the exit button is clicked. *) button#on_click (wakeup wakener); (* Run in the standard terminal. *) lwt term = Lazy.force LTerm.stdout in run term vbox waiter lambda-term-1.9/examples/colors.ml000066400000000000000000000007061254222632000172220ustar00rootroot00000000000000(* * colors.ml * --------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) open Lwt open LTerm_style open LTerm_text lwt () = for_lwt i = 0 to 15 do LTerm.printls (eval [S(Printf.sprintf "color %d: " i); B_fg(index i); S"foreground"; E_fg; S" "; B_bg(index i); S"background"; E_bg]) done lambda-term-1.9/examples/colors_256.ml000066400000000000000000000005601254222632000176140ustar00rootroot00000000000000(* * colors_256.ml * ------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) open Lwt open LTerm_style open LTerm_text lwt () = for_lwt i = 0 to 255 do LTerm.printls (eval [S(Printf.sprintf "color %d: " i); B_fg(index i); S"example"; E_fg]) done lambda-term-1.9/examples/editor.ml000066400000000000000000000015671254222632000172150ustar00rootroot00000000000000(* * editor.ml * --------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) open CamomileLibraryDyn.Camomile open Lwt lwt () = let waiter, wakener = wait () in let frame = new LTerm_widget.frame in let editor = new LTerm_edit.edit () in frame#set editor; (* Exit when the user presses C-x C-c *) editor#bind (let open LTerm_key in [ { control = true; meta = false; shift = false ; code = Char (UChar.of_char 'x') } ; { control = true; meta = false; shift = false ; code = Char (UChar.of_char 'c') } ]) [ LTerm_edit.Custom (fun () -> wakeup wakener ()) ]; Zed_edit.insert editor#context (Zed_rope.of_string "\ This is a simple edition widget. Type C-x C-c to exit. "); lwt term = Lazy.force LTerm.stdout in LTerm_widget.run term frame waiter lambda-term-1.9/examples/events.ml000066400000000000000000000013611254222632000172230ustar00rootroot00000000000000(* * events.ml * --------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (* Show events read from the terminal *) open Lwt open LTerm_event let rec loop term = lwt ev = LTerm.read_event term in lwt () = Lwt_io.printl (LTerm_event.to_string ev) in match ev with | LTerm_event.Key{ LTerm_key.code = LTerm_key.Escape } -> return () | _ -> loop term lwt () = lwt () = Lwt_io.printl "press escape to exit" in lwt term = Lazy.force LTerm.stdout in lwt () = LTerm.enable_mouse term in lwt mode = LTerm.enter_raw_mode term in try_lwt loop term finally lwt () = LTerm.leave_raw_mode term mode in LTerm.disable_mouse term lambda-term-1.9/examples/hello.ml000066400000000000000000000013061254222632000170210ustar00rootroot00000000000000(* * hello.ml * -------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) open Lwt_react open Lwt lwt () = (* Create a thread waiting for escape to be pressed. *) let waiter, wakener = wait () in (* Create the UI. *) let vbox = new LTerm_widget.vbox in vbox#add (new LTerm_widget.label "Hello, world!"); vbox#add (new LTerm_widget.label "Press escape to exit."); vbox#on_event (function | LTerm_event.Key { LTerm_key.code = LTerm_key.Escape } -> wakeup wakener (); true | _ -> false); (* Run. *) lwt term = Lazy.force LTerm.stdout in LTerm_widget.run term vbox waiter lambda-term-1.9/examples/modal.ml000066400000000000000000000024101254222632000170070ustar00rootroot00000000000000open Lwt open Lwt_react open LTerm_widget lwt () = let do_run, push_layer, pop_layer, exit = prepare_simple_run () in let vbox = new vbox in let button = new button "exit" in button#on_click exit; vbox#add button; let change = new button "change counter" in vbox#add change; let counter = ref 42 in let label = new label "" in let update_label () = label#set_text ("Counter: " ^ (string_of_int !counter)) in vbox#add label; update_label (); let change_counter d = fun () -> counter := !counter + d; update_label () in let frame = new frame in frame#set vbox; (* Layer 2 *) let layer2 = new modal_frame in let vbox' = new vbox in layer2#set vbox'; let message = new label "This is a new modal layer.\nPress 'close' to close it." in vbox'#add message; vbox'#add (new hline); let increment = new button "increment counter" in let decrement = new button "decrement counter" in increment#on_click (change_counter 1); decrement#on_click (change_counter (-1)); vbox'#add increment; vbox'#add decrement; vbox'#add (new hline); let close = new button "close" in close#on_click pop_layer; vbox'#add close; (* set 'change' button to open modal layer *) change#on_click (push_layer layer2); do_run frame lambda-term-1.9/examples/move.ml000066400000000000000000000032541254222632000166700ustar00rootroot00000000000000(* * move.ml * ------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) open Lwt open Lwt_react open LTerm_geom open LTerm_text open LTerm_key let rec loop ui coord = LTerm_ui.wait ui >>= function | LTerm_event.Key{ code = Up } -> coord := { !coord with row = !coord.row - 1 }; LTerm_ui.draw ui; loop ui coord | LTerm_event.Key{ code = Down } -> coord := { !coord with row = !coord.row + 1 }; LTerm_ui.draw ui; loop ui coord | LTerm_event.Key{ code = Left } -> coord := { !coord with col = !coord.col - 1 }; LTerm_ui.draw ui; loop ui coord | LTerm_event.Key{ code = Right } -> coord := { !coord with col = !coord.col + 1 }; LTerm_ui.draw ui; loop ui coord | LTerm_event.Key{ code = Escape } -> return () | ev -> loop ui coord let draw ui matrix coord = let size = LTerm_ui.size ui in let ctx = LTerm_draw.context matrix size in LTerm_draw.clear ctx; LTerm_draw.draw_frame ctx { row1 = 0; col1 = 0; row2 = size.rows; col2 = size.cols } LTerm_draw.Light; if size.rows > 2 && size.cols > 2 then begin let ctx = LTerm_draw.sub ctx { row1 = 1; col1 = 1; row2 = size.rows - 1; col2 = size.cols - 1 } in LTerm_draw.draw_styled ctx coord.row coord.col (eval [B_fg LTerm_style.lblue; S"Move me"; E_fg]) end lwt () = lwt term = Lazy.force LTerm.stdout in (* Coordinates of the message. *) let coord = ref { row = 0; col = 0 } in lwt ui = LTerm_ui.create term (fun matrix size -> draw matrix size !coord) in try_lwt loop ui coord finally LTerm_ui.quit ui lambda-term-1.9/examples/radiobuttons.ml000066400000000000000000000034671254222632000204450ustar00rootroot00000000000000(* * radiobuttons.ml *) open Lwt open LTerm_widget lwt () = let waiter, wakener = wait () in let vbox = new vbox in let result_int = (new label "1") in let result_string = (new label "foo") in let group_int = new radiogroup in let group_string = new radiogroup in let callback_int = function | Some n -> result_int#set_text (string_of_int n) | None -> () in let callback_string = function | Some s -> result_string#set_text s | None -> () in group_int#on_state_change callback_int; group_string#on_state_change callback_string; let button = new button "exit" in button#on_click (wakeup wakener); vbox#add ~expand:false button; vbox#add ~expand:false (new hline); let button = new button "reset radiobuttons" in let reset = fun () -> group_int#switch_to 1; group_string#switch_to "foo" in button#on_click reset; vbox#add ~expand:false button; vbox#add ~expand:false (new hline); let hbox = new hbox in hbox#add (new radiobutton group_int "Number 1" 1); hbox#add ~expand:false (new vline); hbox#add (new radiobutton group_string "String 'foo'" "foo"); vbox#add ~expand:false hbox; let hbox = new hbox in hbox#add (new radiobutton group_int "Number 2" 2); hbox#add ~expand:false (new vline); hbox#add (new radiobutton group_string "String 'bar'" "bar"); vbox#add ~expand:false hbox; let hbox = new hbox in hbox#add (new radiobutton group_int "Number 3" 3); hbox#add ~expand:false (new vline); hbox#add (new radiobutton group_string "String 'baz'" "baz"); vbox#add ~expand:false hbox; vbox#add ~expand:false (new hline); vbox#add ~expand:false result_int; vbox#add ~expand:false result_string; vbox#add (new t "glue") ; let frame = new frame in frame#set vbox; lwt term = Lazy.force LTerm.stdout in run term frame waiter lambda-term-1.9/examples/read_password.ml000066400000000000000000000014441254222632000205560ustar00rootroot00000000000000(* * read_password.ml * ---------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (* Read a password and display it. *) open Lwt_react open LTerm_style class read_password term = object(self) inherit LTerm_read_line.read_password () as super inherit [Zed_utf8.t] LTerm_read_line.term term method send_action = function | LTerm_read_line.Break -> (* Ignore Ctrl+C *) () | action -> super#send_action action initializer self#set_prompt (S.const (LTerm_text.of_string "Type a password: ")) end lwt () = lwt () = LTerm_inputrc.load () in lwt term = Lazy.force LTerm.stdout in lwt password = (new read_password term)#run in Lwt_io.printlf "You typed %S" password lambda-term-1.9/examples/read_yes_no.ml000066400000000000000000000023301254222632000202030ustar00rootroot00000000000000(* * read_yes_no.ml * -------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) open Lwt let rec read_char term = LTerm.read_event term >>= function | LTerm_event.Key { LTerm_key.code = LTerm_key.Char ch; LTerm_key.control = true } when ch = CamomileLibraryDyn.Camomile.UChar.of_char 'c' -> (* Exit on Ctrl+C *) raise_lwt (Failure "interrupted") | LTerm_event.Key { LTerm_key.code = LTerm_key.Char ch } -> return ch | _ -> read_char term let rec read_yes_no term = lwt () = LTerm.fprint term "Do you accept (y/n) ? " in lwt ch = read_char term >|= Zed_utf8.singleton in lwt () = LTerm.fprintl term ch in match ch with | "y" -> return true | "n" -> return false | _ -> lwt () = LTerm.fprintl term "Please enter 'y' or 'n'!" in read_yes_no term lwt () = lwt term = Lazy.force LTerm.stdout in lwt mode = LTerm.enter_raw_mode term in try_lwt read_yes_no term >>= function | true -> LTerm.fprintl term "You accepted." | false -> LTerm.fprintl term "You did not accept." finally LTerm.leave_raw_mode term mode lambda-term-1.9/examples/repl.ml000066400000000000000000000056321254222632000166660ustar00rootroot00000000000000(* * repl.ml * -------- * Copyright : (c) 2015, Martin DeMello * Licence : BSD3 * * This file is a part of Lambda-Term. *) (* Add a REPL to an existing interpreter *) open React open Lwt open LTerm_text (* +-----------------------------------------------------------------+ | Interpreter | +-----------------------------------------------------------------+ *) (* A simple model of an interpreter. It maintains some state, and exposes a function * eval : state -> input -> (new_state, output) *) module Interpreter = struct type state = { n : int } let eval state s = let out = "evaluated " ^ s in let new_state = { n = state.n + 1 } in (new_state, out) end (* +-----------------------------------------------------------------+ | Prompt and output wrapping | +-----------------------------------------------------------------+ *) (* Create a prompt based on the current interpreter state *) let make_prompt state = let prompt = Printf.sprintf "In [%d]: " state.Interpreter.n in eval [ S prompt ] (* Format the interpreter output for REPL display *) let make_output state out = let output = Printf.sprintf "Out [%d]: %s" state.Interpreter.n out in eval [ S output ] (* +-----------------------------------------------------------------+ | Customization of the read-line engine | +-----------------------------------------------------------------+ *) class read_line ~term ~history ~state = object(self) inherit LTerm_read_line.read_line ~history () inherit [Zed_utf8.t] LTerm_read_line.term term method show_box = false initializer self#set_prompt (S.const (make_prompt state)) end (* +-----------------------------------------------------------------+ | Main loop | +-----------------------------------------------------------------+ *) let rec loop term history state = match_lwt try_lwt let rl = new read_line ~term ~history:(LTerm_history.contents history) ~state in lwt command = rl#run in return (Some command) with Sys.Break -> return None with | Some command -> let state, out = Interpreter.eval state command in lwt () = LTerm.fprintls term (make_output state out) in LTerm_history.add history command; loop term history state | None -> loop term history state (* +-----------------------------------------------------------------+ | Entry point | +-----------------------------------------------------------------+ *) lwt () = lwt () = LTerm_inputrc.load () in try_lwt let state = { Interpreter.n = 1 } in lwt term = Lazy.force LTerm.stdout in loop term (LTerm_history.create []) state with LTerm_read_line.Interrupt -> return () lambda-term-1.9/examples/rgb.ml000066400000000000000000000012171254222632000164710ustar00rootroot00000000000000(* * rgb.ml * ------ * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) open Lwt open LTerm_style open LTerm_text lwt () = if Array.length Sys.argv <> 4 then begin lwt () = LTerm.eprintlf "usage: %s " (Filename.basename Sys.executable_name) in exit 2 end else begin let r = int_of_string Sys.argv.(1) and g = int_of_string Sys.argv.(2) and b = int_of_string Sys.argv.(3) in LTerm.printls (eval [S(Printf.sprintf "color with component (%d, %d, %d): " r g b); B_fg(rgb r g b); S"example"; E_fg]) end lambda-term-1.9/examples/shell.ml000066400000000000000000000126441254222632000170340ustar00rootroot00000000000000(* * shell.ml * -------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (* A mini shell *) open CamomileLibraryDyn.Camomile open React open Lwt open LTerm_style open LTerm_text open LTerm_geom (* +-----------------------------------------------------------------+ | Prompt creation | +-----------------------------------------------------------------+ *) (* The function [make_prompt] creates the prompt. Parameters are: - size: the current size of the terminal. - exit_code: the exit code of the last executed command. - time: the current time. *) let make_prompt size exit_code time = let tm = Unix.localtime time in let code = string_of_int exit_code in (* Replace the home directory by "~" in the current path. *) let path = Sys.getcwd () in let path = try let home = Sys.getenv "HOME" in if Zed_utf8.starts_with path home then Zed_utf8.replace path 0 (Zed_utf8.length home) "~" else path with Not_found -> path in (* Shorten the path if it is too large for the size of the terminal. *) let path_len = Zed_utf8.length path in let size_for_path = size.cols - 24 - Zed_utf8.length code in let path = if path_len > size_for_path then if size_for_path >= 2 then ".." ^ Zed_utf8.after path (path_len - size_for_path + 2) else path else path in eval [ B_bold true; B_fg lcyan; S"─( "; B_fg lmagenta; S(Printf.sprintf "%02d:%02d:%02d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec); E_fg; S" )─< "; B_fg lyellow; S path; E_fg; S" >─"; S(Zed_utf8.make (size.cols - 24 - Zed_utf8.length code - Zed_utf8.length path) (UChar.of_int 0x2500)); S"[ "; B_fg(if exit_code = 0 then lwhite else lred); S code; E_fg; S" ]─"; E_fg; S"\n"; B_fg lred; S(try Sys.getenv "USER" with Not_found -> ""); E_fg; B_fg lgreen; S"@"; E_fg; B_fg lblue; S(Unix.gethostname ()); E_fg; B_fg lgreen; S" $ "; E_fg; E_bold; ] (* +-----------------------------------------------------------------+ | Listing binaries of the path for completion | +-----------------------------------------------------------------+ *) module String_set = Set.Make(String) let colon_re = Str.regexp ":" let get_paths () = try Str.split colon_re (Sys.getenv "PATH") with Not_found -> [] (* Get the set of all binaries with a name starting with [prefix]. *) let get_binaries () = Lwt_list.fold_left_s (fun set dir -> try_lwt Lwt_stream.fold (fun file set -> if file <> "." && file <> ".." then String_set.add file set else set) (Lwt_unix.files_of_directory dir) set with Unix.Unix_error _ -> return set) String_set.empty (get_paths ()) >|= String_set.elements (* +-----------------------------------------------------------------+ | Customization of the read-line engine | +-----------------------------------------------------------------+ *) (* Signal updated every second with the current time. *) let time = let time, set_time = S.create (Unix.time ()) in (* Update the time every second. *) ignore (Lwt_engine.on_timer 1.0 true (fun _ -> set_time (Unix.time ()))); time class read_line ~term ~history ~exit_code ~binaries = object(self) inherit LTerm_read_line.read_line ~history () inherit [Zed_utf8.t] LTerm_read_line.term term method completion = let prefix = Zed_rope.to_string self#input_prev in let binaries = List.filter (fun file -> Zed_utf8.starts_with file prefix) binaries in self#set_completion 0 (List.map (fun file -> (file, " ")) binaries) initializer self#set_prompt (S.l2 (fun size time -> make_prompt size exit_code time) self#size time) end (* +-----------------------------------------------------------------+ | Main loop | +-----------------------------------------------------------------+ *) let rec loop term history exit_code = lwt binaries = get_binaries () in match_lwt try_lwt lwt command = (new read_line ~term ~history:(LTerm_history.contents history) ~exit_code ~binaries)#run in return (Some command) with Sys.Break -> return None with | Some command -> lwt status = try_lwt Lwt_process.exec (Lwt_process.shell command) with Unix.Unix_error (Unix.ENOENT, _, _) -> lwt () = LTerm.fprintls term (eval [B_fg lred; S "command not found"]) in return (Unix.WEXITED 127) in LTerm_history.add history command; loop term history (match status with | Unix.WEXITED code -> code | Unix.WSIGNALED code -> code | Unix.WSTOPPED code -> code) | None -> loop term history 130 (* +-----------------------------------------------------------------+ | Entry point | +-----------------------------------------------------------------+ *) lwt () = lwt () = LTerm_inputrc.load () in try_lwt lwt term = Lazy.force LTerm.stdout in loop term (LTerm_history.create []) 0 with LTerm_read_line.Interrupt -> return () lambda-term-1.9/lambda-term-api.odocl000066400000000000000000000005761254222632000175340ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: ab0a7c808bd6a138dc73e0c4e0d53271) src/LTerm src/LTerm_key src/LTerm_event src/LTerm_unix src/LTerm_windows src/LTerm_style src/LTerm_geom src/LTerm_draw src/LTerm_mouse src/LTerm_widget src/LTerm_widget_callbacks src/LTerm_edit src/LTerm_read_line src/LTerm_text src/LTerm_ui src/LTerm_resources src/LTerm_inputrc src/LTerm_history # OASIS_STOP lambda-term-1.9/lambda-term-inputrc000066400000000000000000000023321254222632000173400ustar00rootroot00000000000000# -*- conf-colon -*- # Copy this file to your ~/.lambda-term-inputrc [read-line] # Read-line only key bindings [edit] # General key bindings # Each line is of the form: # # : # # where is a list of keys in emacs style. For example # to bind Control+w to cut the word before the cursor, write: # # C-w: kill-prev-word # # may contains several action. For example, to insert # "Hello, world!" when pressing Control+h, write: # # C-h: insert(H), insert(e), insert(l), insert(l), insert(o), insert(,), insert( ), insert(w), insert(o), insert(r), insert(l), insert(d), insert(!) # # Note that in keys and actions, lambda-term recognize only ascii # character, if you want to use non-ascii ones, you must write them # U+. For example to bind Control+é to inserting "É", # write: # # C-U+e9: insert(U+c9) # # For a list of possible actions, run the command # "lambda-term-actions". # # This file is divided in sections, and each section refer to a # particular set of key bindings. There is two sections: [edit] and # [read-line]. The [edit] section is for key bindings that apply # everywhere, and the [read-line] section is for key bindings that # apply only in read-line. lambda-term-1.9/lambda-termrc000066400000000000000000000006461254222632000162110ustar00rootroot00000000000000button.focused.foreground: lyellow button.focused.background: blue checkbutton.focused.foreground: lyellow checkbutton.focused.background: blue radiobutton.focused.foreground: lyellow radiobutton.focused.background: blue ! ! For monochrome experience comment out the resources above and uncomment two ! following lines: ! !button.focused.reverse: true !checkbutton.focused.reverse: true !radiobutton.focused.reverse: true lambda-term-1.9/man/000077500000000000000000000000001254222632000143215ustar00rootroot00000000000000lambda-term-1.9/man/lambda-term-actions.1000066400000000000000000000010321254222632000202220ustar00rootroot00000000000000\" lambda-term-actions.1 \" --------------------- \" Copyright : (c) 2011, Jeremie Dimino \" Licence : BSD3 \" \" This file is a part of Lambda-Term. .TH LAMBDA-TERM-ACTIONS 1 "August 2011" .SH NAME lambda-term-actions \- Display lambda-term editing actions .SH SYNOPSIS .B lambda-term-actions .SH DESCRIPTION .B lambda-term-actions displays the list of actions that can be used in the ~/.lambda-term-inputrc file. .SH AUTHOR Jérémie Dimino .SH "SEE ALSO" .BR lambda-term-inputrc (5). lambda-term-1.9/man/lambda-term-inputrc.5000066400000000000000000000042031254222632000202550ustar00rootroot00000000000000\" lambda-term-inputrc.5 \" --------------------- \" Copyright : (c) 2011, Jeremie Dimino \" Licence : BSD3 \" \" This file is a part of Lambda-Term. .TH LAMBDA-TERM-INPUTRC 5 "August 2011" .SH NAME lambda-term-inputrc \- Key bindings for lambda-term applications .SH SYNOPSIS .B ~/.lambda-term-inputrc .SH DESCRIPTION This manual page describes the format of the .I ~/.lambda-term-inputrc file. This file is a text file which associates editing actions to key sequences. Comments start with a '#' character and empty lines are ignored. Bindings are of the form: : Where .I is a sequence of keys in the emacs format. For example Control+w is written "C-w", Control+Meta+x followed by "e" is written "C-M-x e". .I is a list of editing actions separeted by commas. The list of all available actions with a short description can be obtained by running the command .BR lambda-term-actions (1) in a terminal. Here is an example of bindings: C-w: kill-prev-word M-!: play-macro In addition to letters and symbols the following keys can be used: * enter * escape * tab * up * down * left * right * f1 * f2 * f3 * f4 * f5 * f6 * f7 * f8 * f9 * f10 * f11 * f12 * next * prev * home * end * insert * delete * backspace Note that lambda-term accept only ascii characters in the configuration file, to use other unicode character you must use the notation .I U+ where .I is the code of the character in hexadecimal. The file is divided in two section, the .B [edit] section and the .B [read-line] section. The first one is for key bindings that apply everyhere and the second for key bindings that apply only in read-line. .SH FILES .I ~/.lambda-term-inputrc .SH EXAMPLE [edit] C-e: play-macro [read-line] C-left: complete-bar-prev C-right: complete-bar-next .SH AUTHOR Jérémie Dimino .SH "SEE ALSO" .BR lambda-term-actions (1). lambda-term-1.9/myocamlbuild.ml000066400000000000000000000442771254222632000165770ustar00rootroot00000000000000(* OASIS_START *) (* DO NOT EDIT (digest: 2123244a57a4fbf637450a114eabed6a) *) 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 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 # 132 "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 # 237 "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 -> (String.uncapitalize 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^"/"^(String.uncapitalize 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 # 606 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { MyOCamlbuildBase.lib_ocaml = [("lambda-term", ["src"], [])]; lib_c = [("lambda-term", "src", ["src/lTerm_config.h"])]; flags = [ (["oasis_library_lambda_term_ccopt"; "compile"], [ (OASISExpr.EBool true, S [A "-ccopt"; A "-I${pkg_lwt}"]); (OASISExpr.ETest ("system", "openbsd"), S [ A "-ccopt"; A "-I${pkg_lwt}"; A "-ccopt"; A "-I/usr/local/include" ]) ]); (["oasis_library_lambda_term_cclib"; "link"], [ (OASISExpr.EBool true, S []); (OASISExpr.ETest ("system", "openbsd"), S [ A "-cclib"; A "-L/usr/local/lib"; A "-cclib"; A "-lcharset" ]) ]); (["oasis_library_lambda_term_cclib"; "ocamlmklib"; "c"], [ (OASISExpr.EBool true, S []); (OASISExpr.ETest ("system", "openbsd"), S [A "-L/usr/local/lib"; A "-lcharset"]) ]) ]; includes = [ ("tools", ["src"]); ("tests", ["src"]); ("src/widget_impl", ["src"]); ("src", ["src/widget_impl"]); ("examples", ["src"]) ] } ;; let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; # 661 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; lambda-term-1.9/print_sequences.ml000066400000000000000000000024151254222632000173110ustar00rootroot00000000000000(* * print_sequences.ml * ------------------ * Copyright : (c) 2012, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (* Script to print sequences returned by the terminal. You can execute it like this: # ocaml print_sequences.ml *) #load "unix.cma";; let () = (* Setup terminal attributes. *) let attr = Unix.tcgetattr Unix.stdin in Unix.tcsetattr Unix.stdin Unix.TCSAFLUSH { attr with Unix.c_brkint = false; Unix.c_inpck = false; Unix.c_istrip = false; Unix.c_ixon = false; Unix.c_csize = 8; Unix.c_parenb = false; Unix.c_echo = false; Unix.c_icanon = false; Unix.c_vmin = 1; Unix.c_vtime = 0; Unix.c_isig = false; }; (* Read and print key sequences. *) print_endline "press 'q' to quit"; let buf = String.create 128 in let rec loop () = let n = Unix.read Unix.stdin buf 0 (String.length buf) in let s = String.sub buf 0 n in print_endline (String.escaped s); if s <> "q" then loop () in let result = try loop (); `OK with exn -> `Exn exn in (* Reset terminal attributes. *) Unix.tcsetattr Unix.stdin Unix.TCSAFLUSH attr; match result with | `OK -> () | `Exn exn -> raise exn lambda-term-1.9/setup.ml000066400000000000000000006566711254222632000152650ustar00rootroot00000000000000(* * setup.ml * -------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Zed, an editor engine. *) (* OASIS_START *) (* DO NOT EDIT (digest: 4d3cbbd05be4f358c29058a20cf379a9) *) (* Regenerated by OASIS v0.4.5 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 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 (String.lowercase s1) (String.lowercase s2) module HashStringCsl = Hashtbl.Make (struct type t = string let equal s1 s2 = (String.lowercase s1) = (String.lowercase s2) let hash s = Hashtbl.hash (String.lowercase 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 String.lowercase 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 String.lowercase 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 (String.capitalize base) let uncapitalize_file f = let dir = dirname f in let base = basename f in concat dir (String.uncapitalize 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 # 2893 "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 # 2998 "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 # 5409 "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 -> (String.capitalize modul ^ sufx) :: (String.uncapitalize 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 # 6273 "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 # 6651 "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 # 6799 "setup.ml" open OASISTypes;; let setup_t = { BaseSetup.configure = InternalConfigurePlugin.configure; build = OCamlbuildPlugin.build []; test = []; doc = [ ("lambda-term-api", OCamlbuildDocPlugin.doc_build {OCamlbuildDocPlugin.extra_args = []; run_path = "./"}); ("lambda-term-actions-man", CustomPlugin.Doc.main { CustomPlugin.cmd_main = [ (OASISExpr.EBool true, ("$gzip", [ "-c"; "man/lambda-term-actions.1"; ">"; "man/lambda-term-actions.1.gz" ])) ]; cmd_clean = [ (OASISExpr.EBool true, Some (("$rm", ["man/lambda-term-actions.1.gz"]))) ]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("lambda-term-inputrc-man", CustomPlugin.Doc.main { CustomPlugin.cmd_main = [ (OASISExpr.EBool true, ("$gzip", [ "-c"; "man/lambda-term-inputrc.5"; ">"; "man/lambda-term-inputrc.5.gz" ])) ]; cmd_clean = [ (OASISExpr.EBool true, Some (("$rm", ["man/lambda-term-inputrc.5.gz"]))) ]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("lamda-term-inputrc", CustomPlugin.Doc.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("true", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("lambda-termrc", 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 = [ ("lambda-term-api", OCamlbuildDocPlugin.doc_clean {OCamlbuildDocPlugin.extra_args = []; run_path = "./"}); ("lambda-term-actions-man", CustomPlugin.Doc.clean { CustomPlugin.cmd_main = [ (OASISExpr.EBool true, ("$gzip", [ "-c"; "man/lambda-term-actions.1"; ">"; "man/lambda-term-actions.1.gz" ])) ]; cmd_clean = [ (OASISExpr.EBool true, Some (("$rm", ["man/lambda-term-actions.1.gz"]))) ]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("lambda-term-inputrc-man", CustomPlugin.Doc.clean { CustomPlugin.cmd_main = [ (OASISExpr.EBool true, ("$gzip", [ "-c"; "man/lambda-term-inputrc.5"; ">"; "man/lambda-term-inputrc.5.gz" ])) ]; cmd_clean = [ (OASISExpr.EBool true, Some (("$rm", ["man/lambda-term-inputrc.5.gz"]))) ]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("lamda-term-inputrc", CustomPlugin.Doc.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("true", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("lambda-termrc", 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 = [ ("lambda-term-actions-man", CustomPlugin.Doc.distclean { CustomPlugin.cmd_main = [ (OASISExpr.EBool true, ("$gzip", [ "-c"; "man/lambda-term-actions.1"; ">"; "man/lambda-term-actions.1.gz" ])) ]; cmd_clean = [ (OASISExpr.EBool true, Some (("$rm", ["man/lambda-term-actions.1.gz"]))) ]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("lambda-term-inputrc-man", CustomPlugin.Doc.distclean { CustomPlugin.cmd_main = [ (OASISExpr.EBool true, ("$gzip", [ "-c"; "man/lambda-term-inputrc.5"; ">"; "man/lambda-term-inputrc.5.gz" ])) ]; cmd_clean = [ (OASISExpr.EBool true, Some (("$rm", ["man/lambda-term-inputrc.5.gz"]))) ]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("lamda-term-inputrc", CustomPlugin.Doc.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("true", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }); ("lambda-termrc", 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 "3.12"); findlib_version = None; alpha_features = []; beta_features = []; name = "lambda-term"; version = "1.9"; 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 "http://lambda-term.forge.ocamlcore.org/"; synopsis = "Terminal manipulation library for OCaml"; description = Some [ OASISText.Para "Lambda-term is a cross-platform library for manipulating the terminal. It provides an abstraction for keys, mouse events, colors, as well as a set of widgets to write curses-like applications."; OASISText.Para "The main objective of lambda-term is to provide a higher level functional interface to terminal manipulation than, for example, ncurses, by providing a native OCaml interface instead of bindings to a C library."; OASISText.Para "Lambda-term integrates with zed to provide text edition facilities in console applications." ]; 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/lTerm_config.h.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)] }); Library ({ cs_name = "lambda-term"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("lwt", Some (OASISVersion.VGreaterEqual "2.4.0")); FindlibPackage ("lwt.unix", None); FindlibPackage ("lwt.react", None); FindlibPackage ("zed", Some (OASISVersion.VGreaterEqual "1.2")) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = [ "lTerm_config.h"; "lTerm_term_stubs.c"; "lTerm_unix_stubs.c"; "lTerm_windows_stubs.c" ]; bs_data_files = []; bs_ccopt = [ (OASISExpr.EBool true, ["-I${pkg_lwt}"]); (OASISExpr.ETest ("system", "openbsd"), ["-I${pkg_lwt}"; "-I/usr/local/include"]) ]; bs_cclib = [ (OASISExpr.EBool true, []); (OASISExpr.ETest ("system", "openbsd"), ["-L/usr/local/lib"; "-lcharset"]) ]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = [ "LTerm"; "LTerm_key"; "LTerm_event"; "LTerm_unix"; "LTerm_windows"; "LTerm_style"; "LTerm_geom"; "LTerm_draw"; "LTerm_mouse"; "LTerm_widget"; "LTerm_widget_callbacks"; "LTerm_edit"; "LTerm_read_line"; "LTerm_text"; "LTerm_ui"; "LTerm_resources"; "LTerm_inputrc"; "LTerm_history" ]; lib_pack = false; lib_internal_modules = [ "LTerm_color_mappings"; "LTerm_resource_lexer"; "widget_impl/LTerm_widget_base_impl"; "widget_impl/LTerm_buttons_impl"; "widget_impl/LTerm_containers_impl"; "widget_impl/LTerm_running_impl"; "widget_impl/LTerm_toplevel_impl" ]; lib_findlib_parent = None; lib_findlib_name = Some "lambda-term"; lib_findlib_containers = [] }); Executable ({ cs_name = "events"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "camlp4", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "lambda-term"; FindlibPackage ("lwt.syntax", 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, [])] }, {exec_custom = false; exec_main_is = "events.ml"}); Executable ({ cs_name = "colors"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "camlp4", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "lambda-term"; FindlibPackage ("lwt.syntax", 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, [])] }, {exec_custom = false; exec_main_is = "colors.ml"}); Executable ({ cs_name = "colors_256"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "camlp4", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "lambda-term"; FindlibPackage ("lwt.syntax", 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, [])] }, {exec_custom = false; exec_main_is = "colors_256.ml"}); Executable ({ cs_name = "rgb"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "camlp4", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "lambda-term"; FindlibPackage ("lwt.syntax", 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, [])] }, {exec_custom = false; exec_main_is = "rgb.ml"}); Executable ({ cs_name = "move"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "camlp4", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "lambda-term"; FindlibPackage ("lwt.syntax", 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, [])] }, {exec_custom = false; exec_main_is = "move.ml"}); Executable ({ cs_name = "hello"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "camlp4", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "lambda-term"; FindlibPackage ("lwt.syntax", 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, [])] }, {exec_custom = false; exec_main_is = "hello.ml"}); Executable ({ cs_name = "clock"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "camlp4", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "lambda-term"; FindlibPackage ("lwt.syntax", 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, [])] }, {exec_custom = false; exec_main_is = "clock.ml"}); Executable ({ cs_name = "buttons"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "camlp4", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "lambda-term"; FindlibPackage ("lwt.syntax", 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, [])] }, {exec_custom = false; exec_main_is = "buttons.ml"}); Executable ({ cs_name = "checkbuttons"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "camlp4", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "lambda-term"; FindlibPackage ("lwt.syntax", 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, [])] }, {exec_custom = false; exec_main_is = "checkbuttons.ml"}); Executable ({ cs_name = "radiobuttons"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "camlp4", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "lambda-term"; FindlibPackage ("lwt.syntax", 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, [])] }, {exec_custom = false; exec_main_is = "radiobuttons.ml"}); Executable ({ cs_name = "shell"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "camlp4", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "lambda-term"; FindlibPackage ("lwt.syntax", None); FindlibPackage ("str", 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, [])] }, {exec_custom = false; exec_main_is = "shell.ml"}); Executable ({ cs_name = "repl"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "camlp4", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "lambda-term"; FindlibPackage ("lwt.syntax", 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, [])] }, {exec_custom = false; exec_main_is = "repl.ml"}); Executable ({ cs_name = "modal"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "camlp4", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "lambda-term"; FindlibPackage ("lwt.syntax", 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, [])] }, {exec_custom = false; exec_main_is = "modal.ml"}); Executable ({ cs_name = "read-password"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "camlp4", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "lambda-term"; FindlibPackage ("lwt.syntax", 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, [])] }, {exec_custom = false; exec_main_is = "read_password.ml"}); Executable ({ cs_name = "read-yes-no"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "camlp4", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "lambda-term"; FindlibPackage ("lwt.syntax", 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, [])] }, {exec_custom = false; exec_main_is = "read_yes_no.ml"}); Executable ({ cs_name = "editor"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "camlp4", true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "lambda-term"; FindlibPackage ("lwt.syntax", 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, [])] }, {exec_custom = false; exec_main_is = "editor.ml"}); Executable ({ cs_name = "lambda-term-actions"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "tools"; bs_compiled_object = Best; bs_build_depends = [InternalLibrary "lambda-term"]; 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, [])] }, { exec_custom = false; exec_main_is = "lambda_term_actions.ml" }); Executable ({ cs_name = "history-stress-test"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "tests"; bs_compiled_object = Best; bs_build_depends = [InternalLibrary "lambda-term"]; 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, [])] }, { exec_custom = false; exec_main_is = "history_stress_test.ml" }); Doc ({ cs_name = "lambda-term-api"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { doc_type = (`Doc, "ocamlbuild", Some "0.4"); 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 Lambda-Term"; doc_authors = []; doc_abstract = None; doc_format = OtherDoc; doc_data_files = [("style.css", None)]; doc_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] }); Doc ({ cs_name = "lambda-term-actions-man"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { doc_type = (`Doc, "custom", Some "0.4"); 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 lambda-term-actions"; doc_authors = []; doc_abstract = None; doc_format = OtherDoc; doc_data_files = [("man/lambda-term-actions.1.gz", None)]; doc_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "gzip"] }); Doc ({ cs_name = "lambda-term-inputrc-man"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { doc_type = (`Doc, "custom", Some "0.4"); 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 ~/.lambda-term-inputrc"; doc_authors = []; doc_abstract = None; doc_format = OtherDoc; doc_data_files = [("man/lambda-term-inputrc.5.gz", None)]; doc_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "gzip"] }); Doc ({ cs_name = "lamda-term-inputrc"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { doc_type = (`Doc, "custom", Some "0.4"); 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 = "lambda-term-inputrc example"; doc_authors = []; doc_abstract = None; doc_format = OtherDoc; doc_data_files = [("lambda-term-inputrc", None)]; doc_build_tools = [ExternalTool "ocamlbuild"] }); Doc ({ cs_name = "lambda-termrc"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { doc_type = (`Doc, "custom", Some "0.4"); 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 = "lambda-term resource file example"; doc_authors = []; doc_abstract = None; doc_format = OtherDoc; doc_data_files = [("lambda-termrc", 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/lambda-term.git"; src_repo_browser = Some "https://github.com/diml/lambda-term"; src_repo_module = None; src_repo_branch = None; src_repo_tag = None; src_repo_subdir = None }) ]; plugins = [(`Extra, "DevFiles", Some "0.4"); (`Extra, "META", Some "0.4")]; disable_oasis_section = []; schema_data = PropList.Data.create (); plugin_data = [] }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; oasis_digest = Some "\253\202\217?\027\002\207c\177\201\n\025!\208\192\242"; oasis_exec = None; oasis_setup_args = []; setup_update = false };; let setup () = BaseSetup.setup setup_t;; # 7891 "setup.ml" (* OASIS_STOP *) let () = setup ();; lambda-term-1.9/src/000077500000000000000000000000001254222632000143355ustar00rootroot00000000000000lambda-term-1.9/src/META000066400000000000000000000006121254222632000150050ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: b5399031c9bab5c1e919a2231f734f11) version = "1.9" description = "Cross-platform library for terminal manipulation" requires = "lwt lwt.unix lwt.react zed" archive(byte) = "lambda-term.cma" archive(byte, plugin) = "lambda-term.cma" archive(native) = "lambda-term.cmxa" archive(native, plugin) = "lambda-term.cmxs" exists_if = "lambda-term.cma" # OASIS_STOP lambda-term-1.9/src/gen_color_mappings.ml000066400000000000000000000233421254222632000205400ustar00rootroot00000000000000(* * gen_color_mappings.ml * --------------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (* This program generates the contents of the file lTerm_color_mappings.ml which contains tables used to convert RGB colors to indexes. *) (* +-----------------------------------------------------------------+ | Mapping generation | +-----------------------------------------------------------------+ *) type map = { count_r : int; count_g : int; count_b : int; index_r : string; index_g : string; index_b : string; map : string; } module Int_set = Set.Make(struct type t = int let compare x y = x - y end) let reindex set = let indexes = String.make 256 '\x00' in let rec loop idx prev = function | [] -> for i = prev to 255 do indexes.[i] <- char_of_int idx done; indexes | next :: rest -> let middle = (prev + next) / 2 in for i = prev to middle do indexes.[i] <- char_of_int idx done; let idx = idx + 1 in for i = middle + 1 to next - 1 do indexes.[i] <- char_of_int idx done; loop idx next rest in match Int_set.elements set with | [] -> assert false | n :: rest -> loop 0 n rest let pi = 4. *. atan 1. let hsv_of_rgb (r, g, b) = let r = float r /. 255. and g = float g /. 255. and b = float b /. 255. in let min = min r (min g b) and max = max r (max g b) in let h = if min = max then 0. else if max = r then mod_float (60. *. (g -. b) /. (max -. min) +. 360.) 360. else if max = g then 60. *. (b -. r) /. (max -. min) +. 120. else 60. *. (r -. g) /. (max -. min) +. 240. and s = if max = 0. then 0. else 1. -. min /. max and v = max in (h *. pi /. 180., s, v) let sqr x = x *. x let dist color1 color2 = let (h1, s1, v1) = hsv_of_rgb color1 and (h2, s2, v2) = hsv_of_rgb color2 in let x1 = s1 *. cos h1 and y1 = s1 *. sin h1 and z1 = v1 in let x2 = s2 *. cos h2 and y2 = s2 *. sin h2 and z2 = v2 in sqr (x1 -. x2) +. sqr (y1 -. y2) +. sqr (z1 -. z2) let make_map start colors = let rec loop idx acc = function | [] -> acc | n :: rest -> loop (idx + 1) ((idx, ((n lsr 16) land 0xff, (n lsr 8) land 0xff, n land 0xff)) :: acc) rest in let colors = loop start [] colors in let set_r, set_g, set_b = List.fold_left (fun (set_r, set_g, set_b) (idx, (r, g, b)) -> (Int_set.add r set_r, Int_set.add g set_g, Int_set.add b set_b)) (Int_set.empty, Int_set.empty, Int_set.empty) colors in let count_r = Int_set.cardinal set_r and count_g = Int_set.cardinal set_g and count_b = Int_set.cardinal set_b and index_r = reindex set_r and index_g = reindex set_g and index_b = reindex set_b and value_r = Array.of_list (Int_set.elements set_r) and value_g = Array.of_list (Int_set.elements set_g) and value_b = Array.of_list (Int_set.elements set_b) in let map = String.make (count_r * count_g * count_b) '\x00' in for ir = 0 to count_r - 1 do for ig = 0 to count_g - 1 do for ib = 0 to count_b - 1 do let color = (value_r.(ir), value_g.(ig), value_b.(ib)) in let rec loop min idx_of_min = function | [] -> idx_of_min | (idx, color') :: rest -> let d = dist color color' in if d < min then loop d idx rest else loop min idx_of_min rest in map.[ir + count_r * (ig + count_g * ib)] <- char_of_int (loop max_float 0 colors) done done done; { count_r; count_g; count_b; index_r; index_g; index_b; map } (* +-----------------------------------------------------------------+ | Color tables | +-----------------------------------------------------------------+ *) let colors_16 = make_map 0 [ 0x000000; 0xcd0000; 0x00cd00; 0xcdcd00; 0x0000ee; 0xcd00cd; 0x00cdcd; 0xe5e5e5; 0x7f7f7f; 0xff0000; 0x00ff00; 0xffff00; 0x5c5cff; 0xff00ff; 0x00ffff; 0xffffff; ] let colors_88 = make_map 16 [ 0x000000; 0x00008b; 0x0000cd; 0x0000ff; 0x008b00; 0x008b8b; 0x008bcd; 0x008bff; 0x00cd00; 0x00cd8b; 0x00cdcd; 0x00cdff; 0x00ff00; 0x00ff8b; 0x00ffcd; 0x00ffff; 0x8b0000; 0x8b008b; 0x8b00cd; 0x8b00ff; 0x8b8b00; 0x8b8b8b; 0x8b8bcd; 0x8b8bff; 0x8bcd00; 0x8bcd8b; 0x8bcdcd; 0x8bcdff; 0x8bff00; 0x8bff8b; 0x8bffcd; 0x8bffff; 0xcd0000; 0xcd008b; 0xcd00cd; 0xcd00ff; 0xcd8b00; 0xcd8b8b; 0xcd8bcd; 0xcd8bff; 0xcdcd00; 0xcdcd8b; 0xcdcdcd; 0xcdcdff; 0xcdff00; 0xcdff8b; 0xcdffcd; 0xcdffff; 0xff0000; 0xff008b; 0xff00cd; 0xff00ff; 0xff8b00; 0xff8b8b; 0xff8bcd; 0xff8bff; 0xffcd00; 0xffcd8b; 0xffcdcd; 0xffcdff; 0xffff00; 0xffff8b; 0xffffcd; 0xffffff; 0x2e2e2e; 0x5c5c5c; 0x737373; 0x8b8b8b; 0xa2a2a2; 0xb9b9b9; 0xd0d0d0; 0xe7e7e7; ] let colors_256 = make_map 16 [ 0x000000; 0x00005f; 0x000087; 0x0000af; 0x0000d7; 0x0000ff; 0x005f00; 0x005f5f; 0x005f87; 0x005faf; 0x005fd7; 0x005fff; 0x008700; 0x00875f; 0x008787; 0x0087af; 0x0087d7; 0x0087ff; 0x00af00; 0x00af5f; 0x00af87; 0x00afaf; 0x00afd7; 0x00afff; 0x00d700; 0x00d75f; 0x00d787; 0x00d7af; 0x00d7d7; 0x00d7ff; 0x00ff00; 0x00ff5f; 0x00ff87; 0x00ffaf; 0x00ffd7; 0x00ffff; 0x5f0000; 0x5f005f; 0x5f0087; 0x5f00af; 0x5f00d7; 0x5f00ff; 0x5f5f00; 0x5f5f5f; 0x5f5f87; 0x5f5faf; 0x5f5fd7; 0x5f5fff; 0x5f8700; 0x5f875f; 0x5f8787; 0x5f87af; 0x5f87d7; 0x5f87ff; 0x5faf00; 0x5faf5f; 0x5faf87; 0x5fafaf; 0x5fafd7; 0x5fafff; 0x5fd700; 0x5fd75f; 0x5fd787; 0x5fd7af; 0x5fd7d7; 0x5fd7ff; 0x5fff00; 0x5fff5f; 0x5fff87; 0x5fffaf; 0x5fffd7; 0x5fffff; 0x870000; 0x87005f; 0x870087; 0x8700af; 0x8700d7; 0x8700ff; 0x875f00; 0x875f5f; 0x875f87; 0x875faf; 0x875fd7; 0x875fff; 0x878700; 0x87875f; 0x878787; 0x8787af; 0x8787d7; 0x8787ff; 0x87af00; 0x87af5f; 0x87af87; 0x87afaf; 0x87afd7; 0x87afff; 0x87d700; 0x87d75f; 0x87d787; 0x87d7af; 0x87d7d7; 0x87d7ff; 0x87ff00; 0x87ff5f; 0x87ff87; 0x87ffaf; 0x87ffd7; 0x87ffff; 0xaf0000; 0xaf005f; 0xaf0087; 0xaf00af; 0xaf00d7; 0xaf00ff; 0xaf5f00; 0xaf5f5f; 0xaf5f87; 0xaf5faf; 0xaf5fd7; 0xaf5fff; 0xaf8700; 0xaf875f; 0xaf8787; 0xaf87af; 0xaf87d7; 0xaf87ff; 0xafaf00; 0xafaf5f; 0xafaf87; 0xafafaf; 0xafafd7; 0xafafff; 0xafd700; 0xafd75f; 0xafd787; 0xafd7af; 0xafd7d7; 0xafd7ff; 0xafff00; 0xafff5f; 0xafff87; 0xafffaf; 0xafffd7; 0xafffff; 0xd70000; 0xd7005f; 0xd70087; 0xd700af; 0xd700d7; 0xd700ff; 0xd75f00; 0xd75f5f; 0xd75f87; 0xd75faf; 0xd75fd7; 0xd75fff; 0xd78700; 0xd7875f; 0xd78787; 0xd787af; 0xd787d7; 0xd787ff; 0xd7af00; 0xd7af5f; 0xd7af87; 0xd7afaf; 0xd7afd7; 0xd7afff; 0xd7d700; 0xd7d75f; 0xd7d787; 0xd7d7af; 0xd7d7d7; 0xd7d7ff; 0xd7ff00; 0xd7ff5f; 0xd7ff87; 0xd7ffaf; 0xd7ffd7; 0xd7ffff; 0xff0000; 0xff005f; 0xff0087; 0xff00af; 0xff00d7; 0xff00ff; 0xff5f00; 0xff5f5f; 0xff5f87; 0xff5faf; 0xff5fd7; 0xff5fff; 0xff8700; 0xff875f; 0xff8787; 0xff87af; 0xff87d7; 0xff87ff; 0xffaf00; 0xffaf5f; 0xffaf87; 0xffafaf; 0xffafd7; 0xffafff; 0xffd700; 0xffd75f; 0xffd787; 0xffd7af; 0xffd7d7; 0xffd7ff; 0xffff00; 0xffff5f; 0xffff87; 0xffffaf; 0xffffd7; 0xffffff; 0x080808; 0x121212; 0x1c1c1c; 0x262626; 0x303030; 0x3a3a3a; 0x444444; 0x4e4e4e; 0x585858; 0x626262; 0x6c6c6c; 0x767676; 0x808080; 0x8a8a8a; 0x949494; 0x9e9e9e; 0xa8a8a8; 0xb2b2b2; 0xbcbcbc; 0xc6c6c6; 0xd0d0d0; 0xdadada; 0xe4e4e4; 0xeeeeee; ] (* +-----------------------------------------------------------------+ | Color generation | +-----------------------------------------------------------------+ *) let add_string str strings = let rec aux n strings = match strings with | [] -> let id = "data" ^ string_of_int n in (id, [(id, str)]) | (id, str') :: _ when str = str' -> (id, strings) | x :: strings -> let id, strings = aux (n + 1) strings in (id, x :: strings) in aux 0 strings let code_of_map map strings = let index_r, strings = add_string map.index_r strings in let index_g, strings = add_string map.index_g strings in let index_b, strings = add_string map.index_b strings in let mapping, strings = add_string map.map strings in let code = Printf.sprintf "{ count_r = %d; count_g = %d; count_b = %d; index_r = %s; index_g = %s; index_b = %s; map = %s; }" map.count_r map.count_g map.count_b index_r index_g index_b mapping in (code, strings) let print_string oc str = let rec aux i = if i = String.length str then () else begin if i > 0 then output_string oc "\\\n "; let len = min 16 (String.length str - i) in for i = i to i + len - 1 do Printf.fprintf oc "\\%03u" (Char.code str.[i]) done; aux (i + len) end in aux 0 let () = let oc = if Array.length Sys.argv < 2 then stdout else open_out Sys.argv.(1) in let strings = [] in let code16, strings = code_of_map colors_16 strings in let code88, strings = code_of_map colors_88 strings in let code256, strings = code_of_map colors_256 strings in output_string oc "(* * lTerm_color_mappings.ml * ----------------------- * Copyright : (c) 2012, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (* This file was generated by gen_color_mappings.ml. *) "; List.iter (fun (id, str) -> Printf.fprintf oc "let %s = \"%a\"\n" id print_string str) strings; Printf.fprintf oc " type map = { count_r : int; count_g : int; count_b : int; index_r : string; index_g : string; index_b : string; map : string; } let colors_16 = %s let colors_88 = %s let colors_256 = %s " code16 code88 code256 lambda-term-1.9/src/lTerm.ml000066400000000000000000001264251254222632000157640ustar00rootroot00000000000000(* * lTerm.ml * -------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) open CamomileLibraryDyn.Camomile open Lwt_react open LTerm_geom let return, (>>=) = Lwt.return, Lwt.(>>=) let uspace = UChar.of_char ' ' (* +-----------------------------------------------------------------+ | TTYs sizes | +-----------------------------------------------------------------+ *) external get_size_from_fd : Unix.file_descr -> size = "lt_term_get_size_from_fd" external set_size_from_fd : Unix.file_descr -> size -> unit = "lt_term_set_size_from_fd" let get_size_from_fd fd = Lwt_unix.check_descriptor fd; get_size_from_fd (Lwt_unix.unix_file_descr fd) let set_size_from_fd fd size = Lwt_unix.check_descriptor fd; set_size_from_fd (Lwt_unix.unix_file_descr fd) size (* +-----------------------------------------------------------------+ | The terminal type | +-----------------------------------------------------------------+ *) exception Not_a_tty let () = Printexc.register_printer (function | Not_a_tty -> Some "terminal is not a tty" | _ -> None) module Int_map = Map.Make(struct type t = int let compare a b = a - b end) type t = { model : string; colors : int; windows : bool; bold_is_bright : bool; color_map : LTerm_color_mappings.map; (* Informations. *) mutable raw_mode : bool; (* Whether the terminal is currently in raw mode. *) mutable incoming_fd : Lwt_unix.file_descr; mutable outgoing_fd : Lwt_unix.file_descr; (* File descriptors. *) mutable ic : Lwt_io.input_channel; mutable oc : Lwt_io.output_channel; (* Channels. *) mutable input_stream : char Lwt_stream.t; (* Stream of characters read from the terminal. *) mutable next_event : LTerm_event.t Lwt.t option; (* Thread reading the next event from the terminal. We cannot cancel the reading of an event, so we keep the last thread to reuse it in case the user cancels [read_event]. *) mutable read_event : bool; (* Whether a thread is currently reading an event. *) mutable last_reported_size : size; (* The last size reported by [read_event]. *) mutable size : size; (* The current size of the terminal. *) incoming_encoding : CharEncoding.t; outgoing_encoding : CharEncoding.t; (* Characters encodings. *) outgoing_is_utf8 : bool; (* Whether the outgoing encoding is UTF-8. *) notify : LTerm_event.t Lwt_condition.t; (* Condition used to send a spontaneous event. *) mutable event : unit event; (* Event which handles SIGWINCH. *) mutable incoming_is_a_tty : bool; mutable outgoing_is_a_tty : bool; (* Whether input/output are tty devices. *) mutable escape_time : float; (* Time to wait before returning the escape key. *) } (* +-----------------------------------------------------------------+ | Signals | +-----------------------------------------------------------------+ *) let resize_event, send_resize = E.create () let send_resize () = send_resize () let () = match LTerm_unix.sigwinch with | None -> (* Check for size when something happen. *) ignore (Lwt_sequence.add_r send_resize Lwt_main.enter_iter_hooks) | Some signum -> try ignore (Lwt_unix.on_signal signum (fun _ -> send_resize ())) with Not_found -> ignore (Lwt_sequence.add_r send_resize Lwt_main.enter_iter_hooks) (* +-----------------------------------------------------------------+ | Creation | +-----------------------------------------------------------------+ *) let default_model, term_defined = try (Sys.getenv "TERM", true) with Not_found -> ("dumb", false) let colors_of_term = function | "Eterm-256color" -> 256 | "Eterm-88color" -> 88 | "gnome-256color" -> 256 | "iTerm.app" -> 256 | "konsole-256color" -> 256 | "mlterm-256color" -> 256 | "mrxvt-256color" -> 256 | "putty-256color" -> 256 | "rxvt-256color" -> 256 | "rxvt-88color" -> 88 | "rxvt-unicode-256color" -> 256 | "rxvt-unicode" -> 88 | "screen-256color" -> 256 | "screen-256color-bce" -> 256 | "screen-256color-bce-s" -> 256 | "screen-256color-s" -> 256 | "st-256color" -> 256 | "vte-256color" -> 256 | "xterm-256color" -> 256 | "xterm+256color" -> 256 | "xterm-88color" -> 88 | "xterm+88color" -> 88 | _ -> 16 exception No_such_encoding of string let char_encoding_of_name name = try CharEncoding.of_name name with Not_found -> raise (No_such_encoding name) (* UTF-8 on windows. *) let () = CharEncoding.alias "CP65001" "UTF-8" let empty_stream = Lwt_stream.from (fun () -> return None) let create ?(windows=Sys.win32) ?(model=default_model) ?incoming_encoding ?outgoing_encoding incoming_fd incoming_channel outgoing_fd outgoing_channel = Lwt.catch (fun () -> (* Colors stuff. *) let colors = if windows then 16 else colors_of_term model in let bold_is_bright = match model with | "linux" (* The linux frame buffer *) | "xterm-color" (* The MacOS-X terminal *) -> true | _ -> false in let color_map = match colors with | 16 -> LTerm_color_mappings.colors_16 | 88 -> LTerm_color_mappings.colors_88 | 256 -> LTerm_color_mappings.colors_256 | n -> Printf.ksprintf failwith "LTerm.create: unknown number of colors (%d)" n in (* Encodings. *) let incoming_encoding = char_encoding_of_name (match incoming_encoding with | Some name -> name | None -> if windows then Printf.sprintf "CP%d" (LTerm_windows.get_console_cp ()) else LTerm_unix.system_encoding) and outgoing_encoding = char_encoding_of_name (match outgoing_encoding with | Some name -> name | None -> if windows then Printf.sprintf "CP%d" (LTerm_windows.get_console_output_cp ()) else LTerm_unix.system_encoding) in (* Check if fds are ttys. *) Lwt_unix.isatty incoming_fd >>= fun incoming_is_a_tty -> Lwt_unix.isatty outgoing_fd >>= fun outgoing_is_a_tty -> (* Create the terminal. *) let term = { model; colors; windows; bold_is_bright; color_map; raw_mode = false; incoming_fd; outgoing_fd; ic = incoming_channel; oc = outgoing_channel; input_stream = empty_stream; next_event = None; read_event = false; incoming_encoding; outgoing_encoding; outgoing_is_utf8 = CharEncoding.name_of outgoing_encoding = "UTF-8"; notify = Lwt_condition.create (); event = E.never; incoming_is_a_tty; outgoing_is_a_tty; escape_time = 0.1; size = { rows = 0; cols = 0 }; last_reported_size = { rows = 0; cols = 0 }; } in term.input_stream <- Lwt_stream.from (fun () -> Lwt_io.read_char_opt term.ic); (* Setup initial size and size updater. *) if term.outgoing_is_a_tty then begin let check_size () = let size = get_size_from_fd term.outgoing_fd in if size <> term.size then begin term.size <- size; Lwt_condition.signal term.notify (LTerm_event.Resize size) end in term.size <- get_size_from_fd term.outgoing_fd; term.last_reported_size <- term.size; term.event <- E.map check_size resize_event end; return term) Lwt.fail let set_io ?incoming_fd ?incoming_channel ?outgoing_fd ?outgoing_channel term = let get opt x = match opt with | Some x -> x | None -> x in let incoming_fd = get incoming_fd term.incoming_fd and outgoing_fd = get outgoing_fd term.outgoing_fd and incoming_channel = get incoming_channel term.ic and outgoing_channel = get outgoing_channel term.oc in (* Check if fds are ttys. *) Lwt_unix.isatty incoming_fd >>= fun incoming_is_a_tty -> Lwt_unix.isatty outgoing_fd >>= fun outgoing_is_a_tty -> (* Apply changes. *) term.incoming_fd <- incoming_fd; term.outgoing_fd <- outgoing_fd; term.ic <- incoming_channel; term.oc <- outgoing_channel; term.incoming_is_a_tty <- incoming_is_a_tty; term.outgoing_is_a_tty <- outgoing_is_a_tty; return () let model t = t.model let colors t = t.colors let windows t = t.windows let is_a_tty t = t.incoming_is_a_tty && t.outgoing_is_a_tty let incoming_is_a_tty t = t.incoming_is_a_tty let outgoing_is_a_tty t = t.outgoing_is_a_tty let escape_time t = t.escape_time let set_escape_time t time = t.escape_time <- time let size term = if term.outgoing_is_a_tty then begin let size = get_size_from_fd term.outgoing_fd in if size <> term.size then begin term.size <- size; Lwt_condition.signal term.notify (LTerm_event.Resize size) end; size end else raise Not_a_tty let get_size term = Lwt.catch (fun () -> return (size term)) Lwt.fail let set_size term size = Lwt.fail (Failure "LTerm.set_size is deprecated") (* +-----------------------------------------------------------------+ | Events | +-----------------------------------------------------------------+ *) class output_single (cell : UChar.t option ref) = object method put char = cell := Some char method flush () = () method close_out () = () end let read_char term = begin Lwt_stream.get term.input_stream >>= fun byte_opt -> match byte_opt with | Some byte -> return byte | None -> Lwt.fail End_of_file end >>= fun first_byte -> let cell = ref None in let output = new CharEncoding.convert_uchar_output term.incoming_encoding (new output_single cell) in let rec loop st = match !cell with | Some char -> return char | None -> Lwt_stream.next st >>= fun byte -> assert (output#output (String.make 1 byte) 0 1 = 1); output#flush (); loop st in Lwt.catch (fun () -> assert (output#output (String.make 1 first_byte) 0 1 = 1); Lwt_stream.parse term.input_stream loop) (function | CharEncoding.Malformed_code | Lwt_stream.Empty -> return (UChar.of_char first_byte) | exn -> Lwt.fail exn) >>= fun char -> return (LTerm_event.Key { LTerm_key.control = false; LTerm_key.meta = false; LTerm_key.shift = false; LTerm_key.code = LTerm_key.Char char; }) let rec next_event term = if term.windows then LTerm_windows.read_console_input term.incoming_fd >>= fun input -> match input with | LTerm_windows.Resize -> if term.outgoing_is_a_tty then let size = get_size_from_fd term.outgoing_fd in if size <> term.size then begin term.size <- size; return (LTerm_event.Resize size) end else next_event term else next_event term | LTerm_windows.Key key -> return (LTerm_event.Key key) | LTerm_windows.Mouse mouse -> let window = (LTerm_windows.get_console_screen_buffer_info term.outgoing_fd).LTerm_windows.window in return (LTerm_event.Mouse { mouse with LTerm_mouse.row = mouse.LTerm_mouse.row - window.row1; LTerm_mouse.col = mouse.LTerm_mouse.col - window.col1; }) else LTerm_unix.parse_event ~escape_time:term.escape_time term.incoming_encoding term.input_stream let wrap_next_event next_event term = match term.next_event with | Some thread -> thread | None -> (* Create a non-cancelable thread. *) let waiter, wakener = Lwt.wait () in term.next_event <- Some waiter; (* Connect the [next_event term] thread to [waiter]. *) ignore (Lwt.try_bind (fun () -> next_event term) (fun v -> term.next_event <- None; Lwt.wakeup wakener v; return ()) (fun e -> term.next_event <- None; Lwt.wakeup_exn wakener e; return ())); waiter let read_event term = if term.read_event then Lwt.fail (Failure "LTerm.read_event: cannot read events from two thread at the same time") else if term.size <> term.last_reported_size then begin term.last_reported_size <- term.size; return (LTerm_event.Resize term.last_reported_size) end else begin term.read_event <- true; Lwt.finalize (fun () -> if term.incoming_is_a_tty then Lwt.pick [wrap_next_event next_event term; Lwt_condition.wait term.notify] >>= fun ev -> match ev with | LTerm_event.Resize size -> term.last_reported_size <- size; return (LTerm_event.Resize size) | ev -> return ev else wrap_next_event read_char term) (fun () -> term.read_event <- false; return ()) end (* +-----------------------------------------------------------------+ | Modes | +-----------------------------------------------------------------+ *) type mode = | Mode_fake | Mode_unix of Unix.terminal_io | Mode_windows of LTerm_windows.console_mode let enter_raw_mode term = if term.incoming_is_a_tty then if term.raw_mode then return Mode_fake else if term.windows then begin let mode = LTerm_windows.get_console_mode term.incoming_fd in LTerm_windows.set_console_mode term.incoming_fd { mode with LTerm_windows.cm_echo_input = false; LTerm_windows.cm_line_input = false; LTerm_windows.cm_mouse_input = true; LTerm_windows.cm_processed_input = false; LTerm_windows.cm_window_input = true; }; term.raw_mode <- true; return (Mode_windows mode) end else begin Lwt_unix.tcgetattr term.incoming_fd >>= fun attr -> Lwt_unix.tcsetattr term.incoming_fd Unix.TCSAFLUSH { attr with (* Inspired from Python-3.0/Lib/tty.py: *) Unix.c_brkint = false; Unix.c_inpck = false; Unix.c_istrip = false; Unix.c_ixon = false; Unix.c_csize = 8; Unix.c_parenb = false; Unix.c_echo = false; Unix.c_icanon = false; Unix.c_vmin = 1; Unix.c_vtime = 0; Unix.c_isig = false; } >>= fun () -> term.raw_mode <- true; return (Mode_unix attr) end else Lwt.fail Not_a_tty let leave_raw_mode term mode = if term.incoming_is_a_tty then match mode with | Mode_fake -> return () | Mode_unix attr -> term.raw_mode <- false; Lwt_unix.tcsetattr term.incoming_fd Unix.TCSAFLUSH attr | Mode_windows mode -> term.raw_mode <- false; LTerm_windows.set_console_mode term.incoming_fd mode; return () else Lwt.fail Not_a_tty let enable_mouse term = if term.outgoing_is_a_tty then if term.windows then return () else Lwt_io.write term.oc "\027[?1000h" else Lwt.fail Not_a_tty let disable_mouse term = if term.outgoing_is_a_tty then if term.windows then return () else Lwt_io.write term.oc "\027[?1000l" else Lwt.fail Not_a_tty (* +-----------------------------------------------------------------+ | Cursor | +-----------------------------------------------------------------+ *) let show_cursor term = if term.outgoing_is_a_tty then if term.windows then begin let size, _ = LTerm_windows.get_console_cursor_info term.outgoing_fd in LTerm_windows.set_console_cursor_info term.outgoing_fd size true; return () end else Lwt_io.write term.oc "\027[?25h" else Lwt.fail Not_a_tty let hide_cursor term = if term.outgoing_is_a_tty then if term.windows then begin let size, _ = LTerm_windows.get_console_cursor_info term.outgoing_fd in LTerm_windows.set_console_cursor_info term.outgoing_fd size false; return () end else Lwt_io.write term.oc "\027[?25l" else Lwt.fail Not_a_tty let goto term coord = if term.outgoing_is_a_tty then if term.windows then begin Lwt_io.flush term.oc >>= fun () -> let window = (LTerm_windows.get_console_screen_buffer_info term.outgoing_fd).LTerm_windows.window in LTerm_windows.set_console_cursor_position term.outgoing_fd { row = window.row1 + coord.row; col = window.col1 + coord.col; }; return () end else begin Lwt_io.fprint term.oc "\027[H" >>= fun () -> (if coord.row > 0 then Lwt_io.fprintf term.oc "\027[%dB" coord.row else return ()) >>= fun () -> (if coord.col > 0 then Lwt_io.fprintf term.oc "\027[%dC" coord.col else return ()) >>= fun () -> return () end else Lwt.fail Not_a_tty let move term rows cols = if term.outgoing_is_a_tty then if term.windows then begin Lwt_io.flush term.oc >>= fun () -> let pos = (LTerm_windows.get_console_screen_buffer_info term.outgoing_fd).LTerm_windows.cursor_position in LTerm_windows.set_console_cursor_position term.outgoing_fd { row = pos.row + rows; col = pos.col + cols; }; return () end else begin match rows with | n when n < 0 -> Lwt_io.fprintf term.oc "\027[%dA" (-n) | n when n > 0 -> Lwt_io.fprintf term.oc "\027[%dB" n | _ -> return () end >>= fun () -> begin match cols with | n when n < 0 -> Lwt_io.fprintf term.oc "\027[%dD" (-n) | n when n > 0 -> Lwt_io.fprintf term.oc "\027[%dC" n | _ -> return () end else Lwt.fail Not_a_tty (* +-----------------------------------------------------------------+ | Erasing text | +-----------------------------------------------------------------+ *) let clear_screen term = if term.outgoing_is_a_tty then if term.windows then begin let info = LTerm_windows.get_console_screen_buffer_info term.outgoing_fd in let _ = LTerm_windows.fill_console_output_character term.outgoing_fd uspace (info.LTerm_windows.size.cols * info.LTerm_windows.size.rows) { row = 0; col = 0 } in return () end else Lwt_io.write term.oc "\027[2J" else Lwt.fail Not_a_tty let clear_screen_next term = if term.outgoing_is_a_tty then if term.windows then begin let info = LTerm_windows.get_console_screen_buffer_info term.outgoing_fd in let _ = LTerm_windows.fill_console_output_character term.outgoing_fd uspace (info.LTerm_windows.size.cols * (info.LTerm_windows.size.rows - info.LTerm_windows.cursor_position.row) + info.LTerm_windows.size.cols - info.LTerm_windows.cursor_position.col) info.LTerm_windows.cursor_position in return () end else Lwt_io.write term.oc "\027[J" else Lwt.fail Not_a_tty let clear_screen_prev term = if term.outgoing_is_a_tty then if term.windows then begin let info = LTerm_windows.get_console_screen_buffer_info term.outgoing_fd in let _ = LTerm_windows.fill_console_output_character term.outgoing_fd uspace (info.LTerm_windows.size.cols * info.LTerm_windows.cursor_position.row + info.LTerm_windows.cursor_position.col) { row = 0; col = 0 } in return () end else Lwt_io.write term.oc "\027[1J" else Lwt.fail Not_a_tty let clear_line term = if term.outgoing_is_a_tty then if term.windows then begin let info = LTerm_windows.get_console_screen_buffer_info term.outgoing_fd in let _ = LTerm_windows.fill_console_output_character term.outgoing_fd uspace info.LTerm_windows.size.cols { row = info.LTerm_windows.cursor_position.row; col = 0 } in return () end else Lwt_io.write term.oc "\027[2K" else Lwt.fail Not_a_tty let clear_line_next term = if term.outgoing_is_a_tty then if term.windows then begin let info = LTerm_windows.get_console_screen_buffer_info term.outgoing_fd in let _ = LTerm_windows.fill_console_output_character term.outgoing_fd uspace (info.LTerm_windows.size.cols - info.LTerm_windows.cursor_position.col) info.LTerm_windows.cursor_position in return () end else Lwt_io.write term.oc "\027[K" else Lwt.fail Not_a_tty let clear_line_prev term = if term.outgoing_is_a_tty then if term.windows then begin let info = LTerm_windows.get_console_screen_buffer_info term.outgoing_fd in let _ = LTerm_windows.fill_console_output_character term.outgoing_fd uspace info.LTerm_windows.cursor_position.col { row = info.LTerm_windows.cursor_position.row; col = 0 } in return () end else Lwt_io.write term.oc "\027[1K" else Lwt.fail Not_a_tty (* +-----------------------------------------------------------------+ | State | +-----------------------------------------------------------------+ *) let save_state term = if term.outgoing_is_a_tty then if term.windows then return () else Lwt_io.write term.oc "\027[?1049h" else Lwt.fail Not_a_tty let load_state term = if term.outgoing_is_a_tty then if term.windows then return () else Lwt_io.write term.oc "\027[?1049l" else Lwt.fail Not_a_tty (* +-----------------------------------------------------------------+ | String recoding | +-----------------------------------------------------------------+ *) let vline = UChar.of_char '|' let vlline = UChar.of_char '+' let dlcorner = UChar.of_char '+' let urcorner = UChar.of_char '+' let huline = UChar.of_char '+' let hdline = UChar.of_char '+' let vrline = UChar.of_char '+' let hline = UChar.of_char '-' let cross = UChar.of_char '+' let ulcorner = UChar.of_char '+' let drcorner = UChar.of_char '+' let question = UChar.of_char '?' module UNF = UNF.Make (UText) (* Map characters that cannot be encoded to ASCII ones. *) let map_char char = match UChar.code char with | 0x2500 -> hline | 0x2501 -> hline | 0x2502 -> vline | 0x2503 -> vline | 0x2504 -> hline | 0x2505 -> hline | 0x2506 -> vline | 0x2507 -> vline | 0x2508 -> hline | 0x2509 -> hline | 0x250a -> vline | 0x250b -> vline | 0x250c -> drcorner | 0x250d -> drcorner | 0x250e -> drcorner | 0x250f -> drcorner | 0x2510 -> dlcorner | 0x2511 -> dlcorner | 0x2512 -> dlcorner | 0x2513 -> dlcorner | 0x2514 -> urcorner | 0x2515 -> urcorner | 0x2516 -> urcorner | 0x2517 -> urcorner | 0x2518 -> ulcorner | 0x2519 -> ulcorner | 0x251a -> ulcorner | 0x251b -> ulcorner | 0x251c -> vrline | 0x251d -> vrline | 0x251e -> vrline | 0x251f -> vrline | 0x2520 -> vrline | 0x2521 -> vrline | 0x2522 -> vrline | 0x2523 -> vrline | 0x2524 -> vlline | 0x2525 -> vlline | 0x2526 -> vlline | 0x2527 -> vlline | 0x2528 -> vlline | 0x2529 -> vlline | 0x252a -> vlline | 0x252b -> vlline | 0x252c -> hdline | 0x252d -> hdline | 0x252e -> hdline | 0x252f -> hdline | 0x2530 -> hdline | 0x2531 -> hdline | 0x2532 -> hdline | 0x2533 -> hdline | 0x2534 -> huline | 0x2535 -> huline | 0x2536 -> huline | 0x2537 -> huline | 0x2538 -> huline | 0x2539 -> huline | 0x253a -> huline | 0x253b -> huline | 0x253c -> cross | 0x253d -> cross | 0x253e -> cross | 0x253f -> cross | 0x2540 -> cross | 0x2541 -> cross | 0x2542 -> cross | 0x2543 -> cross | 0x2544 -> cross | 0x2545 -> cross | 0x2546 -> cross | 0x2547 -> cross | 0x2548 -> cross | 0x2549 -> cross | 0x254a -> cross | 0x254b -> cross | 0x254c -> hline | 0x254d -> hline | 0x254e -> vline | 0x254f -> vline | 0x2550 -> hline | 0x2551 -> vline | _ -> match UNF.nfd_decompose char with | char :: _ -> if UChar.code char <= 127 then char else question | [] -> question class output_to_buffer buf res = object method output str ofs len = Buffer.add_substring buf str ofs len; len method flush () = () method close_out () = res := Buffer.contents buf end let encode_string term str = if term.outgoing_is_utf8 then (* Do not recode [str] if the output is UTF-8. *) str else let buf = Buffer.create (String.length str) in let res = ref "" in let output = new CharEncoding.uchar_output_channel_of term.outgoing_encoding (new output_to_buffer buf res) in let rec loop ofs = if ofs = String.length str then begin output#close_out (); !res end else begin let ch, ofs = Zed_utf8.unsafe_extract_next str ofs in (try output#put ch with CharEncoding.Out_of_range | UChar.Out_of_range -> output#put (map_char ch)); loop ofs end in loop 0 let encode_char term ch = if term.outgoing_is_utf8 then Zed_utf8.singleton ch else begin let res = ref "" in let output = new CharEncoding.uchar_output_channel_of term.outgoing_encoding (new output_to_buffer (Buffer.create 8) res) in (try output#put ch with CharEncoding.Out_of_range | UChar.Out_of_range -> output#put (map_char ch)); output#close_out (); !res end (* +-----------------------------------------------------------------+ | Styled printing | +-----------------------------------------------------------------+ *) module Codes = struct let bold = ";1" let underline = ";4" let blink = ";5" let reverse = ";7" let foreground = 30 let background = 40 end let fprint term str = Lwt_io.fprint term.oc (encode_string term str) let fprintl term str = fprint term (str ^ "\n") let fprintf term fmt = Printf.ksprintf (fun str -> fprint term str) fmt let fprintlf term fmt = Printf.ksprintf (fun str -> fprintl term str) fmt let add_int buf n = let rec loop = function | 0 -> () | n -> loop (n / 10); Buffer.add_char buf (Char.unsafe_chr (48 + (n mod 10))) in if n = 0 then Buffer.add_char buf '0' else loop n let map_color term r g b = let open LTerm_color_mappings in let map = term.color_map in (* The [String.unsafe_get]s are safe because the private type [LTerm_style.color] ensure that all components are in the range [0..255]. *) Char.code (String.unsafe_get map.map (Char.code (String.unsafe_get map.index_r r) + map.count_r * (Char.code (String.unsafe_get map.index_g g) + map.count_g * Char.code (String.unsafe_get map.index_b b)))) let add_index term buf base n = if n < 8 then begin Buffer.add_char buf ';'; add_int buf (base + n) end else if n < 16 && term.bold_is_bright then if base = Codes.foreground then begin Buffer.add_string buf ";1;"; add_int buf (base + n - 8) end else begin Buffer.add_char buf ';'; add_int buf (base + n - 8) end else begin Buffer.add_char buf ';'; add_int buf (base + 8); Buffer.add_string buf ";5;"; add_int buf n end let add_color term buf base = function | LTerm_style.Default -> () | LTerm_style.Index n -> add_index term buf base n | LTerm_style.RGB(r, g, b) -> add_index term buf base (map_color term r g b) let add_style term buf style = let open LTerm_style in Buffer.add_string buf "\027[0"; (match style.bold with Some true -> Buffer.add_string buf Codes.bold | _ -> ()); (match style.underline with Some true -> Buffer.add_string buf Codes.underline | _ -> ()); (match style.blink with Some true -> Buffer.add_string buf Codes.blink | _ -> ()); (match style.reverse with Some true -> Buffer.add_string buf Codes.reverse | _ -> ()); (match style.foreground with Some color -> add_color term buf Codes.foreground color | None -> ()); (match style.background with Some color -> add_color term buf Codes.background color | None -> ()); Buffer.add_char buf 'm' let expand term text = if Array.length text = 0 then "" else begin let buf = Buffer.create 256 in Buffer.add_string buf "\027[0m"; let rec loop idx prev_style = if idx = Array.length text then begin Buffer.add_string buf "\027[0m"; Buffer.contents buf end else begin let ch, style = Array.unsafe_get text idx in if not (LTerm_style.equal style prev_style) then add_style term buf style; Buffer.add_string buf (Zed_utf8.singleton ch); loop (idx + 1) style end in loop 0 LTerm_style.none end let windows_fg_color term = function | LTerm_style.Default -> 7 | LTerm_style.Index n -> n | LTerm_style.RGB(r, g, b) -> map_color term r g b let windows_bg_color term = function | LTerm_style.Default -> 0 | LTerm_style.Index n -> n | LTerm_style.RGB(r, g, b) -> map_color term r g b let windows_default_attributes = { LTerm_windows.foreground = 7; LTerm_windows.background = 0 } let windows_attributes_of_style term style = let open LTerm_style in if style.reverse = Some true then { LTerm_windows.foreground = (match style.background with Some color -> windows_bg_color term color | None -> 0); LTerm_windows.background = (match style.foreground with Some color -> windows_fg_color term color | None -> 7); } else { LTerm_windows.foreground = (match style.foreground with Some color -> windows_fg_color term color | None -> 7); LTerm_windows.background = (match style.background with Some color -> windows_bg_color term color | None -> 0); } let fprints_windows term oc text = let rec loop idx prev_attr = if idx = Array.length text then begin Lwt_io.flush oc >>= fun () -> LTerm_windows.set_console_text_attribute term.outgoing_fd windows_default_attributes; return () end else begin let ch, style = Array.unsafe_get text idx in let attr = windows_attributes_of_style term style in begin if attr <> prev_attr then Lwt_io.flush oc >>= fun () -> LTerm_windows.set_console_text_attribute term.outgoing_fd attr; return () else return () end >>= fun () -> Lwt_io.write oc (encode_char term ch) >>= fun () -> loop (idx + 1) attr end in Lwt_io.flush oc >>= fun () -> LTerm_windows.set_console_text_attribute term.outgoing_fd windows_default_attributes; loop 0 windows_default_attributes let fprints term text = if term.outgoing_is_a_tty then if term.windows then Lwt_io.atomic (fun oc -> fprints_windows term oc text) term.oc else fprint term (expand term text) else fprint term (LTerm_text.to_string text) let fprintls term text = fprints term (Array.append text (LTerm_text.of_string "\n")) (* +-----------------------------------------------------------------+ | Printing with contexts | +-----------------------------------------------------------------+ *) type context = { ctx_term : t; ctx_oc : Lwt_io.output_channel; mutable ctx_style : LTerm_style.t; mutable ctx_attr : LTerm_windows.text_attributes; } let clear_styles term oc = if term.outgoing_is_a_tty then if term.windows then Lwt_io.flush oc >>= fun () -> LTerm_windows.set_console_text_attribute term.outgoing_fd windows_default_attributes; return () else Lwt_io.write oc "\027[0m" else return () let with_context term f = Lwt_io.atomic (fun oc -> let ctx = { ctx_term = term; ctx_oc = oc; ctx_style = LTerm_style.none; ctx_attr = windows_default_attributes; } in clear_styles term oc >>= fun () -> Lwt.finalize (fun () -> f ctx) (fun () -> clear_styles term oc)) term.oc let update_style ctx style = if ctx.ctx_term.outgoing_is_a_tty then begin if ctx.ctx_term.windows then begin let attr = windows_attributes_of_style ctx.ctx_term style in if attr <> ctx.ctx_attr then Lwt_io.flush ctx.ctx_oc >>= fun () -> LTerm_windows.set_console_text_attribute ctx.ctx_term.outgoing_fd attr; ctx.ctx_attr <- attr; return () else return () end else begin if not (LTerm_style.equal style ctx.ctx_style) then begin let buf = Buffer.create 16 in add_style ctx.ctx_term buf style; Lwt_io.write ctx.ctx_oc (Buffer.contents buf) >>= fun () -> ctx.ctx_style <- style; return () end else return () end end else return () let context_term ctx = ctx.ctx_term let context_oc ctx = ctx.ctx_oc (* +-----------------------------------------------------------------+ | Styles setting | +-----------------------------------------------------------------+ *) let set_style term style = if term.outgoing_is_a_tty then if term.windows then begin let attr = windows_attributes_of_style term style in Lwt_io.atomic (fun oc -> Lwt_io.flush oc >>= fun () -> LTerm_windows.set_console_text_attribute term.outgoing_fd attr; return ()) term.oc end else begin let buf = Buffer.create 16 in add_style term buf style; Lwt_io.fprint term.oc (Buffer.contents buf) end else return () (* +-----------------------------------------------------------------+ | Rendering | +-----------------------------------------------------------------+ *) let same_style p1 p2 = let open LTerm_draw in p1.bold = p2.bold && p1.underline = p2.underline && p1.blink = p2.blink && p1.reverse = p2.reverse && p1.foreground = p2.foreground && p1.background = p2.background let unknown_char = UChar.of_int 0xfffd let unknown_utf8 = Zed_utf8.singleton unknown_char let render_style term buf old_point new_point = let open LTerm_draw in if not (same_style new_point old_point) then begin (* Reset styles if they are different from the previous point. *) Buffer.add_string buf "\027[0"; if new_point.bold then Buffer.add_string buf Codes.bold; if new_point.underline then Buffer.add_string buf Codes.underline; if new_point.blink then Buffer.add_string buf Codes.blink; if new_point.reverse then Buffer.add_string buf Codes.reverse; add_color term buf Codes.foreground new_point.foreground; add_color term buf Codes.background new_point.background; Buffer.add_char buf 'm'; end let render_point term buf old_point new_point = render_style term buf old_point new_point; (* Skip control characters, otherwise output will be messy. *) if UChar.code new_point.LTerm_draw.char < 32 then Buffer.add_string buf unknown_utf8 else Buffer.add_string buf (Zed_utf8.singleton new_point.LTerm_draw.char) type render_kind = Render_screen | Render_box let render_update_unix term kind old_matrix matrix = let open LTerm_draw in let buf = Buffer.create 16 in Buffer.add_string buf (match kind with | Render_screen -> (* Go the the top-left and reset attributes *) "\027[H\027[0m" | Render_box -> (* Go the the beginnig of line and reset attributes *) "\r\027[0m"); (* The last displayed point. *) let last_point = ref { char = uspace; bold = false; underline = false; blink = false; reverse = false; foreground = LTerm_style.default; background = LTerm_style.default; } in let rows = Array.length matrix and old_rows = Array.length old_matrix in for y = 0 to rows - 1 do let line = Array.unsafe_get matrix y in (* If the current line is equal to the displayed one, skip it *) if y >= old_rows || line <> Array.unsafe_get old_matrix y then begin for x = 0 to Array.length line - 1 do let point = Array.unsafe_get line x in render_point term buf !last_point point; last_point := point done end; if y < rows - 1 then Buffer.add_char buf '\n' done; Buffer.add_string buf "\027[0m"; (* Go to the beginning of the line if rendering a box. *) if kind = Render_box then Buffer.add_char buf '\r'; fprint term (Buffer.contents buf) let blank_windows = { LTerm_windows.ci_char = uspace; LTerm_windows.ci_foreground = 7; LTerm_windows.ci_background = 0; } let windows_char_info term point char = if point.LTerm_draw.reverse then { LTerm_windows.ci_char = char; LTerm_windows.ci_foreground = windows_bg_color term point.LTerm_draw.background; LTerm_windows.ci_background = windows_fg_color term point.LTerm_draw.foreground; } else { LTerm_windows.ci_char = char; LTerm_windows.ci_foreground = windows_fg_color term point.LTerm_draw.foreground; LTerm_windows.ci_background = windows_bg_color term point.LTerm_draw.background; } let render_windows term kind handle_newlines matrix = (* Build the matrix of char infos *) let matrix = Array.map (fun line -> let len = Array.length line - (if handle_newlines then 1 else 0) in if len < 0 then invalid_arg "LTerm.print_box_with_newlines"; let res = Array.make len blank_windows in let rec loop i = if i = len then res else begin let point = Array.unsafe_get line i in let code = UChar.code point.LTerm_draw.char in if handle_newlines && code = 10 then begin (* Copy styles. *) Array.unsafe_set res i (windows_char_info term point uspace); for i = i + 1 to len - 1 do let point = Array.unsafe_get line i in Array.unsafe_set res i (windows_char_info term point uspace) done; res end else begin let char = if code < 32 then unknown_char else point.LTerm_draw.char in Array.unsafe_set res i (windows_char_info term point char); loop (i + 1) end end in loop 0) matrix in let rows = Array.length matrix in begin match kind with | Render_screen -> return () | Render_box -> (* Ensure that there is enough place to display the box. *) fprint term "\r" >>= fun () -> fprint term (String.make (rows - 1) '\n') >>= fun () -> Lwt_io.flush term.oc end >>= fun () -> let info = LTerm_windows.get_console_screen_buffer_info term.outgoing_fd in let window_rect = info.LTerm_windows.window in let rect = match kind with | Render_screen -> window_rect | Render_box -> { window_rect with row1 = info.LTerm_windows.cursor_position.row - (rows - 1); row2 = info.LTerm_windows.cursor_position.row + 1 } in ignore ( LTerm_windows.write_console_output term.outgoing_fd matrix { rows = Array.length matrix; cols = if matrix = [||] then 0 else Array.length matrix.(0) } { row = 0; col = 0 } rect ); return () let render_update term old_matrix matrix = if term.outgoing_is_a_tty then if term.windows then render_windows term Render_screen false matrix else render_update_unix term Render_screen old_matrix matrix else Lwt.fail Not_a_tty let render term m = render_update term [||] m let print_box term matrix = if term.outgoing_is_a_tty then begin if Array.length matrix > 0 then begin if term.windows then render_windows term Render_box false matrix else render_update_unix term Render_box [||] matrix end else fprint term "\r" end else Lwt.fail Not_a_tty let print_box_with_newlines_unix term matrix = let open LTerm_draw in let buf = Buffer.create 16 in (* Go the the beginnig of line and reset attributes *) Buffer.add_string buf "\r\027[0m"; (* The last displayed point. *) let last_point = ref { char = uspace; bold = false; underline = false; blink = false; reverse = false; foreground = LTerm_style.default; background = LTerm_style.default; } in let rows = Array.length matrix in for y = 0 to rows - 1 do let line = Array.unsafe_get matrix y in let cols = Array.length line - 1 in if cols < 0 then invalid_arg "LTerm.print_box_with_newlines"; let rec loop x = let point = Array.unsafe_get line x in let code = UChar.code point.char in if x = cols then begin if code = 10 && y < rows - 1 then Buffer.add_char buf '\n' end else if code = 10 then begin (* Use the style of the newline for the rest of the line. *) render_style term buf !last_point point; last_point := point; (* Erase everything until the end of line. *) Buffer.add_string buf "\027[K"; if y < rows - 1 then Buffer.add_char buf '\n' end else begin render_point term buf !last_point point; last_point := point; loop (x + 1) end in loop 0 done; Buffer.add_string buf "\027[0m\r"; fprint term (Buffer.contents buf) let print_box_with_newlines term matrix = if term.outgoing_is_a_tty then begin if Array.length matrix > 0 then begin if term.windows then render_windows term Render_box true matrix else print_box_with_newlines_unix term matrix end else fprint term "\r" end else Lwt.fail Not_a_tty (* +-----------------------------------------------------------------+ | Misc | +-----------------------------------------------------------------+ *) let flush term = Lwt_io.flush term.oc let get_size_from_fd fd = return (get_size_from_fd fd) let set_size_from_fd fd size = return (set_size_from_fd fd size) (* +-----------------------------------------------------------------+ | Standard terminals | +-----------------------------------------------------------------+ *) let stdout = lazy(create Lwt_unix.stdin Lwt_io.stdin Lwt_unix.stdout Lwt_io.stdout) let stderr = lazy(create Lwt_unix.stdin Lwt_io.stdin Lwt_unix.stderr Lwt_io.stderr) let print str = Lazy.force stdout >>= fun term -> fprint term str let printl str = Lazy.force stdout >>= fun term -> fprintl term str let printf fmt = Printf.ksprintf print fmt let prints str = Lazy.force stdout >>= fun term -> fprints term str let printlf fmt = Printf.ksprintf printl fmt let printls str = Lazy.force stdout >>= fun term -> fprintls term str let eprint str = Lazy.force stderr >>= fun term -> fprint term str let eprintl str = Lazy.force stderr >>= fun term -> fprintl term str let eprintf fmt = Printf.ksprintf eprint fmt let eprints str = Lazy.force stderr >>= fun term -> fprints term str let eprintlf fmt = Printf.ksprintf eprintl fmt let eprintls str = Lazy.force stderr >>= fun term -> fprintls term str lambda-term-1.9/src/lTerm.mli000066400000000000000000000317311254222632000161300ustar00rootroot00000000000000(* * lTerm.mli * --------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (** Terminal definitions *) open CamomileLibrary type t (** Type of terminals. *) (** {6 Creation} *) exception No_such_encoding of string (** Exception raised when an encoding does not exist. *) val create : ?windows : bool -> ?model : string -> ?incoming_encoding : string -> ?outgoing_encoding : string -> Lwt_unix.file_descr -> Lwt_io.input_channel -> Lwt_unix.file_descr -> Lwt_io.output_channel -> t Lwt.t (** [create ?windows ?model ?incoming_encoding ?outgoing_encoding input_fd input_channel outout_fd output_channel] creates a new terminal using [input_fd] and [input_channel] for inputs and [output_fd] and [output_channel] for outputs. - [windows] indicates whether the terminal is a windows console (not mintty, rxvt, ...). It defaults to [Sys.win32]. - [model] is the type of the terminal, such as "rxvt" or "xterm". It defaults to the contents of the "TERM" environment variable, or to "dumb" if this one is not found. It is used to determine capabilities of the terminal, such as the number of colors. This is not used if [windows] is [true]. - [incoming_encoding] is the encoding used for incoming data. It defaults to [LTerm_windows.get_console_cp] if [windows] is [true] and [LTerm_unix.system_encoding] otherwise. - [outgoing_encoding] is the encoding used for outgoing data. It defaults to [LTerm_windows.get_console_output_cp] if [windows] is [true] and [LTerm_unix.system_encoding] otherwise. Note that transliteration is used so printing unicode character on the terminal will never fail. If one of the two given encodings does not exist, it raises [No_such_encoding]. Note about terminal resize: in the windows console resizes are not automatically detected. Lambda-term will only check for resize only when something happens. If you want it to poll just write somewhere in your program: {[ Lwt_engine.on_timer 1.0 true ignore ]} *) (** {6 Informations} *) val model : t -> string (** Returns the model of the terminal. *) val colors : t -> int (** Number of colors of the terminal. *) val windows : t -> bool (** Whether the terminal is a windows console or not. *) val is_a_tty : t -> bool (** [is_a_tty term] whether the intput and output of the given terminal are connected to a tty device. *) val incoming_is_a_tty : t -> bool (** [incoming_is_a_tty term] whether the input of [term] is a tty device. *) val outgoing_is_a_tty : t -> bool (** [incoming_is_a_tty term] whether the output of [term] is a tty device. *) val escape_time : t -> float (** Time waited before returning the escape key. This is not used on windows. *) val set_escape_time : t -> float -> unit (** Set the time waited before returning the escape key. *) exception Not_a_tty (** Exception raised when trying to use a function that can only be used on terminals. *) val size : t -> LTerm_geom.size (** Returns the curent size of the terminal. It raises {!Not_a_tty} if the output of the given terminal is not a tty. *) (** {6 Modes} *) type mode (** Type of terminal modes. *) val enter_raw_mode : t -> mode Lwt.t (** [enter_raw_mode term] puts the terminal in ``raw mode''. In this mode keyboard events are returned as they happen. In normal mode only complete line are returned. It returns the current terminal mode that can be restored using {!leave_raw_mode}. It raises {!Not_a_tty} if the input of the given terminal is not tty. *) val leave_raw_mode : t -> mode -> unit Lwt.t (** [leave_raw_mode term mode] leaves the raw mode by restoring the given mode. It raises {!Not_a_tty} if the input of the given terminal is not tty. *) val enable_mouse : t -> unit Lwt.t (** Enable mouse events reporting. It raises {!Not_a_tty} if the output of the given terminal is not a tty. *) val disable_mouse : t -> unit Lwt.t (** Disable mouse events reporting. It raises {!Not_a_tty} if the output of the given terminal is not a tty. *) (** {6 Cursor} *) val show_cursor : t -> unit Lwt.t (** Make the cursor visible. It raises {!Not_a_tty} if the output of the given terminal is not a tty. *) val hide_cursor : t -> unit Lwt.t (** Make the cursor invisible. It raises {!Not_a_tty} if the output of the given terminal is not a tty. *) val goto : t -> LTerm_geom.coord -> unit Lwt.t (** [goto term coord] moves the cursor to the given coordinates. It raises {!Not_a_tty} if the output of the given terminal is not a tty. *) val move : t -> int -> int -> unit Lwt.t (** [move term rows columns] moves the cursor by the given number of lines and columns. Both [rows] and [columns] may be negavite. It raises {!Not_a_tty} if the output of the given terminal is not a tty. *) (** {6 Erasing text} *) val clear_screen : t -> unit Lwt.t (** [clear_screen term] clears the entire screen. *) val clear_screen_next : t -> unit Lwt.t (** [clear_screen_next term] clears the screen from the cursor to the bottom of the screen. *) val clear_screen_prev : t -> unit Lwt.t (** [clear_screen_prev term] clears the screen from the cursor to the top of the screen. *) val clear_line : t -> unit Lwt.t (** [clear_line term] erases the current line. *) val clear_line_next : t -> unit Lwt.t (** [clear_line_next term] erases the current line from the cursor to the end of the line. *) val clear_line_prev : t -> unit Lwt.t (** [clear_line_prev term] erases the current line from the cursor to the beginning of the line. *) (** {6 State} *) val save_state : t -> unit Lwt.t (** Save the current state of the terminal so it can be restored latter. It raises {!Not_a_tty} if the output of the given terminal is not a tty. *) val load_state : t -> unit Lwt.t (** Load the previously saved state of the terminal. It raises {!Not_a_tty} if the output of the given terminal is not a tty. *) (** {6 Events} *) val read_event : t -> LTerm_event.t Lwt.t (** Reads and returns one event. The terminal should be in raw mode before calling this function, otherwise event will not be reported as they happen. It does not fail if the terminal is not a tty. Note: you must not call {!read_event} from multiple thread at the same time, it will raise {!Failure} if you try to do so. *) (** {6 Printing} *) (** All these functions accept only valid UTF-8 strings (or unicode styled text). Strings are recoded on the fly using the terminal output encoding (except if the terminal output encoding is already UTF-8, in which case the string is just printed as-it). The general name of a printing function is [print]. Where [] is one of: - ['f'], which means that the function takes as argument a terminal - nothing, which means that the function prints on {!stdout} - ['e'], which means that the function prints on {!stderr} and [] is a combination of: - ['l'] which means that a new-line character is printed after the message - ['f'] which means that the function takes as argument a {b format} instead of a string - ['s'] which means that the function takes as argument a styled string instead of a string Note that if the terminal is not a tty, styles are stripped. *) val fprint : t -> Zed_utf8.t -> unit Lwt.t val fprintl : t -> Zed_utf8.t -> unit Lwt.t val fprintf : t -> ('a, unit, Zed_utf8.t, unit Lwt.t) format4 -> 'a val fprints : t -> LTerm_text.t -> unit Lwt.t val fprintlf : t -> ('a, unit, Zed_utf8.t, unit Lwt.t) format4 -> 'a val fprintls : t -> LTerm_text.t -> unit Lwt.t val print : Zed_utf8.t -> unit Lwt.t val printl : Zed_utf8.t -> unit Lwt.t val printf : ('a, unit, Zed_utf8.t, unit Lwt.t) format4 -> 'a val prints : LTerm_text.t -> unit Lwt.t val printlf : ('a, unit, Zed_utf8.t, unit Lwt.t) format4 -> 'a val printls : LTerm_text.t -> unit Lwt.t val eprint : Zed_utf8.t -> unit Lwt.t val eprintl : Zed_utf8.t -> unit Lwt.t val eprintf : ('a, unit, Zed_utf8.t, unit Lwt.t) format4 -> 'a val eprints : LTerm_text.t -> unit Lwt.t val eprintlf : ('a, unit, Zed_utf8.t, unit Lwt.t) format4 -> 'a val eprintls : LTerm_text.t -> unit Lwt.t (** {8 Printing contexts} *) (** You shoud use these functions when you to print a lot of styled text that does not entirely fit in a single {!LTerm_text.t} value. This is more efficient than calling manually {!set_style} since styles will be modified only when needed. *) type context (** A context for styled printing. *) val with_context : t -> (context -> 'a Lwt.t) -> 'a Lwt.t (** [with_context term f] creates a new printing context and pass it to [f]. Note that calls to [with_context] are serialized. *) val update_style : context -> LTerm_style.t -> unit Lwt.t (** [update_style ctx style] updates the style of the context with [style]. If needed styles of the terminal are modified. *) val context_term : context -> t (** Returns the terminal used by the given context. *) val context_oc : context -> Lwt_io.output_channel (** Returns the output channel used by the given context. Note that this channel cannot be used after {!with_context} has terminated. *) val encode_string : t -> Zed_utf8.t -> string (** [encode_string term str] encodes an UTF-8 string using the terminal encoding. *) val encode_char : t -> UChar.t -> string (** [encode_char term ch] encodes an unicode character using the terminal encoding. *) (** {6 Styles} *) val set_style : t -> LTerm_style.t -> unit Lwt.t (** Change the style of the termina for subsequent unstyled output. It does nothing if the output is not a tty. *) (** {6 Rendering} *) val render : t -> LTerm_draw.matrix -> unit Lwt.t (** Render an offscreen array to the given terminal. It raises {!Not_a_tty} if the output of the given terminal is not a tty. *) val render_update : t -> LTerm_draw.matrix -> LTerm_draw.matrix -> unit Lwt.t (** [render_update displayed to_display] does the same as [render to_display] but assumes that [displayed] contains the current displayed text. This reduces the amount of text sent to the terminal. It raises {!Not_a_tty} if the output of the given terminal is not a tty. *) val print_box : t -> LTerm_draw.matrix -> unit Lwt.t (** [print_box term matrix] prints the contents of [matrix] starting at current cursor row. Note that when you have the choice between using {!fprints} and {!print_box} you should use {!print_box} because it works better under windows and is more efficient. The cursor is moved to the beginning of the last displayed line. *) val print_box_with_newlines : t -> LTerm_draw.matrix -> unit Lwt.t (** [print_box term matrix] Same as {!print_box} but [matrix] may contains newline characters. It must contain one more column that the terminal (in case a line of the length of the terminal ends with a newline). The difference between {!print_box} and {!print_box_with_newlines} is that when the text is selected in the terminal, with {!print_box} it will always be a box with the dimensions of [matrix]. With {!print_box_with_newlines} it may contains lines longer than the width of the terminal. The contents of a line after the first newline character (if any) in a row of [matrix] is ignored. The rest of the line get the style of the newline character. *) (** {6 Misc} *) val flush : t -> unit Lwt.t (** Flushes the underlying output channel used by the terminal. *) (** {6 Well known instances} *) val stdout : t Lwt.t Lazy.t (** Terminal using {!Lwt_unix.stdin} as input and {!Lwt_unix.stdout} as output. *) val stderr : t Lwt.t Lazy.t (** Terminal using {!Lwt_unix.stdin} as input and {!Lwt_unix.stderr} as output. *) (** {6 Low-level functions} *) val get_size_from_fd : Lwt_unix.file_descr -> LTerm_geom.size Lwt.t (** [get_size_from_fd fd] returns the size of the terminal accessible via the given file descriptor. *) val set_size_from_fd : Lwt_unix.file_descr -> LTerm_geom.size -> unit Lwt.t (** [set_size_from_fd fd size] tries to set the size of the terminal accessible via the given file descriptor. *) (** {6 Modification} *) val set_io : ?incoming_fd : Lwt_unix.file_descr -> ?incoming_channel : Lwt_io.input_channel -> ?outgoing_fd : Lwt_unix.file_descr -> ?outgoing_channel : Lwt_io.output_channel -> t -> unit Lwt.t (** Modifies file descriptors/channels of a terminal. Unspecified arguments are kept unchanged. Note: before modifying a terminal you should ensure that no operation is pending on it. *) (**/**) val get_size : t -> LTerm_geom.size Lwt.t val set_size : t -> LTerm_geom.size -> unit Lwt.t lambda-term-1.9/src/lTerm_color_mappings.ml000066400000000000000000004366301254222632000210620ustar00rootroot00000000000000(* * lTerm_color_mappings.ml * ----------------------- * Copyright : (c) 2012, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (* This file was generated by gen_color_mappings.ml. *) let data0 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\ \001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\ \001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\ \001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\ \001\001\001\001\001\001\001\001\001\001\001\001\001\001\002\002\ \002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\ \002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\ \002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\ \002\002\002\002\002\002\002\003\003\003\003\003\003\003\003\003\ \003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\ \003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\ \003\003\003\003\003\003\003\003\003\003\004\004\004\004\004\004\ \004\004\004\004\004\004\004\004\004\004\004\004\004\004\004\004\ \004\004\004\005\005\005\005\005\005\005\005\005\005\005\005\005" let data1 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\ \001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\ \001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\ \001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\ \001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\ \001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\ \001\001\001\001\001\001\001\002\002\002\002\002\002\002\002\002\ \002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\ \002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\ \002\002\002\002\002\002\002\002\002\002\003\003\003\003\003\003\ \003\003\003\003\003\003\003\003\003\003\004\004\004\004\004\004\ \004\004\004\004\004\004\004\005\005\005\005\005\005\005\005\005" let data2 = "\000\001\001\001\001\009\002\003\003\001\001\009\002\003\003\003\ \003\009\002\002\003\003\003\011\002\002\003\003\003\011\010\010\ \010\011\011\011\004\005\005\005\005\009\006\008\008\001\001\009\ \006\008\008\007\007\009\006\002\007\007\007\015\006\002\007\007\ \007\015\010\010\010\015\015\011\004\004\005\005\005\013\004\012\ \012\005\005\013\006\012\012\007\007\015\006\006\007\007\007\015\ \006\006\007\007\007\015\014\014\015\015\015\015\004\004\005\005\ \005\013\004\012\012\005\005\013\006\012\012\007\007\015\006\006\ \007\007\007\015\006\006\007\007\007\015\014\014\015\015\015\015\ \004\004\013\013\013\013\004\012\012\013\013\013\014\012\012\012\ \007\015\014\014\012\007\007\015\014\014\007\007\007\015\014\014\ \015\015\015\015\004\004\013\013\013\013\004\012\012\013\013\013\ \014\012\012\012\012\013\014\014\012\015\015\015\014\014\012\015\ \015\015\014\014\014\015\015\015" let data3 = "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\ \001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\ \001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\ \001\001\001\001\001\001\002\002\002\002\002\002\002\002\002\002\ \002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\ \002\002\002\002\002\002\002\002\003\003\003\003\003\003\003\003\ \003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\ \004\004\004\004\004\004\004\004\004\004\004\004\004\004\004\004\ \004\004\004\004\004\004\004\005\005\005\005\005\005\005\005\005\ \005\005\005\005\005\005\005\005\005\005\005\005\005\005\006\006\ \006\006\006\006\006\006\006\006\006\006\006\006\006\006\006\006\ \006\006\006\006\007\007\007\007\007\007\007\007\007\007\007\008\ \008\008\008\008\008\008\008\008\008\008\008\008\009\009\009\009\ \009\009\009\009\009\009\009\009\009\009\009\009\009\009\009\009\ \009\009\009\009\010\010\010\010\010\010\010\010\010\010\010\010" let data4 = "\016\032\032\032\032\032\048\048\048\064\064\020\036\052\032\032\ \032\048\048\048\064\064\020\040\036\036\052\052\052\068\068\068\ \068\020\020\036\036\036\052\052\052\052\068\068\020\020\040\036\ \036\036\052\052\052\068\068\020\020\040\040\036\036\056\052\052\ \052\068\024\024\040\040\040\056\056\056\056\072\072\024\024\044\ \040\040\040\056\056\056\072\072\024\024\044\040\040\040\056\056\ \056\072\072\028\028\044\044\044\040\060\060\060\076\076\028\028\ \044\044\044\044\060\060\060\076\076\017\033\049\032\032\032\048\ \048\048\064\064\021\080\053\032\032\032\048\048\048\064\064\025\ \041\057\057\052\052\048\048\048\064\064\020\020\057\036\036\052\ \052\068\068\068\068\020\020\040\036\036\036\052\052\052\068\068\ \020\020\040\040\036\036\052\052\052\052\068\024\024\024\040\040\ \040\056\056\056\072\068\024\024\024\044\040\040\056\056\056\072\ \072\024\024\024\044\040\040\056\056\056\072\072\028\028\028\044\ \044\040\060\060\060\076\072\028\028\028\044\044\044\044\060\060\ \060\076\017\034\033\033\049\049\049\065\065\065\065\022\038\054\ \054\049\049\048\048\048\064\064\021\042\081\082\053\053\053\069\ \069\069\069\021\042\082\082\053\053\053\069\069\069\069\025\025\ \041\041\057\057\073\073\073\073\073\025\025\041\041\057\057\057\ \073\073\073\073\025\024\041\041\061\057\057\077\077\073\073\029\ \024\045\045\061\061\077\077\077\077\073\029\024\045\045\061\061\ \077\077\077\077\073\029\028\045\045\061\061\061\077\077\077\077\ \029\028\045\045\061\061\061\061\061\077\077\017\017\033\033\033\ \049\049\049\049\065\065\017\017\054\033\033\049\049\065\065\065\ \065\021\042\082\082\053\053\053\069\069\069\069\021\021\082\082\ \083\053\053\053\053\069\069\021\021\041\083\083\057\053\053\053\ \069\069\025\025\041\041\057\057\057\073\073\073\073\025\025\041\ \041\041\057\057\057\057\073\073\025\029\045\041\041\061\057\057\ \057\073\073\025\029\045\041\041\061\057\057\057\077\073\029\029\ \045\045\045\061\061\061\077\077\077\029\029\045\045\045\061\061\ \061\061\077\077\017\017\034\033\033\033\049\049\049\065\065\017\ \017\034\033\033\033\049\049\049\065\065\022\022\038\038\054\054\ \070\070\070\070\070\021\021\038\083\083\054\053\053\053\069\069\ \021\021\042\083\083\084\053\053\053\069\069\021\021\042\042\084\ \084\053\053\053\069\069\025\025\046\041\041\041\057\057\057\073\ \073\025\025\046\041\041\041\057\057\057\073\073\025\025\046\041\ \041\041\057\057\057\073\073\029\029\046\045\045\045\061\061\061\ \077\077\029\029\046\045\045\045\061\061\061\077\077\017\017\034\ \034\033\033\050\049\049\049\065\017\017\034\034\033\033\049\049\ \049\049\065\022\022\038\038\054\054\054\070\070\070\070\022\022\ \038\038\054\054\054\070\070\070\070\021\021\042\042\084\084\054\ \053\053\069\069\021\021\042\042\084\084\085\053\053\053\069\026\ \025\042\042\042\085\085\057\053\053\069\025\025\046\046\041\041\ \057\057\057\057\073\025\025\046\046\041\041\041\057\057\057\073\ \025\025\046\046\045\041\041\057\057\057\073\029\029\046\046\045\ \045\045\061\061\061\077\018\018\034\034\034\050\050\050\050\066\ \066\018\018\018\034\034\034\050\050\050\066\065\022\018\038\038\ \055\054\054\071\071\070\070\022\022\038\038\038\054\054\054\054\ \070\070\022\022\043\038\038\038\054\054\054\070\070\026\022\042\ \042\038\085\085\054\054\053\069\026\026\042\042\042\085\085\058\ \086\074\074\026\026\047\042\042\042\058\058\086\074\074\026\026\ \047\042\042\042\086\086\086\074\074\030\030\046\046\046\041\062\ \062\062\078\078\030\029\046\046\046\045\062\062\062\078\078\018\ \018\035\034\034\034\050\050\050\066\066\018\018\018\035\034\034\ \050\050\050\066\066\023\018\039\039\055\055\071\071\071\071\070\ \022\023\039\038\038\055\054\054\054\070\070\022\022\043\038\038\ \038\054\054\054\070\070\022\022\043\043\038\038\054\054\054\054\ \070\026\026\047\042\042\042\058\058\086\074\074\026\026\047\042\ \042\042\058\058\086\087\074\026\026\047\042\042\042\086\086\086\ \087\074\030\030\047\046\046\042\062\087\087\087\078\030\030\046\ \046\046\046\062\062\062\078\078\018\018\035\034\034\034\050\050\ \050\066\066\018\018\018\035\034\034\050\050\050\066\066\023\018\ \039\039\055\055\071\071\071\071\070\022\023\039\038\038\055\054\ \054\054\071\070\022\022\043\038\038\038\054\054\054\070\070\022\ \022\043\043\038\038\054\054\054\054\070\026\026\047\042\042\038\ \086\086\086\075\074\026\026\047\042\042\042\086\086\086\087\074\ \026\026\047\042\042\042\086\086\086\087\074\030\030\047\047\046\ \042\063\087\087\087\074\030\030\046\046\046\046\062\062\062\062\ \078\019\019\035\035\035\034\051\051\051\067\067\019\019\019\035\ \035\034\051\051\051\067\066\023\019\039\039\055\055\055\071\071\ \071\071\023\023\039\039\039\055\055\055\071\071\071\023\023\043\ \039\039\039\055\055\055\071\071\022\022\043\043\039\038\038\054\ \054\054\070\027\027\043\043\043\038\059\059\059\075\075\027\027\ \047\043\043\042\059\087\087\087\075\027\027\047\047\043\042\059\ \087\087\087\074\031\031\047\047\047\042\063\087\087\087\079\031\ \030\047\047\047\046\063\063\062\079\079\019\019\035\035\035\035\ \051\051\051\067\067\019\019\019\035\035\035\035\051\051\051\067\ \023\019\039\039\055\055\055\055\055\071\071\023\023\039\039\039\ \055\055\055\055\071\071\023\023\043\039\039\039\055\055\055\071\ \071\023\023\043\043\039\039\039\055\055\055\071\027\023\043\043\ \043\039\059\059\059\075\075\027\027\043\043\043\043\059\059\059\ \075\075\027\027\043\043\043\043\059\059\059\059\075\031\027\047\ \047\047\043\063\063\059\079\079\031\031\047\047\047\047\063\063\ \063\079\079" let data5 = "\000\000\000\000\000\001\001\001\001\001\001\001\001\001\002\002\ \002\002\002\002\002\002\002\002\003\003\003\003\003\003\003\003\ \003\003\004\004\004\004\004\004\004\004\004\004\005\005\005\005\ \005\005\005\005\005\005\006\006\006\006\006\006\006\006\006\006\ \007\007\007\007\007\007\007\007\007\007\008\008\008\008\008\008\ \008\008\008\008\009\009\009\009\009\009\009\009\010\010\010\010\ \010\011\011\011\011\011\011\011\012\012\012\012\012\012\012\012\ \012\012\013\013\013\013\013\013\013\013\013\013\014\014\014\014\ \014\014\014\014\015\015\015\015\015\016\016\016\016\016\016\016\ \017\017\017\017\017\017\017\017\017\017\018\018\018\018\018\018\ \018\018\018\018\019\019\019\019\019\019\019\019\020\020\020\020\ \020\021\021\021\021\021\021\021\022\022\022\022\022\022\022\022\ \022\022\023\023\023\023\023\023\023\023\023\023\024\024\024\024\ \024\024\024\024\025\025\025\025\025\026\026\026\026\026\026\026\ \027\027\027\027\027\027\027\027\027\027\028\028\028\028\028\028\ \028\028\028\028\028\028\028\029\029\029\029\029\029\029\029\029" let data6 = "\016\052\052\052\052\052\052\052\052\052\052\052\052\088\088\088\ \088\088\124\124\124\124\124\160\160\160\160\160\196\196\022\058\ \094\052\052\052\052\052\052\052\052\052\052\088\088\088\088\088\ \124\124\124\124\124\160\160\160\160\160\196\196\022\064\058\094\ \094\052\052\052\052\052\052\052\052\088\088\088\088\088\124\124\ \124\124\124\160\160\160\160\160\196\196\022\022\064\058\058\094\ \094\094\052\052\052\052\052\088\088\088\088\088\124\124\124\124\ \124\160\160\160\160\160\196\196\022\022\064\058\058\058\094\094\ \094\094\130\130\130\130\088\088\088\088\124\124\124\124\124\160\ \160\160\160\160\196\196\022\022\022\064\058\058\058\094\094\094\ \094\094\130\130\130\130\130\130\130\166\166\166\166\166\166\202\ \202\202\202\202\022\022\022\064\064\058\058\058\094\094\094\094\ \094\130\130\130\130\130\130\130\166\166\166\166\166\166\202\202\ \202\202\022\022\022\064\064\064\058\058\058\094\094\094\094\094\ \094\130\130\130\130\130\130\166\166\166\166\166\166\202\202\202\ \022\022\022\022\064\064\064\058\058\058\058\094\094\094\094\094\ \094\130\130\130\130\130\166\166\166\166\166\202\202\202\022\022\ \022\022\064\064\064\064\058\058\058\058\094\094\094\094\094\130\ \130\130\130\130\130\166\166\166\166\166\202\202\022\022\022\022\ \070\064\064\064\058\058\058\058\058\094\094\094\094\094\130\130\ \130\130\130\166\166\166\166\166\202\202\022\022\022\022\070\064\ \064\064\064\058\058\058\058\094\094\094\094\094\130\130\130\130\ \130\166\166\166\166\166\202\202\022\022\022\022\070\070\064\064\ \064\064\058\058\058\100\094\094\094\094\094\130\130\130\130\130\ \166\166\166\166\166\202\028\028\028\028\070\070\070\064\064\064\ \064\064\100\100\100\100\100\136\136\136\136\136\130\172\172\172\ \172\166\208\208\028\028\028\028\028\070\070\064\064\064\064\064\ \064\100\100\100\100\136\136\136\136\136\136\172\172\172\172\172\ \208\208\028\028\028\028\028\070\070\070\064\064\064\064\064\100\ \100\100\100\100\136\136\136\136\136\172\172\172\172\172\208\208\ \028\028\028\028\028\070\070\070\064\064\064\064\064\100\100\100\ \100\100\136\136\136\136\136\172\172\172\172\172\208\208\028\028\ \028\028\028\070\070\070\070\070\064\064\064\106\106\100\100\100\ \142\136\136\136\136\136\172\172\172\172\172\208\034\034\034\034\ \034\070\070\070\070\070\070\070\064\106\106\106\106\142\142\142\ \142\142\136\178\178\178\178\172\214\214\034\034\034\034\034\076\ \070\070\070\070\070\070\070\106\106\106\106\106\142\142\142\142\ \142\178\178\178\178\178\214\214\034\034\034\034\034\076\076\070\ \070\070\070\070\070\106\106\106\106\106\142\142\142\142\142\178\ \178\178\178\178\214\214\034\034\034\034\034\076\076\076\070\070\ \070\070\070\106\106\106\106\106\142\142\142\142\142\178\178\178\ \178\178\214\214\034\034\034\034\034\076\076\076\076\070\070\070\ \070\070\106\106\106\106\106\142\142\142\142\184\178\178\178\178\ \220\214\040\040\040\040\040\076\076\076\076\076\076\076\070\112\ \112\112\112\106\148\148\148\148\184\184\184\184\184\178\220\220\ \040\040\040\040\040\076\076\076\076\076\076\076\076\112\112\112\ \112\112\148\148\148\148\148\184\184\184\184\184\220\220\040\040\ \040\040\040\082\076\076\076\076\076\076\076\112\112\112\112\112\ \148\148\148\148\148\184\184\184\184\184\220\220\040\040\040\040\ \040\082\082\076\076\076\076\076\076\112\112\112\112\112\148\148\ \148\148\148\184\184\184\184\184\220\220\040\040\040\040\040\082\ \082\082\082\076\076\076\076\076\112\112\112\112\112\148\148\148\ \148\148\184\184\184\184\226\220\046\046\046\046\046\082\082\082\ \082\082\082\082\076\118\118\118\118\112\154\154\154\154\190\190\ \190\190\190\226\226\226\046\046\046\046\046\082\082\082\082\082\ \082\082\082\118\118\118\118\118\154\154\154\154\154\190\190\190\ \190\190\226\226\017\053\089\052\052\052\052\052\052\052\052\052\ \052\088\088\088\088\088\124\124\124\124\124\160\160\160\160\160\ \196\196\023\232\095\052\052\052\052\052\052\052\052\052\052\088\ \088\088\088\088\124\124\124\124\124\160\160\160\160\160\196\196\ \029\065\101\094\052\052\052\052\052\052\052\052\052\088\088\088\ \088\088\124\124\124\124\124\160\160\160\160\160\196\196\022\022\ \064\058\058\094\052\052\052\052\052\052\052\088\088\088\088\088\ \124\124\124\124\124\160\160\160\160\160\196\196\022\022\022\058\ \058\058\094\094\094\052\052\052\052\088\088\088\088\088\124\124\ \124\124\124\160\160\160\160\160\196\196\022\022\022\064\058\058\ \058\094\094\094\094\094\130\130\130\130\130\130\124\124\124\124\ \124\160\160\160\160\160\196\196\022\022\022\022\064\058\058\058\ \094\094\094\094\094\130\130\130\130\130\130\166\166\166\166\166\ \166\166\202\202\202\202\022\022\022\022\064\064\058\058\058\094\ \094\094\094\094\130\130\130\130\130\130\166\166\166\166\166\166\ \166\202\202\202\022\022\022\022\064\064\064\058\058\058\094\094\ \094\094\094\094\130\130\130\130\130\130\166\166\166\166\166\202\ \202\202\022\022\022\022\022\064\064\064\058\058\058\058\094\094\ \094\094\094\130\130\130\130\130\166\166\166\166\166\166\202\202\ \022\022\022\022\022\064\064\064\064\058\058\058\058\094\094\094\ \094\094\130\130\130\130\130\166\166\166\166\166\202\202\022\022\ \022\022\022\064\064\064\064\058\058\058\058\094\094\094\094\094\ \130\130\130\130\130\166\166\166\166\166\202\202\022\022\022\022\ \022\070\064\064\064\064\058\058\058\100\094\094\094\094\094\130\ \130\130\130\130\166\166\166\166\166\202\028\028\028\028\028\070\ \070\064\064\064\064\064\100\100\100\100\094\094\136\136\136\130\ \130\172\172\166\166\166\208\202\028\028\028\028\028\070\070\070\ \064\064\064\064\064\100\100\100\100\136\136\136\136\136\172\172\ \172\172\172\172\208\208\028\028\028\028\028\070\070\070\064\064\ \064\064\064\100\100\100\100\100\136\136\136\136\136\172\172\172\ \172\172\208\208\028\028\028\028\028\070\070\070\070\064\064\064\ \064\064\100\100\100\100\136\136\136\136\136\172\172\172\172\172\ \208\208\028\028\028\028\028\070\070\070\070\070\064\064\064\064\ \106\100\100\100\142\136\136\136\136\136\172\172\172\172\172\208\ \034\034\034\034\034\034\070\070\070\070\070\070\064\106\106\106\ \106\142\142\142\142\136\136\178\178\178\172\172\214\208\034\034\ \034\034\034\034\076\070\070\070\070\070\070\106\106\106\106\106\ \142\142\142\142\142\178\178\178\178\178\214\214\034\034\034\034\ \034\034\076\076\070\070\070\070\070\106\106\106\106\106\142\142\ \142\142\142\178\178\178\178\178\214\214\034\034\034\034\034\034\ \076\076\070\070\070\070\070\070\106\106\106\106\106\142\142\142\ \142\178\178\178\178\178\214\214\034\034\034\034\034\034\076\076\ \076\076\070\070\070\070\112\106\106\106\106\142\142\142\142\184\ \178\178\178\178\220\214\040\040\040\040\040\040\076\076\076\076\ \076\076\070\112\112\112\112\106\148\148\148\148\184\184\184\184\ \178\178\220\220\040\040\040\040\040\040\076\076\076\076\076\076\ \076\112\112\112\112\112\148\148\148\148\148\184\184\184\184\184\ \220\220\040\040\040\040\040\040\076\076\076\076\076\076\076\076\ \112\112\112\112\148\148\148\148\148\184\184\184\184\184\220\220\ \040\040\040\040\040\040\082\076\076\076\076\076\076\076\112\112\ \112\112\112\148\148\148\148\148\184\184\184\184\220\220\040\040\ \040\040\040\040\082\082\082\076\076\076\076\076\112\112\112\112\ \112\148\148\148\148\148\184\184\184\184\226\220\046\046\046\046\ \046\046\082\082\082\082\082\082\076\118\118\118\118\112\154\154\ \154\154\190\190\190\190\190\226\226\226\046\046\046\046\046\046\ \082\082\082\082\082\082\082\082\118\118\118\118\118\154\154\154\ \154\190\190\190\190\190\226\226\017\054\053\089\089\052\052\052\ \052\052\052\052\052\088\088\088\088\088\124\124\124\124\124\160\ \160\160\160\160\196\196\024\060\096\089\052\052\052\052\052\052\ \052\052\052\088\088\088\088\088\124\124\124\124\124\160\160\160\ \160\160\196\196\023\066\233\234\095\052\052\052\052\052\052\052\ \052\088\088\088\088\088\124\124\124\124\124\160\160\160\160\160\ \196\196\029\029\234\234\095\095\052\052\052\052\052\052\052\088\ \088\088\088\088\124\124\124\124\124\160\160\160\160\160\196\196\ \029\022\065\065\101\101\094\052\052\052\052\052\052\088\088\088\ \088\088\124\124\124\124\124\160\160\160\160\160\196\196\022\022\ \022\065\101\058\058\094\094\094\094\130\052\088\088\088\088\088\ \124\124\124\124\124\160\160\160\160\160\196\196\022\022\022\022\ \064\058\058\058\094\094\094\094\094\130\130\130\130\130\130\166\ \166\166\166\166\160\160\160\160\196\196\022\022\022\022\022\064\ \058\058\058\094\094\094\094\094\130\130\130\130\130\130\166\166\ \166\166\166\166\202\202\202\202\022\022\022\022\022\064\064\058\ \058\058\094\094\094\094\094\130\130\130\130\130\130\166\166\166\ \166\166\166\202\202\202\022\022\022\022\022\064\064\064\058\058\ \058\058\094\094\094\094\094\130\130\130\130\130\166\166\166\166\ \166\202\202\202\022\022\022\022\022\064\064\064\064\058\058\058\ \058\094\094\094\094\130\130\130\130\130\130\166\166\166\166\166\ \202\202\022\022\022\022\022\070\064\064\064\058\058\058\058\094\ \094\094\094\094\130\130\130\130\130\166\166\166\166\166\202\202\ \022\022\022\022\022\022\064\064\064\064\058\058\058\100\094\094\ \094\094\094\130\130\130\130\166\166\166\166\166\202\202\028\028\ \028\028\028\028\070\064\064\064\064\064\100\100\100\100\094\094\ \136\136\130\130\130\130\166\166\166\166\166\202\028\028\028\028\ \028\028\070\070\064\064\064\064\064\100\100\100\100\136\136\136\ \136\136\172\172\172\172\172\166\208\208\028\028\028\028\028\028\ \070\070\070\064\064\064\064\100\100\100\100\100\136\136\136\136\ \136\172\172\172\172\172\208\208\028\028\028\028\028\028\070\070\ \070\064\064\064\064\064\100\100\100\100\136\136\136\136\136\172\ \172\172\172\172\208\208\028\028\028\028\028\028\070\070\070\070\ \070\064\064\064\106\100\100\100\142\136\136\136\136\136\172\172\ \172\172\208\208\034\034\034\034\034\034\070\070\070\070\070\070\ \064\106\106\106\106\142\142\142\142\136\136\178\178\172\172\172\ \214\208\034\034\034\034\034\034\076\070\070\070\070\070\070\106\ \106\106\106\106\142\142\142\142\136\178\178\178\178\172\214\214\ \034\034\034\034\034\034\076\076\070\070\070\070\070\070\106\106\ \106\106\142\142\142\142\142\178\178\178\178\178\214\214\034\034\ \034\034\034\034\076\076\076\070\070\070\070\070\106\106\106\106\ \106\142\142\142\142\178\178\178\178\178\214\214\034\034\034\034\ \034\034\076\076\076\076\070\070\070\070\112\106\106\106\106\106\ \142\142\142\184\178\178\178\178\220\214\040\040\040\040\040\040\ \076\076\076\076\076\076\076\070\112\112\112\106\148\148\148\148\ \184\184\184\184\178\178\220\214\040\040\040\040\040\040\040\076\ \076\076\076\076\076\076\112\112\112\112\148\148\148\148\148\184\ \184\184\184\178\220\220\040\040\040\040\040\040\040\076\076\076\ \076\076\076\076\112\112\112\112\112\148\148\148\148\184\184\184\ \184\184\220\220\040\040\040\040\040\040\040\082\076\076\076\076\ \076\076\112\112\112\112\112\148\148\148\148\148\184\184\184\184\ \220\220\040\040\040\040\040\040\040\082\082\082\076\076\076\076\ \076\112\112\112\112\112\148\148\148\148\148\184\184\184\226\220\ \046\046\046\046\046\046\046\082\082\082\082\082\082\076\118\118\ \118\118\154\154\154\154\190\190\190\190\190\226\226\226\046\046\ \046\046\046\046\046\082\082\082\082\082\082\082\118\118\118\118\ \118\154\154\154\154\154\190\190\190\190\226\226\017\017\054\053\ \053\089\089\089\052\052\052\052\052\088\088\088\088\088\124\124\ \124\124\124\160\160\160\160\160\196\196\017\017\054\053\053\089\ \052\052\052\052\052\052\052\088\088\088\088\088\124\124\124\124\ \124\160\160\160\160\160\196\196\024\024\234\234\096\095\052\052\ \052\052\052\052\052\088\088\088\088\088\124\124\124\124\124\160\ \160\160\160\160\196\196\023\023\234\234\235\095\095\095\052\052\ \052\052\052\088\088\088\088\088\124\124\124\124\124\160\160\160\ \160\160\196\196\023\023\066\235\235\101\095\095\052\052\052\052\ \052\088\088\088\088\088\124\124\124\124\124\160\160\160\160\160\ \196\196\029\029\065\065\065\101\101\137\137\137\052\052\052\088\ \088\088\088\088\124\124\124\124\124\160\160\160\160\160\196\196\ \029\022\022\065\065\101\101\101\137\094\137\137\137\130\088\088\ \088\088\124\124\124\124\124\160\160\160\160\160\196\196\029\022\ \022\065\065\107\101\101\058\094\094\094\094\130\130\130\130\130\ \130\166\166\166\166\166\166\160\160\202\202\196\022\022\022\022\ \022\107\107\058\058\058\094\094\094\094\130\130\130\130\130\130\ \166\166\166\166\166\166\166\202\202\202\022\022\022\022\022\107\ \064\064\058\058\058\058\094\094\094\094\130\130\130\130\130\130\ \166\166\166\166\166\202\202\202\022\022\022\022\022\022\107\064\ \064\058\058\058\058\094\094\094\094\130\130\130\130\130\166\166\ \166\166\166\202\202\202\022\022\022\022\022\022\107\064\064\058\ \058\058\058\094\094\094\094\130\130\130\130\130\166\166\166\166\ \166\166\202\202\022\022\022\022\022\022\107\064\064\064\058\058\ \058\100\094\094\094\094\130\130\130\130\130\166\166\166\166\166\ \202\202\028\028\028\028\028\028\070\070\064\064\064\064\100\100\ \100\094\094\094\094\130\130\130\130\130\166\166\166\166\202\202\ \028\028\028\028\028\028\028\070\070\064\064\064\064\100\100\100\ \100\136\136\136\136\136\130\172\172\166\166\166\208\202\028\028\ \028\028\028\028\028\070\070\064\064\064\064\064\100\100\100\100\ \136\136\136\136\136\172\172\172\172\172\208\208\028\028\028\028\ \028\028\028\070\070\070\064\064\064\064\100\100\100\100\136\136\ \136\136\136\172\172\172\172\172\208\208\028\028\028\028\028\028\ \028\070\070\070\070\070\064\064\106\100\100\100\142\136\136\136\ \136\172\172\172\172\172\208\208\034\034\034\034\034\034\034\070\ \070\070\070\070\070\064\106\106\106\142\142\142\136\136\136\178\ \178\172\172\172\172\208\034\034\034\034\034\034\034\076\070\070\ \070\070\070\070\106\106\106\106\142\142\142\142\136\178\178\178\ \178\172\214\214\034\034\034\034\034\034\034\076\076\070\070\070\ \070\070\106\106\106\106\106\142\142\142\142\178\178\178\178\178\ \214\214\034\034\034\034\034\034\034\076\076\070\070\070\070\070\ \106\106\106\106\106\142\142\142\142\178\178\178\178\178\214\214\ \034\034\034\034\034\034\034\076\076\076\076\076\070\070\070\106\ \106\106\106\106\142\142\142\184\178\178\178\178\214\214\040\040\ \040\040\040\040\040\076\076\076\076\076\076\070\112\112\112\112\ \148\148\148\148\184\184\184\184\178\178\220\214\040\040\040\040\ \040\040\040\076\076\076\076\076\076\076\112\112\112\112\148\148\ \148\148\148\184\184\184\184\178\220\220\040\040\040\040\040\040\ \040\040\076\076\076\076\076\076\076\112\112\112\112\148\148\148\ \148\184\184\184\184\184\220\220\040\040\040\040\040\040\040\040\ \076\076\076\076\076\076\076\112\112\112\112\148\148\148\148\148\ \184\184\184\184\220\220\040\040\040\040\040\040\040\082\082\082\ \082\076\076\076\076\112\112\112\112\112\148\148\148\148\148\184\ \184\184\226\220\046\046\046\046\046\046\046\082\082\082\082\082\ \082\082\118\118\118\118\112\154\154\154\154\190\190\190\190\226\ \226\226\046\046\046\046\046\046\046\046\082\082\082\082\082\082\ \082\118\118\118\118\154\154\154\154\154\190\190\190\190\226\226\ \017\017\054\053\053\053\089\089\089\089\125\125\125\125\088\088\ \088\088\124\124\124\124\124\160\160\160\160\160\196\196\017\017\ \017\053\053\053\089\089\089\052\052\052\052\088\088\088\088\088\ \124\124\124\124\124\160\160\160\160\160\196\196\024\017\060\096\ \096\096\089\052\052\052\052\052\052\088\088\088\088\088\124\124\ \124\124\124\160\160\160\160\160\196\196\023\023\060\235\235\096\ \095\095\052\052\052\052\052\088\088\088\088\088\124\124\124\124\ \124\160\160\160\160\160\196\196\023\023\066\235\235\236\095\095\ \095\095\095\131\131\131\088\088\088\088\124\124\124\124\124\160\ \160\160\160\160\196\196\023\023\066\066\236\236\237\095\095\095\ \095\131\131\131\088\088\088\088\124\124\124\124\124\160\160\160\ \160\160\196\196\029\029\029\065\065\237\101\101\095\137\137\137\ \137\137\131\131\131\088\124\124\124\124\124\160\160\160\160\160\ \196\196\029\029\022\065\065\065\101\101\101\137\137\137\137\137\ \137\137\137\173\173\173\173\173\173\160\160\160\160\160\196\196\ \029\029\022\022\065\065\065\101\101\101\137\137\137\137\137\137\ \137\137\173\173\173\173\173\173\209\209\209\209\209\209\029\022\ \022\022\065\065\107\107\101\101\101\143\137\137\137\137\137\130\ \130\130\130\166\166\166\166\166\166\202\202\202\035\022\022\022\ \065\065\107\107\107\101\101\143\143\094\094\094\094\130\130\130\ \130\130\166\166\166\166\166\202\202\202\035\022\022\022\071\071\ \107\107\107\143\143\143\143\094\094\094\094\130\130\130\130\130\ \166\166\166\166\166\202\202\202\035\022\022\022\071\071\107\107\ \107\107\143\143\143\143\094\094\094\094\130\130\130\130\130\166\ \166\166\166\166\202\202\035\028\028\028\071\071\071\107\107\107\ \064\064\143\143\100\094\094\094\094\130\130\130\130\166\166\166\ \166\166\202\202\028\028\028\028\028\028\071\107\107\107\064\064\ \064\100\100\100\100\136\136\136\130\130\130\172\166\166\166\166\ \166\202\028\028\028\028\028\028\071\107\107\107\064\064\064\064\ \100\100\100\100\136\136\136\136\172\172\172\172\172\166\208\202\ \028\028\028\028\028\028\071\107\107\107\064\064\064\064\100\100\ \100\100\136\136\136\136\136\172\172\172\172\166\208\208\028\028\ \028\028\028\028\028\113\107\070\070\070\064\064\106\100\100\100\ \142\136\136\136\136\172\172\172\172\172\208\208\034\034\034\034\ \034\034\034\113\113\070\070\070\070\064\106\106\106\142\142\142\ \136\136\136\178\172\172\172\172\172\208\034\034\034\034\034\034\ \034\113\113\070\070\070\070\070\106\106\106\106\142\142\142\142\ \136\178\178\178\178\172\214\208\034\034\034\034\034\034\034\113\ \113\070\070\070\070\070\070\106\106\106\106\142\142\142\142\178\ \178\178\178\178\214\214\034\034\034\034\034\034\034\113\113\076\ \070\070\070\070\070\106\106\106\106\142\142\142\142\178\178\178\ \178\178\214\214\034\034\034\034\034\034\034\113\113\076\076\076\ \070\070\070\112\106\106\106\106\142\142\142\184\178\178\178\178\ \214\214\040\040\040\040\040\040\040\040\113\076\076\076\076\076\ \112\112\112\112\148\148\148\148\184\184\184\178\178\178\220\214\ \040\040\040\040\040\040\040\040\119\076\076\076\076\076\076\112\ \112\112\112\148\148\148\148\184\184\184\184\178\220\220\040\040\ \040\040\040\040\040\040\119\076\076\076\076\076\076\112\112\112\ \112\148\148\148\148\148\184\184\184\184\220\220\040\040\040\040\ \040\040\040\040\119\076\076\076\076\076\076\112\112\112\112\148\ \148\148\148\148\184\184\184\184\220\220\040\040\040\040\040\040\ \040\040\119\082\082\082\076\076\076\076\076\112\112\112\148\148\ \148\148\148\184\184\184\226\220\046\046\046\046\046\046\046\046\ \119\082\082\082\082\082\076\118\118\118\112\154\154\154\154\190\ \190\190\190\226\226\226\046\046\046\046\046\046\046\046\119\082\ \082\082\082\082\082\082\118\118\118\118\154\154\154\154\190\190\ \190\190\226\226\017\017\017\054\053\053\053\089\089\089\089\089\ \125\125\125\125\125\125\125\161\161\161\161\161\161\197\197\197\ \197\197\017\017\017\054\053\053\053\089\089\089\089\089\125\125\ \125\125\125\125\124\124\124\124\124\160\160\160\160\160\196\196\ \017\017\017\060\096\053\053\089\089\089\089\125\052\088\088\088\ \088\088\124\124\124\124\124\160\160\160\160\160\196\196\024\024\ \060\060\096\096\096\132\132\132\052\052\052\088\088\088\088\088\ \124\124\124\124\124\160\160\160\160\160\196\196\023\023\066\060\ \236\236\237\095\095\095\095\131\131\131\088\088\088\088\124\124\ \124\124\124\160\160\160\160\160\196\196\023\023\023\066\236\236\ \237\095\095\095\095\095\095\131\131\131\131\131\131\167\167\167\ \167\167\167\203\203\203\203\203\023\023\023\066\237\237\237\238\ \095\095\095\095\095\131\131\131\131\131\131\167\167\167\167\167\ \167\203\203\203\203\203\029\029\029\072\065\065\238\101\101\095\ \095\095\137\137\137\131\131\131\131\173\167\167\167\167\167\203\ \203\203\203\203\029\029\029\072\065\065\065\101\101\101\101\101\ \137\137\137\137\137\137\173\173\173\173\173\173\173\209\209\209\ \209\209\029\029\029\072\065\065\065\065\101\101\101\101\137\137\ \137\137\137\137\137\173\173\173\173\173\173\209\209\209\209\209\ \029\029\029\022\065\065\065\065\101\101\101\101\101\137\137\137\ \137\137\137\173\173\173\173\173\173\209\209\209\209\209\029\029\ \035\022\071\065\065\065\101\101\101\101\101\137\137\137\137\137\ \137\173\173\173\173\173\173\209\209\209\209\209\035\035\022\022\ \071\065\065\107\107\107\101\101\101\143\143\137\137\137\137\137\ \173\173\173\173\173\173\173\209\209\209\035\035\028\028\071\071\ \071\107\107\107\107\107\143\143\143\143\143\137\137\179\179\179\ \173\173\173\166\215\215\209\202\035\035\028\028\028\071\071\071\ \107\107\107\107\107\143\143\143\143\143\179\179\179\179\179\179\ \215\215\215\215\215\202\035\035\028\028\028\071\071\071\107\107\ \107\107\107\143\143\143\143\143\179\179\179\179\179\179\179\215\ \215\215\215\202\035\035\028\028\028\071\071\071\107\107\107\107\ \107\143\143\143\143\143\143\179\179\179\179\179\179\215\215\215\ \215\215\035\035\028\028\028\071\071\071\107\107\107\107\107\107\ \143\143\143\143\143\185\179\179\179\179\179\179\215\215\215\215\ \035\034\034\034\034\071\071\071\113\107\107\107\107\107\149\149\ \143\143\143\185\185\185\179\179\179\179\172\215\215\215\041\034\ \034\034\034\077\077\077\113\113\113\113\107\149\149\149\149\185\ \185\185\185\185\185\179\179\221\221\221\221\215\041\034\034\034\ \034\077\077\077\113\113\113\113\113\149\149\149\149\149\185\185\ \185\185\185\185\179\221\221\221\221\214\041\034\034\034\034\077\ \077\077\113\113\113\113\113\149\149\149\149\149\185\185\185\185\ \185\185\178\221\221\221\221\214\041\034\034\034\034\077\077\077\ \113\113\113\113\113\149\149\149\149\149\149\185\185\185\185\185\ \185\178\221\221\221\214\041\040\040\040\040\077\077\077\113\113\ \113\113\113\113\149\149\149\149\149\149\185\185\185\185\185\227\ \227\221\221\221\041\040\040\040\040\077\077\077\113\113\113\113\ \113\113\155\149\149\149\149\149\149\148\185\185\185\227\227\227\ \221\221\047\040\040\040\040\083\083\083\119\119\119\119\113\076\ \155\155\155\149\149\191\191\191\148\227\227\227\227\227\227\221\ \047\040\040\040\040\083\083\083\119\119\119\119\113\155\155\155\ \155\155\112\191\191\191\191\227\227\227\227\227\227\220\047\040\ \040\040\040\083\083\083\119\119\119\119\119\155\155\155\155\155\ \155\191\191\191\191\191\227\227\227\227\227\220\047\046\046\046\ \046\083\083\083\119\119\119\119\119\119\155\155\155\155\155\191\ \191\191\191\191\191\227\227\227\227\227\047\046\046\046\046\083\ \083\083\119\119\119\119\119\082\082\082\155\155\155\155\154\154\ \154\191\191\191\190\190\227\227\017\017\017\054\054\053\053\053\ \089\089\089\089\089\125\125\125\125\125\125\125\161\161\161\161\ \161\161\197\197\197\197\017\017\017\017\054\053\053\053\089\089\ \089\089\089\125\125\125\125\125\125\161\161\161\161\161\161\161\ \197\197\197\197\017\017\017\017\054\053\053\053\089\089\089\089\ \089\125\125\125\125\125\125\161\161\161\161\161\160\160\160\160\ \196\196\024\017\017\060\060\096\096\096\132\089\132\132\132\125\ \088\088\088\088\124\124\124\124\124\160\160\160\160\160\196\196\ \024\024\024\060\060\237\096\096\096\132\132\132\132\131\131\131\ \131\088\124\124\124\124\124\160\160\160\160\160\196\196\023\023\ \023\066\237\237\237\238\095\095\095\095\095\131\131\131\131\131\ \131\167\167\167\167\167\167\203\203\203\203\203\023\023\023\066\ \066\237\237\238\095\095\095\095\095\095\131\131\131\131\131\131\ \167\167\167\167\167\167\167\203\203\203\023\023\023\066\066\238\ \238\238\239\095\095\095\095\095\131\131\131\131\131\131\167\167\ \167\167\167\167\167\203\203\203\029\029\029\072\066\065\065\239\ \101\101\101\101\095\137\137\137\137\131\131\131\173\173\167\167\ \167\167\167\203\203\203\029\029\029\029\072\065\065\065\101\101\ \101\101\101\137\137\137\137\137\137\173\173\173\173\173\173\209\ \209\209\209\209\029\029\029\072\072\065\065\065\101\101\101\101\ \101\137\137\137\137\137\137\173\173\173\173\173\173\173\209\209\ \209\209\029\029\029\072\072\065\065\065\065\101\101\101\101\137\ \137\137\137\137\137\173\173\173\173\173\173\173\209\209\209\209\ \029\029\029\072\072\065\065\065\065\101\101\101\101\101\137\137\ \137\137\137\137\173\173\173\173\173\173\173\209\209\209\035\035\ \035\035\072\071\065\065\107\107\107\107\101\101\143\143\137\137\ \137\137\137\173\173\173\173\173\173\209\209\209\035\035\035\028\ \071\071\071\071\107\107\107\107\107\143\143\143\143\143\137\179\ \179\179\179\173\173\173\215\215\215\209\035\035\035\028\071\071\ \071\071\107\107\107\107\107\143\143\143\143\143\143\179\179\179\ \179\179\179\215\215\215\215\215\035\035\035\028\071\071\071\071\ \071\107\107\107\107\107\143\143\143\143\143\179\179\179\179\179\ \179\215\215\215\215\215\035\035\035\028\028\071\071\071\071\107\ \107\107\107\107\143\143\143\143\143\143\179\179\179\179\179\179\ \215\215\215\215\035\035\035\034\034\071\071\071\071\107\107\107\ \107\107\107\143\143\143\143\143\185\185\179\179\179\179\179\215\ \215\215\035\041\041\034\034\077\071\071\071\113\113\113\107\107\ \149\149\149\143\143\143\185\185\185\179\179\179\179\221\215\215\ \041\041\041\034\034\077\077\077\113\113\113\113\113\107\149\149\ \149\149\185\185\185\185\185\185\179\179\221\221\221\215\041\041\ \041\034\034\077\077\077\077\113\113\113\113\149\149\149\149\149\ \185\185\185\185\185\185\179\179\221\221\221\215\041\041\041\034\ \034\077\077\077\077\113\113\113\113\113\149\149\149\149\149\185\ \185\185\185\185\185\221\221\221\221\221\041\041\041\040\040\077\ \077\077\077\113\113\113\113\113\149\149\149\149\149\149\185\185\ \185\185\185\185\185\221\221\221\041\041\040\040\040\077\077\077\ \077\113\113\113\113\113\113\149\149\149\149\149\149\149\185\185\ \185\185\185\227\221\221\041\041\040\040\040\083\077\077\077\119\ \113\113\113\113\113\155\155\149\149\149\149\149\191\185\185\185\ \185\227\221\221\047\047\040\040\040\083\077\077\077\119\119\119\ \113\113\155\155\155\155\149\149\191\191\191\185\185\185\185\227\ \227\221\047\047\040\040\040\083\083\083\083\119\119\119\119\119\ \155\155\155\155\155\191\191\191\191\191\227\227\227\227\227\221\ \047\047\046\046\046\083\083\083\083\119\119\119\119\119\155\155\ \155\155\155\155\191\191\191\191\191\191\227\227\227\227\047\047\ \046\046\046\083\083\083\083\119\119\119\119\119\119\155\155\155\ \155\155\155\155\191\191\191\191\191\191\227\227\017\017\017\054\ \054\054\053\053\053\089\089\089\089\089\089\125\125\125\125\125\ \125\161\161\161\161\161\161\197\197\197\017\017\017\017\054\054\ \053\053\053\089\089\089\089\089\125\125\125\125\125\125\161\161\ \161\161\161\161\161\197\197\197\017\017\017\017\017\054\053\053\ \053\089\089\089\089\089\125\125\125\125\125\125\161\161\161\161\ \161\161\197\197\197\197\024\017\017\060\060\097\096\096\053\089\ \089\089\089\125\125\125\125\125\125\161\161\161\161\161\161\160\ \160\197\197\196\024\024\017\060\060\060\096\096\096\132\132\132\ \132\132\132\132\132\168\168\168\168\168\168\160\160\160\160\160\ \196\196\024\024\024\067\060\060\238\096\096\096\095\095\132\132\ \131\131\131\131\131\168\167\167\167\167\167\203\203\203\203\203\ \023\023\023\066\066\238\238\238\239\095\095\095\095\095\131\131\ \131\131\131\131\167\167\167\167\167\167\167\203\203\203\023\023\ \023\066\066\066\238\238\239\095\095\095\095\095\095\131\131\131\ \131\131\131\167\167\167\167\167\167\203\203\203\023\023\023\023\ \066\066\239\239\239\240\095\095\095\095\095\131\131\131\131\131\ \131\167\167\167\167\167\167\203\203\203\029\029\029\029\072\066\ \065\065\240\101\101\101\101\095\137\137\137\137\131\131\131\173\ \173\167\167\167\167\209\203\203\029\029\029\029\072\065\065\065\ \065\101\101\101\101\101\137\137\137\137\137\137\173\173\173\173\ \173\173\173\209\209\209\029\029\029\029\072\065\065\065\065\101\ \101\101\101\101\137\137\137\137\137\137\173\173\173\173\173\173\ \173\209\209\209\029\029\029\029\072\072\065\065\065\065\101\101\ \101\101\137\137\137\137\137\137\173\173\173\173\173\173\173\209\ \209\209\029\029\029\035\072\072\065\065\065\065\101\101\101\101\ \101\137\137\137\137\137\137\137\173\173\173\173\173\209\209\209\ \029\035\035\035\072\072\071\065\065\107\107\107\107\101\101\143\ \143\143\137\137\137\137\173\173\173\173\173\173\209\209\035\035\ \035\035\072\071\071\071\071\107\107\107\107\107\143\143\143\143\ \137\137\179\179\179\179\173\173\173\215\215\209\035\035\035\035\ \072\071\071\071\071\107\107\107\107\107\143\143\143\143\143\137\ \179\179\179\179\173\173\173\215\215\209\035\035\035\035\078\071\ \071\071\071\071\107\107\107\107\107\143\143\143\143\143\179\179\ \179\179\179\179\179\215\215\215\035\035\035\035\078\071\071\071\ \071\071\107\107\107\107\107\107\143\143\143\143\143\179\179\179\ \179\179\179\215\215\215\035\035\035\041\078\078\071\071\071\071\ \107\107\107\107\107\107\107\143\143\143\143\185\185\179\179\179\ \179\179\215\215\035\041\041\041\078\077\077\071\071\071\113\113\ \113\107\107\149\149\149\143\143\143\185\185\179\179\179\179\221\ \221\215\041\041\041\041\078\077\077\077\077\113\113\113\113\107\ \107\149\149\149\149\185\185\185\185\185\179\179\179\221\221\215\ \041\041\041\041\078\077\077\077\077\077\113\113\113\113\149\149\ \149\149\149\185\185\185\185\185\185\179\179\221\221\221\041\041\ \041\041\040\077\077\077\077\077\113\113\113\113\113\149\149\149\ \149\149\149\185\185\185\185\185\185\221\221\221\041\041\041\041\ \040\077\077\077\077\077\113\113\113\113\113\113\149\149\149\149\ \149\149\185\185\185\185\185\227\221\221\041\041\041\040\040\083\ \077\077\077\077\113\113\113\113\113\113\113\149\149\149\149\149\ \149\185\185\185\185\227\221\221\041\041\047\040\040\083\077\077\ \077\077\113\113\113\113\113\113\113\149\149\149\149\149\149\185\ \185\185\185\227\227\221\047\047\047\047\040\083\083\083\083\119\ \119\119\119\119\113\155\155\155\155\149\191\191\191\191\227\227\ \227\227\227\221\047\047\047\047\046\083\083\083\083\083\119\119\ \119\119\119\155\155\155\155\155\191\191\191\191\191\191\227\227\ \227\227\047\047\047\046\046\083\083\083\083\083\119\119\119\119\ \119\119\119\155\155\155\155\155\191\191\191\191\191\191\227\227\ \017\017\017\017\054\054\054\053\053\053\053\089\089\089\089\089\ \089\125\125\125\125\125\161\161\161\161\161\197\197\197\017\017\ \017\017\054\054\054\053\053\053\089\089\089\089\089\089\125\125\ \125\125\125\125\161\161\161\161\161\197\197\197\017\017\017\017\ \017\054\054\053\053\053\089\089\089\089\089\125\125\125\125\125\ \125\161\161\161\161\161\161\197\197\197\017\017\017\017\017\097\ \097\053\053\053\089\089\089\089\125\125\125\125\125\125\161\161\ \161\161\161\161\161\197\197\197\024\024\017\017\060\060\096\096\ \096\096\132\132\132\132\132\132\132\132\168\168\168\168\168\168\ \204\204\204\204\204\204\024\024\024\067\060\060\060\096\096\096\ \096\096\132\132\132\132\132\132\168\168\168\168\168\168\168\204\ \204\204\204\204\024\024\024\067\060\060\060\239\096\096\096\096\ \095\132\132\132\131\131\131\131\168\168\167\167\167\167\167\203\ \203\203\023\023\023\023\066\066\239\239\239\240\095\095\095\095\ \095\131\131\131\131\131\131\167\167\167\167\167\167\203\203\203\ \023\023\023\023\066\066\066\239\239\240\059\095\095\095\095\095\ \095\131\131\131\131\131\167\167\167\167\167\203\203\203\023\023\ \023\023\066\066\066\240\240\240\059\241\095\095\095\095\095\131\ \131\131\131\131\167\167\167\167\167\203\203\203\023\029\029\029\ \072\066\066\065\059\059\059\101\101\095\095\095\095\131\131\131\ \131\131\167\167\167\167\167\167\203\203\029\029\029\029\072\066\ \066\065\065\241\101\101\101\095\095\137\137\137\137\131\131\131\ \173\173\167\167\167\209\209\203\029\029\029\029\072\072\065\065\ \065\065\101\101\101\101\101\137\137\137\137\137\137\173\173\173\ \173\173\173\209\209\209\029\029\029\029\072\072\072\065\065\065\ \065\065\101\101\101\101\137\137\137\137\137\137\173\173\173\173\ \173\209\209\209\029\029\029\035\072\072\072\065\065\065\065\065\ \101\101\101\101\101\137\137\137\137\137\173\173\173\173\173\173\ \209\209\029\029\035\035\072\072\072\071\065\065\065\107\107\101\ \101\101\101\143\137\137\137\137\137\173\173\173\173\173\209\209\ \029\035\035\035\072\072\071\071\065\065\065\107\107\107\101\101\ \101\143\143\137\137\137\179\173\173\173\173\173\215\209\035\035\ \035\035\072\072\071\071\071\071\071\107\107\107\107\143\143\143\ \143\143\137\179\179\179\179\179\173\215\215\215\035\035\035\035\ \078\078\071\071\071\071\071\071\107\107\107\107\107\143\143\143\ \143\143\179\179\179\179\179\215\215\215\035\035\035\035\078\078\ \071\071\071\071\071\071\107\107\107\107\107\143\143\143\143\143\ \179\179\179\179\179\179\215\215\035\035\035\041\078\078\078\071\ \071\071\071\071\107\107\107\107\107\107\143\143\143\143\185\179\ \179\179\179\179\215\215\035\035\041\041\078\078\078\077\071\071\ \071\071\113\107\107\107\107\149\143\143\143\143\185\185\179\179\ \179\179\221\215\041\041\041\041\078\078\077\077\077\077\077\113\ \113\113\113\107\149\149\149\149\185\185\185\185\185\179\179\221\ \221\215\041\041\041\041\078\078\077\077\077\077\077\077\113\113\ \113\113\149\149\149\149\149\149\185\185\185\185\185\221\221\221\ \041\041\041\041\084\078\077\077\077\077\077\077\113\113\113\113\ \113\149\149\149\149\149\185\185\185\185\185\221\221\221\041\041\ \041\041\084\084\077\077\077\077\077\077\113\113\113\113\113\149\ \149\149\149\149\149\185\185\185\185\227\221\221\041\041\041\041\ \084\084\077\077\077\077\077\077\113\113\113\113\113\149\149\149\ \149\149\149\185\185\185\185\227\227\221\047\047\047\047\084\084\ \083\083\083\083\077\119\119\119\113\113\113\155\155\149\149\149\ \191\191\191\227\227\227\227\221\047\047\047\047\084\084\083\083\ \083\083\083\083\119\119\119\119\155\155\155\155\155\191\191\191\ \191\191\227\227\227\227\047\047\047\047\084\084\083\083\083\083\ \083\083\119\119\119\119\119\155\155\155\155\155\155\191\191\191\ \191\191\227\227\017\017\017\017\054\054\054\054\053\053\053\053\ \089\089\089\089\089\125\125\125\125\125\125\161\161\161\161\161\ \197\197\017\017\017\017\017\054\054\054\053\053\053\053\089\089\ \089\089\089\125\125\125\125\125\161\161\161\161\161\161\197\197\ \017\017\017\017\017\054\054\054\053\053\053\053\089\089\089\089\ \089\125\125\125\125\125\161\161\161\161\161\197\197\197\017\017\ \017\017\017\097\054\054\053\053\053\053\089\089\089\089\125\125\ \125\125\125\125\161\161\161\161\161\197\197\197\024\017\017\017\ \060\060\097\097\096\096\096\133\132\132\132\132\132\125\125\125\ \125\161\161\161\161\161\161\197\197\197\024\024\024\067\060\060\ \060\096\096\096\096\096\132\132\132\132\132\132\132\168\168\168\ \168\168\168\204\204\204\204\204\024\024\024\024\067\060\060\060\ \096\096\096\096\096\132\132\132\132\132\132\168\168\168\168\168\ \168\204\204\204\204\204\024\024\024\024\067\060\060\060\240\096\ \096\096\096\095\132\132\132\131\131\131\131\168\168\167\167\167\ \167\204\203\203\023\023\023\023\066\066\066\240\240\240\059\241\ \095\095\095\095\095\131\131\131\131\131\167\167\167\167\167\203\ \203\203\023\023\023\023\066\066\066\066\240\240\059\241\095\095\ \095\095\095\131\131\131\131\131\131\167\167\167\167\167\203\203\ \023\023\023\023\066\066\066\066\059\059\059\241\095\095\095\095\ \095\095\131\131\131\131\131\167\167\167\167\167\203\203\023\023\ \023\023\073\066\066\066\241\241\241\241\242\095\095\095\095\095\ \131\131\131\131\131\167\167\167\167\167\203\203\029\029\029\029\ \072\072\066\066\065\065\065\242\101\101\095\095\095\137\137\137\ \131\131\173\173\173\167\167\167\209\203\029\029\029\029\072\072\ \072\065\065\065\065\065\101\101\101\101\101\137\137\137\137\137\ \173\173\173\173\173\173\209\209\029\029\029\029\072\072\072\072\ \065\065\065\065\065\101\101\101\101\137\137\137\137\137\137\173\ \173\173\173\173\209\209\029\029\029\029\072\072\072\072\065\065\ \065\065\065\101\101\101\101\101\137\137\137\137\137\173\173\173\ \173\173\209\209\029\029\029\035\072\072\072\072\065\065\065\065\ \065\101\101\101\101\101\137\137\137\137\137\173\173\173\173\173\ \209\209\035\035\035\035\035\072\072\072\071\071\065\065\107\107\ \107\101\101\143\143\143\137\137\137\179\173\173\173\173\215\209\ \035\035\035\035\035\072\072\071\071\071\071\071\107\107\107\107\ \107\143\143\143\143\143\179\179\179\179\179\215\215\215\035\035\ \035\035\035\078\078\071\071\071\071\071\071\107\107\107\107\107\ \143\143\143\143\179\179\179\179\179\179\215\215\035\035\035\035\ \035\078\078\071\071\071\071\071\071\107\107\107\107\107\143\143\ \143\143\143\179\179\179\179\179\215\215\035\035\035\035\041\078\ \078\078\071\071\071\071\071\107\107\107\107\107\143\143\143\143\ \143\179\179\179\179\179\215\215\035\041\041\041\041\078\078\078\ \077\071\071\071\113\113\107\107\107\107\149\149\143\143\143\185\ \185\179\179\179\221\215\041\041\041\041\041\078\078\077\077\077\ \077\077\113\113\113\113\113\149\149\149\149\149\185\185\185\185\ \185\179\221\221\041\041\041\041\041\078\078\077\077\077\077\077\ \077\113\113\113\113\149\149\149\149\149\185\185\185\185\185\185\ \221\221\041\041\041\041\041\084\084\077\077\077\077\077\077\113\ \113\113\113\113\149\149\149\149\149\185\185\185\185\185\221\221\ \041\041\041\041\041\084\084\077\077\077\077\077\077\113\113\113\ \113\113\149\149\149\149\149\185\185\185\185\185\221\221\041\041\ \047\047\047\084\084\084\083\077\077\077\077\113\113\113\113\113\ \155\149\149\149\149\149\185\185\185\185\227\221\047\047\047\047\ \047\084\084\083\083\083\083\083\119\119\119\119\119\155\155\155\ \155\155\191\191\191\191\191\227\227\227\047\047\047\047\047\084\ \084\083\083\083\083\083\083\119\119\119\119\119\155\155\155\155\ \155\191\191\191\191\191\227\227\017\017\017\017\055\054\054\054\ \053\053\053\053\053\089\089\089\089\089\125\125\125\125\125\161\ \161\161\161\161\197\197\017\017\017\017\017\054\054\054\054\053\ \053\053\053\089\089\089\089\089\125\125\125\125\125\161\161\161\ \161\161\197\197\017\017\017\017\017\054\054\054\054\053\053\053\ \053\089\089\089\089\125\125\125\125\125\125\161\161\161\161\161\ \197\197\017\017\017\017\017\017\097\054\054\053\053\053\053\089\ \089\089\089\125\125\125\125\125\161\161\161\161\161\197\197\197\ \025\017\017\017\060\060\097\097\097\096\096\133\133\089\089\089\ \089\125\125\125\125\125\161\161\161\161\161\197\197\197\024\024\ \024\017\060\060\060\060\096\096\096\096\096\132\132\132\132\132\ \132\168\168\168\168\168\168\204\204\204\204\204\024\024\024\067\ \067\060\060\060\096\096\096\096\096\132\132\132\132\132\132\168\ \168\168\168\168\168\168\204\204\204\204\024\024\024\024\067\060\ \060\060\060\096\096\096\096\096\132\132\132\132\132\132\168\168\ \168\168\168\168\168\204\204\204\023\024\024\024\067\066\066\060\ \059\059\059\096\096\095\095\095\095\131\131\131\131\131\167\167\ \167\167\167\167\203\203\023\023\023\023\066\066\066\066\059\059\ \059\241\095\095\095\095\095\095\131\131\131\131\131\167\167\167\ \167\167\203\203\023\023\023\023\066\066\066\066\059\059\059\241\ \242\095\095\095\095\095\131\131\131\131\131\167\167\167\167\167\ \203\203\023\023\023\023\073\066\066\066\066\241\241\241\242\095\ \095\095\095\095\131\131\131\131\131\167\167\167\167\167\203\203\ \023\023\023\023\073\066\066\066\066\065\242\242\242\101\095\095\ \095\095\131\131\131\131\131\167\167\167\167\167\203\203\029\029\ \029\029\029\072\072\066\065\065\065\065\101\101\101\101\101\137\ \137\137\137\137\173\173\173\173\173\173\209\209\029\029\029\029\ \029\072\072\072\065\065\065\065\065\101\101\101\101\101\137\137\ \137\137\137\173\173\173\173\173\209\209\029\029\029\029\029\072\ \072\072\065\065\065\065\065\101\101\101\101\101\137\137\137\137\ \137\173\173\173\173\173\209\209\029\029\029\029\029\072\072\072\ \065\065\065\065\065\101\101\101\101\101\137\137\137\137\137\173\ \173\173\173\173\209\209\029\029\035\035\035\072\072\072\071\065\ \065\065\065\107\101\101\101\101\143\137\137\137\137\137\173\173\ \173\173\173\209\035\035\035\035\035\072\072\072\071\071\071\071\ \071\107\107\107\107\143\143\143\143\143\137\179\179\179\179\173\ \215\215\035\035\035\035\035\078\078\072\071\071\071\071\071\107\ \107\107\107\107\143\143\143\143\143\179\179\179\179\179\215\215\ \035\035\035\035\035\078\078\078\071\071\071\071\071\107\107\107\ \107\107\143\143\143\143\143\179\179\179\179\179\215\215\035\035\ \035\035\035\078\078\078\071\071\071\071\071\107\107\107\107\107\ \143\143\143\143\143\179\179\179\179\179\215\215\035\035\035\041\ \041\078\078\078\077\071\071\071\071\113\107\107\107\107\107\143\ \143\143\143\185\179\179\179\179\221\215\041\041\041\041\041\078\ \078\078\077\077\077\077\077\113\113\113\113\107\149\149\149\149\ \185\185\185\185\185\179\221\221\041\041\041\041\041\078\078\078\ \077\077\077\077\077\113\113\113\113\113\149\149\149\149\149\185\ \185\185\185\185\221\221\041\041\041\041\041\084\078\078\077\077\ \077\077\077\113\113\113\113\113\149\149\149\149\149\185\185\185\ \185\185\221\221\041\041\041\041\041\084\084\078\077\077\077\077\ \077\113\113\113\113\113\149\149\149\149\149\185\185\185\185\185\ \221\221\041\041\041\047\047\084\084\084\077\077\077\077\077\113\ \113\113\113\113\113\149\149\149\149\149\185\185\185\185\227\221\ \047\047\047\047\047\084\084\084\083\083\083\083\083\119\119\119\ \119\113\155\155\155\155\191\191\191\191\191\227\227\227\047\047\ \047\047\047\084\084\084\083\083\083\083\083\119\119\119\119\119\ \155\155\155\155\155\191\191\191\191\191\227\227\017\017\017\017\ \055\054\054\054\054\053\053\053\053\089\089\089\089\089\125\125\ \125\125\125\161\161\161\161\161\197\197\017\017\017\017\017\054\ \054\054\054\053\053\053\053\089\089\089\089\089\125\125\125\125\ \125\161\161\161\161\161\197\197\017\017\017\017\017\055\054\054\ \054\053\053\053\053\089\089\089\089\089\125\125\125\125\125\161\ \161\161\161\161\197\197\017\017\017\017\017\017\097\054\054\053\ \053\053\053\089\089\089\089\125\125\125\125\125\161\161\161\161\ \161\161\197\197\025\017\017\017\061\061\097\097\097\133\133\133\ \133\089\089\089\089\125\125\125\125\125\161\161\161\161\161\197\ \197\197\024\024\025\017\061\060\060\060\096\096\096\096\096\132\ \132\132\132\132\132\168\168\168\168\168\168\204\204\204\204\204\ \024\024\024\067\067\060\060\060\096\096\096\096\096\132\132\132\ \132\132\132\168\168\168\168\168\168\168\204\204\204\204\024\024\ \024\024\067\060\060\060\060\096\096\096\096\096\132\132\132\132\ \132\132\168\168\168\168\168\168\168\204\204\204\024\024\024\024\ \067\066\060\060\060\241\096\096\096\096\095\132\132\132\131\131\ \131\131\168\168\167\167\167\204\204\203\023\023\023\023\073\066\ \066\066\241\241\241\241\242\095\095\095\095\095\131\131\131\131\ \131\167\167\167\167\167\203\203\023\023\023\023\073\066\066\066\ \066\241\241\241\242\095\095\095\095\095\131\131\131\131\131\167\ \167\167\167\167\203\203\023\023\023\023\073\066\066\066\066\241\ \241\241\242\095\095\095\095\095\131\131\131\131\131\167\167\167\ \167\167\203\203\023\023\023\023\073\066\066\066\066\242\242\242\ \242\243\095\095\095\095\131\131\131\131\131\167\167\167\167\167\ \203\203\029\029\029\029\029\072\072\066\066\065\065\065\243\101\ \101\101\095\095\137\137\137\137\131\173\173\173\173\167\209\209\ \029\029\029\029\029\072\072\072\065\065\065\065\065\101\101\101\ \101\101\137\137\137\137\137\173\173\173\173\173\209\209\029\029\ \029\029\029\072\072\072\072\065\065\065\065\101\101\101\101\101\ \137\137\137\137\137\173\173\173\173\173\209\209\029\029\029\029\ \029\072\072\072\072\065\065\065\065\101\101\101\101\101\137\137\ \137\137\137\173\173\173\173\173\209\209\029\029\029\035\035\072\ \072\072\072\065\065\065\065\065\101\101\101\101\143\137\137\137\ \137\137\173\173\173\173\173\209\035\035\035\035\035\072\072\072\ \072\071\071\071\071\107\107\107\107\143\143\143\143\143\137\179\ \179\179\173\173\215\215\035\035\035\035\035\078\078\072\071\071\ \071\071\071\107\107\107\107\107\143\143\143\143\143\179\179\179\ \179\179\215\215\035\035\035\035\035\078\078\078\071\071\071\071\ \071\107\107\107\107\107\143\143\143\143\143\179\179\179\179\179\ \215\215\035\035\035\035\035\078\078\078\071\071\071\071\071\071\ \107\107\107\107\107\143\143\143\143\179\179\179\179\179\215\215\ \035\035\035\041\041\078\078\078\078\071\071\071\071\071\107\107\ \107\107\107\143\143\143\143\185\179\179\179\179\179\215\041\041\ \041\041\041\078\078\078\078\077\077\077\077\113\113\113\113\107\ \149\149\149\149\185\185\185\185\185\179\221\221\041\041\041\041\ \041\078\078\078\077\077\077\077\077\113\113\113\113\113\149\149\ \149\149\149\185\185\185\185\185\221\221\041\041\041\041\041\084\ \078\078\077\077\077\077\077\113\113\113\113\113\149\149\149\149\ \149\185\185\185\185\185\221\221\041\041\041\041\041\084\084\078\ \077\077\077\077\077\077\113\113\113\113\113\149\149\149\149\185\ \185\185\185\185\221\221\041\041\041\041\047\084\084\084\084\077\ \077\077\077\077\113\113\113\113\113\149\149\149\149\149\185\185\ \185\185\227\221\047\047\047\047\047\084\084\084\084\083\083\083\ \083\119\119\119\119\113\155\155\155\155\149\191\191\191\191\227\ \227\227\047\047\047\047\047\084\084\084\083\083\083\083\083\119\ \119\119\119\119\155\155\155\155\155\191\191\191\191\191\227\227\ \017\017\017\017\055\055\054\054\054\054\053\053\053\090\089\089\ \089\089\089\125\125\125\125\125\161\161\161\161\161\197\017\017\ \017\017\017\055\054\054\054\054\053\053\053\090\089\089\089\089\ \089\125\125\125\125\125\161\161\161\161\161\197\017\017\017\017\ \017\017\054\054\054\054\053\053\053\090\089\089\089\089\089\125\ \125\125\125\161\161\161\161\161\197\197\017\017\017\017\017\017\ \097\054\054\054\053\053\053\090\089\089\089\089\125\125\125\125\ \125\161\161\161\161\161\197\197\025\017\017\017\061\061\097\097\ \097\097\133\133\133\133\089\089\089\089\125\125\125\125\125\161\ \161\161\161\161\197\197\025\025\017\017\061\060\060\097\097\097\ \096\096\096\133\133\132\132\132\132\132\168\168\168\168\168\168\ \168\204\204\204\024\024\024\067\067\060\060\060\060\096\096\096\ \096\096\132\132\132\132\132\132\168\168\168\168\168\168\168\204\ \204\204\024\024\024\024\067\067\060\060\060\096\096\096\096\096\ \132\132\132\132\132\132\168\168\168\168\168\168\168\204\204\204\ \024\024\024\024\067\067\060\060\060\060\096\096\096\096\096\132\ \132\132\132\132\132\168\168\168\168\168\168\204\204\204\024\024\ \024\024\067\067\066\060\060\060\060\242\096\096\096\095\095\132\ \132\131\131\131\168\168\168\167\167\167\204\203\023\023\023\023\ \073\066\066\066\066\060\242\242\242\096\095\095\095\095\131\131\ \131\131\131\167\167\167\167\167\203\203\023\023\023\023\073\066\ \066\066\066\242\242\242\242\243\095\095\095\095\131\131\131\131\ \131\167\167\167\167\167\203\203\023\023\023\023\073\066\066\066\ \066\066\242\242\242\243\095\095\095\095\095\131\131\131\131\131\ \167\167\167\167\167\203\030\030\030\030\073\073\066\066\066\066\ \066\243\243\243\244\095\095\095\095\131\131\131\131\131\167\167\ \167\167\167\203\029\029\029\029\029\072\072\072\066\066\065\065\ \065\244\101\101\101\095\138\137\137\137\137\173\173\173\173\173\ \209\209\029\029\029\029\029\072\072\072\072\065\065\065\065\065\ \101\101\101\101\137\137\137\137\137\173\173\173\173\173\209\209\ \029\029\029\029\029\072\072\072\072\065\065\065\065\065\101\101\ \101\101\144\137\137\137\137\137\173\173\173\173\209\209\029\029\ \029\029\029\072\072\072\072\072\065\065\065\065\065\101\101\101\ \101\137\137\137\137\137\173\173\173\173\173\209\029\029\029\035\ \035\072\072\072\072\072\071\071\065\065\108\107\144\101\101\143\ \137\137\137\137\180\173\173\173\173\209\035\035\035\035\035\072\ \072\072\072\072\071\071\071\071\107\107\107\107\143\143\143\143\ \143\137\179\179\179\179\215\215\035\035\035\035\035\078\078\078\ \072\071\071\071\071\071\107\107\107\107\107\143\143\143\143\179\ \179\179\179\179\215\215\035\035\035\035\035\078\078\078\078\071\ \071\071\071\071\107\107\107\107\107\143\143\143\143\179\179\179\ \179\179\215\215\035\035\035\035\035\078\078\078\078\078\071\071\ \071\071\071\107\107\107\107\107\143\143\143\143\179\179\179\179\ \179\215\035\035\041\041\041\078\078\078\078\078\077\077\071\071\ \113\113\107\107\107\107\149\149\143\143\185\185\179\179\179\215\ \041\041\041\041\041\078\078\078\078\078\077\077\077\077\113\113\ \113\113\150\149\149\149\149\185\185\185\185\185\221\221\041\041\ \041\041\041\078\078\078\078\077\077\077\077\077\113\113\113\113\ \113\149\149\149\149\185\185\185\185\185\221\221\041\041\041\041\ \041\078\078\078\078\077\077\077\077\077\113\113\113\113\113\149\ \149\149\149\149\185\185\185\185\221\221\041\041\041\041\041\084\ \084\084\084\077\077\077\077\077\077\113\113\113\113\113\149\149\ \149\149\185\185\185\185\185\221\041\041\047\047\047\084\084\084\ \084\084\083\083\077\077\119\119\119\113\113\155\155\155\149\149\ \191\191\191\185\185\227\047\047\047\047\047\084\084\084\084\083\ \083\083\083\083\119\119\119\119\119\155\155\155\155\155\191\191\ \191\191\227\227\018\018\018\018\055\055\055\054\054\054\054\054\ \090\090\090\090\090\126\126\126\126\126\125\162\162\162\162\161\ \198\198\018\018\018\018\018\055\055\054\054\054\054\054\090\090\ \090\090\089\089\126\126\126\125\125\162\162\161\161\161\198\197\ \018\018\018\018\018\018\055\054\054\054\054\054\090\090\090\090\ \089\089\126\126\125\125\125\125\161\161\161\161\161\197\018\018\ \018\018\018\018\055\055\054\054\054\054\090\090\090\089\089\089\ \089\125\125\125\125\125\161\161\161\161\197\197\025\018\018\018\ \061\061\097\097\097\097\054\054\133\133\090\089\089\089\089\125\ \125\125\125\161\161\161\161\161\197\197\025\025\018\018\061\061\ \061\097\097\097\097\097\133\133\133\133\133\132\132\169\169\169\ \169\168\168\161\205\205\204\197\025\025\025\025\067\061\060\060\ \097\097\097\097\096\096\133\133\133\132\132\132\132\169\168\168\ \168\168\168\204\204\204\024\024\024\025\067\067\060\060\060\060\ \096\096\096\096\096\132\132\132\132\132\132\132\168\168\168\168\ \168\204\204\204\024\024\024\024\067\067\067\060\060\060\060\096\ \096\096\096\096\132\132\132\132\132\132\168\168\168\168\168\204\ \204\204\024\024\024\024\067\067\067\060\060\060\060\060\096\096\ \096\096\096\132\132\132\132\132\168\168\168\168\168\168\204\204\ \024\024\024\024\024\067\067\066\060\060\060\060\096\096\096\096\ \096\132\132\132\132\132\168\168\168\168\168\168\204\204\024\024\ \024\024\024\067\067\066\060\060\060\060\243\096\096\096\096\095\ \132\132\132\131\131\168\168\168\168\167\204\204\030\030\030\030\ \073\073\066\066\066\066\066\243\243\243\244\095\095\095\095\131\ \131\131\131\131\167\167\167\167\167\203\030\030\030\030\073\073\ \066\066\066\066\066\066\243\243\244\102\245\095\138\138\138\138\ \131\174\174\174\174\167\210\210\030\030\030\030\030\073\073\066\ \066\066\066\066\244\244\244\102\245\138\138\138\138\138\131\174\ \174\174\174\167\210\210\030\030\030\029\029\073\073\072\066\066\ \066\066\065\102\102\102\245\144\138\138\138\138\174\174\174\174\ \174\167\210\210\030\029\029\029\029\073\072\072\072\066\066\066\ \065\245\245\245\245\144\138\138\138\137\180\174\174\174\173\173\ \216\210\036\029\029\029\029\072\072\072\072\072\072\065\065\065\ \108\144\144\101\144\144\137\137\137\180\180\173\173\173\216\216\ \036\036\036\029\029\072\072\072\072\072\072\072\065\108\108\108\ \108\144\144\144\144\137\137\180\180\180\180\173\216\216\036\036\ \036\035\035\079\072\072\072\072\072\072\071\108\108\108\108\144\ \144\144\144\144\180\180\180\180\180\173\216\216\036\036\035\035\ \035\079\072\072\072\072\072\072\071\108\108\108\108\107\144\144\ \144\144\143\180\180\180\180\179\216\216\036\035\035\035\035\079\ \079\072\072\072\072\071\071\108\108\108\107\107\107\144\144\144\ \143\180\180\180\180\179\216\216\035\035\035\035\035\079\078\078\ \078\078\078\071\071\071\071\114\150\107\107\150\143\143\143\186\ \186\179\179\179\222\215\042\042\035\035\041\078\078\078\078\078\ \078\078\071\114\114\114\114\150\150\150\150\150\186\186\186\186\ \179\179\222\222\042\042\041\041\041\078\078\078\078\078\078\078\ \077\114\114\114\114\150\150\150\150\150\186\186\186\186\186\179\ \222\222\042\041\041\041\041\041\078\078\078\078\078\078\077\114\ \114\114\114\113\150\150\150\150\149\186\186\186\186\185\222\222\ \042\041\041\041\041\085\078\078\078\078\078\078\077\114\114\114\ \113\113\150\150\150\150\149\149\186\186\186\185\228\222\041\041\ \041\041\041\085\084\084\084\078\078\077\077\077\077\077\113\113\ \113\113\149\149\149\149\149\185\185\185\228\221\048\048\041\047\ \047\084\084\084\084\084\084\084\077\120\120\120\120\156\156\156\ \156\192\192\192\192\192\192\228\228\228\048\047\047\047\047\047\ \084\084\084\084\084\084\083\120\120\120\120\156\156\156\156\156\ \155\192\192\192\192\191\228\228\018\018\018\018\018\055\055\054\ \054\054\054\054\054\090\090\090\090\126\126\126\126\126\126\162\ \162\162\162\162\198\198\018\018\018\018\018\055\055\055\054\054\ \054\054\054\090\090\090\090\126\126\126\126\126\162\162\162\162\ \162\162\198\198\018\018\018\018\018\018\055\055\054\054\054\054\ \054\090\090\090\090\126\126\126\126\126\162\162\162\162\162\161\ \198\198\018\018\018\018\018\018\018\055\055\054\054\054\054\090\ \090\090\090\126\126\126\126\126\125\162\162\161\161\161\198\197\ \018\018\018\018\018\018\061\097\097\097\054\054\054\090\090\090\ \090\126\126\126\125\125\125\162\161\161\161\161\161\197\025\025\ \018\018\018\061\061\097\097\097\097\097\133\133\133\133\133\133\ \169\169\169\169\169\169\205\205\205\205\205\197\025\025\025\018\ \061\061\061\061\097\097\097\097\097\133\133\133\133\133\132\169\ \169\169\169\169\168\168\205\205\205\204\024\025\025\025\067\067\ \061\060\060\097\097\097\097\096\096\133\133\133\132\132\132\132\ \169\168\168\168\168\168\204\204\024\024\024\025\067\067\067\060\ \060\060\060\060\096\096\096\096\096\132\132\132\132\132\168\168\ \168\168\168\168\204\204\024\024\024\024\067\067\067\067\060\060\ \060\060\096\096\096\096\096\132\132\132\132\132\132\168\168\168\ \168\168\204\204\024\024\024\024\024\067\067\067\060\060\060\060\ \060\096\096\096\096\096\132\132\132\132\132\168\168\168\168\168\ \204\204\024\024\024\024\024\067\067\067\060\060\060\060\060\096\ \096\096\096\096\132\132\132\132\132\168\168\168\168\168\204\204\ \024\024\024\024\024\073\067\067\066\060\060\060\060\244\096\096\ \096\096\138\132\132\132\131\168\168\168\168\168\204\204\030\030\ \030\030\030\073\073\066\066\066\066\066\244\244\244\102\245\138\ \138\138\138\138\131\174\174\174\174\167\210\210\030\030\030\030\ \030\073\073\066\066\066\066\066\066\244\244\102\245\246\138\138\ \138\138\138\174\174\174\174\174\210\210\030\030\030\030\030\073\ \073\073\066\066\066\066\066\102\102\102\245\246\138\138\138\138\ \138\174\174\174\174\174\210\210\030\030\030\030\030\073\073\073\ \066\066\066\066\066\245\245\245\245\246\138\138\138\138\138\174\ \174\174\174\174\210\210\036\036\036\036\036\073\073\072\072\072\ \066\066\066\108\246\246\246\246\144\144\138\138\180\180\174\174\ \174\174\216\210\036\036\036\036\036\079\072\072\072\072\072\072\ \108\108\108\108\108\144\144\144\144\144\180\180\180\180\180\216\ \216\216\036\036\036\036\036\079\079\072\072\072\072\072\072\108\ \108\108\108\144\144\144\144\144\180\180\180\180\180\180\216\216\ \036\036\036\036\035\079\079\072\072\072\072\072\072\108\108\108\ \108\108\144\144\144\144\144\180\180\180\180\180\216\216\036\036\ \036\036\035\079\079\072\072\072\072\072\072\108\108\108\108\108\ \144\144\144\144\144\180\180\180\180\180\216\216\036\042\042\035\ \035\079\079\079\078\072\072\072\071\071\108\108\108\150\150\150\ \144\144\144\186\180\180\180\180\222\216\042\042\042\042\042\079\ \079\078\078\078\078\078\078\114\114\114\114\150\150\150\150\150\ \186\186\186\186\186\222\222\222\042\042\042\042\041\085\078\078\ \078\078\078\078\078\114\114\114\114\150\150\150\150\150\150\186\ \186\186\186\186\222\222\042\042\042\041\041\085\078\078\078\078\ \078\078\078\114\114\114\114\114\150\150\150\150\150\186\186\186\ \186\186\222\222\042\042\042\041\041\085\085\078\078\078\078\078\ \078\114\114\114\114\114\150\150\150\150\150\186\186\186\186\186\ \222\222\042\042\041\041\041\085\085\078\078\078\078\078\078\077\ \114\114\114\114\156\150\150\150\150\192\186\186\186\186\228\222\ \048\048\048\048\041\085\085\084\084\084\084\084\084\120\120\120\ \120\156\156\156\156\156\192\192\192\192\192\228\228\228\048\048\ \048\047\047\047\084\084\084\084\084\084\084\120\120\120\120\120\ \156\156\156\156\156\192\192\192\192\192\228\228\018\018\018\018\ \018\055\055\055\054\054\054\054\054\090\090\090\090\090\126\126\ \126\126\126\162\162\162\162\162\198\198\018\018\018\018\018\055\ \055\055\054\054\054\054\054\090\090\090\090\090\126\126\126\126\ \126\162\162\162\162\162\198\198\018\018\018\018\018\018\055\055\ \055\054\054\054\054\090\090\090\090\090\126\126\126\126\126\162\ \162\162\162\162\198\198\018\018\018\018\018\018\018\055\055\054\ \054\054\054\054\090\090\090\090\126\126\126\126\126\162\162\162\ \162\162\198\198\018\018\018\018\018\018\061\097\097\097\054\054\ \054\054\090\090\090\090\126\126\126\126\162\162\162\162\162\161\ \198\197\025\025\018\018\018\061\061\061\097\097\097\097\097\133\ \133\133\133\133\169\169\169\169\169\169\169\205\205\205\205\197\ \025\025\025\018\061\061\061\061\097\097\097\097\097\133\133\133\ \133\133\133\169\169\169\169\169\169\205\205\205\205\205\025\025\ \025\025\067\061\061\061\061\097\097\097\097\097\133\133\133\133\ \132\132\169\169\169\169\168\168\168\205\205\204\024\024\025\025\ \067\067\067\061\060\060\060\097\097\096\096\096\096\133\132\132\ \132\132\132\168\168\168\168\168\204\204\024\024\024\024\067\067\ \067\067\060\060\060\060\060\096\096\096\096\096\132\132\132\132\ \132\168\168\168\168\168\204\204\024\024\024\024\024\067\067\067\ \060\060\060\060\060\096\096\096\096\096\132\132\132\132\132\168\ \168\168\168\168\204\204\024\024\024\024\024\067\067\067\067\060\ \060\060\060\096\096\096\096\096\132\132\132\132\132\168\168\168\ \168\168\204\204\024\024\024\024\024\067\067\067\067\060\060\060\ \060\060\096\096\096\096\132\132\132\132\132\168\168\168\168\168\ \204\204\030\030\030\024\024\073\073\067\066\066\066\066\060\102\ \102\102\245\139\138\138\138\138\174\174\174\174\174\167\210\210\ \030\030\030\030\030\073\073\073\066\066\066\066\066\102\102\102\ \245\246\138\138\138\138\138\174\174\174\174\174\210\210\030\030\ \030\030\030\073\073\073\066\066\066\066\066\102\102\102\245\246\ \138\138\138\138\138\174\174\174\174\174\210\210\030\030\030\030\ \030\073\073\073\066\066\066\066\066\245\245\245\245\246\138\138\ \138\138\138\174\174\174\174\174\210\210\030\030\030\030\030\073\ \073\073\073\066\066\066\066\109\246\246\246\246\144\138\138\138\ \138\174\174\174\174\174\210\210\036\036\036\036\036\079\073\072\ \072\072\072\072\072\108\108\108\108\144\144\144\144\144\138\180\ \180\180\180\174\216\216\036\036\036\036\036\079\079\072\072\072\ \072\072\072\108\108\108\108\108\144\144\144\144\144\180\180\180\ \180\180\216\216\036\036\036\036\036\079\079\079\072\072\072\072\ \072\108\108\108\108\108\144\144\144\144\144\180\180\180\180\180\ \216\216\036\036\036\036\036\079\079\079\072\072\072\072\072\108\ \108\108\108\108\144\144\144\144\144\180\180\180\180\180\216\216\ \036\036\036\036\042\079\079\079\072\072\072\072\072\114\108\108\ \108\108\108\144\144\144\144\186\180\180\180\180\222\216\042\042\ \042\042\042\079\079\079\078\078\078\078\078\114\114\114\114\114\ \150\150\150\150\186\186\186\186\186\180\222\222\042\042\042\042\ \042\079\079\078\078\078\078\078\078\114\114\114\114\114\150\150\ \150\150\150\186\186\186\186\186\222\222\042\042\042\042\042\085\ \085\078\078\078\078\078\078\114\114\114\114\114\150\150\150\150\ \150\186\186\186\186\186\222\222\042\042\042\042\042\085\085\078\ \078\078\078\078\078\114\114\114\114\114\150\150\150\150\150\186\ \186\186\186\186\222\222\042\042\042\042\041\085\085\085\078\078\ \078\078\078\077\114\114\114\114\114\150\150\150\150\150\186\186\ \186\186\228\222\048\048\048\048\048\085\085\085\084\084\084\084\ \084\120\120\120\120\120\156\156\156\156\192\192\192\192\192\228\ \228\228\048\048\048\048\047\047\085\084\084\084\084\084\084\120\ \120\120\120\120\156\156\156\156\156\192\192\192\192\192\228\228\ \018\018\018\018\018\055\055\055\054\054\054\054\054\090\090\090\ \090\090\126\126\126\126\126\162\162\162\162\162\198\198\018\018\ \018\018\018\055\055\055\055\054\054\054\054\054\090\090\090\090\ \126\126\126\126\126\162\162\162\162\162\198\198\018\018\018\018\ \018\018\055\055\055\054\054\054\054\054\090\090\090\090\126\126\ \126\126\126\162\162\162\162\162\198\198\018\018\018\018\018\018\ \018\055\055\055\054\054\054\054\090\090\090\090\126\126\126\126\ \126\162\162\162\162\162\198\198\018\018\018\018\018\018\061\097\ \097\097\054\054\054\054\090\090\090\090\126\126\126\126\126\162\ \162\162\162\161\198\198\025\025\018\018\018\061\061\061\097\097\ \097\097\097\133\133\133\133\133\133\169\169\169\169\169\169\205\ \205\205\205\205\025\025\025\018\061\061\061\061\097\097\097\097\ \097\133\133\133\133\133\133\169\169\169\169\169\169\205\205\205\ \205\205\025\025\025\025\067\061\061\061\061\097\097\097\097\097\ \133\133\133\133\133\132\169\169\169\169\169\168\168\205\205\204\ \024\025\025\025\067\067\067\061\060\060\060\097\097\097\096\096\ \096\133\133\132\132\132\169\169\168\168\168\168\204\204\024\024\ \024\025\067\067\067\067\060\060\060\060\060\096\096\096\096\096\ \132\132\132\132\132\168\168\168\168\168\204\204\024\024\024\024\ \024\067\067\067\060\060\060\060\060\096\096\096\096\096\132\132\ \132\132\132\168\168\168\168\168\204\204\024\024\024\024\024\067\ \067\067\067\060\060\060\060\096\096\096\096\096\132\132\132\132\ \132\168\168\168\168\168\204\204\024\024\024\024\024\067\067\067\ \067\060\060\060\060\060\096\096\096\096\139\132\132\132\132\132\ \168\168\168\168\204\204\030\024\024\024\024\073\073\067\067\066\ \066\060\060\245\245\245\245\139\139\138\138\132\175\174\174\174\ \168\168\211\210\030\030\030\030\030\073\073\073\066\066\066\066\ \066\245\245\245\245\246\138\138\138\138\138\174\174\174\174\174\ \210\210\030\030\030\030\030\073\073\073\066\066\066\066\066\245\ \245\245\245\246\138\138\138\138\138\174\174\174\174\174\210\210\ \030\030\030\030\030\073\073\073\066\066\066\066\066\245\245\245\ \245\246\138\138\138\138\138\174\174\174\174\174\210\210\030\030\ \030\030\030\073\073\073\073\066\066\066\066\109\246\246\246\246\ \247\138\138\138\138\174\174\174\174\174\210\210\036\036\036\036\ \036\073\073\073\072\072\072\072\109\108\108\108\108\247\144\144\ \144\138\138\180\180\180\180\174\216\216\036\036\036\036\036\079\ \079\072\072\072\072\072\072\108\108\108\108\108\144\144\144\144\ \144\180\180\180\180\180\216\216\036\036\036\036\036\079\079\079\ \072\072\072\072\072\108\108\108\108\108\144\144\144\144\144\180\ \180\180\180\180\216\216\036\036\036\036\036\079\079\079\072\072\ \072\072\072\072\108\108\108\108\144\144\144\144\144\180\180\180\ \180\180\216\216\036\036\036\036\036\079\079\079\079\072\072\072\ \072\115\108\108\108\108\108\144\144\144\144\186\180\180\180\180\ \180\216\042\042\042\042\042\079\079\079\079\078\078\078\072\114\ \114\114\114\114\150\150\150\150\186\186\186\186\180\180\222\222\ \042\042\042\042\042\079\079\079\078\078\078\078\078\114\114\114\ \114\114\150\150\150\150\150\186\186\186\186\186\222\222\042\042\ \042\042\042\085\085\078\078\078\078\078\078\114\114\114\114\114\ \150\150\150\150\150\186\186\186\186\186\222\222\042\042\042\042\ \042\085\085\078\078\078\078\078\078\078\114\114\114\114\150\150\ \150\150\150\150\186\186\186\186\222\222\042\042\042\042\041\085\ \085\085\078\078\078\078\078\078\114\114\114\114\114\150\150\150\ \150\150\186\186\186\186\228\222\048\048\048\048\048\085\085\085\ \085\084\084\084\084\121\120\120\120\120\156\156\156\156\150\192\ \192\192\192\228\228\228\048\048\048\048\048\085\085\084\084\084\ \084\084\084\120\120\120\120\120\156\156\156\156\156\192\192\192\ \192\192\228\228\018\018\018\018\018\055\055\055\055\055\054\054\ \054\091\091\090\090\090\127\126\126\126\126\126\162\162\162\162\ \162\198\018\018\018\018\018\055\055\055\055\055\054\054\054\054\ \091\090\090\090\127\126\126\126\126\126\162\162\162\162\162\198\ \018\018\018\018\018\018\055\055\055\055\055\054\054\054\091\090\ \090\090\127\126\126\126\126\126\162\162\162\162\198\198\018\018\ \018\018\018\018\018\055\055\055\055\055\054\054\091\090\090\090\ \127\126\126\126\126\162\162\162\162\162\198\198\018\018\018\018\ \018\018\018\098\097\055\055\055\054\054\091\090\090\090\127\126\ \126\126\126\162\162\162\162\162\198\198\025\025\018\018\018\061\ \061\061\097\097\097\097\097\097\133\133\133\133\133\170\169\169\ \169\169\169\169\205\205\205\205\025\025\025\018\018\061\061\061\ \061\097\097\097\097\097\133\133\133\133\133\133\169\169\169\169\ \169\169\205\205\205\205\025\025\025\025\068\061\061\061\061\097\ \097\097\097\097\133\133\133\133\133\133\169\169\169\169\169\169\ \169\205\205\205\025\025\025\025\067\067\061\061\061\061\061\097\ \097\097\097\133\133\133\133\133\132\169\169\169\169\169\169\205\ \205\205\025\025\025\025\025\067\067\061\061\061\060\060\097\097\ \097\096\096\133\133\133\132\132\132\169\169\168\168\168\205\204\ \024\024\025\025\025\067\067\067\061\060\060\060\060\097\096\096\ \096\096\133\132\132\132\132\132\168\168\168\168\168\204\024\024\ \024\025\025\067\067\067\067\060\060\060\060\060\096\096\096\096\ \133\132\132\132\132\132\168\168\168\168\168\204\024\024\024\024\ \024\067\067\067\067\067\060\060\060\060\096\096\096\096\096\132\ \132\132\132\132\168\168\168\168\168\204\031\024\024\024\024\067\ \067\067\067\067\067\060\060\060\103\139\139\096\139\139\132\132\ \132\175\175\168\168\168\211\211\031\031\031\031\031\073\073\073\ \067\067\066\066\060\103\246\246\246\246\139\139\138\138\175\175\ \174\174\174\174\211\210\030\030\030\030\030\073\073\073\073\066\ \066\066\066\109\246\246\246\246\139\138\138\138\138\174\174\174\ \174\174\210\210\030\030\030\030\030\073\073\073\073\066\066\066\ \066\109\246\246\246\246\247\138\138\138\138\174\174\174\174\174\ \210\210\030\030\030\030\030\073\073\073\073\073\066\066\066\066\ \246\246\246\246\247\138\138\138\138\138\174\174\174\174\174\210\ \037\037\037\037\037\073\073\073\073\073\073\073\066\109\109\109\ \247\247\247\248\138\138\138\181\174\174\174\174\174\210\036\036\ \036\036\036\080\073\073\073\072\072\072\072\109\109\108\108\108\ \248\144\144\144\138\181\180\180\180\180\217\216\036\036\036\036\ \036\079\079\079\072\072\072\072\072\072\108\108\108\108\108\144\ \144\144\144\180\180\180\180\180\216\216\036\036\036\036\036\079\ \079\079\079\072\072\072\072\072\108\108\108\108\108\144\144\144\ \144\187\180\180\180\180\223\216\036\036\036\036\036\079\079\079\ \079\072\072\072\072\072\115\108\108\108\108\108\144\144\144\187\ \180\180\180\180\180\216\036\036\036\042\042\079\079\079\079\079\ \072\072\072\115\115\114\114\108\151\151\150\187\187\144\186\180\ \180\180\180\216\042\042\042\042\042\079\079\079\079\079\078\078\ \078\115\114\114\114\114\114\150\150\150\150\186\186\186\186\186\ \223\222\042\042\042\042\042\079\079\079\079\078\078\078\078\078\ \114\114\114\114\114\150\150\150\150\150\186\186\186\186\222\222\ \042\042\042\042\042\085\085\079\079\078\078\078\078\078\114\114\ \114\114\114\150\150\150\150\150\186\186\186\186\229\222\042\042\ \042\042\042\085\085\085\085\078\078\078\078\078\114\114\114\114\ \114\114\150\150\150\150\150\186\186\186\186\222\042\042\048\048\ \048\085\085\085\085\085\078\078\078\121\121\120\120\114\114\157\ \156\193\150\150\193\192\229\186\186\228\048\048\048\048\048\085\ \085\085\085\084\084\084\084\121\120\120\120\120\120\156\156\156\ \156\156\192\192\192\192\228\228\019\019\019\019\019\055\055\055\ \055\055\055\055\054\091\091\091\091\127\127\127\127\127\126\163\ \163\163\163\162\199\199\019\019\019\019\019\019\055\055\055\055\ \055\055\054\091\091\091\091\127\127\127\127\126\126\163\163\163\ \162\162\199\198\019\019\019\019\019\019\055\055\055\055\055\055\ \054\091\091\091\091\127\127\127\127\126\126\163\163\162\162\162\ \199\198\019\019\019\019\019\019\019\055\055\055\055\055\055\054\ \091\091\091\127\127\127\126\126\126\163\163\162\162\162\162\198\ \019\019\019\019\019\019\019\098\098\055\055\055\055\054\091\091\ \091\127\127\127\126\126\126\163\162\162\162\162\162\198\025\019\ \019\019\019\061\061\061\098\097\097\097\097\097\134\134\133\133\ \133\170\170\170\169\169\169\169\162\205\205\205\025\025\025\019\ \019\061\061\061\061\097\097\097\097\097\097\133\133\133\133\133\ \170\170\169\169\169\169\169\205\205\205\025\025\025\025\068\061\ \061\061\061\061\097\097\097\097\097\097\133\133\133\133\133\169\ \169\169\169\169\169\205\205\205\025\025\025\025\068\068\061\061\ \061\061\061\097\097\097\097\097\133\133\133\133\133\133\169\169\ \169\169\169\205\205\205\025\025\025\025\025\067\067\061\061\061\ \061\061\097\097\097\097\097\133\133\133\133\133\169\169\169\169\ \169\205\205\205\025\025\025\025\025\067\067\067\061\061\061\061\ \061\097\097\097\097\133\133\133\133\133\132\169\169\169\169\168\ \205\205\025\025\025\025\025\067\067\067\061\061\061\061\061\097\ \097\097\097\133\133\133\133\133\132\169\169\169\169\168\205\205\ \024\024\024\025\025\067\067\067\067\067\061\061\060\060\103\097\ \139\096\096\133\132\132\132\132\175\168\168\168\168\204\031\031\ \031\024\024\067\067\067\067\067\067\067\060\103\103\103\139\139\ \139\139\139\132\132\175\175\175\175\168\211\211\031\031\031\031\ \031\074\067\067\067\067\067\067\103\103\103\103\103\139\139\139\ \139\139\175\175\175\175\175\211\211\211\031\031\031\031\031\074\ \073\067\067\067\067\067\067\103\103\103\103\139\139\139\139\139\ \138\175\175\175\175\174\211\211\031\031\031\031\031\073\073\073\ \073\067\067\067\109\103\103\103\103\247\139\139\139\139\138\175\ \175\175\174\174\211\211\037\037\037\037\037\073\073\073\073\073\ \073\073\066\109\109\109\247\247\247\248\138\138\138\181\174\174\ \174\174\174\210\037\037\037\037\037\073\073\073\073\073\073\073\ \066\109\109\109\109\247\247\248\145\249\138\181\181\181\181\174\ \217\217\037\037\037\037\037\080\073\073\073\073\073\073\073\109\ \109\109\109\248\248\248\145\249\138\181\181\181\181\174\217\217\ \037\037\037\036\036\080\080\073\073\073\073\073\072\109\109\109\ \109\108\145\145\145\249\144\181\181\181\181\174\217\217\037\036\ \036\036\036\080\080\079\073\073\073\072\072\072\109\109\109\108\ \249\249\249\249\144\181\181\181\180\180\223\217\036\036\036\036\ \036\079\079\079\079\079\072\072\072\072\115\108\108\108\108\108\ \144\144\144\187\187\180\180\180\223\216\043\043\043\043\043\079\ \079\079\079\079\079\079\072\115\115\115\115\151\151\151\151\151\ \187\187\187\187\180\180\223\223\043\043\043\043\042\079\079\079\ \079\079\079\079\115\115\115\115\115\114\151\151\151\151\187\187\ \187\187\187\180\223\223\043\043\042\042\042\079\079\079\079\079\ \079\079\078\115\115\115\115\114\151\151\151\151\150\187\187\187\ \187\186\223\223\043\042\042\042\042\042\079\079\079\079\079\079\ \078\115\115\115\114\114\151\151\151\150\150\150\187\187\187\186\ \223\223\042\042\042\042\042\085\085\085\085\085\078\078\078\078\ \121\114\114\114\114\114\114\150\150\150\150\186\186\186\229\222\ \049\049\049\042\042\085\085\085\085\085\085\085\078\121\121\121\ \121\114\157\157\157\157\193\193\193\193\193\229\229\229\049\048\ \048\048\048\085\085\085\085\085\085\085\084\121\121\121\121\120\ \157\157\157\157\156\193\193\193\193\192\229\229\019\019\019\019\ \019\056\055\055\055\055\055\055\055\091\091\091\091\091\127\127\ \127\127\127\163\163\163\163\163\199\199\019\019\019\019\019\019\ \056\055\055\055\055\055\055\091\091\091\091\091\127\127\127\127\ \127\163\163\163\163\163\199\199\019\019\019\019\019\019\056\055\ \055\055\055\055\055\091\091\091\091\091\127\127\127\127\126\163\ \163\163\163\162\199\199\019\019\019\019\019\019\019\056\055\055\ \055\055\055\055\091\091\091\091\127\127\127\127\126\163\163\163\ \163\162\199\199\019\019\019\019\019\019\019\098\098\055\055\055\ \055\055\091\091\091\091\127\127\127\127\126\163\163\163\163\162\ \199\198\026\019\019\019\019\062\062\062\098\098\098\098\097\134\ \134\134\134\134\170\170\170\170\170\169\169\206\206\206\206\205\ \025\026\026\019\019\062\061\061\061\098\098\098\097\097\134\134\ \134\133\133\133\170\170\170\169\169\169\169\206\205\205\025\025\ \025\026\068\062\061\061\061\061\097\097\097\097\097\097\097\133\ \133\133\133\170\169\169\169\169\169\169\205\205\025\025\025\025\ \068\068\061\061\061\061\061\061\097\097\097\097\097\133\133\133\ \133\133\169\169\169\169\169\169\205\205\025\025\025\025\025\068\ \068\061\061\061\061\061\097\097\097\097\097\133\133\133\133\133\ \169\169\169\169\169\169\205\205\025\025\025\025\025\068\068\067\ \061\061\061\061\061\097\097\097\097\097\133\133\133\133\133\169\ \169\169\169\169\205\205\025\025\025\025\025\068\068\067\061\061\ \061\061\061\097\097\097\097\097\133\133\133\133\133\169\169\169\ \169\169\205\205\025\025\025\025\025\067\067\067\067\061\061\061\ \061\061\097\097\097\097\133\133\133\133\132\132\169\169\169\169\ \205\205\031\031\031\025\025\074\067\067\067\067\067\067\061\103\ \103\103\103\139\139\139\139\139\175\175\175\175\175\168\211\211\ \031\031\031\031\031\074\074\067\067\067\067\067\067\103\103\103\ \103\139\139\139\139\139\175\175\175\175\175\175\211\211\031\031\ \031\031\031\074\074\067\067\067\067\067\067\103\103\103\103\103\ \139\139\139\139\139\175\175\175\175\175\211\211\031\031\031\031\ \031\074\074\067\067\067\067\067\067\103\103\103\103\103\139\139\ \139\139\139\175\175\175\175\175\211\211\031\031\031\031\031\074\ \073\073\073\073\067\067\067\109\109\103\103\103\248\139\139\139\ \139\181\175\175\175\174\217\211\037\037\037\037\037\080\073\073\ \073\073\073\073\073\109\109\109\109\248\248\248\145\249\138\181\ \181\181\181\174\217\217\037\037\037\037\037\080\073\073\073\073\ \073\073\073\109\109\109\109\109\248\248\145\249\250\181\181\181\ \181\181\217\217\037\037\037\037\037\080\080\073\073\073\073\073\ \073\109\109\109\109\109\145\145\145\249\250\181\181\181\181\181\ \217\217\037\037\037\037\037\080\080\080\073\073\073\073\073\109\ \109\109\109\109\249\249\249\249\250\181\181\181\181\181\217\217\ \037\037\036\036\036\080\080\080\079\079\073\073\072\115\115\109\ \109\108\108\250\250\250\250\187\181\181\181\181\223\217\043\043\ \043\043\043\079\079\079\079\079\079\079\072\115\115\115\115\151\ \151\151\151\151\187\187\187\187\187\223\223\223\043\043\043\043\ \043\079\079\079\079\079\079\079\079\115\115\115\115\115\151\151\ \151\151\187\187\187\187\187\187\223\223\043\043\043\043\043\086\ \079\079\079\079\079\079\079\115\115\115\115\115\151\151\151\151\ \151\187\187\187\187\187\223\223\043\043\043\043\043\086\079\079\ \079\079\079\079\079\115\115\115\115\115\151\151\151\151\151\187\ \187\187\187\187\223\223\043\043\042\042\042\086\086\079\079\079\ \079\079\079\078\115\115\115\115\114\151\151\151\151\193\187\187\ \187\187\229\223\049\049\049\049\049\086\085\085\085\085\085\085\ \085\121\121\121\121\157\157\157\157\157\193\193\193\193\193\229\ \229\229\049\049\049\049\048\085\085\085\085\085\085\085\085\121\ \121\121\121\121\157\157\157\157\157\193\193\193\193\193\229\229\ \019\019\019\019\019\056\056\055\055\055\055\055\055\091\091\091\ \091\091\127\127\127\127\127\163\163\163\163\163\199\199\019\019\ \019\019\019\019\056\056\055\055\055\055\055\091\091\091\091\091\ \127\127\127\127\127\163\163\163\163\163\199\199\019\019\019\019\ \019\019\056\056\055\055\055\055\055\055\091\091\091\091\127\127\ \127\127\127\163\163\163\163\163\199\199\019\019\019\019\019\019\ \019\056\056\055\055\055\055\055\091\091\091\091\091\127\127\127\ \127\163\163\163\163\163\199\199\019\019\019\019\019\019\019\098\ \098\055\055\055\055\055\055\091\091\091\091\127\127\127\127\163\ \163\163\163\163\199\199\026\019\019\019\019\062\062\062\098\098\ \098\098\098\134\134\134\134\134\170\170\170\170\170\170\169\206\ \206\206\206\199\026\026\026\019\019\062\062\062\098\098\098\098\ \098\097\134\134\134\134\170\170\170\170\170\170\169\169\206\206\ \206\205\025\026\026\026\068\062\062\061\061\061\098\098\098\097\ \097\134\134\134\133\133\133\170\170\169\169\169\169\206\206\205\ \025\025\025\026\068\068\068\061\061\061\061\061\097\097\097\097\ \097\097\133\133\133\133\170\169\169\169\169\169\205\205\025\025\ \025\025\025\068\068\061\061\061\061\061\061\097\097\097\097\097\ \133\133\133\133\133\169\169\169\169\169\205\205\025\025\025\025\ \025\068\068\068\061\061\061\061\061\097\097\097\097\097\133\133\ \133\133\133\169\169\169\169\169\205\205\025\025\025\025\025\068\ \068\068\061\061\061\061\061\097\097\097\097\097\133\133\133\133\ \133\169\169\169\169\169\205\205\025\025\025\025\025\068\068\068\ \067\061\061\061\061\061\097\097\097\097\097\133\133\133\133\169\ \169\169\169\169\205\205\031\031\025\025\025\074\067\067\067\067\ \067\067\061\103\103\103\103\097\139\139\139\139\133\175\175\175\ \175\169\211\211\031\031\031\031\025\074\074\067\067\067\067\067\ \067\103\103\103\103\103\139\139\139\139\139\175\175\175\175\175\ \211\211\031\031\031\031\031\074\074\074\067\067\067\067\067\103\ \103\103\103\103\139\139\139\139\139\175\175\175\175\175\211\211\ \031\031\031\031\031\074\074\074\067\067\067\067\067\103\103\103\ \103\103\139\139\139\139\139\175\175\175\175\175\211\211\031\031\ \031\031\031\074\074\074\067\067\067\067\067\067\103\103\103\103\ \103\139\139\139\139\175\175\175\175\175\211\211\037\037\037\031\ \031\080\080\073\073\073\073\073\067\109\109\109\109\103\145\145\ \145\249\139\181\181\181\181\174\217\217\037\037\037\037\037\080\ \080\073\073\073\073\073\073\109\109\109\109\109\145\145\145\249\ \250\181\181\181\181\181\217\217\037\037\037\037\037\080\080\073\ \073\073\073\073\073\109\109\109\109\109\145\145\145\249\250\181\ \181\181\181\181\217\217\037\037\037\037\037\080\080\080\073\073\ \073\073\073\109\109\109\109\109\249\249\249\249\250\181\181\181\ \181\181\217\217\037\037\037\037\037\080\080\080\080\073\073\073\ \073\073\109\109\109\109\109\250\250\250\250\251\181\181\181\181\ \217\217\043\043\043\043\043\080\080\079\079\079\079\079\079\115\ \115\115\115\115\151\151\151\151\251\187\187\187\187\181\223\223\ \043\043\043\043\043\079\079\079\079\079\079\079\079\115\115\115\ \115\115\151\151\151\151\151\187\187\187\187\187\223\223\043\043\ \043\043\043\086\079\079\079\079\079\079\079\115\115\115\115\115\ \151\151\151\151\151\187\187\187\187\187\223\223\043\043\043\043\ \043\086\086\079\079\079\079\079\079\115\115\115\115\115\151\151\ \151\151\151\187\187\187\187\187\223\223\043\043\043\043\043\086\ \086\086\079\079\079\079\079\079\115\115\115\115\114\151\151\151\ \151\151\187\187\187\187\229\223\049\049\049\049\049\086\086\086\ \085\085\085\085\085\121\121\121\121\121\157\157\157\157\157\193\ \193\193\193\229\229\229\049\049\049\049\049\049\085\085\085\085\ \085\085\085\121\121\121\121\121\157\157\157\157\157\193\193\193\ \193\193\229\229\019\019\019\019\019\056\056\056\055\055\055\055\ \055\091\091\091\091\091\127\127\127\127\127\163\163\163\163\163\ \199\199\019\019\019\019\019\019\056\056\055\055\055\055\055\055\ \091\091\091\091\091\127\127\127\127\163\163\163\163\163\199\199\ \019\019\019\019\019\019\056\056\056\055\055\055\055\055\091\091\ \091\091\091\127\127\127\127\163\163\163\163\163\199\199\019\019\ \019\019\019\019\019\056\056\055\055\055\055\055\091\091\091\091\ \091\127\127\127\127\163\163\163\163\163\199\199\019\019\019\019\ \019\019\019\098\098\056\055\055\055\055\055\091\091\091\091\127\ \127\127\127\163\163\163\163\163\199\199\026\019\019\019\019\062\ \062\062\098\098\098\098\098\134\134\134\134\134\170\170\170\170\ \170\170\163\206\206\206\206\199\026\026\026\019\019\062\062\062\ \062\098\098\098\098\134\134\134\134\134\134\170\170\170\170\170\ \169\169\206\206\206\205\026\026\026\026\068\062\062\062\062\098\ \098\098\098\097\097\134\134\134\134\170\170\170\170\170\169\169\ \169\206\206\205\025\025\026\026\068\068\062\062\061\061\061\061\ \098\097\097\097\097\134\133\133\133\133\170\170\169\169\169\169\ \205\205\025\025\025\025\026\068\068\068\061\061\061\061\061\097\ \097\097\097\097\133\133\133\133\133\169\169\169\169\169\205\205\ \025\025\025\025\025\068\068\068\061\061\061\061\061\097\097\097\ \097\097\133\133\133\133\133\169\169\169\169\169\205\205\025\025\ \025\025\025\068\068\068\061\061\061\061\061\097\097\097\097\097\ \133\133\133\133\133\169\169\169\169\169\205\205\025\025\025\025\ \025\068\068\068\068\061\061\061\061\061\097\097\097\097\097\133\ \133\133\133\169\169\169\169\169\205\205\031\025\025\025\025\074\ \068\067\067\067\067\061\061\103\103\103\097\097\097\139\139\139\ \133\176\175\175\175\169\212\211\031\031\031\031\025\074\074\067\ \067\067\067\067\067\103\103\103\103\103\139\139\139\139\139\175\ \175\175\175\175\211\211\031\031\031\031\031\074\074\074\067\067\ \067\067\067\103\103\103\103\103\139\139\139\139\139\175\175\175\ \175\175\211\211\031\031\031\031\031\074\074\074\067\067\067\067\ \067\067\103\103\103\103\139\139\139\139\139\175\175\175\175\175\ \211\211\031\031\031\031\031\074\074\074\074\067\067\067\067\067\ \103\103\103\103\103\139\139\139\139\182\175\175\175\175\218\211\ \037\031\031\031\031\080\074\074\073\073\073\073\067\067\109\109\ \109\103\249\249\249\249\139\182\181\181\175\175\217\217\037\037\ \037\037\037\080\080\080\073\073\073\073\073\109\109\109\109\109\ \249\249\249\249\250\181\181\181\181\181\217\217\037\037\037\037\ \037\080\080\080\073\073\073\073\073\109\109\109\109\109\249\249\ \249\249\250\181\181\181\181\181\217\217\037\037\037\037\037\080\ \080\080\073\073\073\073\073\109\109\109\109\109\249\249\249\249\ \250\251\181\181\181\181\217\217\037\037\037\037\037\080\080\080\ \080\073\073\073\073\073\109\109\109\109\109\250\250\250\250\251\ \181\181\181\181\217\217\043\043\043\043\043\080\080\080\080\079\ \079\079\079\115\115\115\115\152\151\151\151\251\251\251\187\187\ \181\181\223\223\043\043\043\043\043\043\079\079\079\079\079\079\ \079\115\115\115\115\115\151\151\151\151\151\187\187\187\187\187\ \223\223\043\043\043\043\043\086\079\079\079\079\079\079\079\115\ \115\115\115\115\151\151\151\151\151\187\187\187\187\187\223\223\ \043\043\043\043\043\086\086\079\079\079\079\079\079\115\115\115\ \115\115\115\151\151\151\151\187\187\187\187\187\223\223\043\043\ \043\043\043\086\086\086\079\079\079\079\079\079\115\115\115\115\ \115\151\151\151\151\151\187\187\187\187\229\223\049\049\049\049\ \049\086\086\086\085\085\085\085\085\122\121\121\121\158\157\157\ \157\157\157\193\193\193\193\229\229\229\049\049\049\049\049\049\ \085\085\085\085\085\085\085\121\121\121\121\121\157\157\157\157\ \157\193\193\193\193\193\229\229\019\019\019\019\019\056\056\056\ \056\055\055\055\055\055\091\091\091\091\091\127\127\127\127\164\ \163\163\163\163\200\199\019\019\019\019\019\019\056\056\056\056\ \055\055\055\055\092\091\091\091\091\127\127\127\127\164\163\163\ \163\163\200\199\019\019\019\019\019\019\056\056\056\056\055\055\ \055\055\092\091\091\091\091\091\127\127\127\164\163\163\163\163\ \200\199\019\019\019\019\019\019\019\056\056\056\056\056\055\055\ \055\091\091\091\091\091\127\127\127\164\163\163\163\163\199\199\ \019\019\019\019\019\019\019\098\098\056\056\056\055\055\055\092\ \091\091\091\091\127\127\127\164\163\163\163\163\199\199\026\019\ \019\019\019\062\062\062\098\098\098\098\098\134\134\134\134\134\ \134\170\170\170\170\170\170\163\206\206\206\199\026\026\026\019\ \019\062\062\062\062\098\098\098\098\098\134\134\134\134\134\170\ \170\170\170\170\170\206\206\206\206\206\026\026\026\026\068\062\ \062\062\062\062\098\098\098\098\134\134\134\134\134\134\170\170\ \170\170\170\169\169\206\206\206\026\026\026\026\068\068\062\062\ \062\062\062\098\098\098\098\097\134\134\134\134\170\170\170\170\ \170\169\169\206\206\205\025\026\026\026\026\068\068\062\062\061\ \061\061\098\098\097\097\097\097\134\134\133\133\133\170\169\169\ \169\169\206\205\025\025\025\026\026\068\068\068\062\061\061\061\ \061\098\097\097\097\097\097\133\133\133\133\170\169\169\169\169\ \206\205\025\025\025\026\026\068\068\068\068\061\061\061\061\061\ \097\097\097\097\097\133\133\133\133\170\169\169\169\169\169\205\ \025\025\025\025\025\068\068\068\068\068\061\061\061\061\097\097\ \097\097\097\133\133\133\133\133\169\169\169\169\169\205\025\025\ \025\025\025\068\068\068\068\068\068\061\061\061\061\104\140\097\ \097\140\133\133\133\176\176\169\169\169\212\205\031\032\032\025\ \025\074\074\068\068\067\067\067\061\061\103\103\103\140\140\140\ \139\139\139\176\175\175\175\175\212\211\031\031\031\031\032\074\ \074\074\067\067\067\067\067\104\103\103\103\103\103\139\139\139\ \139\176\175\175\175\175\212\211\031\031\031\031\031\074\074\074\ \074\067\067\067\067\110\103\103\103\103\103\139\139\139\139\176\ \175\175\175\175\175\211\031\031\031\031\031\074\074\074\074\067\ \067\067\067\067\110\103\103\103\103\139\139\139\139\182\175\175\ \175\175\175\211\031\031\031\031\031\074\074\074\074\074\067\067\ \067\067\110\103\103\103\103\103\139\139\139\182\182\175\175\175\ \218\211\037\037\031\031\031\080\080\074\074\074\073\073\073\110\ \110\109\109\103\103\250\250\250\250\182\182\181\181\181\218\217\ \037\037\037\037\037\080\080\080\080\073\073\073\073\073\109\109\ \109\109\109\250\250\250\250\251\181\181\181\181\217\217\037\037\ \037\037\037\080\080\080\080\073\073\073\073\073\109\109\109\109\ \109\250\250\250\250\251\181\181\181\181\217\217\037\037\037\037\ \037\080\080\080\080\073\073\073\073\073\109\109\109\109\109\250\ \250\250\250\251\181\181\181\181\224\217\044\044\044\044\044\080\ \080\080\080\080\080\080\073\116\116\116\116\152\152\152\251\251\ \251\251\252\181\181\181\224\217\043\043\043\043\043\080\080\080\ \080\080\079\079\079\116\115\115\115\115\152\152\151\151\151\252\ \187\187\187\181\224\223\043\043\043\043\043\043\086\079\079\079\ \079\079\079\079\115\115\115\115\115\151\151\151\151\151\187\187\ \187\187\230\223\043\043\043\043\043\086\086\079\079\079\079\079\ \079\079\115\115\115\115\115\151\151\151\151\151\187\187\187\187\ \230\223\043\043\043\043\043\086\086\086\086\079\079\079\079\079\ \115\115\115\115\115\151\151\151\151\151\151\187\187\187\230\223\ \050\050\050\049\049\086\086\086\086\086\086\079\079\122\122\122\ \115\115\158\158\157\157\194\194\194\230\230\230\230\223\049\049\ \049\049\049\049\086\086\085\085\085\085\085\085\121\121\121\121\ \121\157\157\157\157\157\193\193\193\193\193\229\020\020\020\020\ \020\056\056\056\056\056\056\056\055\092\092\092\092\091\128\128\ \128\128\164\164\164\164\164\163\200\200\020\020\020\020\020\020\ \056\056\056\056\056\056\055\092\092\092\092\091\128\128\128\128\ \164\164\164\164\163\163\200\200\020\020\020\020\020\020\056\056\ \056\056\056\056\056\055\092\092\092\091\128\128\128\128\164\164\ \164\164\163\163\200\199\020\020\020\020\020\020\020\056\056\056\ \056\056\056\055\092\092\092\092\128\128\128\128\164\164\164\164\ \163\163\200\199\020\020\020\020\020\020\020\020\098\056\056\056\ \056\056\092\092\092\092\128\128\128\128\164\164\164\163\163\163\ \200\199\026\020\020\020\020\062\062\062\098\098\098\098\098\098\ \134\134\134\134\134\134\170\170\170\170\170\207\207\206\206\206\ \026\026\026\020\020\062\062\062\062\098\098\098\098\098\134\134\ \134\134\134\134\170\170\170\170\170\170\170\206\206\206\026\026\ \026\026\020\062\062\062\062\062\098\098\098\098\098\134\134\134\ \134\134\134\170\170\170\170\170\170\206\206\206\026\026\026\026\ \068\068\062\062\062\062\062\062\098\098\098\098\134\134\134\134\ \134\134\170\170\170\170\170\206\206\206\026\026\026\026\026\068\ \068\062\062\062\062\062\098\098\098\098\098\134\134\134\134\134\ \170\170\170\170\170\169\206\206\026\026\026\026\026\068\068\068\ \062\062\062\062\062\098\098\098\098\097\134\134\134\134\170\170\ \170\170\170\169\206\206\026\026\026\026\026\068\068\068\062\062\ \062\062\062\098\098\098\098\097\134\134\134\134\170\170\170\170\ \169\169\206\206\025\025\026\026\026\068\068\068\068\068\062\062\ \061\061\098\098\097\097\097\097\134\134\133\133\170\170\169\169\ \169\205\032\032\025\025\026\068\068\068\068\068\068\068\061\104\ \104\104\140\140\140\140\140\176\176\176\176\176\169\169\212\212\ \032\032\032\032\032\074\068\068\068\068\068\068\068\104\104\104\ \104\140\140\140\140\140\176\176\176\176\176\212\212\212\032\032\ \032\032\032\074\074\074\068\068\068\068\068\104\104\104\104\104\ \140\140\140\140\176\176\176\176\176\175\212\212\032\032\032\032\ \032\074\074\074\068\068\068\068\067\104\104\104\104\104\140\140\ \140\140\176\176\176\176\175\175\212\212\031\031\031\032\032\074\ \074\074\074\074\067\067\067\110\110\104\104\103\146\146\140\182\ \182\139\176\175\175\175\175\211\038\038\038\038\038\074\074\074\ \074\074\074\074\067\110\110\110\110\146\146\146\146\182\182\182\ \182\182\175\175\218\218\038\038\038\038\038\074\074\074\074\074\ \074\074\067\110\110\110\110\146\146\146\146\146\182\182\182\182\ \182\218\218\218\038\038\038\038\038\080\080\074\074\074\074\074\ \074\110\110\110\110\110\146\146\146\146\251\182\182\182\182\181\ \218\218\038\038\038\038\038\080\080\080\074\074\074\074\074\116\ \110\110\110\152\146\146\146\251\251\251\182\182\182\181\218\218\ \044\044\044\044\044\080\080\080\080\080\080\080\073\116\116\116\ \116\152\152\152\251\251\251\251\252\181\181\181\224\217\044\044\ \044\044\044\080\080\080\080\080\080\080\073\116\116\116\116\109\ \152\152\152\251\251\251\252\188\253\181\224\224\044\044\044\044\ \044\080\080\080\080\080\080\080\080\116\116\116\116\116\152\152\ \152\152\252\252\252\188\253\181\224\224\044\044\044\044\043\087\ \080\080\080\080\080\080\080\116\116\116\116\115\152\152\152\152\ \151\188\188\188\253\187\224\224\044\043\043\043\043\087\080\080\ \080\080\080\080\079\079\116\116\115\115\115\152\152\152\151\253\ \253\253\253\187\224\224\043\043\043\043\043\086\086\086\086\079\ \079\079\079\079\122\115\115\115\115\158\151\151\151\151\151\187\ \187\187\230\223\050\050\050\050\050\086\086\086\086\086\086\086\ \079\122\122\122\122\115\158\158\158\158\194\194\194\194\194\230\ \230\230\050\050\049\049\049\086\086\086\086\086\086\086\085\122\ \122\122\122\121\158\158\158\158\157\194\194\194\194\193\230\230\ \020\020\020\020\020\056\056\056\056\056\056\056\056\092\092\092\ \092\092\128\128\128\128\128\164\164\164\164\164\200\200\020\020\ \020\020\020\020\056\056\056\056\056\056\056\092\092\092\092\092\ \128\128\128\128\128\164\164\164\164\164\200\200\020\020\020\020\ \020\020\020\056\056\056\056\056\056\056\092\092\092\092\128\128\ \128\128\128\164\164\164\164\163\200\200\020\020\020\020\020\020\ \020\056\056\056\056\056\056\056\092\092\092\092\128\128\128\128\ \128\164\164\164\164\163\200\200\020\020\020\020\020\020\020\020\ \099\056\056\056\056\056\056\092\092\092\092\128\128\128\128\164\ \164\164\164\163\200\200\026\020\020\020\020\062\062\062\098\098\ \098\098\098\098\135\134\134\134\134\134\134\128\170\170\170\207\ \207\207\206\206\026\026\020\020\020\062\062\062\062\098\098\098\ \098\098\098\134\134\134\134\134\134\134\170\170\170\170\170\207\ \206\206\026\026\026\026\020\062\062\062\062\062\098\098\098\098\ \098\098\134\134\134\134\134\134\170\170\170\170\170\207\206\206\ \026\026\026\026\069\068\062\062\062\062\062\062\098\098\098\098\ \098\134\134\134\134\134\170\170\170\170\170\206\206\206\026\026\ \026\026\026\068\068\062\062\062\062\062\062\098\098\098\098\134\ \134\134\134\134\134\170\170\170\170\170\206\206\026\026\026\026\ \026\068\068\068\062\062\062\062\062\098\098\098\098\098\134\134\ \134\134\134\170\170\170\170\170\206\206\026\026\026\026\026\068\ \068\068\062\062\062\062\062\098\098\098\098\098\134\134\134\134\ \134\170\170\170\170\170\206\206\026\026\026\026\026\068\068\068\ \068\062\062\062\062\062\098\098\098\098\140\134\134\134\134\170\ \170\170\170\169\206\206\032\032\026\026\026\068\068\068\068\068\ \068\068\062\104\104\104\104\140\140\140\140\140\176\176\176\176\ \176\169\212\212\032\032\032\032\026\075\068\068\068\068\068\068\ \068\104\104\104\104\140\140\140\140\140\176\176\176\176\176\176\ \212\212\032\032\032\032\032\074\074\068\068\068\068\068\068\104\ \104\104\104\104\140\140\140\140\140\176\176\176\176\176\212\212\ \032\032\032\032\032\074\074\068\068\068\068\068\068\104\104\104\ \104\104\140\140\140\140\140\176\176\176\176\176\212\212\032\032\ \032\032\032\074\074\074\074\068\068\068\068\110\104\104\104\104\ \104\140\140\140\140\176\176\176\176\175\218\212\038\038\038\038\ \032\074\074\074\074\074\074\074\110\110\110\110\110\104\146\146\ \146\146\182\182\182\182\182\175\218\218\038\038\038\038\038\074\ \074\074\074\074\074\074\074\110\110\110\110\110\146\146\146\146\ \182\182\182\182\182\182\218\218\038\038\038\038\038\074\074\074\ \074\074\074\074\074\110\110\110\110\110\146\146\146\146\146\182\ \182\182\182\182\218\218\038\038\038\038\038\038\074\074\074\074\ \074\074\074\110\110\110\110\110\146\146\146\146\146\182\182\182\ \182\182\218\218\038\038\038\038\038\080\080\080\080\074\074\074\ \074\116\116\110\110\110\152\152\146\146\146\252\182\182\182\182\ \224\218\044\044\044\044\044\080\080\080\080\080\080\080\080\116\ \116\116\116\116\152\152\152\152\252\252\252\188\253\181\224\224\ \044\044\044\044\044\080\080\080\080\080\080\080\080\116\116\116\ \116\116\152\152\152\152\152\252\252\188\253\254\224\224\044\044\ \044\044\044\087\080\080\080\080\080\080\080\116\116\116\116\116\ \152\152\152\152\152\188\188\188\253\254\224\224\044\044\044\044\ \044\087\080\080\080\080\080\080\080\116\116\116\116\116\152\152\ \152\152\152\253\253\253\253\254\224\224\044\044\043\043\043\087\ \087\087\086\080\080\080\080\079\116\116\116\115\115\152\152\152\ \151\151\254\254\254\254\230\224\050\050\050\050\050\086\086\086\ \086\086\086\086\086\122\122\122\122\158\158\158\158\158\194\194\ \194\194\194\230\230\230\050\050\050\050\050\086\086\086\086\086\ \086\086\086\122\122\122\122\122\158\158\158\158\158\194\194\194\ \194\194\230\230\020\020\020\020\020\057\056\056\056\056\056\056\ \056\092\092\092\092\092\128\128\128\128\128\164\164\164\164\164\ \200\200\020\020\020\020\020\020\056\056\056\056\056\056\056\056\ \092\092\092\092\128\128\128\128\128\164\164\164\164\164\200\200\ \020\020\020\020\020\020\020\056\056\056\056\056\056\056\092\092\ \092\092\092\128\128\128\128\164\164\164\164\164\200\200\020\020\ \020\020\020\020\020\020\056\056\056\056\056\056\056\092\092\092\ \092\128\128\128\128\164\164\164\164\164\200\200\020\020\020\020\ \020\020\020\020\099\056\056\056\056\056\056\092\092\092\092\128\ \128\128\128\128\164\164\164\164\200\200\027\020\020\020\020\063\ \063\063\099\099\099\099\098\056\135\135\135\134\134\171\171\171\ \128\207\207\207\207\207\207\206\026\026\020\020\020\063\062\062\ \062\099\098\098\098\098\098\135\135\134\134\134\134\134\171\170\ \170\170\170\207\206\206\026\026\026\020\020\063\062\062\062\062\ \098\098\098\098\098\098\098\134\134\134\134\134\134\170\170\170\ \170\207\206\206\026\026\026\026\069\069\062\062\062\062\062\062\ \098\098\098\098\098\134\134\134\134\134\134\170\170\170\170\207\ \206\206\026\026\026\026\026\069\069\062\062\062\062\062\062\098\ \098\098\098\098\134\134\134\134\134\170\170\170\170\170\206\206\ \026\026\026\026\026\069\068\068\062\062\062\062\062\098\098\098\ \098\098\134\134\134\134\134\170\170\170\170\170\206\206\026\026\ \026\026\026\069\068\068\062\062\062\062\062\098\098\098\098\098\ \134\134\134\134\134\170\170\170\170\170\206\206\026\026\026\026\ \026\068\068\068\068\062\062\062\062\062\098\098\098\098\098\134\ \134\134\134\170\170\170\170\170\206\206\032\026\026\026\026\026\ \068\068\068\068\068\068\062\104\104\104\104\098\140\140\140\140\ \134\176\176\176\176\170\212\212\032\032\032\026\026\075\068\068\ \068\068\068\068\068\104\104\104\104\104\140\140\140\140\140\176\ \176\176\176\176\212\212\032\032\032\032\032\075\075\068\068\068\ \068\068\068\104\104\104\104\104\140\140\140\140\140\176\176\176\ \176\176\212\212\032\032\032\032\032\075\075\068\068\068\068\068\ \068\104\104\104\104\104\140\140\140\140\140\176\176\176\176\176\ \212\212\032\032\032\032\032\074\074\074\074\068\068\068\068\068\ \104\104\104\104\104\140\140\140\140\140\176\176\176\176\212\212\ \038\038\032\032\032\074\074\074\074\074\074\074\068\110\110\110\ \110\104\146\146\146\146\140\182\182\182\182\176\218\218\038\038\ \038\038\038\081\074\074\074\074\074\074\074\110\110\110\110\110\ \146\146\146\146\146\182\182\182\182\182\218\218\038\038\038\038\ \038\081\074\074\074\074\074\074\074\110\110\110\110\110\146\146\ \146\146\146\182\182\182\182\182\218\218\038\038\038\038\038\081\ \074\074\074\074\074\074\074\110\110\110\110\110\146\146\146\146\ \146\182\182\182\182\182\218\218\038\038\038\038\038\038\081\074\ \074\074\074\074\074\074\110\110\110\110\110\146\146\146\146\146\ \182\182\182\182\225\218\044\044\044\044\038\087\080\080\080\080\ \080\080\080\116\116\116\116\110\152\152\152\152\146\188\188\188\ \253\182\224\224\044\044\044\044\044\087\080\080\080\080\080\080\ \080\116\116\116\116\116\152\152\152\152\152\188\188\188\253\254\ \224\224\044\044\044\044\044\087\080\080\080\080\080\080\080\116\ \116\116\116\116\152\152\152\152\152\188\188\188\253\254\224\224\ \044\044\044\044\044\087\080\080\080\080\080\080\080\116\116\116\ \116\116\152\152\152\152\152\253\253\253\253\254\224\224\044\044\ \044\044\044\087\087\087\087\080\080\080\080\080\116\116\116\116\ \116\152\152\152\152\152\254\254\254\254\255\224\050\050\050\050\ \050\087\086\086\086\086\086\086\086\122\122\122\122\122\158\158\ \158\158\195\194\194\194\194\255\230\230\050\050\050\050\050\086\ \086\086\086\086\086\086\086\122\122\122\122\122\158\158\158\158\ \158\194\194\194\194\194\230\230\020\020\020\020\020\057\057\056\ \056\056\056\056\056\092\092\092\092\092\128\128\128\128\128\164\ \164\164\164\164\200\200\020\020\020\020\020\020\057\056\056\056\ \056\056\056\056\092\092\092\092\092\128\128\128\128\128\164\164\ \164\164\200\200\020\020\020\020\020\020\020\057\056\056\056\056\ \056\056\092\092\092\092\092\128\128\128\128\128\164\164\164\164\ \200\200\020\020\020\020\020\020\020\020\056\056\056\056\056\056\ \056\092\092\092\092\128\128\128\128\128\164\164\164\164\200\200\ \020\020\020\020\020\020\020\020\099\056\056\056\056\056\056\092\ \092\092\092\128\128\128\128\128\164\164\164\164\200\200\027\020\ \020\020\020\063\063\063\099\099\099\099\098\135\135\135\135\135\ \092\171\171\171\171\207\207\207\207\207\207\200\027\027\020\020\ \020\063\062\062\062\099\099\099\098\098\135\135\135\135\134\134\ \171\171\171\170\170\170\170\207\207\206\026\026\027\020\020\063\ \062\062\062\062\098\098\098\098\098\098\098\134\134\134\134\134\ \134\170\170\170\170\207\207\206\026\026\026\026\069\069\062\062\ \062\062\062\062\098\098\098\098\098\134\134\134\134\134\134\170\ \170\170\170\207\207\206\026\026\026\026\026\069\069\062\062\062\ \062\062\062\098\098\098\098\098\134\134\134\134\134\170\170\170\ \170\170\206\206\026\026\026\026\026\069\069\068\062\062\062\062\ \062\098\098\098\098\098\134\134\134\134\134\170\170\170\170\170\ \206\206\026\026\026\026\026\069\069\068\062\062\062\062\062\062\ \098\098\098\098\134\134\134\134\134\134\170\170\170\170\206\206\ \026\026\026\026\026\068\068\068\068\062\062\062\062\062\098\098\ \098\098\098\134\134\134\134\134\170\170\170\170\206\206\032\026\ \026\026\026\075\068\068\068\068\068\062\062\104\104\104\098\098\ \140\140\140\140\134\134\176\176\176\170\213\212\032\032\032\026\ \026\075\075\068\068\068\068\068\068\104\104\104\104\104\140\140\ \140\140\140\176\176\176\176\176\212\212\032\032\032\032\032\075\ \075\068\068\068\068\068\068\104\104\104\104\104\140\140\140\140\ \140\176\176\176\176\176\212\212\032\032\032\032\032\075\075\068\ \068\068\068\068\068\068\104\104\104\104\140\140\140\140\140\176\ \176\176\176\176\212\212\032\032\032\032\032\075\075\074\068\068\ \068\068\068\068\104\104\104\104\104\140\140\140\140\140\176\176\ \176\176\219\212\038\032\032\032\032\032\074\074\074\074\074\068\ \068\110\110\110\104\104\146\146\146\140\140\140\182\182\182\176\ \219\218\038\038\038\038\038\081\074\074\074\074\074\074\074\110\ \110\110\110\110\146\146\146\146\146\182\182\182\182\182\218\218\ \038\038\038\038\038\081\081\074\074\074\074\074\074\110\110\110\ \110\110\146\146\146\146\146\182\182\182\182\182\218\218\038\038\ \038\038\038\081\081\074\074\074\074\074\074\110\110\110\110\110\ \110\146\146\146\146\182\182\182\182\182\218\218\038\038\038\038\ \038\081\081\074\074\074\074\074\074\074\110\110\110\110\110\146\ \146\146\146\146\182\182\182\182\225\218\044\038\038\038\038\087\ \080\080\080\080\080\074\074\074\116\116\116\110\110\152\152\152\ \146\253\253\253\253\182\225\224\044\044\044\044\044\087\080\080\ \080\080\080\080\080\116\116\116\116\116\152\152\152\152\152\253\ \253\253\253\254\224\224\044\044\044\044\044\087\080\080\080\080\ \080\080\080\116\116\116\116\116\152\152\152\152\152\253\253\253\ \253\254\224\224\044\044\044\044\044\087\080\080\080\080\080\080\ \080\116\116\116\116\116\152\152\152\152\152\253\253\253\253\254\ \255\224\044\044\044\044\044\087\087\087\087\080\080\080\080\080\ \116\116\116\116\116\152\152\152\152\152\254\254\254\254\255\224\ \050\050\050\050\050\087\087\087\087\086\086\086\086\123\122\122\ \122\159\158\158\158\158\195\194\194\194\255\255\255\230\050\050\ \050\050\050\050\086\086\086\086\086\086\086\122\122\122\122\122\ \158\158\158\158\158\194\194\194\194\194\230\230\020\020\020\020\ \020\057\057\057\057\056\056\056\056\056\092\092\092\092\092\128\ \128\128\128\128\164\164\164\164\201\200\020\020\020\020\020\020\ \057\057\057\056\056\056\056\056\092\092\092\092\092\128\128\128\ \128\128\164\164\164\164\201\200\020\020\020\020\020\020\020\057\ \057\057\056\056\056\056\056\092\092\092\092\092\128\128\128\128\ \128\164\164\164\201\200\020\020\020\020\020\020\020\057\057\057\ \057\056\056\056\056\092\092\092\092\092\128\128\128\128\128\164\ \164\164\201\200\020\020\020\020\020\020\020\020\099\057\057\057\ \056\056\056\056\056\092\092\092\128\128\128\128\128\164\164\164\ \201\200\027\020\020\020\020\063\063\063\099\099\099\099\099\135\ \135\135\135\135\135\171\171\171\171\171\207\207\207\207\207\200\ \027\027\020\020\020\063\063\063\063\099\099\099\099\099\135\135\ \135\135\135\171\171\171\171\171\207\207\207\207\207\206\027\027\ \027\027\020\063\063\063\063\099\099\099\099\099\098\135\135\135\ \135\134\171\171\171\171\207\207\207\207\207\206\027\027\027\027\ \069\069\063\063\063\063\062\099\099\099\098\098\098\135\135\134\ \134\134\171\171\171\207\207\207\207\206\026\026\027\027\027\069\ \069\069\063\062\062\062\062\098\098\098\098\098\135\134\134\134\ \134\134\170\170\170\170\207\206\026\026\026\027\027\069\069\069\ \062\062\062\062\062\098\098\098\098\098\098\134\134\134\134\134\ \170\170\170\170\207\206\026\026\026\026\027\069\069\069\069\062\ \062\062\062\062\098\098\098\098\098\134\134\134\134\134\170\170\ \170\170\207\206\026\026\026\026\026\069\069\069\069\062\062\062\ \062\062\062\098\098\098\098\098\134\134\134\134\134\170\170\170\ \170\206\026\026\026\026\026\075\069\069\069\068\068\062\062\062\ \062\062\098\098\098\098\134\134\134\134\134\170\170\170\213\206\ \032\032\026\026\026\075\075\068\068\068\068\068\062\062\104\104\ \104\104\141\140\140\140\140\177\176\176\176\176\213\212\032\032\ \032\032\026\075\075\075\068\068\068\068\068\062\104\104\104\104\ \104\140\140\140\140\140\176\176\176\176\213\212\032\032\032\032\ \026\075\075\075\068\068\068\068\068\068\104\104\104\104\104\140\ \140\140\140\140\176\176\176\176\213\212\032\032\032\032\032\075\ \075\075\075\068\068\068\068\068\104\104\104\104\104\140\140\140\ \140\140\176\176\176\176\176\212\032\032\032\032\032\075\075\075\ \075\075\068\068\068\068\111\104\104\104\104\104\104\140\140\140\ \140\176\176\176\219\212\038\038\032\032\032\081\081\074\074\074\ \074\074\068\068\110\110\110\104\104\146\146\146\146\183\182\182\ \182\182\219\218\038\038\038\038\038\081\081\081\074\074\074\074\ \074\074\110\110\110\110\104\146\146\146\146\146\182\182\182\182\ \219\218\038\038\038\038\038\081\081\081\074\074\074\074\074\074\ \110\110\110\110\110\146\146\146\146\146\182\182\182\182\219\218\ \038\038\038\038\038\081\081\081\081\074\074\074\074\074\110\110\ \110\110\110\146\146\146\146\146\182\182\182\182\225\218\038\038\ \038\038\038\081\081\081\081\074\074\074\074\074\117\110\110\110\ \110\153\146\146\146\146\146\182\182\182\225\218\044\044\038\038\ \038\087\087\087\081\080\080\080\074\074\116\116\116\116\110\152\ \152\152\146\146\254\254\254\254\225\224\044\044\044\044\044\087\ \087\087\087\080\080\080\080\080\116\116\116\116\116\152\152\152\ \152\152\254\254\254\254\255\224\044\044\044\044\044\087\087\087\ \087\080\080\080\080\080\116\116\116\116\116\152\152\152\152\152\ \254\254\254\254\255\224\044\044\044\044\044\087\087\087\087\080\ \080\080\080\080\116\116\116\116\116\152\152\152\152\152\254\254\ \254\254\255\224\051\051\051\051\051\087\087\087\087\087\087\087\ \080\123\123\123\123\116\159\159\159\159\195\195\195\255\255\255\ \255\224\050\050\050\050\050\050\086\086\086\086\086\086\086\086\ \122\122\122\122\122\158\158\158\158\158\194\194\194\194\194\230\ \021\021\021\021\021\057\057\057\057\057\057\057\056\093\093\093\ \093\092\129\129\129\129\165\165\165\165\165\201\201\201\021\021\ \021\021\021\021\057\057\057\057\057\057\056\093\093\093\093\092\ \129\129\129\129\165\165\165\165\165\201\201\201\021\021\021\021\ \021\021\021\057\057\057\057\057\057\056\093\093\093\093\129\129\ \129\129\165\165\165\165\165\201\201\201\021\021\021\021\021\021\ \021\057\057\057\057\057\057\057\093\093\093\093\092\129\129\129\ \129\165\165\165\165\201\201\201\021\021\021\021\021\021\021\021\ \099\057\057\057\057\057\056\093\093\093\092\129\129\129\129\165\ \165\165\165\201\201\201\027\021\021\021\021\063\063\063\099\099\ \099\099\099\099\135\135\135\135\135\171\171\171\171\171\171\207\ \207\207\207\207\027\027\021\021\021\063\063\063\063\099\099\099\ \099\099\135\135\135\135\135\135\171\171\171\171\171\171\207\207\ \207\207\027\027\027\027\021\063\063\063\063\063\099\099\099\099\ \099\135\135\135\135\135\171\171\171\171\171\171\207\207\207\207\ \027\027\027\027\069\069\063\063\063\063\063\099\099\099\099\099\ \099\135\135\135\135\171\171\171\171\171\207\207\207\207\027\027\ \027\027\027\069\069\063\063\063\063\063\099\099\099\099\099\135\ \135\135\135\135\171\171\171\171\171\207\207\207\027\027\027\027\ \027\069\069\069\063\063\063\063\063\099\099\099\099\098\135\135\ \135\135\171\171\171\171\171\207\207\207\027\027\027\027\027\069\ \069\069\063\063\063\063\063\099\099\099\099\098\135\135\135\135\ \134\171\171\171\171\207\207\207\026\026\027\027\027\069\069\069\ \069\069\063\063\062\062\099\099\099\098\098\135\135\135\134\134\ \171\171\171\170\170\207\033\033\026\027\027\069\069\069\069\069\ \069\069\062\105\105\105\105\141\141\141\141\141\177\177\177\177\ \177\213\213\213\033\033\033\033\026\075\075\069\069\069\069\069\ \069\105\105\105\105\141\141\141\141\141\177\177\177\177\177\213\ \213\213\033\033\033\033\033\075\075\075\069\069\069\069\069\105\ \105\105\105\105\141\141\141\141\177\177\177\177\177\213\213\213\ \033\033\033\033\033\075\075\075\069\069\069\069\069\105\105\105\ \105\105\141\141\141\141\140\177\177\177\177\213\213\213\032\032\ \033\033\033\075\075\075\075\075\068\068\068\111\111\105\105\104\ \104\147\141\183\140\140\183\177\219\176\176\213\039\039\039\032\ \032\075\075\075\075\075\075\075\068\111\111\111\111\104\147\147\ \147\183\183\183\183\183\219\219\219\219\039\039\039\039\039\081\ \075\075\075\075\075\075\075\111\111\111\111\147\147\147\147\147\ \183\183\183\183\183\219\219\219\039\039\039\039\039\081\081\081\ \075\075\075\075\075\111\111\111\111\111\147\147\147\147\147\183\ \183\183\183\219\219\219\039\039\039\039\039\081\081\081\081\075\ \075\075\075\111\111\111\111\153\147\147\147\147\147\183\183\183\ \183\219\219\219\045\045\045\039\039\081\081\081\081\081\081\074\ \074\117\117\117\110\110\153\153\147\147\189\189\189\225\225\225\ \225\218\045\045\045\045\045\081\081\081\081\081\081\081\074\117\ \117\117\117\110\153\153\153\153\189\189\189\189\225\225\225\225\ \045\045\045\045\045\081\081\081\081\081\081\081\081\117\117\117\ \117\153\153\153\153\153\189\189\189\189\189\225\225\225\045\045\ \045\045\045\087\081\081\081\081\081\081\081\117\117\117\117\117\ \153\153\153\153\195\189\189\189\189\255\225\225\045\045\045\045\ \045\087\087\087\087\081\081\081\081\117\117\117\117\159\159\153\ \153\153\195\189\189\189\255\255\255\225\051\051\051\051\051\087\ \087\087\087\087\087\087\080\123\123\123\123\116\159\159\159\159\ \195\195\195\255\255\255\255\224\051\051\051\051\051\087\087\087\ \087\087\087\087\080\123\123\123\123\116\159\159\159\159\195\195\ \195\195\255\255\255\231\051\051\051\051\051\087\087\087\087\087\ \087\087\087\123\123\123\123\123\159\159\159\159\158\195\195\195\ \195\194\231\231\021\021\021\021\021\057\057\057\057\057\057\057\ \057\093\093\093\093\093\129\129\129\129\129\165\165\165\165\165\ \201\201\021\021\021\021\021\021\057\057\057\057\057\057\057\057\ \093\093\093\093\093\129\129\129\129\165\165\165\165\165\201\201\ \021\021\021\021\021\021\021\057\057\057\057\057\057\057\093\093\ \093\093\093\129\129\129\129\129\165\165\165\165\201\201\021\021\ \021\021\021\021\021\021\057\057\057\057\057\057\057\093\093\093\ \093\129\129\129\129\129\165\165\165\165\201\201\021\021\021\021\ \021\021\021\021\099\057\057\057\057\057\057\057\093\093\093\093\ \129\129\129\129\165\165\165\165\201\201\027\021\021\021\021\063\ \063\063\099\099\099\099\099\057\057\057\135\135\135\135\129\129\ \129\171\171\171\165\165\207\207\027\027\021\021\021\063\063\063\ \063\099\099\099\099\099\099\135\135\135\135\135\135\135\171\171\ \171\171\171\171\207\207\027\027\027\021\021\063\063\063\063\063\ \099\099\099\099\099\099\099\135\135\135\135\135\171\171\171\171\ \171\171\207\207\027\027\027\027\069\069\063\063\063\063\063\063\ \099\099\099\099\099\135\135\135\135\135\135\171\171\171\171\171\ \207\207\027\027\027\027\027\069\069\063\063\063\063\063\063\099\ \099\099\099\099\135\135\135\135\135\171\171\171\171\171\207\207\ \027\027\027\027\027\069\069\069\063\063\063\063\063\099\099\099\ \099\099\135\135\135\135\135\171\171\171\171\171\207\207\027\027\ \027\027\027\069\069\069\063\063\063\063\063\099\099\099\099\099\ \135\135\135\135\135\171\171\171\171\171\207\207\027\027\027\027\ \027\069\069\069\069\063\063\063\063\063\099\099\099\099\099\135\ \135\135\135\135\171\171\171\171\207\207\033\027\027\027\027\027\ \069\069\069\069\069\069\063\105\105\105\105\141\141\141\141\141\ \135\177\177\177\177\171\213\213\033\033\033\027\027\027\069\069\ \069\069\069\069\069\105\105\105\105\105\141\141\141\141\141\177\ \177\177\177\177\213\213\033\033\033\033\027\027\075\069\069\069\ \069\069\069\105\105\105\105\105\141\141\141\141\141\177\177\177\ \177\177\213\213\033\033\033\033\033\075\075\069\069\069\069\069\ \069\105\105\105\105\105\141\141\141\141\141\177\177\177\177\177\ \213\213\033\033\033\033\033\075\075\075\075\069\069\069\069\111\ \105\105\105\105\105\141\141\141\141\141\177\177\177\177\213\213\ \039\033\033\033\033\075\075\075\075\075\075\075\069\111\111\111\ \111\105\147\147\147\147\141\183\183\183\183\177\219\219\039\039\ \039\039\033\075\075\075\075\075\075\075\075\111\111\111\111\111\ \147\147\147\147\147\183\183\183\183\183\219\219\039\039\039\039\ \039\039\075\075\075\075\075\075\075\111\111\111\111\111\147\147\ \147\147\147\183\183\183\183\183\219\219\039\039\039\039\039\039\ \075\075\075\075\075\075\075\111\111\111\111\111\147\147\147\147\ \147\183\183\183\183\183\219\219\039\039\039\039\039\039\081\081\ \075\075\075\075\075\075\111\111\111\111\111\147\147\147\147\147\ \183\183\183\183\183\219\045\045\039\039\039\081\081\081\081\081\ \081\081\075\117\117\117\117\111\153\153\153\153\147\189\189\189\ \189\183\225\225\045\045\045\045\045\081\081\081\081\081\081\081\ \081\117\117\117\117\117\153\153\153\153\153\189\189\189\189\189\ \225\225\045\045\045\045\045\081\081\081\081\081\081\081\081\117\ \117\117\117\117\153\153\153\153\153\189\189\189\189\189\225\225\ \045\045\045\045\045\045\081\081\081\081\081\081\081\117\117\117\ \117\117\153\153\153\153\153\189\189\189\189\189\225\225\045\045\ \045\045\045\045\081\081\081\081\081\081\081\081\117\117\117\117\ \117\153\153\153\153\153\189\189\189\189\189\225\051\051\051\051\ \051\087\087\087\087\087\087\087\087\123\123\123\123\123\159\159\ \159\159\153\195\195\195\195\189\231\231\051\051\051\051\051\087\ \087\087\087\087\087\087\087\123\123\123\123\123\159\159\159\159\ \159\195\195\195\195\195\231\231" type map = { count_r : int; count_g : int; count_b : int; index_r : string; index_g : string; index_b : string; map : string; } let colors_16 = { count_r = 6; count_g = 6; count_b = 6; index_r = data0; index_g = data0; index_b = data1; map = data2; } let colors_88 = { count_r = 11; count_g = 11; count_b = 11; index_r = data3; index_g = data3; index_b = data3; map = data4; } let colors_256 = { count_r = 30; count_g = 30; count_b = 30; index_r = data5; index_g = data5; index_b = data5; map = data6; } lambda-term-1.9/src/lTerm_config.h.ab000066400000000000000000000004231254222632000174760ustar00rootroot00000000000000/* * lTerm_config.h * -------------- * Copyright : (c) 2014, Jeremie Dimino * Licence : BSD3 * * This file is a part of lambda-term. */ #ifndef __LTERM_CONFIG_H #define __LTERM_CONFIG_H #define SYS_$(system) #endif /* __LTERM_CONFIG_H */ lambda-term-1.9/src/lTerm_draw.ml000066400000000000000000000642321254222632000167760ustar00rootroot00000000000000(* * lTerm_draw.ml * ------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) open CamomileLibraryDyn.Camomile open LTerm_geom open LTerm_style let unsafe_get matrix line column = Array.unsafe_get (Array.unsafe_get matrix line) column type point = { mutable char : UChar.t; mutable bold : bool; mutable underline : bool; mutable blink : bool; mutable reverse : bool; mutable foreground : LTerm_style.color; mutable background : LTerm_style.color; } type matrix = point array array let make_matrix size = Array.init size.rows (fun _ -> Array.init size.cols (fun _ -> { char = UChar.of_char ' '; bold = false; underline = false; blink = false; reverse = false; foreground = LTerm_style.default; background = LTerm_style.default; })) let set_style point style = begin match LTerm_style.bold style with | Some x -> point.bold <- x | None -> () end; begin match LTerm_style.underline style with | Some x -> point.underline <- x | None -> () end; begin match LTerm_style.blink style with | Some x -> point.blink <- x | None -> () end; begin match LTerm_style.reverse style with | Some x -> point.reverse <- x | None -> () end; begin match LTerm_style.foreground style with | Some x -> point.foreground <- x | None -> () end; begin match LTerm_style.background style with | Some x -> point.background <- x | None -> () end let maybe_set_style point style = match style with | Some style -> set_style point style | None -> () type context = { ctx_matrix : matrix; ctx_matrix_size : size; ctx_row1 : int; ctx_col1 : int; ctx_row2 : int; ctx_col2 : int; } let context m s = if Array.length m <> s.rows then invalid_arg "LTerm_draw.context"; Array.iter (fun l -> if Array.length l <> s.cols then invalid_arg "LTerm_draw.context") m; { ctx_matrix = m; ctx_matrix_size = s; ctx_row1 = 0; ctx_col1 = 0; ctx_row2 = s.rows; ctx_col2 = s.cols; } let size ctx = { rows = ctx.ctx_row2 - ctx.ctx_row1; cols = ctx.ctx_col2 - ctx.ctx_col1; } exception Out_of_bounds let sub ctx rect = if rect.row1 < 0 || rect.col1 < 0 || rect.row1 > rect.row2 || rect.col1 > rect.col2 then raise Out_of_bounds; let row1 = ctx.ctx_row1 + rect.row1 and col1 = ctx.ctx_col1 + rect.col1 and row2 = ctx.ctx_row1 + rect.row2 and col2 = ctx.ctx_col1 + rect.col2 in if row2 > ctx.ctx_row2 || col2 > ctx.ctx_col2 then raise Out_of_bounds; { ctx with ctx_row1 = row1; ctx_col1 = col1; ctx_row2 = row2; ctx_col2 = col2 } let space = UChar.of_char ' ' let newline = UChar.of_char '\n' let clear ctx = for row = ctx.ctx_row1 to ctx.ctx_row2 - 1 do for col = ctx.ctx_col1 to ctx.ctx_col2 - 1 do let point = unsafe_get ctx.ctx_matrix row col in point.char <- space; point.bold <- false; point.underline <- false; point.blink <- false; point.reverse <- false; point.foreground <- LTerm_style.default; point.background <- LTerm_style.default done done let fill ctx ?style ch = match style with | Some style -> for row = ctx.ctx_row1 to ctx.ctx_row2 - 1 do for col = ctx.ctx_col1 to ctx.ctx_col2 - 1 do let point = unsafe_get ctx.ctx_matrix row col in point.char <- ch; set_style point style done done | None -> for row = ctx.ctx_row1 to ctx.ctx_row2 - 1 do for col = ctx.ctx_col1 to ctx.ctx_col2 - 1 do (unsafe_get ctx.ctx_matrix row col).char <- ch done done let fill_style ctx style = for row = ctx.ctx_row1 to ctx.ctx_row2 - 1 do for col = ctx.ctx_col1 to ctx.ctx_col2 - 1 do set_style (unsafe_get ctx.ctx_matrix row col) style done done let point ctx row col = if row < 0 || col < 0 then raise Out_of_bounds; let row = ctx.ctx_row1 + row and col = ctx.ctx_col1 + col in if row >= ctx.ctx_row2 || col >= ctx.ctx_col2 then raise Out_of_bounds; unsafe_get ctx.ctx_matrix row col let draw_char ctx row col ?style ch = if row >= 0 && col >= 0 then begin let row = ctx.ctx_row1 + row and col = ctx.ctx_col1 + col in if row < ctx.ctx_row2 && col < ctx.ctx_col2 then let point = unsafe_get ctx.ctx_matrix row col in point.char <- ch; maybe_set_style point style end let draw_string ctx row col ?style str = let rec loop row col ofs = if ofs < String.length str then begin let ch, ofs = Zed_utf8.unsafe_extract_next str ofs in if ch = newline then loop (row + 1) ctx.ctx_col1 ofs else begin if row >= ctx.ctx_row1 && row < ctx.ctx_row2 && col >= ctx.ctx_col1 && col < ctx.ctx_col2 then begin let point = unsafe_get ctx.ctx_matrix row col in point.char <- ch; maybe_set_style point style end; loop row (col + 1) ofs end end in loop (ctx.ctx_row1 + row) (ctx.ctx_col1 + col) 0 let draw_styled ctx row col ?style str = let rec loop row col idx = if idx < Array.length str then begin let ch, ch_style = Array.unsafe_get str idx in if ch = newline then loop (row + 1) ctx.ctx_col1 (idx + 1) else begin if row >= ctx.ctx_row1 && row < ctx.ctx_row2 && col >= ctx.ctx_col1 && col < ctx.ctx_col2 then begin let point = unsafe_get ctx.ctx_matrix row col in point.char <- ch; maybe_set_style point style; set_style point ch_style end; loop row (col + 1) (idx + 1) end end in loop (ctx.ctx_row1 + row) (ctx.ctx_col1 + col) 0 let draw_string_aligned ctx row alignment ?style str = let rec line_length ofs len = if ofs = String.length str then len else let ch, ofs = Zed_utf8.unsafe_extract_next str ofs in if ch = newline then len else line_length ofs (len + 1) in let rec loop row col ofs = if ofs < String.length str then begin let ch, ofs = Zed_utf8.unsafe_extract_next str ofs in if ch = newline then ofs else begin if row >= ctx.ctx_row1 && row < ctx.ctx_row2 && col >= ctx.ctx_col1 && col < ctx.ctx_col2 then begin let point = unsafe_get ctx.ctx_matrix row col in point.char <- ch; maybe_set_style point style end; loop row (col + 1) ofs end end else ofs in let rec loop_lines row ofs = if ofs < String.length str then begin let ofs = loop row (match alignment with | H_align_left -> ctx.ctx_col1 | H_align_center -> ctx.ctx_col1 + (ctx.ctx_col2 - ctx.ctx_col1 - line_length ofs 0) / 2 | H_align_right -> ctx.ctx_col2 - line_length ofs 0) ofs in loop_lines (row + 1) ofs end in loop_lines (ctx.ctx_row1 + row) 0 let draw_styled_aligned ctx row alignment ?style str = let rec line_length idx len = if idx = Array.length str then len else if fst (Array.unsafe_get str idx) = newline then len else line_length (idx + 1) (len + 1) in let rec loop row col idx = if idx < Array.length str then begin let ch, ch_style = Array.unsafe_get str idx in if ch = newline then idx + 1 else begin if row >= ctx.ctx_row1 && row < ctx.ctx_row2 && col >= ctx.ctx_col1 && col < ctx.ctx_col2 then begin let point = unsafe_get ctx.ctx_matrix row col in point.char <- ch; maybe_set_style point style; set_style point ch_style end; loop row (col + 1) (idx + 1) end end else idx in let rec loop_lines row idx = if idx < Array.length str then begin let idx = loop row (match alignment with | H_align_left -> ctx.ctx_col1 | H_align_center -> ctx.ctx_col1 + (ctx.ctx_col2 - ctx.ctx_col1 - line_length idx 0) / 2 | H_align_right -> ctx.ctx_col2 - line_length idx 0) idx in loop_lines (row + 1) idx end in loop_lines (ctx.ctx_row1 + row) 0 type connection = | Blank | Light | Heavy type piece = { top : connection; bottom : connection; left : connection; right : connection } let piece_of_char char = match UChar.code char with | 0x2500 -> Some { top = Blank; bottom = Blank; left = Light; right = Light } | 0x2501 -> Some { top = Blank; bottom = Blank; left = Heavy; right = Heavy } | 0x2502 -> Some { top = Light; bottom = Light; left = Blank; right = Blank } | 0x2503 -> Some { top = Heavy; bottom = Heavy; left = Blank; right = Blank } | 0x250c -> Some { top = Blank; bottom = Light; left = Blank; right = Light } | 0x250d -> Some { top = Blank; bottom = Light; left = Blank; right = Heavy } | 0x250e -> Some { top = Blank; bottom = Heavy; left = Blank; right = Light } | 0x250f -> Some { top = Blank; bottom = Heavy; left = Blank; right = Heavy } | 0x2510 -> Some { top = Blank; bottom = Light; left = Light; right = Blank } | 0x2511 -> Some { top = Blank; bottom = Light; left = Heavy; right = Blank } | 0x2512 -> Some { top = Blank; bottom = Heavy; left = Light; right = Blank } | 0x2513 -> Some { top = Blank; bottom = Heavy; left = Heavy; right = Blank } | 0x2514 -> Some { top = Light; bottom = Blank; left = Blank; right = Light } | 0x2515 -> Some { top = Light; bottom = Blank; left = Blank; right = Heavy } | 0x2516 -> Some { top = Heavy; bottom = Blank; left = Blank; right = Light } | 0x2517 -> Some { top = Heavy; bottom = Blank; left = Blank; right = Heavy } | 0x2518 -> Some { top = Light; bottom = Blank; left = Light; right = Blank } | 0x2519 -> Some { top = Light; bottom = Blank; left = Heavy; right = Blank } | 0x251a -> Some { top = Heavy; bottom = Blank; left = Light; right = Blank } | 0x251b -> Some { top = Heavy; bottom = Blank; left = Heavy; right = Blank } | 0x251c -> Some { top = Light; bottom = Light; left = Blank; right = Light } | 0x251d -> Some { top = Light; bottom = Light; left = Blank; right = Heavy } | 0x251e -> Some { top = Heavy; bottom = Light; left = Blank; right = Light } | 0x251f -> Some { top = Light; bottom = Heavy; left = Blank; right = Light } | 0x2520 -> Some { top = Heavy; bottom = Heavy; left = Blank; right = Light } | 0x2521 -> Some { top = Heavy; bottom = Light; left = Blank; right = Heavy } | 0x2522 -> Some { top = Light; bottom = Heavy; left = Blank; right = Heavy } | 0x2523 -> Some { top = Heavy; bottom = Heavy; left = Blank; right = Heavy } | 0x2524 -> Some { top = Light; bottom = Light; left = Light; right = Blank } | 0x2525 -> Some { top = Light; bottom = Light; left = Heavy; right = Blank } | 0x2526 -> Some { top = Heavy; bottom = Light; left = Light; right = Blank } | 0x2527 -> Some { top = Light; bottom = Heavy; left = Light; right = Blank } | 0x2528 -> Some { top = Heavy; bottom = Heavy; left = Light; right = Blank } | 0x2529 -> Some { top = Heavy; bottom = Light; left = Heavy; right = Blank } | 0x252a -> Some { top = Light; bottom = Heavy; left = Heavy; right = Blank } | 0x252b -> Some { top = Heavy; bottom = Heavy; left = Heavy; right = Blank } | 0x252c -> Some { top = Blank; bottom = Light; left = Light; right = Light } | 0x252d -> Some { top = Blank; bottom = Light; left = Heavy; right = Light } | 0x252e -> Some { top = Blank; bottom = Light; left = Light; right = Heavy } | 0x252f -> Some { top = Blank; bottom = Light; left = Heavy; right = Heavy } | 0x2530 -> Some { top = Blank; bottom = Heavy; left = Light; right = Light } | 0x2531 -> Some { top = Blank; bottom = Heavy; left = Heavy; right = Light } | 0x2532 -> Some { top = Blank; bottom = Heavy; left = Light; right = Heavy } | 0x2533 -> Some { top = Blank; bottom = Heavy; left = Heavy; right = Heavy } | 0x2534 -> Some { top = Light; bottom = Blank; left = Light; right = Light } | 0x2535 -> Some { top = Light; bottom = Blank; left = Heavy; right = Light } | 0x2536 -> Some { top = Light; bottom = Blank; left = Light; right = Heavy } | 0x2537 -> Some { top = Light; bottom = Blank; left = Heavy; right = Heavy } | 0x2538 -> Some { top = Heavy; bottom = Blank; left = Light; right = Light } | 0x2539 -> Some { top = Heavy; bottom = Blank; left = Heavy; right = Light } | 0x253a -> Some { top = Heavy; bottom = Blank; left = Light; right = Heavy } | 0x253b -> Some { top = Heavy; bottom = Blank; left = Heavy; right = Heavy } | 0x253c -> Some { top = Light; bottom = Light; left = Light; right = Light } | 0x253d -> Some { top = Light; bottom = Light; left = Heavy; right = Light } | 0x253e -> Some { top = Light; bottom = Light; left = Light; right = Heavy } | 0x253f -> Some { top = Light; bottom = Light; left = Heavy; right = Heavy } | 0x2540 -> Some { top = Heavy; bottom = Light; left = Light; right = Light } | 0x2541 -> Some { top = Light; bottom = Heavy; left = Light; right = Light } | 0x2542 -> Some { top = Heavy; bottom = Heavy; left = Light; right = Light } | 0x2543 -> Some { top = Heavy; bottom = Light; left = Heavy; right = Light } | 0x2544 -> Some { top = Heavy; bottom = Light; left = Light; right = Heavy } | 0x2545 -> Some { top = Light; bottom = Heavy; left = Heavy; right = Light } | 0x2546 -> Some { top = Light; bottom = Heavy; left = Light; right = Heavy } | 0x2547 -> Some { top = Heavy; bottom = Light; left = Heavy; right = Heavy } | 0x2548 -> Some { top = Light; bottom = Heavy; left = Heavy; right = Heavy } | 0x2549 -> Some { top = Heavy; bottom = Heavy; left = Heavy; right = Light } | 0x254a -> Some { top = Heavy; bottom = Heavy; left = Light; right = Heavy } | 0x254b -> Some { top = Heavy; bottom = Heavy; left = Heavy; right = Heavy } | 0x2574 -> Some { top = Blank; bottom = Blank; left = Light; right = Blank } | 0x2575 -> Some { top = Light; bottom = Blank; left = Blank; right = Blank } | 0x2576 -> Some { top = Blank; bottom = Blank; left = Blank; right = Light } | 0x2577 -> Some { top = Blank; bottom = Light; left = Blank; right = Blank } | 0x2578 -> Some { top = Blank; bottom = Blank; left = Heavy; right = Blank } | 0x2579 -> Some { top = Heavy; bottom = Blank; left = Blank; right = Blank } | 0x257a -> Some { top = Blank; bottom = Blank; left = Blank; right = Heavy } | 0x257b -> Some { top = Blank; bottom = Heavy; left = Blank; right = Blank } | 0x257c -> Some { top = Blank; bottom = Blank; left = Light; right = Heavy } | 0x257d -> Some { top = Light; bottom = Heavy; left = Blank; right = Blank } | 0x257e -> Some { top = Blank; bottom = Blank; left = Heavy; right = Light } | 0x257f -> Some { top = Heavy; bottom = Light; left = Blank; right = Blank } | _ -> None let char_of_piece = function | { top = Blank; bottom = Blank; left = Blank; right = Blank } -> UChar.of_int 0x0020 | { top = Blank; bottom = Blank; left = Light; right = Light } -> UChar.of_int 0x2500 | { top = Blank; bottom = Blank; left = Heavy; right = Heavy } -> UChar.of_int 0x2501 | { top = Light; bottom = Light; left = Blank; right = Blank } -> UChar.of_int 0x2502 | { top = Heavy; bottom = Heavy; left = Blank; right = Blank } -> UChar.of_int 0x2503 | { top = Blank; bottom = Light; left = Blank; right = Light } -> UChar.of_int 0x250c | { top = Blank; bottom = Light; left = Blank; right = Heavy } -> UChar.of_int 0x250d | { top = Blank; bottom = Heavy; left = Blank; right = Light } -> UChar.of_int 0x250e | { top = Blank; bottom = Heavy; left = Blank; right = Heavy } -> UChar.of_int 0x250f | { top = Blank; bottom = Light; left = Light; right = Blank } -> UChar.of_int 0x2510 | { top = Blank; bottom = Light; left = Heavy; right = Blank } -> UChar.of_int 0x2511 | { top = Blank; bottom = Heavy; left = Light; right = Blank } -> UChar.of_int 0x2512 | { top = Blank; bottom = Heavy; left = Heavy; right = Blank } -> UChar.of_int 0x2513 | { top = Light; bottom = Blank; left = Blank; right = Light } -> UChar.of_int 0x2514 | { top = Light; bottom = Blank; left = Blank; right = Heavy } -> UChar.of_int 0x2515 | { top = Heavy; bottom = Blank; left = Blank; right = Light } -> UChar.of_int 0x2516 | { top = Heavy; bottom = Blank; left = Blank; right = Heavy } -> UChar.of_int 0x2517 | { top = Light; bottom = Blank; left = Light; right = Blank } -> UChar.of_int 0x2518 | { top = Light; bottom = Blank; left = Heavy; right = Blank } -> UChar.of_int 0x2519 | { top = Heavy; bottom = Blank; left = Light; right = Blank } -> UChar.of_int 0x251a | { top = Heavy; bottom = Blank; left = Heavy; right = Blank } -> UChar.of_int 0x251b | { top = Light; bottom = Light; left = Blank; right = Light } -> UChar.of_int 0x251c | { top = Light; bottom = Light; left = Blank; right = Heavy } -> UChar.of_int 0x251d | { top = Heavy; bottom = Light; left = Blank; right = Light } -> UChar.of_int 0x251e | { top = Light; bottom = Heavy; left = Blank; right = Light } -> UChar.of_int 0x251f | { top = Heavy; bottom = Heavy; left = Blank; right = Light } -> UChar.of_int 0x2520 | { top = Heavy; bottom = Light; left = Blank; right = Heavy } -> UChar.of_int 0x2521 | { top = Light; bottom = Heavy; left = Blank; right = Heavy } -> UChar.of_int 0x2522 | { top = Heavy; bottom = Heavy; left = Blank; right = Heavy } -> UChar.of_int 0x2523 | { top = Light; bottom = Light; left = Light; right = Blank } -> UChar.of_int 0x2524 | { top = Light; bottom = Light; left = Heavy; right = Blank } -> UChar.of_int 0x2525 | { top = Heavy; bottom = Light; left = Light; right = Blank } -> UChar.of_int 0x2526 | { top = Light; bottom = Heavy; left = Light; right = Blank } -> UChar.of_int 0x2527 | { top = Heavy; bottom = Heavy; left = Light; right = Blank } -> UChar.of_int 0x2528 | { top = Heavy; bottom = Light; left = Heavy; right = Blank } -> UChar.of_int 0x2529 | { top = Light; bottom = Heavy; left = Heavy; right = Blank } -> UChar.of_int 0x252a | { top = Heavy; bottom = Heavy; left = Heavy; right = Blank } -> UChar.of_int 0x252b | { top = Blank; bottom = Light; left = Light; right = Light } -> UChar.of_int 0x252c | { top = Blank; bottom = Light; left = Heavy; right = Light } -> UChar.of_int 0x252d | { top = Blank; bottom = Light; left = Light; right = Heavy } -> UChar.of_int 0x252e | { top = Blank; bottom = Light; left = Heavy; right = Heavy } -> UChar.of_int 0x252f | { top = Blank; bottom = Heavy; left = Light; right = Light } -> UChar.of_int 0x2530 | { top = Blank; bottom = Heavy; left = Heavy; right = Light } -> UChar.of_int 0x2531 | { top = Blank; bottom = Heavy; left = Light; right = Heavy } -> UChar.of_int 0x2532 | { top = Blank; bottom = Heavy; left = Heavy; right = Heavy } -> UChar.of_int 0x2533 | { top = Light; bottom = Blank; left = Light; right = Light } -> UChar.of_int 0x2534 | { top = Light; bottom = Blank; left = Heavy; right = Light } -> UChar.of_int 0x2535 | { top = Light; bottom = Blank; left = Light; right = Heavy } -> UChar.of_int 0x2536 | { top = Light; bottom = Blank; left = Heavy; right = Heavy } -> UChar.of_int 0x2537 | { top = Heavy; bottom = Blank; left = Light; right = Light } -> UChar.of_int 0x2538 | { top = Heavy; bottom = Blank; left = Heavy; right = Light } -> UChar.of_int 0x2539 | { top = Heavy; bottom = Blank; left = Light; right = Heavy } -> UChar.of_int 0x253a | { top = Heavy; bottom = Blank; left = Heavy; right = Heavy } -> UChar.of_int 0x253b | { top = Light; bottom = Light; left = Light; right = Light } -> UChar.of_int 0x253c | { top = Light; bottom = Light; left = Heavy; right = Light } -> UChar.of_int 0x253d | { top = Light; bottom = Light; left = Light; right = Heavy } -> UChar.of_int 0x253e | { top = Light; bottom = Light; left = Heavy; right = Heavy } -> UChar.of_int 0x253f | { top = Heavy; bottom = Light; left = Light; right = Light } -> UChar.of_int 0x2540 | { top = Light; bottom = Heavy; left = Light; right = Light } -> UChar.of_int 0x2541 | { top = Heavy; bottom = Heavy; left = Light; right = Light } -> UChar.of_int 0x2542 | { top = Heavy; bottom = Light; left = Heavy; right = Light } -> UChar.of_int 0x2543 | { top = Heavy; bottom = Light; left = Light; right = Heavy } -> UChar.of_int 0x2544 | { top = Light; bottom = Heavy; left = Heavy; right = Light } -> UChar.of_int 0x2545 | { top = Light; bottom = Heavy; left = Light; right = Heavy } -> UChar.of_int 0x2546 | { top = Heavy; bottom = Light; left = Heavy; right = Heavy } -> UChar.of_int 0x2547 | { top = Light; bottom = Heavy; left = Heavy; right = Heavy } -> UChar.of_int 0x2548 | { top = Heavy; bottom = Heavy; left = Heavy; right = Light } -> UChar.of_int 0x2549 | { top = Heavy; bottom = Heavy; left = Light; right = Heavy } -> UChar.of_int 0x254a | { top = Heavy; bottom = Heavy; left = Heavy; right = Heavy } -> UChar.of_int 0x254b | { top = Blank; bottom = Blank; left = Light; right = Blank } -> UChar.of_int 0x2574 | { top = Light; bottom = Blank; left = Blank; right = Blank } -> UChar.of_int 0x2575 | { top = Blank; bottom = Blank; left = Blank; right = Light } -> UChar.of_int 0x2576 | { top = Blank; bottom = Light; left = Blank; right = Blank } -> UChar.of_int 0x2577 | { top = Blank; bottom = Blank; left = Heavy; right = Blank } -> UChar.of_int 0x2578 | { top = Heavy; bottom = Blank; left = Blank; right = Blank } -> UChar.of_int 0x2579 | { top = Blank; bottom = Blank; left = Blank; right = Heavy } -> UChar.of_int 0x257a | { top = Blank; bottom = Heavy; left = Blank; right = Blank } -> UChar.of_int 0x257b | { top = Blank; bottom = Blank; left = Light; right = Heavy } -> UChar.of_int 0x257c | { top = Light; bottom = Heavy; left = Blank; right = Blank } -> UChar.of_int 0x257d | { top = Blank; bottom = Blank; left = Heavy; right = Light } -> UChar.of_int 0x257e | { top = Heavy; bottom = Light; left = Blank; right = Blank } -> UChar.of_int 0x257f let draw_piece ctx row col ?style piece = let row = ctx.ctx_row1 + row and col = ctx.ctx_col1 + col in if row >= ctx.ctx_row1 && col >= ctx.ctx_col1 && row < ctx.ctx_row2 && col < ctx.ctx_col2 then begin let piece = if row > 0 then begin let point = unsafe_get ctx.ctx_matrix (row - 1) col in match piece_of_char point.char with | None -> piece | Some piece' -> if piece.top = piece'.bottom then piece else if piece.top = Blank then { piece with top = piece'.bottom } else if piece'.bottom = Blank then begin point.char <- char_of_piece { piece' with bottom = piece.top }; piece end else piece end else piece in let piece = if row < ctx.ctx_matrix_size.rows - 1 then begin let point = unsafe_get ctx.ctx_matrix (row + 1) col in match piece_of_char point.char with | None -> piece | Some piece' -> if piece.bottom = piece'.top then piece else if piece.bottom = Blank then { piece with bottom = piece'.top } else if piece'.top = Blank then begin point.char <- char_of_piece { piece' with top = piece.bottom }; piece end else piece end else piece in let piece = if col > 0 then begin let point = unsafe_get ctx.ctx_matrix row (col - 1) in match piece_of_char point.char with | None -> piece | Some piece' -> if piece.left = piece'.right then piece else if piece.left = Blank then { piece with left = piece'.right } else if piece'.right = Blank then begin point.char <- char_of_piece { piece' with right = piece.left }; piece end else piece end else piece in let piece = if col < ctx.ctx_matrix_size.cols - 1 then begin let point = unsafe_get ctx.ctx_matrix row (col + 1) in match piece_of_char point.char with | None -> piece | Some piece' -> if piece.right = piece'.left then piece else if piece.right = Blank then { piece with right = piece'.left } else if piece'.left = Blank then begin point.char <- char_of_piece { piece' with left = piece.right }; piece end else piece end else piece in let point = unsafe_get ctx.ctx_matrix row col in point.char <- char_of_piece piece; maybe_set_style point style end let draw_hline ctx row col len ?style connection = let piece = { top = Blank; bottom = Blank; left = connection; right = connection } in for i = 0 to len - 1 do draw_piece ctx row (col + i) ?style piece done let draw_vline ctx row col len ?style connection = let piece = { top = connection; bottom = connection; left = Blank; right = Blank } in for i = 0 to len - 1 do draw_piece ctx (row + i) col ?style piece done let draw_frame ctx rect ?style connection = let hline = { top = Blank; bottom = Blank; left = connection; right = connection } in let vline = { top = connection; bottom = connection; left = Blank; right = Blank } in for col = rect.col1 + 1 to rect.col2 - 2 do draw_piece ctx (rect.row1 + 0) col ?style hline; draw_piece ctx (rect.row2 - 1) col ?style hline done; for row = rect.row1 + 1 to rect.row2 - 2 do draw_piece ctx row (rect.col1 + 0) ?style vline; draw_piece ctx row (rect.col2 - 1) ?style vline done; draw_piece ctx (rect.row1 + 0) (rect.col1 + 0) ?style { top = Blank; bottom = connection; left = Blank; right = connection }; draw_piece ctx (rect.row1 + 0) (rect.col2 - 1) ?style { top = Blank; bottom = connection; left = connection; right = Blank }; draw_piece ctx (rect.row2 - 1) (rect.col2 - 1) ?style { top = connection; bottom = Blank; left = connection; right = Blank }; draw_piece ctx (rect.row2 - 1) (rect.col1 + 0) ?style { top = connection; bottom = Blank; left = Blank; right = connection } lambda-term-1.9/src/lTerm_draw.mli000066400000000000000000000114001254222632000171340ustar00rootroot00000000000000(* * lTerm_draw.mli * -------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (** Drawing *) open CamomileLibrary open LTerm_geom (** Type of a point in a matrix of styled characters. *) type point = { mutable char : UChar.t; (** The unicode character. *) mutable bold : bool; (** Whether the character is in bold or not. *) mutable underline : bool; (** Whether the character is underlined or not. *) mutable blink : bool; (** Whether the character is blinking or not. *) mutable reverse : bool; (** Whether the character is in reverse video mode or not. *) mutable foreground : LTerm_style.color; (** The foreground color. *) mutable background : LTerm_style.color; (** The background color. *) } type matrix = point array array (** Type of a matrix of points. The matrix is indexed by lines then columns, i.e. to access the point at line [l] and column [c] in matrix [m] you should use [m.(l).(c)]. *) val make_matrix : LTerm_geom.size -> matrix (** [matrix size] creates a matrix of the given size containing only blank characters. *) val set_style : point -> LTerm_style.t -> unit (** [set_style point style] sets fields of [point] according to fields of [style]. For example: {[ set_style point { LTerm_style.none with LTerm_style.bold = Some true } ]} will have the following effect: {[ point.bold <- true ]} *) type context (** Type of contexts. A context is used for drawing. *) val context : matrix -> LTerm_geom.size -> context (** [context m s] creates a context from a matrix [m] of size [s]. It raises [Invalid_argument] if [s] is not the size of [m]. *) exception Out_of_bounds (** Exception raised when trying to access a point that is outside the bounds of a context. *) val size : context -> size (** [size ctx] returns the size of the given context. *) val sub : context -> rect -> context (** [sub ctx rect] creates a sub-context from the given context. It raises {!Out_of_bounds} if the rectangle is not contained in the given context. *) val clear : context -> unit (** [clear ctx] clears the given context. It resets all styles to their default and sets characters to spaces. *) val fill : context -> ?style : LTerm_style.t -> UChar.t -> unit (** [fill ctx ch] fills the given context with [ch]. *) val fill_style : context -> LTerm_style.t -> unit (** [fill_style style] fills the given context with [style]. *) val point : context -> int -> int -> point (** [point ctx row column] returns the point at given position in [ctx]. It raises {!Out_of_bounds} if the coordinates are outside the given context. *) val draw_char : context -> int -> int -> ?style : LTerm_style.t -> UChar.t -> unit (** [draw_char ctx row column ?style ch] sets the character at given coordinates to [ch]. It does nothing if the given coordinates are outside the bounds of the context. *) val draw_string : context -> int -> int -> ?style : LTerm_style.t -> string -> unit (** [draw_string ctx row column ?style str] draws the given string at given coordinates. This does not affect styles. [str] may contains newlines. *) val draw_styled : context -> int -> int -> ?style : LTerm_style.t -> LTerm_text.t -> unit (** [draw_styled ctx row column ?style text] draws the given styled text at given coordinates. *) val draw_string_aligned : context -> int -> horz_alignment -> ?style : LTerm_style.t -> string -> unit (** Draws a string with the given alignment. *) val draw_styled_aligned : context -> int -> horz_alignment -> ?style : LTerm_style.t -> LTerm_text.t -> unit (** Draws a styled string with the given aglienment. *) (** Type of an connection in a piece that can be connected to other pieces. *) type connection = | Blank (** No connection. *) | Light (** Connection with a light line. *) | Heavy (** Connection with a heavy line. *) type piece = { top : connection; bottom : connection; left : connection; right : connection } (** Type of a piece, given by its four connection. *) val draw_piece : context -> int -> int -> ?style : LTerm_style.t -> piece -> unit (** Draws a piece. It may modify pieces around it. *) val draw_hline : context -> int -> int -> int -> ?style : LTerm_style.t -> connection -> unit (** [draw_hline ctx row column length connection] draws an horizontal line. *) val draw_vline : context -> int -> int -> int -> ?style : LTerm_style.t -> connection -> unit (** [draw_hline ctx row column length connection] draws a vertical line. *) val draw_frame : context -> rect -> ?style : LTerm_style.t -> connection -> unit (** Draws a rectangle. *) lambda-term-1.9/src/lTerm_edit.ml000066400000000000000000000433621254222632000167670ustar00rootroot00000000000000(* * lTerm_edit.ml * ------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) open CamomileLibraryDyn.Camomile open Zed_edit open LTerm_key open LTerm_geom open Lwt_react (* +-----------------------------------------------------------------+ | Actions | +-----------------------------------------------------------------+ *) type action = | Zed of Zed_edit.action | Start_macro | Stop_macro | Cancel_macro | Play_macro | Insert_macro_counter | Set_macro_counter | Add_macro_counter | Custom of (unit -> unit) let doc_of_action = function | Zed action -> Zed_edit.doc_of_action action | Start_macro -> "start a new macro." | Stop_macro -> "end the current macro." | Cancel_macro -> "cancel the current macro." | Play_macro -> "play the last recorded macro." | Insert_macro_counter -> "insert the current value of the macro counter." | Set_macro_counter -> "sets the value of the macro counter." | Add_macro_counter -> "adds a value to the macro counter." | Custom _ -> "programmer defined action." let actions = [ Start_macro, "start-macro"; Stop_macro, "stop-macro"; Cancel_macro, "cancel-macro"; Play_macro, "play-macro"; Insert_macro_counter, "insert-macro-counter"; Set_macro_counter, "set-macro-counter"; Add_macro_counter, "add-macro-counter"; ] let actions_to_names = Array.of_list (List.sort (fun (a1, n1) (a2, n2) -> Pervasives.compare a1 a2) actions) let names_to_actions = Array.of_list (List.sort (fun (a1, n1) (a2, n2) -> Pervasives.compare n1 n2) actions) let action_of_name x = let rec loop a b = if a = b then Zed (Zed_edit.action_of_name x) else let c = (a + b) / 2 in let action, name = Array.unsafe_get names_to_actions c in match Pervasives.compare x name with | d when d < 0 -> loop a c | d when d > 0 -> loop (c + 1) b | _ -> action in loop 0 (Array.length names_to_actions) let name_of_action x = let rec loop a b = if a = b then raise Not_found else let c = (a + b) / 2 in let action, name = Array.unsafe_get actions_to_names c in match Pervasives.compare x action with | d when d < 0 -> loop a c | d when d > 0 -> loop (c + 1) b | _ -> name in match x with | Zed x -> Zed_edit.name_of_action x | Custom _ -> "custom" | _ -> loop 0 (Array.length actions_to_names) module Bindings = Zed_input.Make (LTerm_key) let bindings = ref Bindings.empty let bind seq actions = bindings := Bindings.add seq actions !bindings let unbind seq = bindings := Bindings.remove seq !bindings let () = bind [{ control = false; meta = false; shift = false; code = Left }] [Zed Prev_char]; bind [{ control = false; meta = false; shift = false; code = Right }] [Zed Next_char]; bind [{ control = false; meta = false; shift = false; code = Up }] [Zed Prev_line]; bind [{ control = false; meta = false; shift = false; code = Down }] [Zed Next_line]; bind [{ control = false; meta = false; shift = false; code = Home }] [Zed Goto_bol]; bind [{ control = false; meta = false; shift = false; code = End }] [Zed Goto_eol]; bind [{ control = false; meta = false; shift = false; code = Insert }] [Zed Switch_erase_mode]; bind [{ control = false; meta = false; shift = false; code = Delete }] [Zed Delete_next_char]; bind [{ control = false; meta = false; shift = false; code = Enter }] [Zed Newline]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char ' ') }] [Zed Set_mark]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'a') }] [Zed Goto_bol]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'e') }] [Zed Goto_eol]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'd') }] [Zed Delete_next_char]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'h') }] [Zed Delete_prev_char]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'k') }] [Zed Kill_next_line]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'u') }] [Zed Kill_prev_line]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'n') }] [Zed Next_line]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'p') }] [Zed Prev_line]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'w') }] [Zed Kill]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'y') }] [Zed Yank]; bind [{ control = false; meta = false; shift = false; code = Backspace }] [Zed Delete_prev_char]; bind [{ control = false; meta = true; shift = false; code = Char(UChar.of_char 'w') }] [Zed Copy]; bind [{ control = false; meta = true; shift = false; code = Char(UChar.of_char 'c') }] [Zed Capitalize_word]; bind [{ control = false; meta = true; shift = false; code = Char(UChar.of_char 'l') }] [Zed Lowercase_word]; bind [{ control = false; meta = true; shift = false; code = Char(UChar.of_char 'u') }] [Zed Uppercase_word]; bind [{ control = false; meta = true; shift = false; code = Char(UChar.of_char 'b') }] [Zed Prev_word]; bind [{ control = false; meta = true; shift = false; code = Char(UChar.of_char 'f') }] [Zed Next_word]; bind [{ control = false; meta = true; shift = false; code = Right }] [Zed Next_word]; bind [{ control = false; meta = true; shift = false; code = Left }] [Zed Prev_word]; bind [{ control = true; meta = false; shift = false; code = Right }] [Zed Next_word]; bind [{ control = true; meta = false; shift = false; code = Left }] [Zed Prev_word]; bind [{ control = false; meta = true; shift = false; code = Backspace }] [Zed Kill_prev_word]; bind [{ control = false; meta = true; shift = false; code = Delete }] [Zed Kill_prev_word]; bind [{ control = true; meta = false; shift = false; code = Delete }] [Zed Kill_next_word]; bind [{ control = false; meta = true; shift = false; code = Char(UChar.of_char 'd') }] [Zed Kill_next_word]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char '_') }] [Zed Undo]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'x') }; { control = false; meta = false; shift = false; code = Char(UChar.of_char '(') }] [Start_macro]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'x') }; { control = false; meta = false; shift = false; code = Char(UChar.of_char ')') }] [Stop_macro]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'x') }; { control = false; meta = false; shift = false; code = Char(UChar.of_char 'e') }] [Play_macro]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'g') }] [Cancel_macro]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'x') }; { control = true; meta = false; shift = false; code = Char(UChar.of_char 'k') }; { control = false; meta = false; shift = false; code = Tab }] [Insert_macro_counter]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'x') }; { control = true; meta = false; shift = false; code = Char(UChar.of_char 'k') }; { control = true; meta = false; shift = false; code = Char(UChar.of_char 'a') }] [Add_macro_counter]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'x') }; { control = true; meta = false; shift = false; code = Char(UChar.of_char 'k') }; { control = true; meta = false; shift = false; code = Char(UChar.of_char 'c') }] [Set_macro_counter] (* +-----------------------------------------------------------------+ | Widgets | +-----------------------------------------------------------------+ *) let clipboard = Zed_edit.new_clipboard () let macro = Zed_macro.create [] let regexp_word = let set = UCharInfo.load_property_set `Alphabetic in let set = List.fold_left (fun set ch -> USet.add (UChar.of_char ch) set) set ['0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9'] in Zed_re.compile (`Repn(`Set set, 1, None)) let dummy_engine = Zed_edit.create () let dummy_cursor = Zed_edit.new_cursor dummy_engine let dummy_context = Zed_edit.context dummy_engine dummy_cursor let newline = UChar.of_char '\n' class edit ?(clipboard = clipboard) ?(macro = macro) () = let locale, set_locale = S.create None in object(self) inherit LTerm_widget.t "edit" method clipboard = clipboard method macro = macro method can_focus = true val mutable engine = dummy_engine method engine = engine val mutable cursor = dummy_cursor method cursor = cursor val mutable context = dummy_context method context = context method text = Zed_rope.to_string (Zed_edit.text engine) val mutable style = LTerm_style.none val mutable marked_style = LTerm_style.none val mutable current_line_style = LTerm_style.none method update_resources = let rc = self#resource_class and resources = self#resources in style <- LTerm_resources.get_style rc resources; marked_style <- LTerm_resources.get_style (rc ^ ".marked") resources; current_line_style <- LTerm_resources.get_style (rc ^ ".current-line") resources method editable pos len = true method match_word text pos = match_by_regexp regexp_word text pos method locale = S.value locale method set_locale locale = set_locale locale val mutable event = E.never val mutable resolver = None val mutable local_bindings = Bindings.empty method bind keys actions = local_bindings <- Bindings.add keys actions local_bindings initializer engine <- ( Zed_edit.create ~editable:(fun pos len -> self#editable pos len) ~match_word:(fun text pos -> self#match_word text pos) ~clipboard ~locale () ); cursor <- Zed_edit.new_cursor engine; context <- Zed_edit.context engine cursor; Zed_edit.set_data engine (self :> edit); event <- E.map (fun _ -> self#queue_draw) (Zed_edit.update engine [cursor]); self#on_event (function | LTerm_event.Key key -> begin let res = match resolver with | Some res -> res | None -> Bindings.resolver [ Bindings.pack (fun x -> x) local_bindings ; Bindings.pack (fun x -> x) !bindings ] in match Bindings.resolve key res with | Bindings.Accepted actions -> resolver <- None; let rec exec = function | Custom f :: actions -> Zed_macro.add macro (Custom f); f (); exec actions | Zed action :: actions -> Zed_macro.add macro (Zed action); Zed_edit.get_action action context; exec actions | Start_macro :: actions -> Zed_macro.set_recording macro true; exec actions | Stop_macro :: actions -> Zed_macro.set_recording macro false; exec actions | Cancel_macro :: actions -> Zed_macro.cancel macro; exec actions | Play_macro :: actions -> Zed_macro.cancel macro; exec (Zed_macro.contents macro @ actions) | Insert_macro_counter :: actions -> Zed_macro.add macro Insert_macro_counter; Zed_edit.insert context (Zed_rope.of_string (string_of_int (Zed_macro.get_counter macro))); Zed_macro.add_counter macro 1; exec actions | (Add_macro_counter | Set_macro_counter) :: actions -> exec actions | [] -> true in exec actions | Bindings.Continue res -> resolver <- Some res; true | Bindings.Rejected -> if resolver = None then match key with | { control = false; meta = false; shift = false; code = Char ch } -> Zed_edit.insert context (Zed_rope.singleton ch); true | _ -> false else begin resolver <- None; false end end | _ -> false) val mutable shift = 0 val mutable start = 0 method draw ctx focused = let open LTerm_draw in let size = LTerm_draw.size ctx in (*** Check that the cursor is displayed ***) let line_set = Zed_edit.lines engine in let cursor_offset = Zed_cursor.get_position cursor in let cursor_line = Zed_lines.line_index line_set cursor_offset in let cursor_column = cursor_offset - Zed_lines.line_start line_set cursor_line in (* Horizontal check *) if cursor_column < shift || cursor_column >= shift + size.cols then shift <- max 0 (cursor_column - size.cols / 2); (* Vertical check *) let start_line = Zed_lines.line_index line_set start in let start_line = if cursor_line < start_line || cursor_line >= start_line + size.rows then begin let start_line = max 0 (cursor_line - size.rows / 2) in start <- Zed_lines.line_start line_set start_line; start_line end else start_line in (*** Drawing ***) (* Initialises points with the text style and spaces. *) fill ctx (UChar.of_char ' '); fill_style ctx style; (*** Text drawing ***) let rec draw_line row col zip = if Zed_rope.Zip.at_eos zip then draw_eoi (row + 1) else let char, zip = Zed_rope.Zip.next zip in if char = newline then begin let row = row + 1 in if row < size.rows then begin_line row zip end else begin if col > size.cols then begin let row = row + 1 in if row < size.rows then skip_eol row zip end else begin draw_char ctx row col char; draw_line row (col + 1) zip end end and skip_eol row zip = if Zed_rope.Zip.at_eos zip then draw_eoi (row + 1) else let char, zip = Zed_rope.Zip.next zip in if char = newline then begin_line row zip else skip_eol row zip and skip_bol row zip remaining = if remaining = 0 then draw_line row 0 zip else if Zed_rope.Zip.at_eos zip then draw_eoi (row + 1) else let char, zip = Zed_rope.Zip.next zip in if char = newline then begin let row = row + 1 in if row < size.rows then begin_line row zip end else skip_bol row zip (remaining - 1) and begin_line row zip = if Zed_rope.Zip.at_eos zip then draw_eoi row else if shift <> 0 then begin skip_bol row zip shift end else draw_line row 0 zip and draw_eoi row = () in let text = Zed_edit.text engine in begin_line 0 (Zed_rope.Zip.make_f text start); (* Colorize the current line. *) for col = 0 to size.cols - 1 do set_style (point ctx (cursor_line - start_line) col) current_line_style done; (* Colorize the selection if needed *) if Zed_edit.get_selection engine then begin let sel_offset = Zed_cursor.get_position (Zed_edit.mark engine) in let sel_line = Zed_lines.line_index line_set sel_offset in let sel_column = sel_offset - Zed_lines.line_start line_set sel_line in let line_a, column_a, line_b, column_b = if sel_offset < cursor_offset then (sel_line, sel_column, cursor_line, cursor_column) else (cursor_line, cursor_column, sel_line, sel_column) in let line_a, column_a = if line_a < start_line then (start_line, 0) else (line_a, column_a) in let line_b, column_b = if line_b >= start_line + size.rows then (start_line + size.rows - 1, size.cols - 1) else (line_b, column_b) in if line_a < start_line + size.rows && line_b >= start_line then begin let line_a = line_a - start_line and line_b = line_b - start_line in let column_a = column_a and column_b = column_b in if line_a = line_b then for column = column_a to column_b - 1 do set_style (point ctx line_a column) marked_style done else begin for column = column_a to size.cols - 1 do set_style (point ctx line_a column) marked_style done; for line = line_a + 1 to line_b - 1 do for column = 0 to size.cols - 1 do set_style (point ctx line column) marked_style done done; for column = 0 to column_b - 1 do set_style (point ctx line_b column) marked_style done end end end method cursor_position = let line_set = Zed_edit.lines engine in let cursor_offset = Zed_cursor.get_position cursor in let cursor_line = Zed_lines.line_index line_set cursor_offset in let cursor_column = cursor_offset - Zed_lines.line_start line_set cursor_line in let start_line = Zed_lines.line_index line_set start in Some { row = cursor_line - start_line; col = cursor_column - shift } end lambda-term-1.9/src/lTerm_edit.mli000066400000000000000000000057131254222632000171360ustar00rootroot00000000000000(* * lTerm_edit.mli * -------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (** Text edition *) (** {6 Actions} *) type action = | Zed of Zed_edit.action (** A zed action. *) | Start_macro (** Start a new macro. *) | Stop_macro (** Ends the current macro. *) | Cancel_macro (** Cancel the current macro. *) | Play_macro (** Play the last recorded macro. *) | Insert_macro_counter (** Insert the current value of the macro counter. *) | Set_macro_counter (** Sets the value of the macro counter. *) | Add_macro_counter (** Adds a value to the macro counter. *) | Custom of (unit -> unit) val bindings : action list Zed_input.Make(LTerm_key).t ref (** Bindings. These bindings are used by {!LTerm_read_line} and by edition widgets. *) val bind : LTerm_key.t list -> action list -> unit (** [bind seq actions] associates [actions] to the given sequence. *) val unbind : LTerm_key.t list -> unit (** [unbind seq] unbinds [seq]. *) val actions : (action * string) list (** List of actions with their names, except {!Zed}. *) val doc_of_action : action -> string (** [doc_of_action action] returns a short description of the action. *) val action_of_name : string -> action (** [action_of_name str] converts the given action name into an action. Action name are the same as variants name but lowercased and with '_' replaced by '-'. It raises [Not_found] if the name does not correspond to an action. It also recognizes zed actions. *) val name_of_action : action -> string (** [name_of_action act] returns the name of the given action. *) (** {6 Widgets} *) val clipboard : Zed_edit.clipboard (** The global clipboard. *) val macro : action Zed_macro.t (** The global macro recorder. *) (** Class of edition widgets. If no clipboard is provided, then the global one is used. *) class edit : ?clipboard : Zed_edit.clipboard -> ?macro : action Zed_macro.t -> unit -> object inherit LTerm_widget.t method engine : edit Zed_edit.t (** The edition engine used by this widget. *) method cursor : Zed_cursor.t (** The cursor used by this widget. *) method context : edit Zed_edit.context (** The context for editing the engine. *) method clipboard : Zed_edit.clipboard (** The clipboard used by the edition engine. *) method macro : action Zed_macro.t (** The macro recorder. *) method text : string (** Shorthand for [Zed_rope.to_string (Zed_edit.text edit#engine)]. *) method editable : int -> int -> bool (** The editable function of the engine. *) method match_word : Zed_rope.t -> int -> int option (** The match word function of the engine. *) method locale : string option (** The locale used by the engine. *) method set_locale : string option -> unit method bind : LTerm_key.t list -> action list -> unit end lambda-term-1.9/src/lTerm_event.ml000066400000000000000000000011311254222632000171470ustar00rootroot00000000000000(* * lTerm_event.ml * -------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) type t = | Resize of LTerm_geom.size | Key of LTerm_key.t | Sequence of string | Mouse of LTerm_mouse.t let to_string = function | Resize size -> Printf.sprintf "Resize %s" (LTerm_geom.string_of_size size) | Key key -> Printf.sprintf "Key %s" (LTerm_key.to_string key) | Sequence seq -> Printf.sprintf "Sequence %S" seq | Mouse mouse -> Printf.sprintf "Mouse %s" (LTerm_mouse.to_string mouse) lambda-term-1.9/src/lTerm_event.mli000066400000000000000000000011521254222632000173230ustar00rootroot00000000000000(* * lTerm_event.mli * --------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (** Events *) (** Event from the terminal. *) type t = | Resize of LTerm_geom.size (** The terminal has been resized. *) | Key of LTerm_key.t (** A key has been pressed. *) | Sequence of string (** An uninterpreted escape sequence. *) | Mouse of LTerm_mouse.t (** A mouse button has been pressed. *) val to_string : t -> string (** [to_string event] returns the string representation of the given event. *) lambda-term-1.9/src/lTerm_geom.ml000066400000000000000000000021121254222632000167550ustar00rootroot00000000000000(* * lTerm_geom.ml * ------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) type size = { rows : int; cols : int; } let rows size = size.rows let cols size = size.cols let string_of_size size = Printf.sprintf "{ rows = %d; cols = %d }" size.rows size.cols type coord = { row : int; col : int; } let row size = size.row let col size = size.col let string_of_coord coord = Printf.sprintf "{ row = %d; col = %d }" coord.row coord.col type rect = { row1 : int; col1 : int; row2 : int; col2 : int; } let row1 rect = rect.row1 let col1 rect = rect.col1 let row2 rect = rect.row2 let col2 rect = rect.col2 let size_of_rect rect = { rows = rect.row2 - rect.row1; cols = rect.col2 - rect.col1 } let string_of_rect rect = Printf.sprintf "{ row1 = %d; col1 = %d; row2 = %d; col2 = %d }" rect.row1 rect.col1 rect.row2 rect.col2 type horz_alignment = | H_align_left | H_align_center | H_align_right type vert_alignment = | V_align_top | V_align_center | V_align_bottom lambda-term-1.9/src/lTerm_geom.mli000066400000000000000000000022731254222632000171360ustar00rootroot00000000000000(* * lTerm_geom.mli * -------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (** Common types. *) (** Type of sizes. *) type size = { rows : int; cols : int; } val rows : size -> int val cols : size -> int val string_of_size : size -> string (** Returns the string representation of the given size. *) (** Type of coordinates. *) type coord = { row : int; col : int; } val row : coord -> int val col : coord -> int val string_of_coord : coord -> string (** Returns the string representation of the given coordinates. *) (** Type of rectangles. *) type rect = { row1 : int; col1 : int; row2 : int; col2 : int; } val row1 : rect -> int val col1 : rect -> int val row2 : rect -> int val col2 : rect -> int val size_of_rect : rect -> size (** Returns the size of a rectangle. *) val string_of_rect : rect -> string (** Returns the string representation of the given rectangle. *) (** Horizontal alignment. *) type horz_alignment = | H_align_left | H_align_center | H_align_right (** Vertical alignement. *) type vert_alignment = | V_align_top | V_align_center | V_align_bottom lambda-term-1.9/src/lTerm_history.ml000066400000000000000000000347651254222632000175520ustar00rootroot00000000000000(* * lTerm_history.ml * ---------------- * Copyright : (c) 2012, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) open CamomileLibraryDyn.Camomile let return, (>>=) = Lwt.return, Lwt.(>>=) let section = Lwt_log.Section.make "lambda-term(history)" (* A node contains an entry of the history. *) type node = { mutable data : Zed_utf8.t; mutable size : int; mutable prev : node; } type t = { mutable entries : node; (* Points to the first entry (the most recent). Its [prev] is a fake node used as marker, is after the oldest entry. *) mutable full_size : int; mutable length : int; mutable max_size : int; mutable max_entries : int; mutable old_count : int; mutable cache : Zed_utf8.t list option; (* When set, the cache is equal to the list of entries, from the most recent to the oldest. *) } let entry_size str = let size = ref 0 in for i = 0 to String.length str - 1 do match String.unsafe_get str i with | '\n' | '\\' -> size := !size + 2 | _ -> size := !size + 1 done; !size + 1 (* Check that [size1 + size2 < limit], handling overflow. *) let size_ok size1 size2 limit = let sum = size1 + size2 in sum >= 0 && sum <= limit let create ?(max_size=max_int) ?(max_entries=max_int) init = if max_size < 0 then invalid_arg "LTerm_history.create: negative maximum size"; if max_entries < 0 then invalid_arg "LTerm_history.create: negative maximum number of entries"; let rec aux size count node entries = match entries with | [] -> (size, count, node) | entry :: entries -> let entry_size = entry_size entry in if size_ok size entry_size max_size && count + 1 < max_entries then begin let next = { data = ""; prev = node; size = 0 } in node.data <- entry; node.size <- entry_size; aux (size + entry_size) (count + 1) next entries end else (size, count, node) in let rec node = { data = ""; size = 0; prev = node } in let size, count, marker = aux 0 0 node init in node.prev <- marker; { entries = node; full_size = size; length = count; max_size = max_size; max_entries = max_entries; old_count = count; cache = None; } let spaces = UCharInfo.load_property_tbl `White_Space let is_space ch = UCharTbl.Bool.get spaces ch let is_empty str = Zed_utf8.for_all is_space str let is_dup history entry = history.length > 0 && history.entries.data = entry (* Remove the oldest entry of history, precondition: the history contains at least one entry. *) let drop_oldest history = let last = history.entries.prev.prev in (* Make [last] become the end of entries marker. *) history.entries.prev <- last; (* Update counters. *) history.length <- history.length - 1; history.full_size <- history.full_size - last.size; if history.old_count > 0 then history.old_count <- history.old_count - 1; (* Clear the marker so its contents can be garbage collected. *) last.data <- ""; last.size <- 0 let add_aux history data size = if size <= history.max_size then begin (* Check length. *) if history.length = history.max_entries then begin history.cache <- None; (* We know that [max_entries > 0], so the precondition is verified. *) drop_oldest history end; (* Check size. *) if not (size_ok history.full_size size history.max_size) then begin history.cache <- None; (* We know that size <= max_size, so we are here only if there is at least one other entry in the history, so the precondition is verified. *) drop_oldest history; while not (size_ok history.full_size size history.max_size) do (* Same here. *) drop_oldest history done end; (* Add the entry. *) let node = { data = data; size = size; prev = history.entries.prev } in history.entries.prev <- node; history.entries <- node; history.length <- history.length + 1; history.full_size <- history.full_size + size; match history.cache with | None -> () | Some l -> history.cache <- Some (data :: l) end let add history ?(skip_empty=true) ?(skip_dup=true) entry = if history.max_entries > 0 && history.max_size > 0 && not (skip_empty && is_empty entry) && not (skip_dup && is_dup history entry) then add_aux history entry (entry_size entry) let rec list_of_nodes marker acc node = if node == marker then acc else list_of_nodes marker (node.data :: acc) node.prev let contents history = match history.cache with | Some l -> l | None -> let marker = history.entries.prev in let l = list_of_nodes marker [] marker.prev in history.cache <- Some l; l let size history = history.full_size let length history = history.length let old_count history = history.old_count let max_size history = history.max_size let max_entries history = history.max_entries let set_old_count history n = if n < 0 then invalid_arg "LTerm_history.set_old_count: negative old count"; if n > history.length then invalid_arg "LTerm_history.set_old_count: old count greater than the length of the history"; history.old_count <- n let set_max_size history size = if size < 0 then invalid_arg "LTerm_history.set_max_size: negative maximum size"; if size < history.full_size then begin history.cache <- None; (* 0 <= size < full_size so there is at least one element. *) drop_oldest history; while size < history.full_size do (* Same here. *) drop_oldest history done end; history.max_size <- size let set_max_entries history n = if n < 0 then invalid_arg "LTerm_history.set_max_entries: negative maximum number of entries"; if n < history.length then begin history.cache <- None; (* 0 <= n < length so there is at least one element. *) drop_oldest history; while n < history.length do (* Same here. *) drop_oldest history done end; history.max_entries <- n let escape entry = let len = String.length entry in let buf = Buffer.create len in let rec loop ofs = if ofs = len then Buffer.contents buf else match String.unsafe_get entry ofs with | '\n' -> Buffer.add_string buf "\\n"; loop (ofs + 1) | '\\' -> Buffer.add_string buf "\\\\"; loop (ofs + 1) | ch when Char.code ch <= 127 -> Buffer.add_char buf ch; loop (ofs + 1) | _ -> let ofs' = Zed_utf8.unsafe_next entry ofs in Buffer.add_substring buf entry ofs (ofs' - ofs); loop ofs' in loop 0 let unescape line = let len = String.length line in let buf = Buffer.create len in let rec loop ofs size = if ofs = len then (Buffer.contents buf, size + 1) else match String.unsafe_get line ofs with | '\\' -> if ofs = len then begin Buffer.add_char buf '\\'; (Buffer.contents buf, size + 3) end else begin match String.unsafe_get line (ofs + 1) with | 'n' -> Buffer.add_char buf '\n'; loop (ofs + 2) (size + 2) | '\\' -> Buffer.add_char buf '\\'; loop (ofs + 2) (size + 2) | _ -> Buffer.add_char buf '\\'; loop (ofs + 1) (size + 2) end | ch when Char.code ch <= 127 -> Buffer.add_char buf ch; loop (ofs + 1) (size + 1) | _ -> let ofs' = Zed_utf8.unsafe_next line ofs in Buffer.add_substring buf line ofs (ofs' - ofs); loop ofs' (size + ofs' - ofs) in loop 0 0 let section = Lwt_log.Section.make "lambda-term(history)" let rec safe_lockf fn fd cmd ofs = Lwt.catch (fun () -> Lwt_unix.lockf fd cmd ofs >>= fun () -> return true) (function | Unix.Unix_error (Unix.EINTR, _, _) -> safe_lockf fn fd cmd ofs | Unix.Unix_error (error, _, _) -> Lwt_log.ign_warning_f ~section "failed to lock file '%s': %s" fn (Unix.error_message error); return false | exn -> Lwt.fail exn) let open_history fn = Lwt.catch (fun () -> Lwt_unix.openfile fn [Unix.O_RDWR] 0 >>= fun fd -> safe_lockf fn fd Lwt_unix.F_LOCK 0 >>= fun locked -> return (Some (fd, locked))) (function | Unix.Unix_error (Unix.ENOENT, _, _) -> return None | Unix.Unix_error (Unix.EACCES, _, _) -> Lwt_log.ign_info_f "cannot open file '%s' in read and write mode: %s" fn (Unix.error_message Unix.EACCES); (* If the file cannot be openned in read & write mode, open it in read only mode but do not lock it. *) Lwt.catch (fun () -> Lwt_unix.openfile fn [Unix.O_RDONLY] 0 >>= fun fd -> return (Some (fd, false))) (function | Unix.Unix_error (Unix.ENOENT, _, _) -> return None | exn -> Lwt.fail exn) | exn -> Lwt.fail exn) let load history ?log ?(skip_empty=true) ?(skip_dup=true) fn = (* In case we do not load anything. *) history.old_count <- history.length; if history.max_entries = 0 || history.max_size = 0 then (* Do not bother loading the file for nothing... *) return () else begin let log = match log with | Some func -> func | None -> fun line msg -> Lwt_log.ign_error_f ~section "File %S, at line %d: %s" fn line msg in (* File opening. *) open_history fn >>= fun history_file -> match history_file with | None -> return () | Some (fd, locked) -> (* File loading. *) let ic = Lwt_io.of_fd ~mode:Lwt_io.input fd in Lwt.finalize (fun () -> let rec aux num = Lwt_io.read_line_opt ic >>= fun line -> match line with | None -> return () | Some line -> (try let entry, size = unescape line in if not (skip_empty && is_empty entry) && not (skip_dup && is_dup history entry) then begin add_aux history entry size; history.old_count <- history.length end with Zed_utf8.Invalid (msg, _) -> log num msg); aux (num + 1) in aux 1) (fun () -> (* Cleanup. *) (if locked then safe_lockf fn fd Lwt_unix.F_ULOCK 0 else return true) >>= fun _ -> Lwt_unix.close fd) end let rec skip_nodes node count = if count = 0 then node else skip_nodes node.prev (count - 1) let rec copy history marker node skip_empty skip_dup = if node != marker then begin let line = escape node.data in if not (skip_empty && is_empty line) && not (skip_dup && is_dup history line) then add_aux history line node.size; copy history marker node.prev skip_empty skip_dup end let rec dump_entries oc marker node = if node == marker then return () else begin Lwt_io.write_line oc node.data >>= fun () -> dump_entries oc marker node.prev end let save history ?max_size ?max_entries ?(skip_empty=true) ?(skip_dup=true) ?(append=true) ?(perm=0o666) fn = let max_size = match max_size with | Some m -> m | None -> history.max_size and max_entries = match max_entries with | Some m -> m | None -> history.max_entries in let history_save = create ~max_size ~max_entries [] in if history_save.max_size = 0 || history_save.max_entries = 0 || (not append && history.old_count = history.length) then (* Just empty the history. *) Lwt_unix.openfile fn [Unix.O_CREAT; Unix.O_TRUNC] perm >>= Lwt_unix.close else if append && history.old_count = history.length then (* Do not touch the file. *) return () else begin Lwt_unix.openfile fn [Unix.O_CREAT; Unix.O_RDWR] perm >>= fun fd -> (* Lock the entire file. *) safe_lockf fn fd Unix.F_LOCK 0 >>= fun locked -> Lwt.finalize (fun () -> begin if append then begin (* Load existing entries into [history_save]. We return the number of entries read. This may be greater than the number of entries stored in [history_save]: - because of limits - because the history files contains duplicated lines and/or empty lines and [skip_dup] and/or [skip_empty] have been specified. *) let ic = Lwt_io.of_fd ~mode:Lwt_io.input ~close:return fd in let rec aux count = Lwt_io.read_line_opt ic >>= fun line -> match line with | None -> history_save.old_count <- history_save.length; Lwt_io.close ic >>= fun () -> return count | Some line -> (* Do not bother unescaping. Tests remain the same on the unescaped version. *) if not (skip_empty && is_empty line) && not (skip_dup && is_dup history_save line) then add_aux history_save line (String.length line + 1); aux (count + 1) in aux 0 end else return 0 end >>= fun count -> let marker = history.entries.prev in (* Copy new entries into the saving history. *) copy history_save marker (skip_nodes marker.prev history.old_count) skip_empty skip_dup; begin if append && history_save.old_count = count then (* We are in append mode and no old entries were removed: do not modify the file and append new entries at the end of the file. *) return count else (* Otherwise truncate the file and save everything. *) Lwt_unix.lseek fd 0 Unix.SEEK_SET >>= fun _ -> Lwt_unix.ftruncate fd 0 >>= fun () -> return 0 end >>= fun to_skip -> (* Save entries to the temporary file. *) let oc = Lwt_io.of_fd ~mode:Lwt_io.output ~close:return fd in let marker = history_save.entries.prev in dump_entries oc marker (skip_nodes marker.prev to_skip) >>= fun () -> Lwt_io.close oc >>= fun () -> (* Done! *) history.old_count <- history.length; return ()) (fun () -> (if locked then safe_lockf fn fd Lwt_unix.F_ULOCK 0 else return true) >>= fun _ -> Lwt_unix.close fd) end lambda-term-1.9/src/lTerm_history.mli000066400000000000000000000104201254222632000177010ustar00rootroot00000000000000(* * lTerm_history.mli * ----------------- * Copyright : (c) 2012, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (** History management *) type t (** Type of a history. *) val create : ?max_size : int -> ?max_entries : int -> Zed_utf8.t list -> t (** [create ?max_size ?max_lines init] creates a new history. [max_size] is the maximum size in bytes of the history. Oldest entries are dropped if this limit is reached. The default is [max_int]. [max_entries] is the maximum number of entries of the history. Oldest entries are dropped if this limit is reached. The default is no [max_int]. [init] is the initial contents of the history. All entries of [init] are considered "old". Old entries are not saved by {!save} when [append] is set to [true]. Note: the first element of [init] must be the most recent entry. *) val add : t -> ?skip_empty : bool -> ?skip_dup : bool -> Zed_utf8.t -> unit (** [add history ?skip_empty ?skip_dup entry] adds [entry] to the top of the history. If [skip_empty] is [true] (the default) and [entry] contains only spaces, it is not added. If [skip_dup] is [true] (the default) and [entry] is equal to the top of the history, it is not added. If [entry] is bigger than the maximum size of the history, the history is not modified. *) val contents : t -> Zed_utf8.t list (** Returns all the entries of the history. The first element of the list is the most recent entry. *) val size : t -> int (** Returns the size (in bytes) of the history. *) val length : t -> int (** Returns the number of entries in the history. *) val old_count : t -> int (** Returns the number of old entries in the history. *) val set_old_count : t -> int -> unit (** [set_old_count history count] sets the number of old entries in the history. *) val max_size : t -> int (** Returns the maximum size of the history. *) val set_max_size : t -> int -> unit (** Sets the maximum size of the history. It may drop oldest entries to honor the new limit. *) val max_entries : t -> int (** Returns the maximum number of entries of the history. *) val set_max_entries : t -> int -> unit (** Sets the maximum number of entries of the history. It may drop oldest entries to honor the new limit. *) val load : t -> ?log : (int -> string -> unit) -> ?skip_empty : bool -> ?skip_dup : bool -> string -> unit Lwt.t (** [load history ?log ?skip_empty ?skip_dup filename] loads entries from [filename] to [history]. If [filename] does not exists [history] is not modified. [log] is the function used to log errors contained in the history file (errors are because of non-UTF8 data). Arguments are a line number and an error message. The default is to use the default logger (of [Lwt_log]). Entries containing errors are skipped. Note: all entries are marked as old, i.e. [old_count history = length history]. *) val save : t -> ?max_size : int -> ?max_entries : int -> ?skip_empty : bool -> ?skip_dup : bool -> ?append : bool -> ?perm : int -> string -> unit Lwt.t (** [save history ?max_size ?max_entries ?skip_empty ?sjip_dup ?perm filename] saves [history] to [filename]. If [append] is [false] then the file is truncated and new entries are saved. If it is [true] (the default) then new entries are added at the end. [perm] are the file permissions in case it is created. If [append] is [true] and there is no new entries, the file is not touched. In any other case, limits are honored and the resulting file will never contains more bytes than [max_size] or more entries than [max_entries]. If [max_size] and/or [max_entries] are not specified, the ones of [history] are used. After the history is successfully saved, all entries of [history] are marked as old, i.e. [old_count history = length history]. *) val entry_size : Zed_utf8.t -> int (** [entry_size entry] returns the size taken by an entry in the history file in bytes. This is not exactly [String.length entry] since some characters are escaped and the entry is terminated by a newline character. *) lambda-term-1.9/src/lTerm_inputrc.mli000066400000000000000000000011661254222632000176730ustar00rootroot00000000000000(* * lTerm_inputrc.mli * ----------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (** Loading of key bindings *) exception Parse_error of string * int * string (** [Parse_error(source, line, message)] is raised when the inputrc file contains errors. *) val load : ?file : string -> unit -> unit Lwt.t (** [load ?file ()] loads key bindings from [file], which defaults to ~/.lambda-term-inputrc, if it exists. *) val default : string (** The name of the default key bindings file, i.e. ~/.lambda-term-inputrc. *) lambda-term-1.9/src/lTerm_inputrc.mll000066400000000000000000000250401254222632000176730ustar00rootroot00000000000000(* * lTerm_inputrc.mll * ----------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) { open CamomileLibraryDyn.Camomile open LTerm_key let return, (>>=) = Lwt.return, Lwt.(>>=) exception Parse_error of string * int * string let parse_error src line fmt = Printf.ksprintf (fun msg -> raise (Parse_error (src, line, msg))) fmt let handle_edit_action src line seq actions = if actions = [] then LTerm_edit.unbind seq else let actions = List.map (fun str -> try LTerm_edit.action_of_name str with Not_found -> parse_error src line "invalid edit action %S" str) actions in LTerm_edit.bind seq actions let handle_read_line_action src line seq actions = if actions = [] then LTerm_read_line.unbind seq else let actions = List.map (fun str -> try LTerm_read_line.action_of_name str with Not_found -> parse_error src line "invalid read-line action %S" str) actions in LTerm_read_line.bind seq actions type line = | Comment | Section of string | Binding of LTerm_key.t list * string list | Error of string let dummy_key = { control = false; meta = false; shift = false; code = Escape } } let blank = [' ' '\t'] rule line = parse | blank* eof { Comment } | blank* '#' [^'\n']* eof { Comment } | blank* '[' blank* ([^'\n' ' ' '\t' ']']* as section) blank* ']' blank* ('#' [^'\n']*)? eof { Section section } | blank* { sequence dummy_key [] lexbuf } and sequence key seq = parse | "C-" { sequence { key with control = true } seq lexbuf } | "M-" { sequence { key with meta = true } seq lexbuf } | "S-" { sequence { key with shift = true } seq lexbuf } | "enter" (blank+ | ':' as sep) { let seq = { key with code = Enter } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "escape" (blank+ | ':' as sep) { let seq = { key with code = Escape } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "tab" (blank+ | ':' as sep) { let seq = { key with code = Tab } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "up" (blank+ | ':' as sep) { let seq = { key with code = Up } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "down" (blank+ | ':' as sep) { let seq = { key with code = Down } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "left" (blank+ | ':' as sep) { let seq = { key with code = Left } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "right" (blank+ | ':' as sep) { let seq = { key with code = Right } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "f1" (blank+ | ':' as sep) { let seq = { key with code = F1 } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "f2" (blank+ | ':' as sep) { let seq = { key with code = F2 } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "f3" (blank+ | ':' as sep) { let seq = { key with code = F3 } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "f4" (blank+ | ':' as sep) { let seq = { key with code = F4 } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "f5" (blank+ | ':' as sep) { let seq = { key with code = F5 } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "f6" (blank+ | ':' as sep) { let seq = { key with code = F6 } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "f7" (blank+ | ':' as sep) { let seq = { key with code = F7 } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "f8" (blank+ | ':' as sep) { let seq = { key with code = F8 } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "f9" (blank+ | ':' as sep) { let seq = { key with code = F9 } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "f10" (blank+ | ':' as sep) { let seq = { key with code = F10 } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "f11" (blank+ | ':' as sep) { let seq = { key with code = F11 } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "f12" (blank+ | ':' as sep) { let seq = { key with code = F12 } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "next" (blank+ | ':' as sep) { let seq = { key with code = Next_page } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "prev" (blank+ | ':' as sep) { let seq = { key with code = Prev_page } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "home" (blank+ | ':' as sep) { let seq = { key with code = Home } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "end" (blank+ | ':' as sep) { let seq = { key with code = End } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "insert" (blank+ | ':' as sep) { let seq = { key with code = Insert } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "delete" (blank+ | ':' as sep) { let seq = { key with code = Delete } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "backspace" (blank+ | ':' as sep) { let seq = { key with code = Backspace } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | [ 'a'-'z' 'A'-'Z' '0'-'9' '_' '(' ')' '[' ']' '{' '}' '~' '&' '$' '*' '%' '!' '?' ',' ';' '/' '\\' '.' '@' '=' '+' '-' ] as ch (blank+ | ':' as sep) { let seq = { key with code = Char(UChar.of_char ch) } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf } | "U+" (['a'-'f' 'A'-'F' '0'-'9']+ as hexa) (blank+ | ':' as sep) { let code = ref 0 in for i = 0 to String.length hexa - 1 do let ch = hexa.[i] in code := !code * 16 + (match ch with | '0' .. '9' -> Char.code ch - Char.code '0' | 'A' .. 'F' -> Char.code ch - Char.code 'A' + 10 | 'a' .. 'f' -> Char.code ch - Char.code 'a' + 10 | _ -> assert false) done; match try Some (UChar.of_int !code) with _ -> None with | Some ch -> let seq = { key with code = Char ch } :: seq in if sep = ":" then actions (List.rev seq) [] lexbuf else sequence dummy_key seq lexbuf | None -> Error (Printf.sprintf "invalid unicode character U+%s" hexa) } | "" { Error "parsing error in key sequence" } and actions seq l = parse | blank* ('#' [^'\n']*)? eof { Binding (seq, List.rev l) } | blank* (['a'-'z' 'A'-'Z' '-']+ ('(' [^')' '\n']* ')')? as action) { comma_actions seq (action :: l) lexbuf } | "" { Error "parsing error in actions" } and comma_actions seq l = parse | blank* ',' { actions seq l lexbuf } | blank* ('#' [^'\n']*)? eof { Binding (seq, List.rev l) } | "" { Error "parsing error in actions" } { let default = Filename.concat LTerm_resources.home ".lambda-term-inputrc" let load ?(file = default) () = Lwt.catch (fun () -> Lwt_io.open_file ~mode:Lwt_io.input file >>= fun ic -> let rec loop num handler = Lwt_io.read_line_opt ic >>= fun input_line -> match input_line with | None -> return () | Some str -> match line (Lexing.from_string str) with | Comment -> loop (num + 1) handler | Section "edit" -> loop (num + 1) handle_edit_action | Section "read-line" -> loop (num + 1) handle_read_line_action | Section section -> parse_error file num "invalid section %S" section | Binding (seq, actions) -> handler file num seq actions; loop (num + 1) handler | Error msg -> raise (Parse_error (file, num, msg)) in Lwt.finalize (fun () -> loop 1 handle_edit_action) (fun () -> Lwt_io.close ic)) (function | Unix.Unix_error(Unix.ENOENT, _, _) -> return () | exn -> Lwt.fail exn) } lambda-term-1.9/src/lTerm_key.ml000066400000000000000000000050071254222632000166240ustar00rootroot00000000000000(* * lTerm_key.ml * ------------ * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) open CamomileLibraryDyn.Camomile type code = | Char of UChar.t | Enter | Escape | Tab | Up | Down | Left | Right | F1 | F2 | F3 | F4 | F5 | F6 | F7 | F8 | F9 | F10 | F11 | F12 | Next_page | Prev_page | Home | End | Insert | Delete | Backspace type t = { control : bool; meta : bool; shift : bool; code : code; } let compare = compare let control key = key.control let meta key = key.meta let code key = key.code let string_of_code = function | Char ch -> Printf.sprintf "Char 0x%02x" (UChar.code ch) | Enter -> "Enter" | Escape -> "Escape" | Tab -> "Tab" | Up -> "Up" | Down -> "Down" | Left -> "Left" | Right -> "Right" | F1 -> "F1" | F2 -> "F2" | F3 -> "F3" | F4 -> "F4" | F5 -> "F5" | F6 -> "F6" | F7 -> "F7" | F8 -> "F8" | F9 -> "F9" | F10 -> "F10" | F11 -> "F11" | F12 -> "F12" | Next_page -> "Next_page" | Prev_page -> "Prev_page" | Home -> "Home" | End -> "End" | Insert -> "Insert" | Delete -> "Delete" | Backspace -> "Backspace" let to_string key = Printf.sprintf "{ control = %B; meta = %B; shift = %B; code = %s }" key.control key.meta key.shift (string_of_code key.code) let to_string_compact key = let buffer = Buffer.create 32 in if key.control then Buffer.add_string buffer "C-"; if key.meta then Buffer.add_string buffer "M-"; if key.shift then Buffer.add_string buffer "S-"; (match key.code with | Char ch -> let code = UChar.code ch in if code <= 255 then match Char.chr code with | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~' | '&' | '$' | '*' | '%' | '!' | '?' | ',' | ';' | ':' | '/' | '\\' | '.' | '@' | '=' | '+' | '-' as ch -> Buffer.add_char buffer ch | ' ' -> Buffer.add_string buffer "space" | _ -> Printf.bprintf buffer "U+%02x" code else if code <= 0xffff then Printf.bprintf buffer "U+%04x" code else Printf.bprintf buffer "U+%06x" code | Next_page -> Buffer.add_string buffer "next" | Prev_page -> Buffer.add_string buffer "prev" | code -> Buffer.add_string buffer (String.lowercase (string_of_code code))); Buffer.contents buffer lambda-term-1.9/src/lTerm_key.mli000066400000000000000000000021141254222632000167710ustar00rootroot00000000000000(* * lTerm_key.mli * ------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (** Keys *) open CamomileLibrary (** Type of key code. *) type code = | Char of UChar.t (** A unicode character. *) | Enter | Escape | Tab | Up | Down | Left | Right | F1 | F2 | F3 | F4 | F5 | F6 | F7 | F8 | F9 | F10 | F11 | F12 | Next_page | Prev_page | Home | End | Insert | Delete | Backspace (** Type of key. *) type t = { control : bool; (** Is the control key down ? *) meta : bool; (** Is the meta key down ? *) shift : bool; (** Is the shift key down ? *) code : code; (** The code of the key. *) } val compare : t -> t -> int (** Same as [Pervasives.compare]. *) val control : t -> bool val meta : t -> bool val code : t -> code val to_string : t -> string (** Returns the string representation of the given key. *) val to_string_compact : t -> string (** Returns the string representation of the given key in the form "C-M-a". *) lambda-term-1.9/src/lTerm_mouse.ml000066400000000000000000000017111254222632000171620ustar00rootroot00000000000000(* * lTerm_mouse.ml * -------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) type button = | Button1 | Button2 | Button3 | Button4 | Button5 | Button6 | Button7 | Button8 | Button9 type t = { control : bool; meta : bool; shift : bool; button : button; row : int; col : int; } let compare = compare let control m = m.control let meta m = m.meta let button m = m.button let row m = m.row let col m = m.col let string_of_button = function | Button1 -> "Button1" | Button2 -> "Button2" | Button3 -> "Button3" | Button4 -> "Button4" | Button5 -> "Button5" | Button6 -> "Button6" | Button7 -> "Button7" | Button8 -> "Button8" | Button9 -> "Button9" let to_string m = Printf.sprintf "{ control = %B; meta = %B; shift = %B; button = %s; row = %d; col = %d }" m.control m.meta m.shift (string_of_button m.button) m.row m.col lambda-term-1.9/src/lTerm_mouse.mli000066400000000000000000000020471254222632000173360ustar00rootroot00000000000000(* * lTerm_mouse.mli * --------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (** Mouse events *) (** Type of mouse button. *) type button = | Button1 | Button2 | Button3 | Button4 | Button5 | Button6 | Button7 | Button8 | Button9 (** Type of mouse click event. *) type t = { control : bool; (** Is the control key down ? *) meta : bool; (** Is the meta key down ? *) shift : bool; (** Is the shift key down ? *) button : button; (** Which button have been pressed ? *) row : int; (** The row at which the mouse was when the button has been pressed. *) col : int; (** The column at which the mouse was when the button has been pressed. *) } val compare : t -> t -> int (** Same as [Pervasives.compare]. *) val control : t -> bool val meta : t -> bool val button : t -> button val row : t -> int val col : t -> int val to_string : t -> string (** Returns the string representation of the given mouse event. *) lambda-term-1.9/src/lTerm_read_line.ml000066400000000000000000001253161254222632000177640ustar00rootroot00000000000000(* * lTerm_read_line.ml * ------------------ * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) open CamomileLibraryDyn.Camomile open Lwt_react open LTerm_geom open LTerm_style open LTerm_text open LTerm_key let return, (>>=) = Lwt.return, Lwt.(>>=) exception Interrupt type prompt = LTerm_text.t type history = Zed_utf8.t list (* +-----------------------------------------------------------------+ | Completion | +-----------------------------------------------------------------+ *) let common_prefix_one a b = let rec loop ofs = if ofs = String.length a || ofs = String.length b then String.sub a 0 ofs else let ch1, ofs1 = Zed_utf8.unsafe_extract_next a ofs and ch2, ofs2 = Zed_utf8.unsafe_extract_next b ofs in if ch1 = ch2 && ofs1 = ofs2 then loop ofs1 else String.sub a 0 ofs in loop 0 let common_prefix = function | [] -> "" | word :: rest -> List.fold_left common_prefix_one word rest let lookup word words = List.filter (fun word' -> Zed_utf8.starts_with word' word) words let lookup_assoc word words = List.filter (fun (word', x) -> Zed_utf8.starts_with word' word) words (* +-----------------------------------------------------------------+ | Actions | +-----------------------------------------------------------------+ *) type action = | Edit of LTerm_edit.action | Interrupt_or_delete_next_char | Complete | Complete_bar_next | Complete_bar_prev | Complete_bar_first | Complete_bar_last | Complete_bar | History_prev | History_next | Accept | Clear_screen | Prev_search | Cancel_search | Break | Suspend let doc_of_action = function | Edit action -> LTerm_edit.doc_of_action action | Interrupt_or_delete_next_char -> "interrupt if at the beginning of an empty line, or delete the next character." | Complete -> "complete current input." | Complete_bar_next -> "go to the next possible completion in the completion bar." | Complete_bar_prev -> "go to the previous possible completion in the completion bar." | Complete_bar_first -> "go to the beginning of the completion bar." | Complete_bar_last -> "go to the end of the completion bar." | Complete_bar -> "complete current input using the completion bar." | History_prev -> "go to the previous entry of the history." | History_next -> "go to the next entry of the history." | Accept -> "accept the current input." | Clear_screen -> "clear the screen." | Prev_search -> "search backward in the history." | Cancel_search -> "cancel search mode." | Break -> "cancel edition." | Suspend -> "suspend edition." let actions = [ Interrupt_or_delete_next_char, "interrupt-or-delete-next-char"; Complete, "complete"; Complete_bar_next, "complete-bar-next"; Complete_bar_prev, "complete-bar-prev"; Complete_bar_first, "complete-bar-first"; Complete_bar_last, "complete-bar-last"; Complete_bar, "complete-bar"; History_prev, "history-prev"; History_next, "history-next"; Accept, "accept"; Clear_screen, "clear-screen"; Prev_search, "prev-search"; Cancel_search, "cancel-search"; Break, "break"; Suspend, "suspend"; ] let actions_to_names = Array.of_list (List.sort (fun (a1, n1) (a2, n2) -> Pervasives.compare a1 a2) actions) let names_to_actions = Array.of_list (List.sort (fun (a1, n1) (a2, n2) -> Pervasives.compare n1 n2) actions) let action_of_name x = let rec loop a b = if a = b then Edit (LTerm_edit.action_of_name x) else let c = (a + b) / 2 in let action, name = Array.unsafe_get names_to_actions c in match Pervasives.compare x name with | d when d < 0 -> loop a c | d when d > 0 -> loop (c + 1) b | _ -> action in loop 0 (Array.length names_to_actions) let name_of_action x = let rec loop a b = if a = b then raise Not_found else let c = (a + b) / 2 in let action, name = Array.unsafe_get actions_to_names c in match Pervasives.compare x action with | d when d < 0 -> loop a c | d when d > 0 -> loop (c + 1) b | _ -> name in match x with | Edit x -> LTerm_edit.name_of_action x | _ -> loop 0 (Array.length actions_to_names) module Bindings = Zed_input.Make (LTerm_key) let bindings = ref Bindings.empty let bind seq actions = bindings := Bindings.add seq actions !bindings let unbind seq = bindings := Bindings.remove seq !bindings let () = bind [{ control = false; meta = false; shift = false; code = Home }] [Edit (LTerm_edit.Zed Zed_edit.Goto_bot)]; bind [{ control = false; meta = false; shift = false; code = End }] [Edit (LTerm_edit.Zed Zed_edit.Goto_eot)]; bind [{ control = false; meta = false; shift = false; code = Up }] [History_prev]; bind [{ control = false; meta = false; shift = false; code = Down }] [History_next]; bind [{ control = false; meta = false; shift = false; code = Tab }] [Complete]; bind [{ control = false; meta = false; shift = false; code = Enter }] [Accept]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'b') }] [Edit (LTerm_edit.Zed Zed_edit.Prev_char)]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'f') }] [Edit (LTerm_edit.Zed Zed_edit.Next_char)]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'h') }] [Edit (LTerm_edit.Zed Zed_edit.Delete_prev_char)]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'c') }] [Break]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'z') }] [Suspend]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'm') }] [Accept]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'l') }] [Clear_screen]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'r') }] [Prev_search]; bind [{ control = true; meta = false; shift = false; code = Char(UChar.of_char 'd') }] [Interrupt_or_delete_next_char]; bind [{ control = false; meta = true; shift = false; code = Char(UChar.of_char 'p') }] [History_prev]; bind [{ control = false; meta = true; shift = false; code = Char(UChar.of_char 'n') }] [History_next]; bind [{ control = false; meta = true; shift = false; code = Left }] [Complete_bar_prev]; bind [{ control = false; meta = true; shift = false; code = Right }] [Complete_bar_next]; bind [{ control = false; meta = true; shift = false; code = Home }] [Complete_bar_first]; bind [{ control = false; meta = true; shift = false; code = End }] [Complete_bar_last]; bind [{ control = false; meta = true; shift = false; code = Tab }] [Complete_bar]; bind [{ control = false; meta = true; shift = false; code = Down }] [Complete_bar]; bind [{ control = false; meta = true; shift = false; code = Enter }] [Edit (LTerm_edit.Zed Zed_edit.Newline)]; bind [{ control = false; meta = false; shift = false; code = Escape }] [Cancel_search] (* +-----------------------------------------------------------------+ | The read-line engine | +-----------------------------------------------------------------+ *) let search_string str sub = let rec equal_at a b = (b = String.length sub) || (String.unsafe_get str a = String.unsafe_get sub b) && equal_at (a + 1) (b + 1) in let rec loop ofs idx = if ofs + String.length sub > String.length str then None else if equal_at ofs 0 then Some idx else loop (Zed_utf8.unsafe_next str ofs) (idx + 1) in loop 0 0 let macro = Zed_macro.create [] type mode = | Edition | Search | Set_counter | Add_counter type completion_state = { start : int; (* Beginning of the word being completed *) index : int; (* Index of the selected in [words] *) count : int; (* Length of [words] *) words : (Zed_utf8.t * Zed_utf8.t) list; } let no_completion = { start = 0; index = 0; words = []; count = 0; } class virtual ['a] engine ?(history = []) ?(clipboard = LTerm_edit.clipboard) ?(macro = macro) () = let edit : unit Zed_edit.t = Zed_edit.create ~clipboard () in let context = Zed_edit.context edit (Zed_edit.new_cursor edit) in let mode, set_mode = S.create Edition in let user_completion_state, set_completion_state = E.create () in let reset_completion_state = E.when_ (S.map (fun mode -> mode = Edition) mode) (E.select [ E.stamp (Zed_edit.changes edit ) no_completion; E.stamp (S.changes (Zed_cursor.position (Zed_edit.cursor context))) no_completion; ]) in let completion_state = S.hold ~eq:(==) no_completion (E.select [reset_completion_state; user_completion_state]) in let completion_words = S.map ~eq:(==) (fun c -> c.words) completion_state in let completion_index = S.map (fun c -> c.index) completion_state in let history, set_history = S.create (history, []) in let message, set_message = S.create None in object(self) method virtual eval : 'a method edit = edit method context = context method show_box = true method mode = mode method history = history method message = message method clipboard = clipboard method macro = macro (* The event which occurs when completion need to be recomputed. *) val mutable completion_event = E.never (* Save for when setting the macro counter. *) val mutable save = (0, Zed_rope.empty) method set_completion ?(index=0) start words = let count = List.length words in if index < 0 || index > max 0 (count - 1) then invalid_arg "LTerm_read_line.set_completion: \ index out of bounds compared to words."; set_completion_state { start; index; count; words } initializer completion_event <- ( E.map (fun _ -> (* We can't execute it right now as the user might call [set_completion] immediatly. *) Lwt.pause () >>= fun () -> self#completion; Lwt.return_unit) reset_completion_state ); self#completion method input_prev = Zed_rope.before (Zed_edit.text edit) (Zed_edit.position context) method input_next = Zed_rope.after (Zed_edit.text edit) (Zed_edit.position context) method completion_words = completion_words method completion_index = completion_index method completion = self#set_completion 0 [] method complete = let comp = S.value completion_state in let prefix_length = Zed_edit.position context - comp.start in match comp.words with | [] -> () | [(completion, suffix)] -> Zed_edit.insert context (Zed_rope.of_string (Zed_utf8.after completion prefix_length)); Zed_edit.insert context (Zed_rope.of_string suffix) | (completion, suffix) :: rest -> let word = List.fold_left (fun acc (word, _) -> common_prefix_one acc word) completion rest in Zed_edit.insert context (Zed_rope.of_string (Zed_utf8.after word prefix_length)) (* The event which search for the string in the history. *) val mutable search_event = E.never (* The result of the search. If the search was successful it contains the matched history entry, the position of the substring in this entry and the rest of the history. *) val mutable search_result = None initializer search_event <- E.map (fun _ -> search_result <- None; self#search) (E.when_ (S.map (fun mode -> mode = Search) mode) (Zed_edit.changes edit)) method private search = let input = Zed_rope.to_string (Zed_edit.text edit) in let rec loop = function | [] -> search_result <- None; set_message (Some(LTerm_text.of_string "Reverse search: not found")) | entry :: rest -> match search_string entry input with | Some pos -> begin match search_result with | Some(entry', _, _) when entry = entry' -> loop rest | _ -> search_result <- Some(entry, pos, rest); let txt = LTerm_text.of_string entry in for i = pos to pos + Zed_rope.length (Zed_edit.text edit) - 1 do let ch, style = txt.(i) in txt.(i) <- (ch, { style with underline = Some true }) done; set_message (Some(Array.append (LTerm_text.of_string "Reverse search: ") txt)) end | None -> loop rest in match search_result with | Some(entry, pos, rest) -> loop rest | None -> loop (fst (S.value history)) method insert ch = Zed_edit.insert context (Zed_rope.singleton ch) method send_action action = if action <> Edit LTerm_edit.Stop_macro then Zed_macro.add macro action; match action with | (Complete | Complete_bar | Accept) when S.value mode = Search -> begin set_mode Edition; set_message None; match search_result with | Some(entry, pos, rest) -> search_result <- None; Zed_edit.goto context 0; Zed_edit.remove context (Zed_rope.length (Zed_edit.text edit)); Zed_edit.insert context (Zed_rope.of_string entry) | None -> () end | Edit (LTerm_edit.Zed action) -> Zed_edit.get_action action context | Interrupt_or_delete_next_char -> if Zed_rope.is_empty (Zed_edit.text edit) then raise Interrupt else Zed_edit.delete_next_char context | Complete when S.value mode = Edition -> self#complete | Complete_bar_next when S.value mode = Edition -> let comp = S.value completion_state in if comp.index < comp.count - 1 then set_completion_state { comp with index = comp.index + 1 } | Complete_bar_prev when S.value mode = Edition -> let comp = S.value completion_state in if comp.index > 0 then set_completion_state { comp with index = comp.index - 1 } | Complete_bar_first when S.value mode = Edition -> let comp = S.value completion_state in if comp.index > 0 then set_completion_state { comp with index = 0 } | Complete_bar_last when S.value mode = Edition -> let comp = S.value completion_state in if comp.index < comp.count - 1 then set_completion_state { comp with index = comp.count - 1 } | Complete_bar when S.value mode = Edition -> let comp = S.value completion_state in if comp.words <> [] then begin let prefix_length = Zed_edit.position context - comp.start in let completion, suffix = List.nth comp.words comp.index in Zed_edit.insert context (Zed_rope.of_string (Zed_utf8.after completion prefix_length)); Zed_edit.insert context (Zed_rope.of_string suffix) end | History_prev when S.value mode = Edition ->begin let prev, next = S.value history in match prev with | [] -> () | line :: rest -> let text = Zed_edit.text edit in set_history (rest, Zed_rope.to_string text :: next); Zed_edit.goto context 0; Zed_edit.remove context (Zed_rope.length text); Zed_edit.insert context (Zed_rope.of_string line) end | History_next when S.value mode = Edition -> begin let prev, next = S.value history in match next with | [] -> () | line :: rest -> let text = Zed_edit.text edit in set_history (Zed_rope.to_string text :: prev, rest); Zed_edit.goto context 0; Zed_edit.remove context (Zed_rope.length text); Zed_edit.insert context (Zed_rope.of_string line) end | Prev_search -> begin match S.value mode with | Search -> self#search | Edition -> let text = Zed_edit.text edit in Zed_edit.goto context 0; Zed_edit.remove context (Zed_rope.length text); let prev, next = S.value history in set_history (Zed_rope.to_string text :: (List.rev_append next prev), []); search_result <- None; set_mode Search; self#search | _ -> () end | Cancel_search -> if S.value mode = Search then begin set_mode Edition; set_message None end | Edit LTerm_edit.Start_macro when S.value mode = Edition -> Zed_macro.set_recording macro true | Edit LTerm_edit.Stop_macro -> Zed_macro.set_recording macro false | Edit LTerm_edit.Cancel_macro -> Zed_macro.cancel macro | Edit LTerm_edit.Play_macro -> Zed_macro.cancel macro; List.iter self#send_action (Zed_macro.contents macro) | Edit LTerm_edit.Insert_macro_counter -> Zed_edit.insert context (Zed_rope.of_string (string_of_int (Zed_macro.get_counter macro))); Zed_macro.add_counter macro 1 | Edit LTerm_edit.Set_macro_counter when S.value mode = Edition -> let text = Zed_edit.text edit in save <- (Zed_edit.position context, text); Zed_edit.goto context 0; Zed_edit.remove context (Zed_rope.length text); set_mode Set_counter; set_message (Some (LTerm_text.of_string "Enter a value for the macro counter.")) | Edit LTerm_edit.Add_macro_counter when S.value mode = Edition -> let text = Zed_edit.text edit in save <- (Zed_edit.position context, text); Zed_edit.goto context 0; Zed_edit.remove context (Zed_rope.length text); set_mode Add_counter; set_message (Some (LTerm_text.of_string "Enter a value to add to the macro counter.")) | Accept -> begin match S.value mode with | Edition | Search -> () | Set_counter -> let pos, text = save in save <- (0, Zed_rope.empty); (try Zed_macro.set_counter macro (int_of_string (Zed_rope.to_string (Zed_edit.text edit))) with Failure _ -> ()); Zed_edit.goto context 0; Zed_edit.remove context (Zed_rope.length (Zed_edit.text edit)); Zed_edit.insert context text; Zed_edit.goto context pos; set_mode Edition; set_message None | Add_counter -> let pos, text = save in save <- (0, Zed_rope.empty); (try Zed_macro.add_counter macro (int_of_string (Zed_rope.to_string (Zed_edit.text edit))) with Failure _ -> ()); Zed_edit.goto context 0; Zed_edit.remove context (Zed_rope.length (Zed_edit.text edit)); Zed_edit.insert context text; Zed_edit.goto context pos; set_mode Edition; set_message None end | Break -> raise Sys.Break | Edit (LTerm_edit.Custom f) -> f () | _ -> () method stylise last = let txt = LTerm_text.of_rope (Zed_edit.text edit) in let pos = Zed_edit.position context in if not last && Zed_edit.get_selection edit then begin let mark = Zed_cursor.get_position (Zed_edit.mark edit) in let a = min pos mark and b = max pos mark in for i = a to b - 1 do let ch, style = txt.(i) in txt.(i) <- (ch, { style with underline = Some true }) done; end; (txt, pos) end class virtual ['a] abstract = object method virtual eval : 'a method virtual send_action : action -> unit method virtual insert : UChar.t -> unit method virtual edit : unit Zed_edit.t method virtual context : unit Zed_edit.context method virtual clipboard : Zed_edit.clipboard method virtual macro : action Zed_macro.t method virtual stylise : bool -> LTerm_text.t * int method virtual history : (Zed_utf8.t list * Zed_utf8.t list) signal method virtual message : LTerm_text.t option signal method virtual input_prev : Zed_rope.t method virtual input_next : Zed_rope.t method virtual completion_words : (Zed_utf8.t * Zed_utf8.t) list signal method virtual completion_index : int signal method virtual set_completion : ?index:int -> int -> (Zed_utf8.t * Zed_utf8.t) list -> unit method virtual completion : unit method virtual complete : unit method virtual show_box : bool method virtual mode : mode signal end (* +-----------------------------------------------------------------+ | Predefined classes | +-----------------------------------------------------------------+ *) class read_line ?history () = object(self) inherit [Zed_utf8.t] engine ?history () method eval = Zed_rope.to_string (Zed_edit.text self#edit) end class read_password () = object(self) inherit [Zed_utf8.t] engine () as super method stylise last = let text, pos = super#stylise last in for i = 0 to Array.length text - 1 do let ch, style = text.(i) in text.(i) <- (UChar.of_char '*', style) done; (text, pos) method eval = Zed_rope.to_string (Zed_edit.text self#edit) method show_box = false method send_action = function | Prev_search -> () | action -> super#send_action action end type 'a read_keyword_result = | Rk_value of 'a | Rk_error of Zed_utf8.t class ['a] read_keyword ?history () = object(self) inherit ['a read_keyword_result] engine ?history () method keywords = [] method eval = let input = Zed_rope.to_string (Zed_edit.text self#edit) in try Rk_value(List.assoc input self#keywords) with Not_found -> Rk_error input method completion = let word = Zed_rope.to_string self#input_prev in let keywords = List.filter (fun (keyword, value) -> Zed_utf8.starts_with keyword word) self#keywords in self#set_completion 0 (List.map (fun (keyword, value) -> (keyword, "")) keywords) end (* +-----------------------------------------------------------------+ | Running in a terminal | +-----------------------------------------------------------------+ *) let newline = UChar.of_char '\n' let vline = LTerm_draw.({ top = Light; bottom = Light; left = Blank; right = Blank }) let reverse_style = { LTerm_style.none with LTerm_style.reverse = Some true } let default_prompt = LTerm_text.of_string "# " let rec drop count l = if count <= 0 then l else match l with | [] -> [] | e :: l -> drop (count - 1) l (* Computes the position of the cursor after printing the given styled string: - [pos] is the current cursor position (it may be at column [max-column + 1]) - [text] is the text to display - [start] is the start of the chunk to display in [text] - [stop] is the end of the chunk to display in [text] *) let rec compute_position cols pos text start stop = if start = stop then pos else let ch, style = text.(start) in if ch = newline then compute_position cols { row = pos.row + 1; col = 0 } text (start + 1) stop else if pos.col = cols then compute_position cols { row = pos.row + 1; col = 1 } text (start + 1) stop else compute_position cols { pos with col = pos.col + 1 } text (start + 1) stop (* Return the "real" position of the cursor, i.e. on the screen. *) let real_pos cols pos = if pos.col = cols then { row = pos.row + 1; col = 0 } else pos let rec get_index_of_last_displayed_word column columns index words = match words with | [] -> index - 1 | (word, suffix) :: words -> let column = column + Zed_utf8.length word in if column <= columns - 1 then get_index_of_last_displayed_word (column + 1) columns (index + 1) words else index - 1 let draw_styled ctx row col str = let size = LTerm_draw.size ctx in let rec loop row col idx = if idx < Array.length str then begin let ch, style = Array.unsafe_get str idx in if ch = newline then loop (row + 1) 0 (idx + 1) else begin let point = LTerm_draw.point ctx row col in point.LTerm_draw.char <- ch; LTerm_draw.set_style point style; let col = col + 1 in if col = size.cols then loop (row + 1) 0 (idx + 1) else loop row col (idx + 1) end end in loop row col 0 let unsafe_get matrix row col = Array.unsafe_get (Array.unsafe_get matrix row) col let draw_styled_with_newlines matrix cols row col str = let rec loop row col idx = if idx < Array.length str then begin let ch, style = Array.unsafe_get str idx in if ch = newline then begin (unsafe_get matrix row col).LTerm_draw.char <- newline; loop (row + 1) 0 (idx + 1) end else begin let row, col = if col = cols then (row + 1, 0) else (row, col) in let point = unsafe_get matrix row col in point.LTerm_draw.char <- ch; LTerm_draw.set_style point style; loop row (col + 1) (idx + 1) end end in loop row col 0 let styled_newline = [|(newline, LTerm_style.none)|] class virtual ['a] term term = let size, set_size = S.create (LTerm.size term) in let event, set_prompt = E.create () in let prompt = S.switch (S.hold ~eq:( == ) (S.const default_prompt) event) in let key_sequence, set_key_sequence = S.create [] in object(self) inherit ['a] abstract method size = size method prompt = prompt method set_prompt prompt = set_prompt prompt val mutable visible = true (* Whether the read-line instance is currently visible. *) val mutable displayed = false (* Whether the read-line instance is currently displayed on the screen. *) val mutable draw_queued = false (* Whether a draw operation has been queued, in which case it is not necessary to redraw. *) val mutable cursor = { row = 0; col = 0 } (* The position of the cursor. *) val mutable completion_start = S.const 0 (* Index of the first displayed word in the completion bar. *) val mutable height = 0 (* The height of the displayed material. *) val mutable resolver = None (* The current resolver for resolving input sequences. *) initializer completion_start <- ( S.fold (fun start (words, index, columns) -> if index < start then (* The cursor is before the left margin. *) let count = List.length words in let rev_index = count - index - 1 in count - get_index_of_last_displayed_word 1 columns rev_index (drop rev_index (List.rev words)) - 1 else if index > get_index_of_last_displayed_word 1 columns start (drop start words) then (* The cursor is after the right margin. *) index else start) 0 (S.changes (S.l3 (fun words index size -> (words, index, size.cols)) self#completion_words self#completion_index size)) ) method key_sequence = key_sequence method completion_start = completion_start val draw_mutex = Lwt_mutex.create () method private queue_draw_update = if draw_queued then return () else begin (* Wait a bit in order not to draw too often. *) draw_queued <- true; Lwt.pause () >>= fun () -> draw_queued <- false; Lwt_mutex.with_lock draw_mutex (fun () -> self#draw_update) end method draw_update = let size = S.value size in if visible && size.rows > 0 && size.cols > 0 then begin let styled, position = self#stylise false in let prompt = S.value prompt in (* Compute the position of the cursor after displaying the prompt. *) let pos_after_prompt = compute_position size.cols { row = 0; col = 0 } prompt 0 (Array.length prompt) in (* Compute the position of the cursor after displaying the input before the cursor. *) let pos_after_before = compute_position size.cols pos_after_prompt styled 0 position in (* Compute the position of the cursor after displaying the input. *) let pos_after_styled = compute_position size.cols pos_after_before styled position (Array.length styled) in (* Compute the position of the cursor after displaying the newline used to end the input. *) let pos_after_newline = compute_position size.cols pos_after_styled styled_newline 0 1 in (* The real position of the cursor on the screen. *) let pos_cursor = real_pos size.cols pos_after_before in (* Height of prompt+input. *) let prompt_input_height = max (pos_cursor.row + 1) pos_after_newline.row in let matrix = if self#show_box && size.cols > 2 then match S.value self#message with | Some msg -> (* Compute the height of the message. *) let message_height = (compute_position (size.cols - 2) { row = 0; col = 0 } msg 0 (Array.length msg)).row + 1 in (* The total height of the displayed text. *) let total_height = prompt_input_height + message_height + 2 in (* Create the matrix for the rendering. *) let matrix_size = { cols = size.cols + 1; rows = if displayed then max total_height height else total_height } in let matrix = LTerm_draw.make_matrix matrix_size in (* Update the height parameter. *) height <- total_height; (* Draw the prompt and the input. *) draw_styled_with_newlines matrix size.cols 0 0 prompt; draw_styled_with_newlines matrix size.cols pos_after_prompt.row pos_after_prompt.col styled; draw_styled_with_newlines matrix size.cols pos_after_styled.row pos_after_styled.col styled_newline; let ctx = LTerm_draw.sub (LTerm_draw.context matrix matrix_size) { row1 = 0; col1 = 0; row2 = matrix_size.rows; col2 = size.cols; } in (* Draw a frame for the message. *) LTerm_draw.draw_frame ctx { row1 = prompt_input_height; col1 = 0; row2 = total_height; col2 = size.cols; } LTerm_draw.Light; for row = prompt_input_height to total_height - 1 do (unsafe_get matrix row size.cols).LTerm_draw.char <- newline done; (* Draw the message. *) let ctx = LTerm_draw.sub ctx { row1 = prompt_input_height + 1; col1 = 1; row2 = total_height - 1; col2 = size.cols - 1; } in draw_styled ctx 0 0 msg; matrix | None -> let comp_start = S.value self#completion_start in let comp_index = S.value self#completion_index in let comp_words = drop comp_start (S.value self#completion_words) in (* The total height of the displayed text. *) let total_height = prompt_input_height + 3 in (* Create the matrix for the rendering. *) let matrix_size = { cols = size.cols + 1; rows = if displayed then max total_height height else total_height } in let matrix = LTerm_draw.make_matrix matrix_size in (* Update the height parameter. *) height <- total_height; (* Draw the prompt and the input. *) draw_styled_with_newlines matrix size.cols 0 0 prompt; draw_styled_with_newlines matrix size.cols pos_after_prompt.row pos_after_prompt.col styled; draw_styled_with_newlines matrix size.cols pos_after_styled.row pos_after_styled.col styled_newline; let ctx = LTerm_draw.sub (LTerm_draw.context matrix matrix_size) { row1 = 0; col1 = 0; row2 = matrix_size.rows; col2 = size.cols; } in (* Draw a frame for the completion. *) LTerm_draw.draw_frame ctx { row1 = prompt_input_height; col1 = 0; row2 = total_height; col2 = size.cols; } LTerm_draw.Light; for row = prompt_input_height to total_height - 1 do (unsafe_get matrix row size.cols).LTerm_draw.char <- newline done; (* Draw the completion. *) let ctx = LTerm_draw.sub ctx { row1 = prompt_input_height + 1; col1 = 1; row2 = total_height - 1; col2 = size.cols - 1; } in let rec loop idx col = function | [] -> () | (word, suffix) :: words -> let len = Zed_utf8.length word in LTerm_draw.draw_string ctx 0 col word; (* Apply the reverse style if this is the selected word. *) if idx = comp_index then for col = col to min (col + len - 1) (size.cols - 2) do LTerm_draw.set_style (LTerm_draw.point ctx 0 col) reverse_style done; (* Draw a separator. *) LTerm_draw.draw_piece ctx 0 (col + len) vline; let col = col + len + 1 in if col < size.cols - 2 then loop (idx + 1) col words in loop comp_start 0 comp_words; matrix else begin let total_height = prompt_input_height in let matrix_size = { cols = size.cols + 1; rows = if displayed then max total_height height else total_height } in let matrix = LTerm_draw.make_matrix matrix_size in height <- total_height; draw_styled_with_newlines matrix size.cols 0 0 prompt; draw_styled_with_newlines matrix size.cols pos_after_prompt.row pos_after_prompt.col styled; matrix end in LTerm.hide_cursor term >>= fun () -> begin if displayed then (* Go back to the beginning of displayed text. *) LTerm.move term (-cursor.row) (-cursor.col) else return () end >>= fun () -> (* Display everything. *) LTerm.print_box_with_newlines term matrix >>= fun () -> (* Update the cursor. *) cursor <- pos_cursor; (* Move the cursor to the right position. *) LTerm.move term (cursor.row - Array.length matrix + 1) cursor.col >>= fun () -> LTerm.show_cursor term >>= fun () -> LTerm.flush term >>= fun () -> displayed <- true; return () end else return () method draw_success = let size = S.value size in if size.rows > 0 && size.cols > 0 then begin let styled, position = self#stylise true in let prompt = S.value prompt in let pos_after_prompt = compute_position size.cols { row = 0; col = 0 } prompt 0 (Array.length prompt) in let pos_after_before = compute_position size.cols pos_after_prompt styled 0 position in let pos_after_styled = compute_position size.cols pos_after_before styled position (Array.length styled) in let total_height = pos_after_styled.row + 1 in let matrix_size = { cols = size.cols + 1; rows = if displayed then max total_height height else total_height } in let matrix = LTerm_draw.make_matrix matrix_size in draw_styled_with_newlines matrix size.cols 0 0 prompt; draw_styled_with_newlines matrix size.cols pos_after_prompt.row pos_after_prompt.col styled; draw_styled_with_newlines matrix size.cols pos_after_styled.row pos_after_styled.col styled_newline; (if displayed then LTerm.move term (-cursor.row) (-cursor.col) else return ()) >>= fun () -> LTerm.print_box_with_newlines term matrix >>= fun () -> LTerm.move term (total_height - Array.length matrix) 0 >>= fun () -> (* Print a newline instead of a movement to ensure scrolling when at the end of screen. *) LTerm.fprint term "\n" end else return () method draw_failure = self#draw_success method hide = if visible then begin visible <- false; Lwt_mutex.lock draw_mutex >>= fun () -> Lwt.finalize (fun () -> let size = S.value size in if displayed && size.rows > 0 && size.cols > 0 then let matrix_size = { cols = size.cols + 1; rows = height } in let matrix = LTerm_draw.make_matrix matrix_size in for row = 0 to height - 1 do (unsafe_get matrix row 0).LTerm_draw.char <- newline done; LTerm.move term (-cursor.row) (-cursor.col) >>= fun () -> LTerm.print_box_with_newlines term matrix >>= fun () -> LTerm.move term (1 - Array.length matrix) 0 >>= fun () -> cursor <- { row = 0; col = 0 }; height <- 0; displayed <- false; return () else return ()) (fun () -> Lwt_mutex.unlock draw_mutex; return ()) end else return () method show = if not visible then begin visible <- true; self#queue_draw_update end else return () val mutable mode = None val mutable local_bindings = Bindings.empty method bind keys actions = local_bindings <- Bindings.add keys actions local_bindings (* The main loop. *) method private loop = LTerm.read_event term >>= fun ev -> match ev with | LTerm_event.Resize size -> set_size size; self#loop | LTerm_event.Key key -> begin let res = match resolver with | Some res -> res | None -> Bindings.resolver [ Bindings.pack (fun x -> x) local_bindings ; Bindings.pack (fun x -> x) !bindings ; Bindings.pack (List.map (fun x -> Edit x)) !LTerm_edit.bindings ] in match Bindings.resolve key res with | Bindings.Accepted actions -> resolver <- None; set_key_sequence []; self#exec actions | Bindings.Continue res -> resolver <- Some res; set_key_sequence (S.value key_sequence @ [key]); self#loop | Bindings.Rejected -> set_key_sequence []; if resolver = None then match key with | { control = false; meta = false; shift = false; code = Char ch } -> Zed_macro.add self#macro (Edit (LTerm_edit.Zed (Zed_edit.Insert ch))); self#insert ch | { code = Char ch } when LTerm.windows term && UChar.code ch >= 32 -> (* Windows reports Shift+A for A, ... *) Zed_macro.add self#macro (Edit (LTerm_edit.Zed (Zed_edit.Insert ch))); self#insert ch | _ -> () else resolver <- None; self#loop end | _ -> self#loop method private exec = function | Accept :: _ when S.value self#mode = Edition -> Zed_macro.add self#macro Accept; return self#eval | Clear_screen :: actions -> Zed_macro.add self#macro Clear_screen; LTerm.clear_screen term >>= fun () -> LTerm.goto term { row = 0; col = 0 } >>= fun () -> displayed <- false; self#queue_draw_update >>= fun () -> self#exec actions | Edit LTerm_edit.Play_macro :: actions -> Zed_macro.cancel self#macro; self#exec (Zed_macro.contents macro @ actions) | Suspend :: actions -> if Sys.win32 then self#exec actions else begin let is_visible = visible in self#hide >>= fun () -> LTerm.flush term >>= fun () -> begin match mode with | Some mode -> LTerm.leave_raw_mode term mode | None -> return () end >>= fun () -> Unix.kill (Unix.getpid ()) Sys.sigtstp; begin match LTerm.is_a_tty term with | true -> LTerm.enter_raw_mode term >>= fun m -> mode <- Some m; return () | false -> return () end >>= fun () -> (if is_visible then self#show else return ()) >>= fun () -> self#exec actions end | action :: actions -> self#send_action action; self#exec actions | [] -> self#loop method run = (* Update the size with the current size. *) set_size (LTerm.size term); let running = ref true in (* Redraw everything when needed. *) let event = E.map_p (fun () -> if !running then self#queue_draw_update else return ()) (E.select [ E.stamp (S.changes size) (); Zed_edit.update self#edit [Zed_edit.cursor self#context]; E.stamp (S.changes prompt) (); E.stamp (S.changes self#completion_words) (); E.stamp (S.changes self#completion_index) (); E.stamp (S.changes self#completion_start) (); E.stamp (S.changes self#message) (); ]) in begin match LTerm.is_a_tty term with | true -> LTerm.enter_raw_mode term >>= fun m -> mode <- Some m; return () | false -> return () end >>= fun () -> begin Lwt.finalize (fun () -> Lwt.catch (fun () -> (* Go to the beginning of line otherwise all offset calculation will be false. *) LTerm.fprint term "\r" >>= fun () -> self#queue_draw_update >>= fun () -> self#loop) (fun exn -> running := false; E.stop event; Lwt_mutex.with_lock draw_mutex (fun () -> self#draw_failure) >>= fun () -> Lwt.fail exn)) (fun () -> match mode with | Some mode -> LTerm.leave_raw_mode term mode | None -> return ()) end >>= fun result -> running := false; E.stop event; Lwt_mutex.with_lock draw_mutex (fun () -> self#draw_success) >>= fun () -> return result end lambda-term-1.9/src/lTerm_read_line.mli000066400000000000000000000244441254222632000201350ustar00rootroot00000000000000(* * lTerm_read_line.mli * ------------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (** Interactive line input *) (** For a complete example of usage of this module, look at the shell example (examples/shell.ml) distributed with Lambda-Term. *) open CamomileLibrary open React exception Interrupt (** Exception raised when the user presses [Ctrl^D] with an empty input. *) type prompt = LTerm_text.t (** Type of prompts. *) type history = Zed_utf8.t list (** Type of histories. It is a list of entries from the most recent to the oldest. *) (** {6 Completion} *) val common_prefix : string list -> string (** Returns the common prefix of a list of words. *) val lookup : Zed_utf8.t -> Zed_utf8.t list -> Zed_utf8.t list (** [lookup word words] lookup for completion of [word] into [words]. It returns all words starting with [word]. *) val lookup_assoc : Zed_utf8.t -> (Zed_utf8.t * 'a) list -> (Zed_utf8.t * 'a) list (** [lookup_assoc word words] does the same as {!lookup} but works on associative list. *) (** {6 Actions} *) (** Type of actions. *) type action = | Edit of LTerm_edit.action (** An edition action. *) | Interrupt_or_delete_next_char (** Interrupt if at the beginning of an empty line, or delete the next character. *) | Complete (** Complete current input. *) | Complete_bar_next (** Go to the next possible completion in the completion bar. *) | Complete_bar_prev (** Go to the previous possible completion in the completion bar. *) | Complete_bar_first (** Goto the beginning of the completion bar. *) | Complete_bar_last (** Goto the end of the completion bar. *) | Complete_bar (** Complete current input using the completion bar. *) | History_prev (** Go to the previous entry of the history. *) | History_next (** Go to the next entry of the history. *) | Accept (** Accept the current input. *) | Clear_screen (** Clear the screen. *) | Prev_search (** Search backward in the history. *) | Cancel_search (** Cancel search mode. *) | Break (** Raise [Sys.Break]. *) | Suspend (** Suspend the program. *) val bindings : action list Zed_input.Make(LTerm_key).t ref (** Bindings. *) val bind : LTerm_key.t list -> action list -> unit (** [bind seq actions] associates [actions] to the given sequence. *) val unbind : LTerm_key.t list -> unit (** [unbind seq] unbinds [seq]. *) val actions : (action * string) list (** List of actions with their names, except {!Edit}. *) val doc_of_action : action -> string (** [doc_of_action action] returns a short description of the action. *) val action_of_name : string -> action (** [action_of_name str] converts the given action name into an action. Action name are the same as variants name but lowercased and with '_' replaced by '-'. It raises [Not_found] if the name does not correspond to an action. It also recognizes edition actions. *) val name_of_action : action -> string (** [name_of_action act] returns the name of the given action. *) (** {6 The read-line engine} *) val macro : action Zed_macro.t (** The global macro recorder. *) (** The current read-line mode. *) type mode = | Edition (** Editing. *) | Search (** Backward search. *) | Set_counter (** Setting the macro counter value. *) | Add_counter (** Adding a value to the macro counter. *) (** The read-line engine. If no clipboard is provided, {!LTerm_edit.clipboard} is used. If no macro recorder is provided, {!macro} is used. *) class virtual ['a] engine : ?history : history -> ?clipboard : Zed_edit.clipboard -> ?macro : action Zed_macro.t -> unit -> object (** {6 Result} *) method virtual eval : 'a (** Evaluates the contents of the engine. *) (** {6 Actions} *) method insert : UChar.t -> unit (** Inserts the given character. Note that is it also possible to manipulate directly the edition context. *) method send_action : action -> unit (** Evolves according to the given action. *) (** {6 State} *) method edit : unit Zed_edit.t (** The edition engine used by this read-line engine. *) method context : unit Zed_edit.context (** The context for the edition engine. *) method clipboard : Zed_edit.clipboard (** The clipboard used by the edition engine. *) method macro : action Zed_macro.t (** The macro recorder. *) method input_prev : Zed_rope.t (** The input before the cursor. *) method input_next : Zed_rope.t (** The input after the cursor. *) method mode : mode signal (** The current mode. *) method stylise : bool -> LTerm_text.t * int (** Returns the stylised input and the position of the cursor. The argument is [true] if this is for the last drawing or [false] otherwise. *) method history : (Zed_utf8.t list * Zed_utf8.t list) signal (** The history zipper. *) method message : LTerm_text.t option signal (** A message to display in the completion box. When [None] the completion should be displayed, and when [Some msg] [msg] should be displayed. *) (** {6 Completion} *) method completion_words : (Zed_utf8.t * Zed_utf8.t) list signal (** Current possible completions. Each completion is of the form [(word, suffix)] where [word] is the completion itself and [suffix] is a suffix to add if the completion is choosen. *) method completion_index : int signal (** The position in the completion bar. *) method set_completion : ?index:int -> int -> (Zed_utf8.t * Zed_utf8.t) list -> unit (** [set_completion ?index start words] sets the current completions. [start] is the position of the beginning of the word being completed and [words] is the list of possible completions with their suffixes. [index] is the position in the completion bar, default to [0]. The result is made available through the {!completion_words} signal. *) method completion : unit (** Ask for computing completion for current input. This method should call {!set_completion}. *) method complete : unit (** Complete current input. This is the method called when the user presses Tab. *) method show_box : bool (** Whether to show the box or not. It default to [true]. *) end (** Abstract version of {!engine}. *) class virtual ['a] abstract : object method virtual eval : 'a method virtual send_action : action -> unit method virtual insert : UChar.t -> unit method virtual edit : unit Zed_edit.t method virtual context : unit Zed_edit.context method virtual clipboard : Zed_edit.clipboard method virtual macro : action Zed_macro.t method virtual stylise : bool -> LTerm_text.t * int method virtual history : (Zed_utf8.t list * Zed_utf8.t list) signal method virtual message : LTerm_text.t option signal method virtual input_prev : Zed_rope.t method virtual input_next : Zed_rope.t method virtual completion_words : (Zed_utf8.t * Zed_utf8.t) list signal method virtual completion_index : int signal method virtual set_completion : ?index:int -> int -> (Zed_utf8.t * Zed_utf8.t) list -> unit method virtual completion : unit method virtual complete : unit method virtual show_box : bool method virtual mode : mode signal end (** {6 Predefined classes} *) (** Simple read-line engine which returns the result as a string. *) class read_line : ?history : history -> unit -> object inherit [Zed_utf8.t] engine method eval : Zed_utf8.t (** Returns the result as a UTF-8 encoded string. *) end (** Read-line engine for reading a password. The [stylise] method default to replacing all characters by ['*']. You can also for example completely disable displaying the password by doing: {[ method stylise = ([||], 0) ]} Also showing completion is disabled. *) class read_password : unit -> object inherit [Zed_utf8.t] engine method eval : Zed_utf8.t (** Returns the result as a UTF-8 encoded string. *) end (** The result of reading a keyword. *) type 'a read_keyword_result = | Rk_value of 'a (** The user typed a correct keyword and this is its associated value. *) | Rk_error of Zed_utf8.t (** The user did not enter a correct keyword and this is what he typed instead. *) (** Read a keyword. *) class ['a] read_keyword : ?history : history -> unit -> object inherit ['a read_keyword_result] engine method eval : 'a read_keyword_result (** If the input correspond to a keyword, returns its associated value. otherwise returns [`Error input]. *) method keywords : (string * 'a) list (** List of keywords with their associated values. *) end (** {6 Running in a terminal} *) (** Class for read-line instances running in a terminal. *) class virtual ['a] term : LTerm.t -> object inherit ['a] abstract method run : 'a Lwt.t (** Run this read-line instance. *) method private exec : action list -> 'a Lwt.t (** Executes a list of actions. Rememver to call [Zed_macro.add self#macro action] if you overload this method. *) method bind : LTerm_key.t list -> action list -> unit method draw_update : unit Lwt.t (** Updates current display and put the cursor at current edition position. *) method draw_success : unit Lwt.t (** Draws after accepting current input. *) method draw_failure : unit Lwt.t (** Draws after an exception has been raised. *) method prompt : prompt signal (** The signal holding the prompt. *) method set_prompt : prompt signal -> unit (** Sets the prompt signal. *) method size : LTerm_geom.size signal (** The size of the terminal. This can be used for computing the prompt. *) method key_sequence : LTerm_key.t list signal (** The currently typed key sequence. *) method completion_start : int signal (** Index of the first displayed word in the completion bar. *) method hide : unit Lwt.t (** Hide this read-line instance. It remains invisible until {!show} is called. *) method show : unit Lwt.t (** Show this read-line instance if it has been previously hidden. *) val mutable visible : bool (** Whether the instance is visible. *) end lambda-term-1.9/src/lTerm_resource_lexer.mll000066400000000000000000000011511254222632000212320ustar00rootroot00000000000000(* * lTerm_resource_lexer.mll * ------------------------ * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) let blank = [' ' '\t'] let eol = ('\n' | eof) rule line = parse | eof { `EOF } | blank* ('!' [^'\n']* eol | eol) { `Empty } | blank* ([^' ' '\t' '\n']+ as key) blank* ':' blank* ([^' ' '\t' '\n']* as value) blank* eol { `Assoc(key, value) } | [^':' '\n']+ eol { `Error("':' missing") } | blank* ':' [^'\n']* eol { `Error("key missing") } | [^'\n']* eol { `Error("unknown error") } lambda-term-1.9/src/lTerm_resources.ml000066400000000000000000001427071254222632000200570ustar00rootroot00000000000000(* * lTerm_resources.ml * ------------------ * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) let return, (>>=) = Lwt.return, Lwt.(>>=) let home = try Sys.getenv "HOME" with Not_found -> try (Unix.getpwuid (Unix.getuid ())).Unix.pw_dir with Unix.Unix_error _ | Not_found -> if Sys.win32 then try Sys.getenv "AppData" with Not_found -> "" else "" (* +-----------------------------------------------------------------+ | Types | +-----------------------------------------------------------------+ *) type pattern = string list (* Type of a pattern. For example the pattern ["foo*bar*"] is represented by the list [["foo"; "bar"; ""]]. *) type t = (pattern * string) list (* +-----------------------------------------------------------------+ | Pattern matching | +-----------------------------------------------------------------+ *) let sub_equal str ofs patt = let str_len = String.length str and patt_len = String.length patt in let rec loop ofs ofs_patt = ofs_patt = patt_len || (str.[ofs] = patt.[ofs_patt] && loop (ofs + 1) (ofs_patt + 1)) in ofs + patt_len <= str_len && loop ofs 0 let pattern_match pattern string = let length = String.length string in let rec loop offset pattern = if offset = length then pattern = [] || pattern = [""] else match pattern with | [] -> false | literal :: pattern -> let literal_length = String.length literal in let max_offset = length - literal_length in let rec search offset = offset <= max_offset && ((sub_equal string offset literal && loop (offset + literal_length) pattern) || search (offset + 1)) in search offset in match pattern with | [] -> string = "" | literal :: pattern -> sub_equal string 0 literal && loop (String.length literal) pattern (* +-----------------------------------------------------------------+ | Pattern creation | +-----------------------------------------------------------------+ *) let split pattern = let len = String.length pattern in let rec loop ofs = if ofs = len then [""] else match try Some(String.index_from pattern ofs '*') with Not_found -> None with | Some ofs' -> String.sub pattern ofs (ofs' - ofs) :: loop (ofs' + 1) | None -> [String.sub pattern ofs (len - ofs)] in loop 0 (* +-----------------------------------------------------------------+ | Set operations | +-----------------------------------------------------------------+ *) let empty = [] let rec get key = function | [] -> "" | (pattern, value) :: rest -> if pattern_match pattern key then value else get key rest let add pattern value resources = (split pattern, value) :: resources let merge = ( @ ) (* +-----------------------------------------------------------------+ | Readers | +-----------------------------------------------------------------+ *) exception Error of string let error str = raise (Error str) let get_bool key resources = match String.lowercase (get key resources) with | "true" -> Some true | "false" -> Some false | "" | "none" -> None | s -> Printf.ksprintf error "invalid boolean value %S" s let hex_of_char ch = match ch with | '0' .. '9' -> Char.code ch - Char.code '0' | 'A' .. 'F' -> Char.code ch - Char.code 'A' + 10 | 'a' .. 'f' -> Char.code ch - Char.code 'a' + 10 | ch -> raise Exit let get_color key resources = match String.lowercase (get key resources) with (* Terminal colors. *) | "default" -> Some LTerm_style.default | "black" -> Some LTerm_style.black | "red" -> Some LTerm_style.red | "green" -> Some LTerm_style.green | "yellow" -> Some LTerm_style.yellow | "blue" -> Some LTerm_style.blue | "magenta" -> Some LTerm_style.magenta | "cyan" -> Some LTerm_style.cyan | "white" -> Some LTerm_style.white | "lblack" -> Some LTerm_style.lblack | "lred" -> Some LTerm_style.lred | "lgreen" -> Some LTerm_style.lgreen | "lyellow" -> Some LTerm_style.lyellow | "lblue" -> Some LTerm_style.lblue | "lmagenta" -> Some LTerm_style.lmagenta | "lcyan" -> Some LTerm_style.lcyan | "lwhite" -> Some LTerm_style.lwhite | "light-black" -> Some LTerm_style.lblack | "light-red" -> Some LTerm_style.lred | "light-green" -> Some LTerm_style.lgreen | "light-yellow" -> Some LTerm_style.lyellow | "light-blue" -> Some LTerm_style.lblue | "light-magenta" -> Some LTerm_style.lmagenta | "light-cyan" -> Some LTerm_style.lcyan | "light-white" -> Some LTerm_style.lwhite (* X11 colors. *) | "x-snow" -> Some (LTerm_style.rgb 255 250 250) | "x-ghost-white" -> Some (LTerm_style.rgb 248 248 255) | "x-ghostwhite" -> Some (LTerm_style.rgb 248 248 255) | "x-white-smoke" -> Some (LTerm_style.rgb 245 245 245) | "x-whitesmoke" -> Some (LTerm_style.rgb 245 245 245) | "x-gainsboro" -> Some (LTerm_style.rgb 220 220 220) | "x-floral-white" -> Some (LTerm_style.rgb 255 250 240) | "x-floralwhite" -> Some (LTerm_style.rgb 255 250 240) | "x-old-lace" -> Some (LTerm_style.rgb 253 245 230) | "x-oldlace" -> Some (LTerm_style.rgb 253 245 230) | "x-linen" -> Some (LTerm_style.rgb 250 240 230) | "x-antique-white" -> Some (LTerm_style.rgb 250 235 215) | "x-antiquewhite" -> Some (LTerm_style.rgb 250 235 215) | "x-papaya-whip" -> Some (LTerm_style.rgb 255 239 213) | "x-papayawhip" -> Some (LTerm_style.rgb 255 239 213) | "x-blanched-almond" -> Some (LTerm_style.rgb 255 235 205) | "x-blanchedalmond" -> Some (LTerm_style.rgb 255 235 205) | "x-bisque" -> Some (LTerm_style.rgb 255 228 196) | "x-peach-puff" -> Some (LTerm_style.rgb 255 218 185) | "x-peachpuff" -> Some (LTerm_style.rgb 255 218 185) | "x-navajo-white" -> Some (LTerm_style.rgb 255 222 173) | "x-navajowhite" -> Some (LTerm_style.rgb 255 222 173) | "x-moccasin" -> Some (LTerm_style.rgb 255 228 181) | "x-cornsilk" -> Some (LTerm_style.rgb 255 248 220) | "x-ivory" -> Some (LTerm_style.rgb 255 255 240) | "x-lemon-chiffon" -> Some (LTerm_style.rgb 255 250 205) | "x-lemonchiffon" -> Some (LTerm_style.rgb 255 250 205) | "x-seashell" -> Some (LTerm_style.rgb 255 245 238) | "x-honeydew" -> Some (LTerm_style.rgb 240 255 240) | "x-mint-cream" -> Some (LTerm_style.rgb 245 255 250) | "x-mintcream" -> Some (LTerm_style.rgb 245 255 250) | "x-azure" -> Some (LTerm_style.rgb 240 255 255) | "x-alice-blue" -> Some (LTerm_style.rgb 240 248 255) | "x-aliceblue" -> Some (LTerm_style.rgb 240 248 255) | "x-lavender" -> Some (LTerm_style.rgb 230 230 250) | "x-lavender-blush" -> Some (LTerm_style.rgb 255 240 245) | "x-lavenderblush" -> Some (LTerm_style.rgb 255 240 245) | "x-misty-rose" -> Some (LTerm_style.rgb 255 228 225) | "x-mistyrose" -> Some (LTerm_style.rgb 255 228 225) | "x-white" -> Some (LTerm_style.rgb 255 255 255) | "x-black" -> Some (LTerm_style.rgb 0 0 0) | "x-dark-slate-gray" -> Some (LTerm_style.rgb 47 79 79) | "x-darkslategray" -> Some (LTerm_style.rgb 47 79 79) | "x-dark-slate-grey" -> Some (LTerm_style.rgb 47 79 79) | "x-darkslategrey" -> Some (LTerm_style.rgb 47 79 79) | "x-dim-gray" -> Some (LTerm_style.rgb 105 105 105) | "x-dimgray" -> Some (LTerm_style.rgb 105 105 105) | "x-dim-grey" -> Some (LTerm_style.rgb 105 105 105) | "x-dimgrey" -> Some (LTerm_style.rgb 105 105 105) | "x-slate-gray" -> Some (LTerm_style.rgb 112 128 144) | "x-slategray" -> Some (LTerm_style.rgb 112 128 144) | "x-slate-grey" -> Some (LTerm_style.rgb 112 128 144) | "x-slategrey" -> Some (LTerm_style.rgb 112 128 144) | "x-light-slate-gray" -> Some (LTerm_style.rgb 119 136 153) | "x-lightslategray" -> Some (LTerm_style.rgb 119 136 153) | "x-light-slate-grey" -> Some (LTerm_style.rgb 119 136 153) | "x-lightslategrey" -> Some (LTerm_style.rgb 119 136 153) | "x-gray" -> Some (LTerm_style.rgb 190 190 190) | "x-grey" -> Some (LTerm_style.rgb 190 190 190) | "x-light-grey" -> Some (LTerm_style.rgb 211 211 211) | "x-lightgrey" -> Some (LTerm_style.rgb 211 211 211) | "x-light-gray" -> Some (LTerm_style.rgb 211 211 211) | "x-lightgray" -> Some (LTerm_style.rgb 211 211 211) | "x-midnight-blue" -> Some (LTerm_style.rgb 25 25 112) | "x-midnightblue" -> Some (LTerm_style.rgb 25 25 112) | "x-navy" -> Some (LTerm_style.rgb 0 0 128) | "x-navy-blue" -> Some (LTerm_style.rgb 0 0 128) | "x-navyblue" -> Some (LTerm_style.rgb 0 0 128) | "x-cornflower-blue" -> Some (LTerm_style.rgb 100 149 237) | "x-cornflowerblue" -> Some (LTerm_style.rgb 100 149 237) | "x-dark-slate-blue" -> Some (LTerm_style.rgb 72 61 139) | "x-darkslateblue" -> Some (LTerm_style.rgb 72 61 139) | "x-slate-blue" -> Some (LTerm_style.rgb 106 90 205) | "x-slateblue" -> Some (LTerm_style.rgb 106 90 205) | "x-medium-slate-blue" -> Some (LTerm_style.rgb 123 104 238) | "x-mediumslateblue" -> Some (LTerm_style.rgb 123 104 238) | "x-light-slate-blue" -> Some (LTerm_style.rgb 132 112 255) | "x-lightslateblue" -> Some (LTerm_style.rgb 132 112 255) | "x-medium-blue" -> Some (LTerm_style.rgb 0 0 205) | "x-mediumblue" -> Some (LTerm_style.rgb 0 0 205) | "x-royal-blue" -> Some (LTerm_style.rgb 65 105 225) | "x-royalblue" -> Some (LTerm_style.rgb 65 105 225) | "x-blue" -> Some (LTerm_style.rgb 0 0 255) | "x-dodger-blue" -> Some (LTerm_style.rgb 30 144 255) | "x-dodgerblue" -> Some (LTerm_style.rgb 30 144 255) | "x-deep-sky-blue" -> Some (LTerm_style.rgb 0 191 255) | "x-deepskyblue" -> Some (LTerm_style.rgb 0 191 255) | "x-sky-blue" -> Some (LTerm_style.rgb 135 206 235) | "x-skyblue" -> Some (LTerm_style.rgb 135 206 235) | "x-light-sky-blue" -> Some (LTerm_style.rgb 135 206 250) | "x-lightskyblue" -> Some (LTerm_style.rgb 135 206 250) | "x-steel-blue" -> Some (LTerm_style.rgb 70 130 180) | "x-steelblue" -> Some (LTerm_style.rgb 70 130 180) | "x-light-steel-blue" -> Some (LTerm_style.rgb 176 196 222) | "x-lightsteelblue" -> Some (LTerm_style.rgb 176 196 222) | "x-light-blue" -> Some (LTerm_style.rgb 173 216 230) | "x-lightblue" -> Some (LTerm_style.rgb 173 216 230) | "x-powder-blue" -> Some (LTerm_style.rgb 176 224 230) | "x-powderblue" -> Some (LTerm_style.rgb 176 224 230) | "x-pale-turquoise" -> Some (LTerm_style.rgb 175 238 238) | "x-paleturquoise" -> Some (LTerm_style.rgb 175 238 238) | "x-dark-turquoise" -> Some (LTerm_style.rgb 0 206 209) | "x-darkturquoise" -> Some (LTerm_style.rgb 0 206 209) | "x-medium-turquoise" -> Some (LTerm_style.rgb 72 209 204) | "x-mediumturquoise" -> Some (LTerm_style.rgb 72 209 204) | "x-turquoise" -> Some (LTerm_style.rgb 64 224 208) | "x-cyan" -> Some (LTerm_style.rgb 0 255 255) | "x-light-cyan" -> Some (LTerm_style.rgb 224 255 255) | "x-lightcyan" -> Some (LTerm_style.rgb 224 255 255) | "x-cadet-blue" -> Some (LTerm_style.rgb 95 158 160) | "x-cadetblue" -> Some (LTerm_style.rgb 95 158 160) | "x-medium-aquamarine" -> Some (LTerm_style.rgb 102 205 170) | "x-mediumaquamarine" -> Some (LTerm_style.rgb 102 205 170) | "x-aquamarine" -> Some (LTerm_style.rgb 127 255 212) | "x-dark-green" -> Some (LTerm_style.rgb 0 100 0) | "x-darkgreen" -> Some (LTerm_style.rgb 0 100 0) | "x-dark-olive-green" -> Some (LTerm_style.rgb 85 107 47) | "x-darkolivegreen" -> Some (LTerm_style.rgb 85 107 47) | "x-dark-sea-green" -> Some (LTerm_style.rgb 143 188 143) | "x-darkseagreen" -> Some (LTerm_style.rgb 143 188 143) | "x-sea-green" -> Some (LTerm_style.rgb 46 139 87) | "x-seagreen" -> Some (LTerm_style.rgb 46 139 87) | "x-medium-sea-green" -> Some (LTerm_style.rgb 60 179 113) | "x-mediumseagreen" -> Some (LTerm_style.rgb 60 179 113) | "x-light-sea-green" -> Some (LTerm_style.rgb 32 178 170) | "x-lightseagreen" -> Some (LTerm_style.rgb 32 178 170) | "x-pale-green" -> Some (LTerm_style.rgb 152 251 152) | "x-palegreen" -> Some (LTerm_style.rgb 152 251 152) | "x-spring-green" -> Some (LTerm_style.rgb 0 255 127) | "x-springgreen" -> Some (LTerm_style.rgb 0 255 127) | "x-lawn-green" -> Some (LTerm_style.rgb 124 252 0) | "x-lawngreen" -> Some (LTerm_style.rgb 124 252 0) | "x-green" -> Some (LTerm_style.rgb 0 255 0) | "x-chartreuse" -> Some (LTerm_style.rgb 127 255 0) | "x-medium-spring-green" -> Some (LTerm_style.rgb 0 250 154) | "x-mediumspringgreen" -> Some (LTerm_style.rgb 0 250 154) | "x-green-yellow" -> Some (LTerm_style.rgb 173 255 47) | "x-greenyellow" -> Some (LTerm_style.rgb 173 255 47) | "x-lime-green" -> Some (LTerm_style.rgb 50 205 50) | "x-limegreen" -> Some (LTerm_style.rgb 50 205 50) | "x-yellow-green" -> Some (LTerm_style.rgb 154 205 50) | "x-yellowgreen" -> Some (LTerm_style.rgb 154 205 50) | "x-forest-green" -> Some (LTerm_style.rgb 34 139 34) | "x-forestgreen" -> Some (LTerm_style.rgb 34 139 34) | "x-olive-drab" -> Some (LTerm_style.rgb 107 142 35) | "x-olivedrab" -> Some (LTerm_style.rgb 107 142 35) | "x-dark-khaki" -> Some (LTerm_style.rgb 189 183 107) | "x-darkkhaki" -> Some (LTerm_style.rgb 189 183 107) | "x-khaki" -> Some (LTerm_style.rgb 240 230 140) | "x-pale-goldenrod" -> Some (LTerm_style.rgb 238 232 170) | "x-palegoldenrod" -> Some (LTerm_style.rgb 238 232 170) | "x-light-goldenrod-yellow" -> Some (LTerm_style.rgb 250 250 210) | "x-lightgoldenrodyellow" -> Some (LTerm_style.rgb 250 250 210) | "x-light-yellow" -> Some (LTerm_style.rgb 255 255 224) | "x-lightyellow" -> Some (LTerm_style.rgb 255 255 224) | "x-yellow" -> Some (LTerm_style.rgb 255 255 0) | "x-gold" -> Some (LTerm_style.rgb 255 215 0) | "x-light-goldenrod" -> Some (LTerm_style.rgb 238 221 130) | "x-lightgoldenrod" -> Some (LTerm_style.rgb 238 221 130) | "x-goldenrod" -> Some (LTerm_style.rgb 218 165 32) | "x-dark-goldenrod" -> Some (LTerm_style.rgb 184 134 11) | "x-darkgoldenrod" -> Some (LTerm_style.rgb 184 134 11) | "x-rosy-brown" -> Some (LTerm_style.rgb 188 143 143) | "x-rosybrown" -> Some (LTerm_style.rgb 188 143 143) | "x-indian-red" -> Some (LTerm_style.rgb 205 92 92) | "x-indianred" -> Some (LTerm_style.rgb 205 92 92) | "x-saddle-brown" -> Some (LTerm_style.rgb 139 69 19) | "x-saddlebrown" -> Some (LTerm_style.rgb 139 69 19) | "x-sienna" -> Some (LTerm_style.rgb 160 82 45) | "x-peru" -> Some (LTerm_style.rgb 205 133 63) | "x-burlywood" -> Some (LTerm_style.rgb 222 184 135) | "x-beige" -> Some (LTerm_style.rgb 245 245 220) | "x-wheat" -> Some (LTerm_style.rgb 245 222 179) | "x-sandy-brown" -> Some (LTerm_style.rgb 244 164 96) | "x-sandybrown" -> Some (LTerm_style.rgb 244 164 96) | "x-tan" -> Some (LTerm_style.rgb 210 180 140) | "x-chocolate" -> Some (LTerm_style.rgb 210 105 30) | "x-firebrick" -> Some (LTerm_style.rgb 178 34 34) | "x-brown" -> Some (LTerm_style.rgb 165 42 42) | "x-dark-salmon" -> Some (LTerm_style.rgb 233 150 122) | "x-darksalmon" -> Some (LTerm_style.rgb 233 150 122) | "x-salmon" -> Some (LTerm_style.rgb 250 128 114) | "x-light-salmon" -> Some (LTerm_style.rgb 255 160 122) | "x-lightsalmon" -> Some (LTerm_style.rgb 255 160 122) | "x-orange" -> Some (LTerm_style.rgb 255 165 0) | "x-dark-orange" -> Some (LTerm_style.rgb 255 140 0) | "x-darkorange" -> Some (LTerm_style.rgb 255 140 0) | "x-coral" -> Some (LTerm_style.rgb 255 127 80) | "x-light-coral" -> Some (LTerm_style.rgb 240 128 128) | "x-lightcoral" -> Some (LTerm_style.rgb 240 128 128) | "x-tomato" -> Some (LTerm_style.rgb 255 99 71) | "x-orange-red" -> Some (LTerm_style.rgb 255 69 0) | "x-orangered" -> Some (LTerm_style.rgb 255 69 0) | "x-red" -> Some (LTerm_style.rgb 255 0 0) | "x-hot-pink" -> Some (LTerm_style.rgb 255 105 180) | "x-hotpink" -> Some (LTerm_style.rgb 255 105 180) | "x-deep-pink" -> Some (LTerm_style.rgb 255 20 147) | "x-deeppink" -> Some (LTerm_style.rgb 255 20 147) | "x-pink" -> Some (LTerm_style.rgb 255 192 203) | "x-light-pink" -> Some (LTerm_style.rgb 255 182 193) | "x-lightpink" -> Some (LTerm_style.rgb 255 182 193) | "x-pale-violet-red" -> Some (LTerm_style.rgb 219 112 147) | "x-palevioletred" -> Some (LTerm_style.rgb 219 112 147) | "x-maroon" -> Some (LTerm_style.rgb 176 48 96) | "x-medium-violet-red" -> Some (LTerm_style.rgb 199 21 133) | "x-mediumvioletred" -> Some (LTerm_style.rgb 199 21 133) | "x-violet-red" -> Some (LTerm_style.rgb 208 32 144) | "x-violetred" -> Some (LTerm_style.rgb 208 32 144) | "x-magenta" -> Some (LTerm_style.rgb 255 0 255) | "x-violet" -> Some (LTerm_style.rgb 238 130 238) | "x-plum" -> Some (LTerm_style.rgb 221 160 221) | "x-orchid" -> Some (LTerm_style.rgb 218 112 214) | "x-medium-orchid" -> Some (LTerm_style.rgb 186 85 211) | "x-mediumorchid" -> Some (LTerm_style.rgb 186 85 211) | "x-dark-orchid" -> Some (LTerm_style.rgb 153 50 204) | "x-darkorchid" -> Some (LTerm_style.rgb 153 50 204) | "x-dark-violet" -> Some (LTerm_style.rgb 148 0 211) | "x-darkviolet" -> Some (LTerm_style.rgb 148 0 211) | "x-blue-violet" -> Some (LTerm_style.rgb 138 43 226) | "x-blueviolet" -> Some (LTerm_style.rgb 138 43 226) | "x-purple" -> Some (LTerm_style.rgb 160 32 240) | "x-medium-purple" -> Some (LTerm_style.rgb 147 112 219) | "x-mediumpurple" -> Some (LTerm_style.rgb 147 112 219) | "x-thistle" -> Some (LTerm_style.rgb 216 191 216) | "x-snow1" -> Some (LTerm_style.rgb 255 250 250) | "x-snow2" -> Some (LTerm_style.rgb 238 233 233) | "x-snow3" -> Some (LTerm_style.rgb 205 201 201) | "x-snow4" -> Some (LTerm_style.rgb 139 137 137) | "x-seashell1" -> Some (LTerm_style.rgb 255 245 238) | "x-seashell2" -> Some (LTerm_style.rgb 238 229 222) | "x-seashell3" -> Some (LTerm_style.rgb 205 197 191) | "x-seashell4" -> Some (LTerm_style.rgb 139 134 130) | "x-antiquewhite1" -> Some (LTerm_style.rgb 255 239 219) | "x-antiquewhite2" -> Some (LTerm_style.rgb 238 223 204) | "x-antiquewhite3" -> Some (LTerm_style.rgb 205 192 176) | "x-antiquewhite4" -> Some (LTerm_style.rgb 139 131 120) | "x-bisque1" -> Some (LTerm_style.rgb 255 228 196) | "x-bisque2" -> Some (LTerm_style.rgb 238 213 183) | "x-bisque3" -> Some (LTerm_style.rgb 205 183 158) | "x-bisque4" -> Some (LTerm_style.rgb 139 125 107) | "x-peachpuff1" -> Some (LTerm_style.rgb 255 218 185) | "x-peachpuff2" -> Some (LTerm_style.rgb 238 203 173) | "x-peachpuff3" -> Some (LTerm_style.rgb 205 175 149) | "x-peachpuff4" -> Some (LTerm_style.rgb 139 119 101) | "x-navajowhite1" -> Some (LTerm_style.rgb 255 222 173) | "x-navajowhite2" -> Some (LTerm_style.rgb 238 207 161) | "x-navajowhite3" -> Some (LTerm_style.rgb 205 179 139) | "x-navajowhite4" -> Some (LTerm_style.rgb 139 121 94) | "x-lemonchiffon1" -> Some (LTerm_style.rgb 255 250 205) | "x-lemonchiffon2" -> Some (LTerm_style.rgb 238 233 191) | "x-lemonchiffon3" -> Some (LTerm_style.rgb 205 201 165) | "x-lemonchiffon4" -> Some (LTerm_style.rgb 139 137 112) | "x-cornsilk1" -> Some (LTerm_style.rgb 255 248 220) | "x-cornsilk2" -> Some (LTerm_style.rgb 238 232 205) | "x-cornsilk3" -> Some (LTerm_style.rgb 205 200 177) | "x-cornsilk4" -> Some (LTerm_style.rgb 139 136 120) | "x-ivory1" -> Some (LTerm_style.rgb 255 255 240) | "x-ivory2" -> Some (LTerm_style.rgb 238 238 224) | "x-ivory3" -> Some (LTerm_style.rgb 205 205 193) | "x-ivory4" -> Some (LTerm_style.rgb 139 139 131) | "x-honeydew1" -> Some (LTerm_style.rgb 240 255 240) | "x-honeydew2" -> Some (LTerm_style.rgb 224 238 224) | "x-honeydew3" -> Some (LTerm_style.rgb 193 205 193) | "x-honeydew4" -> Some (LTerm_style.rgb 131 139 131) | "x-lavenderblush1" -> Some (LTerm_style.rgb 255 240 245) | "x-lavenderblush2" -> Some (LTerm_style.rgb 238 224 229) | "x-lavenderblush3" -> Some (LTerm_style.rgb 205 193 197) | "x-lavenderblush4" -> Some (LTerm_style.rgb 139 131 134) | "x-mistyrose1" -> Some (LTerm_style.rgb 255 228 225) | "x-mistyrose2" -> Some (LTerm_style.rgb 238 213 210) | "x-mistyrose3" -> Some (LTerm_style.rgb 205 183 181) | "x-mistyrose4" -> Some (LTerm_style.rgb 139 125 123) | "x-azure1" -> Some (LTerm_style.rgb 240 255 255) | "x-azure2" -> Some (LTerm_style.rgb 224 238 238) | "x-azure3" -> Some (LTerm_style.rgb 193 205 205) | "x-azure4" -> Some (LTerm_style.rgb 131 139 139) | "x-slateblue1" -> Some (LTerm_style.rgb 131 111 255) | "x-slateblue2" -> Some (LTerm_style.rgb 122 103 238) | "x-slateblue3" -> Some (LTerm_style.rgb 105 89 205) | "x-slateblue4" -> Some (LTerm_style.rgb 71 60 139) | "x-royalblue1" -> Some (LTerm_style.rgb 72 118 255) | "x-royalblue2" -> Some (LTerm_style.rgb 67 110 238) | "x-royalblue3" -> Some (LTerm_style.rgb 58 95 205) | "x-royalblue4" -> Some (LTerm_style.rgb 39 64 139) | "x-blue1" -> Some (LTerm_style.rgb 0 0 255) | "x-blue2" -> Some (LTerm_style.rgb 0 0 238) | "x-blue3" -> Some (LTerm_style.rgb 0 0 205) | "x-blue4" -> Some (LTerm_style.rgb 0 0 139) | "x-dodgerblue1" -> Some (LTerm_style.rgb 30 144 255) | "x-dodgerblue2" -> Some (LTerm_style.rgb 28 134 238) | "x-dodgerblue3" -> Some (LTerm_style.rgb 24 116 205) | "x-dodgerblue4" -> Some (LTerm_style.rgb 16 78 139) | "x-steelblue1" -> Some (LTerm_style.rgb 99 184 255) | "x-steelblue2" -> Some (LTerm_style.rgb 92 172 238) | "x-steelblue3" -> Some (LTerm_style.rgb 79 148 205) | "x-steelblue4" -> Some (LTerm_style.rgb 54 100 139) | "x-deepskyblue1" -> Some (LTerm_style.rgb 0 191 255) | "x-deepskyblue2" -> Some (LTerm_style.rgb 0 178 238) | "x-deepskyblue3" -> Some (LTerm_style.rgb 0 154 205) | "x-deepskyblue4" -> Some (LTerm_style.rgb 0 104 139) | "x-skyblue1" -> Some (LTerm_style.rgb 135 206 255) | "x-skyblue2" -> Some (LTerm_style.rgb 126 192 238) | "x-skyblue3" -> Some (LTerm_style.rgb 108 166 205) | "x-skyblue4" -> Some (LTerm_style.rgb 74 112 139) | "x-lightskyblue1" -> Some (LTerm_style.rgb 176 226 255) | "x-lightskyblue2" -> Some (LTerm_style.rgb 164 211 238) | "x-lightskyblue3" -> Some (LTerm_style.rgb 141 182 205) | "x-lightskyblue4" -> Some (LTerm_style.rgb 96 123 139) | "x-slategray1" -> Some (LTerm_style.rgb 198 226 255) | "x-slategray2" -> Some (LTerm_style.rgb 185 211 238) | "x-slategray3" -> Some (LTerm_style.rgb 159 182 205) | "x-slategray4" -> Some (LTerm_style.rgb 108 123 139) | "x-lightsteelblue1" -> Some (LTerm_style.rgb 202 225 255) | "x-lightsteelblue2" -> Some (LTerm_style.rgb 188 210 238) | "x-lightsteelblue3" -> Some (LTerm_style.rgb 162 181 205) | "x-lightsteelblue4" -> Some (LTerm_style.rgb 110 123 139) | "x-lightblue1" -> Some (LTerm_style.rgb 191 239 255) | "x-lightblue2" -> Some (LTerm_style.rgb 178 223 238) | "x-lightblue3" -> Some (LTerm_style.rgb 154 192 205) | "x-lightblue4" -> Some (LTerm_style.rgb 104 131 139) | "x-lightcyan1" -> Some (LTerm_style.rgb 224 255 255) | "x-lightcyan2" -> Some (LTerm_style.rgb 209 238 238) | "x-lightcyan3" -> Some (LTerm_style.rgb 180 205 205) | "x-lightcyan4" -> Some (LTerm_style.rgb 122 139 139) | "x-paleturquoise1" -> Some (LTerm_style.rgb 187 255 255) | "x-paleturquoise2" -> Some (LTerm_style.rgb 174 238 238) | "x-paleturquoise3" -> Some (LTerm_style.rgb 150 205 205) | "x-paleturquoise4" -> Some (LTerm_style.rgb 102 139 139) | "x-cadetblue1" -> Some (LTerm_style.rgb 152 245 255) | "x-cadetblue2" -> Some (LTerm_style.rgb 142 229 238) | "x-cadetblue3" -> Some (LTerm_style.rgb 122 197 205) | "x-cadetblue4" -> Some (LTerm_style.rgb 83 134 139) | "x-turquoise1" -> Some (LTerm_style.rgb 0 245 255) | "x-turquoise2" -> Some (LTerm_style.rgb 0 229 238) | "x-turquoise3" -> Some (LTerm_style.rgb 0 197 205) | "x-turquoise4" -> Some (LTerm_style.rgb 0 134 139) | "x-cyan1" -> Some (LTerm_style.rgb 0 255 255) | "x-cyan2" -> Some (LTerm_style.rgb 0 238 238) | "x-cyan3" -> Some (LTerm_style.rgb 0 205 205) | "x-cyan4" -> Some (LTerm_style.rgb 0 139 139) | "x-darkslategray1" -> Some (LTerm_style.rgb 151 255 255) | "x-darkslategray2" -> Some (LTerm_style.rgb 141 238 238) | "x-darkslategray3" -> Some (LTerm_style.rgb 121 205 205) | "x-darkslategray4" -> Some (LTerm_style.rgb 82 139 139) | "x-aquamarine1" -> Some (LTerm_style.rgb 127 255 212) | "x-aquamarine2" -> Some (LTerm_style.rgb 118 238 198) | "x-aquamarine3" -> Some (LTerm_style.rgb 102 205 170) | "x-aquamarine4" -> Some (LTerm_style.rgb 69 139 116) | "x-darkseagreen1" -> Some (LTerm_style.rgb 193 255 193) | "x-darkseagreen2" -> Some (LTerm_style.rgb 180 238 180) | "x-darkseagreen3" -> Some (LTerm_style.rgb 155 205 155) | "x-darkseagreen4" -> Some (LTerm_style.rgb 105 139 105) | "x-seagreen1" -> Some (LTerm_style.rgb 84 255 159) | "x-seagreen2" -> Some (LTerm_style.rgb 78 238 148) | "x-seagreen3" -> Some (LTerm_style.rgb 67 205 128) | "x-seagreen4" -> Some (LTerm_style.rgb 46 139 87) | "x-palegreen1" -> Some (LTerm_style.rgb 154 255 154) | "x-palegreen2" -> Some (LTerm_style.rgb 144 238 144) | "x-palegreen3" -> Some (LTerm_style.rgb 124 205 124) | "x-palegreen4" -> Some (LTerm_style.rgb 84 139 84) | "x-springgreen1" -> Some (LTerm_style.rgb 0 255 127) | "x-springgreen2" -> Some (LTerm_style.rgb 0 238 118) | "x-springgreen3" -> Some (LTerm_style.rgb 0 205 102) | "x-springgreen4" -> Some (LTerm_style.rgb 0 139 69) | "x-green1" -> Some (LTerm_style.rgb 0 255 0) | "x-green2" -> Some (LTerm_style.rgb 0 238 0) | "x-green3" -> Some (LTerm_style.rgb 0 205 0) | "x-green4" -> Some (LTerm_style.rgb 0 139 0) | "x-chartreuse1" -> Some (LTerm_style.rgb 127 255 0) | "x-chartreuse2" -> Some (LTerm_style.rgb 118 238 0) | "x-chartreuse3" -> Some (LTerm_style.rgb 102 205 0) | "x-chartreuse4" -> Some (LTerm_style.rgb 69 139 0) | "x-olivedrab1" -> Some (LTerm_style.rgb 192 255 62) | "x-olivedrab2" -> Some (LTerm_style.rgb 179 238 58) | "x-olivedrab3" -> Some (LTerm_style.rgb 154 205 50) | "x-olivedrab4" -> Some (LTerm_style.rgb 105 139 34) | "x-darkolivegreen1" -> Some (LTerm_style.rgb 202 255 112) | "x-darkolivegreen2" -> Some (LTerm_style.rgb 188 238 104) | "x-darkolivegreen3" -> Some (LTerm_style.rgb 162 205 90) | "x-darkolivegreen4" -> Some (LTerm_style.rgb 110 139 61) | "x-khaki1" -> Some (LTerm_style.rgb 255 246 143) | "x-khaki2" -> Some (LTerm_style.rgb 238 230 133) | "x-khaki3" -> Some (LTerm_style.rgb 205 198 115) | "x-khaki4" -> Some (LTerm_style.rgb 139 134 78) | "x-lightgoldenrod1" -> Some (LTerm_style.rgb 255 236 139) | "x-lightgoldenrod2" -> Some (LTerm_style.rgb 238 220 130) | "x-lightgoldenrod3" -> Some (LTerm_style.rgb 205 190 112) | "x-lightgoldenrod4" -> Some (LTerm_style.rgb 139 129 76) | "x-lightyellow1" -> Some (LTerm_style.rgb 255 255 224) | "x-lightyellow2" -> Some (LTerm_style.rgb 238 238 209) | "x-lightyellow3" -> Some (LTerm_style.rgb 205 205 180) | "x-lightyellow4" -> Some (LTerm_style.rgb 139 139 122) | "x-yellow1" -> Some (LTerm_style.rgb 255 255 0) | "x-yellow2" -> Some (LTerm_style.rgb 238 238 0) | "x-yellow3" -> Some (LTerm_style.rgb 205 205 0) | "x-yellow4" -> Some (LTerm_style.rgb 139 139 0) | "x-gold1" -> Some (LTerm_style.rgb 255 215 0) | "x-gold2" -> Some (LTerm_style.rgb 238 201 0) | "x-gold3" -> Some (LTerm_style.rgb 205 173 0) | "x-gold4" -> Some (LTerm_style.rgb 139 117 0) | "x-goldenrod1" -> Some (LTerm_style.rgb 255 193 37) | "x-goldenrod2" -> Some (LTerm_style.rgb 238 180 34) | "x-goldenrod3" -> Some (LTerm_style.rgb 205 155 29) | "x-goldenrod4" -> Some (LTerm_style.rgb 139 105 20) | "x-darkgoldenrod1" -> Some (LTerm_style.rgb 255 185 15) | "x-darkgoldenrod2" -> Some (LTerm_style.rgb 238 173 14) | "x-darkgoldenrod3" -> Some (LTerm_style.rgb 205 149 12) | "x-darkgoldenrod4" -> Some (LTerm_style.rgb 139 101 8) | "x-rosybrown1" -> Some (LTerm_style.rgb 255 193 193) | "x-rosybrown2" -> Some (LTerm_style.rgb 238 180 180) | "x-rosybrown3" -> Some (LTerm_style.rgb 205 155 155) | "x-rosybrown4" -> Some (LTerm_style.rgb 139 105 105) | "x-indianred1" -> Some (LTerm_style.rgb 255 106 106) | "x-indianred2" -> Some (LTerm_style.rgb 238 99 99) | "x-indianred3" -> Some (LTerm_style.rgb 205 85 85) | "x-indianred4" -> Some (LTerm_style.rgb 139 58 58) | "x-sienna1" -> Some (LTerm_style.rgb 255 130 71) | "x-sienna2" -> Some (LTerm_style.rgb 238 121 66) | "x-sienna3" -> Some (LTerm_style.rgb 205 104 57) | "x-sienna4" -> Some (LTerm_style.rgb 139 71 38) | "x-burlywood1" -> Some (LTerm_style.rgb 255 211 155) | "x-burlywood2" -> Some (LTerm_style.rgb 238 197 145) | "x-burlywood3" -> Some (LTerm_style.rgb 205 170 125) | "x-burlywood4" -> Some (LTerm_style.rgb 139 115 85) | "x-wheat1" -> Some (LTerm_style.rgb 255 231 186) | "x-wheat2" -> Some (LTerm_style.rgb 238 216 174) | "x-wheat3" -> Some (LTerm_style.rgb 205 186 150) | "x-wheat4" -> Some (LTerm_style.rgb 139 126 102) | "x-tan1" -> Some (LTerm_style.rgb 255 165 79) | "x-tan2" -> Some (LTerm_style.rgb 238 154 73) | "x-tan3" -> Some (LTerm_style.rgb 205 133 63) | "x-tan4" -> Some (LTerm_style.rgb 139 90 43) | "x-chocolate1" -> Some (LTerm_style.rgb 255 127 36) | "x-chocolate2" -> Some (LTerm_style.rgb 238 118 33) | "x-chocolate3" -> Some (LTerm_style.rgb 205 102 29) | "x-chocolate4" -> Some (LTerm_style.rgb 139 69 19) | "x-firebrick1" -> Some (LTerm_style.rgb 255 48 48) | "x-firebrick2" -> Some (LTerm_style.rgb 238 44 44) | "x-firebrick3" -> Some (LTerm_style.rgb 205 38 38) | "x-firebrick4" -> Some (LTerm_style.rgb 139 26 26) | "x-brown1" -> Some (LTerm_style.rgb 255 64 64) | "x-brown2" -> Some (LTerm_style.rgb 238 59 59) | "x-brown3" -> Some (LTerm_style.rgb 205 51 51) | "x-brown4" -> Some (LTerm_style.rgb 139 35 35) | "x-salmon1" -> Some (LTerm_style.rgb 255 140 105) | "x-salmon2" -> Some (LTerm_style.rgb 238 130 98) | "x-salmon3" -> Some (LTerm_style.rgb 205 112 84) | "x-salmon4" -> Some (LTerm_style.rgb 139 76 57) | "x-lightsalmon1" -> Some (LTerm_style.rgb 255 160 122) | "x-lightsalmon2" -> Some (LTerm_style.rgb 238 149 114) | "x-lightsalmon3" -> Some (LTerm_style.rgb 205 129 98) | "x-lightsalmon4" -> Some (LTerm_style.rgb 139 87 66) | "x-orange1" -> Some (LTerm_style.rgb 255 165 0) | "x-orange2" -> Some (LTerm_style.rgb 238 154 0) | "x-orange3" -> Some (LTerm_style.rgb 205 133 0) | "x-orange4" -> Some (LTerm_style.rgb 139 90 0) | "x-darkorange1" -> Some (LTerm_style.rgb 255 127 0) | "x-darkorange2" -> Some (LTerm_style.rgb 238 118 0) | "x-darkorange3" -> Some (LTerm_style.rgb 205 102 0) | "x-darkorange4" -> Some (LTerm_style.rgb 139 69 0) | "x-coral1" -> Some (LTerm_style.rgb 255 114 86) | "x-coral2" -> Some (LTerm_style.rgb 238 106 80) | "x-coral3" -> Some (LTerm_style.rgb 205 91 69) | "x-coral4" -> Some (LTerm_style.rgb 139 62 47) | "x-tomato1" -> Some (LTerm_style.rgb 255 99 71) | "x-tomato2" -> Some (LTerm_style.rgb 238 92 66) | "x-tomato3" -> Some (LTerm_style.rgb 205 79 57) | "x-tomato4" -> Some (LTerm_style.rgb 139 54 38) | "x-orangered1" -> Some (LTerm_style.rgb 255 69 0) | "x-orangered2" -> Some (LTerm_style.rgb 238 64 0) | "x-orangered3" -> Some (LTerm_style.rgb 205 55 0) | "x-orangered4" -> Some (LTerm_style.rgb 139 37 0) | "x-red1" -> Some (LTerm_style.rgb 255 0 0) | "x-red2" -> Some (LTerm_style.rgb 238 0 0) | "x-red3" -> Some (LTerm_style.rgb 205 0 0) | "x-red4" -> Some (LTerm_style.rgb 139 0 0) | "x-debianred" -> Some (LTerm_style.rgb 215 7 81) | "x-deeppink1" -> Some (LTerm_style.rgb 255 20 147) | "x-deeppink2" -> Some (LTerm_style.rgb 238 18 137) | "x-deeppink3" -> Some (LTerm_style.rgb 205 16 118) | "x-deeppink4" -> Some (LTerm_style.rgb 139 10 80) | "x-hotpink1" -> Some (LTerm_style.rgb 255 110 180) | "x-hotpink2" -> Some (LTerm_style.rgb 238 106 167) | "x-hotpink3" -> Some (LTerm_style.rgb 205 96 144) | "x-hotpink4" -> Some (LTerm_style.rgb 139 58 98) | "x-pink1" -> Some (LTerm_style.rgb 255 181 197) | "x-pink2" -> Some (LTerm_style.rgb 238 169 184) | "x-pink3" -> Some (LTerm_style.rgb 205 145 158) | "x-pink4" -> Some (LTerm_style.rgb 139 99 108) | "x-lightpink1" -> Some (LTerm_style.rgb 255 174 185) | "x-lightpink2" -> Some (LTerm_style.rgb 238 162 173) | "x-lightpink3" -> Some (LTerm_style.rgb 205 140 149) | "x-lightpink4" -> Some (LTerm_style.rgb 139 95 101) | "x-palevioletred1" -> Some (LTerm_style.rgb 255 130 171) | "x-palevioletred2" -> Some (LTerm_style.rgb 238 121 159) | "x-palevioletred3" -> Some (LTerm_style.rgb 205 104 137) | "x-palevioletred4" -> Some (LTerm_style.rgb 139 71 93) | "x-maroon1" -> Some (LTerm_style.rgb 255 52 179) | "x-maroon2" -> Some (LTerm_style.rgb 238 48 167) | "x-maroon3" -> Some (LTerm_style.rgb 205 41 144) | "x-maroon4" -> Some (LTerm_style.rgb 139 28 98) | "x-violetred1" -> Some (LTerm_style.rgb 255 62 150) | "x-violetred2" -> Some (LTerm_style.rgb 238 58 140) | "x-violetred3" -> Some (LTerm_style.rgb 205 50 120) | "x-violetred4" -> Some (LTerm_style.rgb 139 34 82) | "x-magenta1" -> Some (LTerm_style.rgb 255 0 255) | "x-magenta2" -> Some (LTerm_style.rgb 238 0 238) | "x-magenta3" -> Some (LTerm_style.rgb 205 0 205) | "x-magenta4" -> Some (LTerm_style.rgb 139 0 139) | "x-orchid1" -> Some (LTerm_style.rgb 255 131 250) | "x-orchid2" -> Some (LTerm_style.rgb 238 122 233) | "x-orchid3" -> Some (LTerm_style.rgb 205 105 201) | "x-orchid4" -> Some (LTerm_style.rgb 139 71 137) | "x-plum1" -> Some (LTerm_style.rgb 255 187 255) | "x-plum2" -> Some (LTerm_style.rgb 238 174 238) | "x-plum3" -> Some (LTerm_style.rgb 205 150 205) | "x-plum4" -> Some (LTerm_style.rgb 139 102 139) | "x-mediumorchid1" -> Some (LTerm_style.rgb 224 102 255) | "x-mediumorchid2" -> Some (LTerm_style.rgb 209 95 238) | "x-mediumorchid3" -> Some (LTerm_style.rgb 180 82 205) | "x-mediumorchid4" -> Some (LTerm_style.rgb 122 55 139) | "x-darkorchid1" -> Some (LTerm_style.rgb 191 62 255) | "x-darkorchid2" -> Some (LTerm_style.rgb 178 58 238) | "x-darkorchid3" -> Some (LTerm_style.rgb 154 50 205) | "x-darkorchid4" -> Some (LTerm_style.rgb 104 34 139) | "x-purple1" -> Some (LTerm_style.rgb 155 48 255) | "x-purple2" -> Some (LTerm_style.rgb 145 44 238) | "x-purple3" -> Some (LTerm_style.rgb 125 38 205) | "x-purple4" -> Some (LTerm_style.rgb 85 26 139) | "x-mediumpurple1" -> Some (LTerm_style.rgb 171 130 255) | "x-mediumpurple2" -> Some (LTerm_style.rgb 159 121 238) | "x-mediumpurple3" -> Some (LTerm_style.rgb 137 104 205) | "x-mediumpurple4" -> Some (LTerm_style.rgb 93 71 139) | "x-thistle1" -> Some (LTerm_style.rgb 255 225 255) | "x-thistle2" -> Some (LTerm_style.rgb 238 210 238) | "x-thistle3" -> Some (LTerm_style.rgb 205 181 205) | "x-thistle4" -> Some (LTerm_style.rgb 139 123 139) | "x-gray0" -> Some (LTerm_style.rgb 0 0 0) | "x-grey0" -> Some (LTerm_style.rgb 0 0 0) | "x-gray1" -> Some (LTerm_style.rgb 3 3 3) | "x-grey1" -> Some (LTerm_style.rgb 3 3 3) | "x-gray2" -> Some (LTerm_style.rgb 5 5 5) | "x-grey2" -> Some (LTerm_style.rgb 5 5 5) | "x-gray3" -> Some (LTerm_style.rgb 8 8 8) | "x-grey3" -> Some (LTerm_style.rgb 8 8 8) | "x-gray4" -> Some (LTerm_style.rgb 10 10 10) | "x-grey4" -> Some (LTerm_style.rgb 10 10 10) | "x-gray5" -> Some (LTerm_style.rgb 13 13 13) | "x-grey5" -> Some (LTerm_style.rgb 13 13 13) | "x-gray6" -> Some (LTerm_style.rgb 15 15 15) | "x-grey6" -> Some (LTerm_style.rgb 15 15 15) | "x-gray7" -> Some (LTerm_style.rgb 18 18 18) | "x-grey7" -> Some (LTerm_style.rgb 18 18 18) | "x-gray8" -> Some (LTerm_style.rgb 20 20 20) | "x-grey8" -> Some (LTerm_style.rgb 20 20 20) | "x-gray9" -> Some (LTerm_style.rgb 23 23 23) | "x-grey9" -> Some (LTerm_style.rgb 23 23 23) | "x-gray10" -> Some (LTerm_style.rgb 26 26 26) | "x-grey10" -> Some (LTerm_style.rgb 26 26 26) | "x-gray11" -> Some (LTerm_style.rgb 28 28 28) | "x-grey11" -> Some (LTerm_style.rgb 28 28 28) | "x-gray12" -> Some (LTerm_style.rgb 31 31 31) | "x-grey12" -> Some (LTerm_style.rgb 31 31 31) | "x-gray13" -> Some (LTerm_style.rgb 33 33 33) | "x-grey13" -> Some (LTerm_style.rgb 33 33 33) | "x-gray14" -> Some (LTerm_style.rgb 36 36 36) | "x-grey14" -> Some (LTerm_style.rgb 36 36 36) | "x-gray15" -> Some (LTerm_style.rgb 38 38 38) | "x-grey15" -> Some (LTerm_style.rgb 38 38 38) | "x-gray16" -> Some (LTerm_style.rgb 41 41 41) | "x-grey16" -> Some (LTerm_style.rgb 41 41 41) | "x-gray17" -> Some (LTerm_style.rgb 43 43 43) | "x-grey17" -> Some (LTerm_style.rgb 43 43 43) | "x-gray18" -> Some (LTerm_style.rgb 46 46 46) | "x-grey18" -> Some (LTerm_style.rgb 46 46 46) | "x-gray19" -> Some (LTerm_style.rgb 48 48 48) | "x-grey19" -> Some (LTerm_style.rgb 48 48 48) | "x-gray20" -> Some (LTerm_style.rgb 51 51 51) | "x-grey20" -> Some (LTerm_style.rgb 51 51 51) | "x-gray21" -> Some (LTerm_style.rgb 54 54 54) | "x-grey21" -> Some (LTerm_style.rgb 54 54 54) | "x-gray22" -> Some (LTerm_style.rgb 56 56 56) | "x-grey22" -> Some (LTerm_style.rgb 56 56 56) | "x-gray23" -> Some (LTerm_style.rgb 59 59 59) | "x-grey23" -> Some (LTerm_style.rgb 59 59 59) | "x-gray24" -> Some (LTerm_style.rgb 61 61 61) | "x-grey24" -> Some (LTerm_style.rgb 61 61 61) | "x-gray25" -> Some (LTerm_style.rgb 64 64 64) | "x-grey25" -> Some (LTerm_style.rgb 64 64 64) | "x-gray26" -> Some (LTerm_style.rgb 66 66 66) | "x-grey26" -> Some (LTerm_style.rgb 66 66 66) | "x-gray27" -> Some (LTerm_style.rgb 69 69 69) | "x-grey27" -> Some (LTerm_style.rgb 69 69 69) | "x-gray28" -> Some (LTerm_style.rgb 71 71 71) | "x-grey28" -> Some (LTerm_style.rgb 71 71 71) | "x-gray29" -> Some (LTerm_style.rgb 74 74 74) | "x-grey29" -> Some (LTerm_style.rgb 74 74 74) | "x-gray30" -> Some (LTerm_style.rgb 77 77 77) | "x-grey30" -> Some (LTerm_style.rgb 77 77 77) | "x-gray31" -> Some (LTerm_style.rgb 79 79 79) | "x-grey31" -> Some (LTerm_style.rgb 79 79 79) | "x-gray32" -> Some (LTerm_style.rgb 82 82 82) | "x-grey32" -> Some (LTerm_style.rgb 82 82 82) | "x-gray33" -> Some (LTerm_style.rgb 84 84 84) | "x-grey33" -> Some (LTerm_style.rgb 84 84 84) | "x-gray34" -> Some (LTerm_style.rgb 87 87 87) | "x-grey34" -> Some (LTerm_style.rgb 87 87 87) | "x-gray35" -> Some (LTerm_style.rgb 89 89 89) | "x-grey35" -> Some (LTerm_style.rgb 89 89 89) | "x-gray36" -> Some (LTerm_style.rgb 92 92 92) | "x-grey36" -> Some (LTerm_style.rgb 92 92 92) | "x-gray37" -> Some (LTerm_style.rgb 94 94 94) | "x-grey37" -> Some (LTerm_style.rgb 94 94 94) | "x-gray38" -> Some (LTerm_style.rgb 97 97 97) | "x-grey38" -> Some (LTerm_style.rgb 97 97 97) | "x-gray39" -> Some (LTerm_style.rgb 99 99 99) | "x-grey39" -> Some (LTerm_style.rgb 99 99 99) | "x-gray40" -> Some (LTerm_style.rgb 102 102 102) | "x-grey40" -> Some (LTerm_style.rgb 102 102 102) | "x-gray41" -> Some (LTerm_style.rgb 105 105 105) | "x-grey41" -> Some (LTerm_style.rgb 105 105 105) | "x-gray42" -> Some (LTerm_style.rgb 107 107 107) | "x-grey42" -> Some (LTerm_style.rgb 107 107 107) | "x-gray43" -> Some (LTerm_style.rgb 110 110 110) | "x-grey43" -> Some (LTerm_style.rgb 110 110 110) | "x-gray44" -> Some (LTerm_style.rgb 112 112 112) | "x-grey44" -> Some (LTerm_style.rgb 112 112 112) | "x-gray45" -> Some (LTerm_style.rgb 115 115 115) | "x-grey45" -> Some (LTerm_style.rgb 115 115 115) | "x-gray46" -> Some (LTerm_style.rgb 117 117 117) | "x-grey46" -> Some (LTerm_style.rgb 117 117 117) | "x-gray47" -> Some (LTerm_style.rgb 120 120 120) | "x-grey47" -> Some (LTerm_style.rgb 120 120 120) | "x-gray48" -> Some (LTerm_style.rgb 122 122 122) | "x-grey48" -> Some (LTerm_style.rgb 122 122 122) | "x-gray49" -> Some (LTerm_style.rgb 125 125 125) | "x-grey49" -> Some (LTerm_style.rgb 125 125 125) | "x-gray50" -> Some (LTerm_style.rgb 127 127 127) | "x-grey50" -> Some (LTerm_style.rgb 127 127 127) | "x-gray51" -> Some (LTerm_style.rgb 130 130 130) | "x-grey51" -> Some (LTerm_style.rgb 130 130 130) | "x-gray52" -> Some (LTerm_style.rgb 133 133 133) | "x-grey52" -> Some (LTerm_style.rgb 133 133 133) | "x-gray53" -> Some (LTerm_style.rgb 135 135 135) | "x-grey53" -> Some (LTerm_style.rgb 135 135 135) | "x-gray54" -> Some (LTerm_style.rgb 138 138 138) | "x-grey54" -> Some (LTerm_style.rgb 138 138 138) | "x-gray55" -> Some (LTerm_style.rgb 140 140 140) | "x-grey55" -> Some (LTerm_style.rgb 140 140 140) | "x-gray56" -> Some (LTerm_style.rgb 143 143 143) | "x-grey56" -> Some (LTerm_style.rgb 143 143 143) | "x-gray57" -> Some (LTerm_style.rgb 145 145 145) | "x-grey57" -> Some (LTerm_style.rgb 145 145 145) | "x-gray58" -> Some (LTerm_style.rgb 148 148 148) | "x-grey58" -> Some (LTerm_style.rgb 148 148 148) | "x-gray59" -> Some (LTerm_style.rgb 150 150 150) | "x-grey59" -> Some (LTerm_style.rgb 150 150 150) | "x-gray60" -> Some (LTerm_style.rgb 153 153 153) | "x-grey60" -> Some (LTerm_style.rgb 153 153 153) | "x-gray61" -> Some (LTerm_style.rgb 156 156 156) | "x-grey61" -> Some (LTerm_style.rgb 156 156 156) | "x-gray62" -> Some (LTerm_style.rgb 158 158 158) | "x-grey62" -> Some (LTerm_style.rgb 158 158 158) | "x-gray63" -> Some (LTerm_style.rgb 161 161 161) | "x-grey63" -> Some (LTerm_style.rgb 161 161 161) | "x-gray64" -> Some (LTerm_style.rgb 163 163 163) | "x-grey64" -> Some (LTerm_style.rgb 163 163 163) | "x-gray65" -> Some (LTerm_style.rgb 166 166 166) | "x-grey65" -> Some (LTerm_style.rgb 166 166 166) | "x-gray66" -> Some (LTerm_style.rgb 168 168 168) | "x-grey66" -> Some (LTerm_style.rgb 168 168 168) | "x-gray67" -> Some (LTerm_style.rgb 171 171 171) | "x-grey67" -> Some (LTerm_style.rgb 171 171 171) | "x-gray68" -> Some (LTerm_style.rgb 173 173 173) | "x-grey68" -> Some (LTerm_style.rgb 173 173 173) | "x-gray69" -> Some (LTerm_style.rgb 176 176 176) | "x-grey69" -> Some (LTerm_style.rgb 176 176 176) | "x-gray70" -> Some (LTerm_style.rgb 179 179 179) | "x-grey70" -> Some (LTerm_style.rgb 179 179 179) | "x-gray71" -> Some (LTerm_style.rgb 181 181 181) | "x-grey71" -> Some (LTerm_style.rgb 181 181 181) | "x-gray72" -> Some (LTerm_style.rgb 184 184 184) | "x-grey72" -> Some (LTerm_style.rgb 184 184 184) | "x-gray73" -> Some (LTerm_style.rgb 186 186 186) | "x-grey73" -> Some (LTerm_style.rgb 186 186 186) | "x-gray74" -> Some (LTerm_style.rgb 189 189 189) | "x-grey74" -> Some (LTerm_style.rgb 189 189 189) | "x-gray75" -> Some (LTerm_style.rgb 191 191 191) | "x-grey75" -> Some (LTerm_style.rgb 191 191 191) | "x-gray76" -> Some (LTerm_style.rgb 194 194 194) | "x-grey76" -> Some (LTerm_style.rgb 194 194 194) | "x-gray77" -> Some (LTerm_style.rgb 196 196 196) | "x-grey77" -> Some (LTerm_style.rgb 196 196 196) | "x-gray78" -> Some (LTerm_style.rgb 199 199 199) | "x-grey78" -> Some (LTerm_style.rgb 199 199 199) | "x-gray79" -> Some (LTerm_style.rgb 201 201 201) | "x-grey79" -> Some (LTerm_style.rgb 201 201 201) | "x-gray80" -> Some (LTerm_style.rgb 204 204 204) | "x-grey80" -> Some (LTerm_style.rgb 204 204 204) | "x-gray81" -> Some (LTerm_style.rgb 207 207 207) | "x-grey81" -> Some (LTerm_style.rgb 207 207 207) | "x-gray82" -> Some (LTerm_style.rgb 209 209 209) | "x-grey82" -> Some (LTerm_style.rgb 209 209 209) | "x-gray83" -> Some (LTerm_style.rgb 212 212 212) | "x-grey83" -> Some (LTerm_style.rgb 212 212 212) | "x-gray84" -> Some (LTerm_style.rgb 214 214 214) | "x-grey84" -> Some (LTerm_style.rgb 214 214 214) | "x-gray85" -> Some (LTerm_style.rgb 217 217 217) | "x-grey85" -> Some (LTerm_style.rgb 217 217 217) | "x-gray86" -> Some (LTerm_style.rgb 219 219 219) | "x-grey86" -> Some (LTerm_style.rgb 219 219 219) | "x-gray87" -> Some (LTerm_style.rgb 222 222 222) | "x-grey87" -> Some (LTerm_style.rgb 222 222 222) | "x-gray88" -> Some (LTerm_style.rgb 224 224 224) | "x-grey88" -> Some (LTerm_style.rgb 224 224 224) | "x-gray89" -> Some (LTerm_style.rgb 227 227 227) | "x-grey89" -> Some (LTerm_style.rgb 227 227 227) | "x-gray90" -> Some (LTerm_style.rgb 229 229 229) | "x-grey90" -> Some (LTerm_style.rgb 229 229 229) | "x-gray91" -> Some (LTerm_style.rgb 232 232 232) | "x-grey91" -> Some (LTerm_style.rgb 232 232 232) | "x-gray92" -> Some (LTerm_style.rgb 235 235 235) | "x-grey92" -> Some (LTerm_style.rgb 235 235 235) | "x-gray93" -> Some (LTerm_style.rgb 237 237 237) | "x-grey93" -> Some (LTerm_style.rgb 237 237 237) | "x-gray94" -> Some (LTerm_style.rgb 240 240 240) | "x-grey94" -> Some (LTerm_style.rgb 240 240 240) | "x-gray95" -> Some (LTerm_style.rgb 242 242 242) | "x-grey95" -> Some (LTerm_style.rgb 242 242 242) | "x-gray96" -> Some (LTerm_style.rgb 245 245 245) | "x-grey96" -> Some (LTerm_style.rgb 245 245 245) | "x-gray97" -> Some (LTerm_style.rgb 247 247 247) | "x-grey97" -> Some (LTerm_style.rgb 247 247 247) | "x-gray98" -> Some (LTerm_style.rgb 250 250 250) | "x-grey98" -> Some (LTerm_style.rgb 250 250 250) | "x-gray99" -> Some (LTerm_style.rgb 252 252 252) | "x-grey99" -> Some (LTerm_style.rgb 252 252 252) | "x-gray100" -> Some (LTerm_style.rgb 255 255 255) | "x-grey100" -> Some (LTerm_style.rgb 255 255 255) | "x-dark-grey" -> Some (LTerm_style.rgb 169 169 169) | "x-darkgrey" -> Some (LTerm_style.rgb 169 169 169) | "x-dark-gray" -> Some (LTerm_style.rgb 169 169 169) | "x-darkgray" -> Some (LTerm_style.rgb 169 169 169) | "x-dark-blue" -> Some (LTerm_style.rgb 0 0 139) | "x-darkblue" -> Some (LTerm_style.rgb 0 0 139) | "x-dark-cyan" -> Some (LTerm_style.rgb 0 139 139) | "x-darkcyan" -> Some (LTerm_style.rgb 0 139 139) | "x-dark-magenta" -> Some (LTerm_style.rgb 139 0 139) | "x-darkmagenta" -> Some (LTerm_style.rgb 139 0 139) | "x-dark-red" -> Some (LTerm_style.rgb 139 0 0) | "x-darkred" -> Some (LTerm_style.rgb 139 0 0) | "x-light-green" -> Some (LTerm_style.rgb 144 238 144) | "x-lightgreen" -> Some (LTerm_style.rgb 144 238 144) | "" | "none" -> None | str when str.[0] = '#' -> if String.length str = 7 then try Some(LTerm_style.rgb (hex_of_char str.[1] lsl 4 lor hex_of_char str.[2]) (hex_of_char str.[3] lsl 4 lor hex_of_char str.[4]) (hex_of_char str.[5] lsl 4 lor hex_of_char str.[6])) with Exit -> Printf.ksprintf error "invalid color %S" str else Printf.ksprintf error "invalid color %S" str | str -> try Some(LTerm_style.index (int_of_string str)) with Failure _ -> Printf.ksprintf error "invalid color %S" str let get_style prefix resources = { LTerm_style.bold = get_bool (prefix ^ ".bold") resources; LTerm_style.underline = get_bool (prefix ^ ".underline") resources; LTerm_style.blink = get_bool (prefix ^ ".blink") resources; LTerm_style.reverse = get_bool (prefix ^ ".reverse") resources; LTerm_style.foreground = get_color (prefix ^ ".foreground") resources; LTerm_style.background = get_color (prefix ^ ".background") resources; } let get_connection key resources = match String.lowercase (get key resources) with | "blank" -> LTerm_draw.Blank | "light" -> LTerm_draw.Light | "heavy" -> LTerm_draw.Heavy | "" -> LTerm_draw.Light | str -> Printf.ksprintf error "invalid connection %S" str (* +-----------------------------------------------------------------+ | Parsing | +-----------------------------------------------------------------+ *) exception Parse_error of string * int * string let parse str = let lexbuf = Lexing.from_string str in let rec loop line acc = match LTerm_resource_lexer.line lexbuf with | `EOF -> acc | `Empty -> loop (line + 1) acc | `Assoc(pattern, value) -> loop (line + 1) (add pattern value acc) | `Error msg -> raise (Parse_error("", line, msg)) in loop 1 [] let load file = Lwt_io.open_file ~mode:Lwt_io.input file >>= fun ic -> let rec loop lineno acc = Lwt_io.read_line_opt ic >>= fun line -> match line with | None -> Lwt.return acc | Some str -> match LTerm_resource_lexer.line (Lexing.from_string str) with | `EOF -> loop (lineno + 1) acc | `Empty -> loop (lineno + 1) acc | `Assoc(pattern, value) -> loop (lineno + 1) (add pattern value acc) | `Error msg -> Lwt.fail (Parse_error(file, lineno, msg)) in Lwt.finalize (fun () -> loop 1 []) (fun () -> Lwt_io.close ic) lambda-term-1.9/src/lTerm_resources.mli000066400000000000000000000035701254222632000202220ustar00rootroot00000000000000(* * lTerm_resources.mli * ------------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (** Widgets resources *) type t (** Type of resources. *) val empty : t (** The empty set of resources. *) val get : string -> t -> string (** [get key resources] returns the key associated to the last pattern that matches [key] in [resources], or the empty string if no pattern matches [key]. *) val add : string -> string -> t -> t (** [add pattern value] returns the new set of resources with the binding [pattern -> value] at the end. *) val merge : t -> t -> t (** [merge res1 res2] merges the two given sets of resources. *) exception Error of string (** Exception raised when the contents of a resource is invalid. *) val get_bool : string -> t -> bool option (** [get_bool name resources] reads the boolean encoded in [resources]. *) val get_color : string -> t -> LTerm_style.color option (** [get_color name resources] reads the color encoded in [resources]. *) val get_style : string -> t -> LTerm_style.t (** [get_style prefix resources] reads the style encoded in [resources]. *) val get_connection : string -> t -> LTerm_draw.connection (** [get_connection name resources] *) exception Parse_error of string * int * string (** [Parse_error(source, line, msg)] is raised when a parsing error is encountered in the input. *) val parse : string -> t (** [parse str] parses a string for a list of properties. [str] must follow the format of X resources files. i.e. comments start with a [!], empty lines are ignored, and configuration lines looks-like: {[ key: value ]} *) val load : string -> t Lwt.t (** Same as {!parse} but parses the contents of a file. *) val home : string (** The home directory. *) lambda-term-1.9/src/lTerm_style.ml000066400000000000000000000046021254222632000171740ustar00rootroot00000000000000(* * lTerm_style.ml * -------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (* +-----------------------------------------------------------------+ | Colors | +-----------------------------------------------------------------+ *) type color = | Default | Index of int | RGB of int * int * int let default = Default let index n = Index n let rgb r g b = if r < 0 || r > 255 || g < 0 || g > 255 || b < 0 || b > 255 then invalid_arg "LTerm_style.rgb" else RGB(r, g, b) let black = Index 0 let red = Index 1 let green = Index 2 let yellow = Index 3 let blue = Index 4 let magenta = Index 5 let cyan = Index 6 let white = Index 7 let lblack = Index 8 let lred = Index 9 let lgreen = Index 10 let lyellow = Index 11 let lblue = Index 12 let lmagenta = Index 13 let lcyan = Index 14 let lwhite = Index 15 (* +-----------------------------------------------------------------+ | Styles | +-----------------------------------------------------------------+ *) type t = { bold : bool option; underline : bool option; blink : bool option; reverse : bool option; foreground : color option; background : color option; } let bold s = s.bold let underline s = s.underline let blink s = s.blink let reverse s = s.reverse let foreground s = s.foreground let background s = s.background let none = { bold = None; underline = None; blink = None; reverse = None; foreground = None; background = None; } let merge_field f1 f2 = match f2 with | Some _ -> f2 | None -> f1 let merge s1 s2 = { bold = merge_field s1.bold s2.bold; underline = merge_field s1.underline s2.underline; blink = merge_field s1.blink s2.blink; reverse = merge_field s1.reverse s2.reverse; foreground = merge_field s1.foreground s2.foreground; background = merge_field s1.background s2.background; } let bool = function | Some b -> b | None -> false let color = function | Some c -> c | None -> Default let equal s1 s2 = (bool s1.bold = bool s2.bold) && (bool s1.underline = bool s2.underline) && (bool s1.blink = bool s2.blink) && (bool s1.reverse = bool s2.reverse) && (color s1.foreground = color s2.foreground) && (color s1.background = color s2.background) lambda-term-1.9/src/lTerm_style.mli000066400000000000000000000034541254222632000173510ustar00rootroot00000000000000(* * lTerm_style.mli * --------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (** Text styles *) (** {6 Colors} *) type color = private | Default (** The default color of the terminal. *) | Index of int (** A color given by its index. Most terminal have at least 8 colors. *) | RGB of int * int * int (** A color given by its three component between 0 and 255. The closest color will be used. *) val default : color val index : int -> color val rgb : int -> int -> int -> color (** [rgb r g b] raises [Invalid_argument] if one of [r], [g] or [b] is not in the range [0..255]. *) (** {8 Standard colors} *) val black : color val red : color val green : color val yellow : color val blue : color val magenta : color val cyan : color val white : color (** {8 Light colors} *) val lblack : color val lred : color val lgreen : color val lyellow : color val lblue : color val lmagenta : color val lcyan : color val lwhite : color (** {6 Styles} *) (** Type of text styles. *) type t = { bold : bool option; underline : bool option; blink : bool option; reverse : bool option; foreground : color option; background : color option; } val bold : t -> bool option val underline : t -> bool option val blink : t -> bool option val reverse : t -> bool option val foreground : t -> color option val background : t -> color option val none : t (** Style with all fields set to [None]. *) val merge : t -> t -> t (** [merge s1 s2] is [s2] with all undefined fields set to ones of [s1]. *) val equal : t -> t -> bool (** [equal s1 s2] returns [true] iff [s1] and [s2] are equal after having replaced all [None] fields by [Some false] or [Some Default]. *) lambda-term-1.9/src/lTerm_term_stubs.c000066400000000000000000000053421254222632000200370ustar00rootroot00000000000000/* * lTerm_term_stubs.c * ------------------ * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. */ #include #include #include #include #if defined(_WIN32) || defined(_WIN64) /* +-----------------------------------------------------------------+ | Terminal sizes on Windows | +-----------------------------------------------------------------+ */ #include #include CAMLprim value lt_term_get_size_from_fd(value fd) { CONSOLE_SCREEN_BUFFER_INFO info; value result; if (!GetConsoleScreenBufferInfo(Handle_val(fd), &info)) { win32_maperr(GetLastError()); uerror("GetConsoleScreenBufferInfo", Nothing); } result = caml_alloc_tuple(2); Field(result, 0) = Val_int(info.srWindow.Bottom - info.srWindow.Top + 1); Field(result, 1) = Val_int(info.srWindow.Right - info.srWindow.Left + 1); return result; } CAMLprim value lt_term_set_size_from_fd(value fd, value val_size) { CONSOLE_SCREEN_BUFFER_INFO info; SMALL_RECT rect; if (!GetConsoleScreenBufferInfo(Handle_val(fd), &info)) { win32_maperr(GetLastError()); uerror("GetConsoleScreenBufferInfo", Nothing); } rect; rect.Top = info.srWindow.Top; rect.Left = info.srWindow.Left; rect.Bottom = rect.Top + Int_val(Field(val_size, 0)) - 1; rect.Right = rect.Left + Int_val(Field(val_size, 1)) - 1; if (!SetConsoleWindowInfo(Handle_val(fd), TRUE, &rect)) { win32_maperr(GetLastError()); uerror("SetConsoleWindowInfo", Nothing); } return Val_unit; } #else /* +-----------------------------------------------------------------+ | Terminal sizes on Unix | +-----------------------------------------------------------------+ */ #include #include #include #include CAMLprim value lt_term_get_size_from_fd(value fd) { struct winsize size; if (ioctl(Int_val(fd), TIOCGWINSZ, &size) < 0) uerror("ioctl", Nothing); value result = caml_alloc_tuple(2); Field(result, 0) = Val_int(size.ws_row); Field(result, 1) = Val_int(size.ws_col); return result; } CAMLprim value lt_term_set_size_from_fd(value fd, value val_size) { struct winsize size; if (ioctl(Int_val(fd), TIOCGWINSZ, &size) < 0) uerror("ioctl", Nothing); int row = Int_val(Field(val_size, 0)); int col = Int_val(Field(val_size, 1)); size.ws_xpixel = size.ws_xpixel * col / size.ws_col; size.ws_ypixel = size.ws_ypixel * row / size.ws_row; size.ws_row = row; size.ws_col = col; if (ioctl(Int_val(fd), TIOCSWINSZ, &size) < 0) uerror("ioctl", Nothing); return Val_unit; } #endif lambda-term-1.9/src/lTerm_text.ml000066400000000000000000000273271254222632000170310ustar00rootroot00000000000000(* * lTerm_text.ml * ------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) open CamomileLibraryDyn.Camomile open LTerm_style type t = (UChar.t * LTerm_style.t) array (* +-----------------------------------------------------------------+ | Conversions | +-----------------------------------------------------------------+ *) let dummy = (UChar.of_char ' ', LTerm_style.none) let of_string str = let len = Zed_utf8.length str in let arr = Array.make len dummy in let rec loop ofs idx = if idx = len then arr else begin let chr, ofs = Zed_utf8.unsafe_extract_next str ofs in Array.unsafe_set arr idx (chr, LTerm_style.none); loop ofs (idx + 1) end in loop 0 0 let rec invalid_length str ofs acc = let ofs, len, _ = Zed_utf8.next_error str ofs in if ofs = String.length str then acc + len else invalid_length str (ofs + 1) (acc + len + 4) let uchar_of_hex x = if x < 10 then UChar.of_int (Char.code '0' + x) else UChar.of_int (Char.code 'a' + x - 10) let of_string_maybe_invalid str = let len = invalid_length str 0 0 in let arr = Array.make len dummy in let rec loop ofs idx = if idx = len then arr else begin let ofs, idx = try let chr, ofs = Zed_utf8.unsafe_extract_next str ofs in Array.unsafe_set arr idx (chr, LTerm_style.none); (ofs, idx + 1) with Zed_utf8.Invalid _ -> let code = Char.code (String.unsafe_get str ofs) in Array.unsafe_set arr (idx + 0) (UChar.of_char '\\', LTerm_style.none); Array.unsafe_set arr (idx + 1) (UChar.of_char 'y', LTerm_style.none); Array.unsafe_set arr (idx + 2) (uchar_of_hex (code lsr 4), LTerm_style.none); Array.unsafe_set arr (idx + 3) (uchar_of_hex (code land 15), LTerm_style.none); (ofs + 1, idx + 4) in loop ofs idx end in loop 0 0 let to_string txt = let buf = Buffer.create (Array.length txt) in Array.iter (fun (ch, style) -> Buffer.add_string buf (Zed_utf8.singleton ch)) txt; Buffer.contents buf let of_rope rope = let arr = Array.make (Zed_rope.length rope) dummy in let rec loop zip idx = if Zed_rope.Zip.at_eos zip then arr else begin let chr, zip = Zed_rope.Zip.next zip in Array.unsafe_set arr idx (chr, LTerm_style.none); loop zip (idx + 1) end in loop (Zed_rope.Zip.make_f rope 0) 0 let to_rope txt = let buf = Zed_rope.Buffer.create () in Array.iter (fun (ch, style) -> Zed_rope.Buffer.add buf ch) txt; Zed_rope.Buffer.contents buf let stylise str style = let len = Zed_utf8.length str in let arr = Array.make len dummy in let rec loop ofs idx = if idx = len then arr else begin let chr, ofs = Zed_utf8.unsafe_extract_next str ofs in Array.unsafe_set arr idx (chr, style); loop ofs (idx + 1) end in loop 0 0 (* +-----------------------------------------------------------------+ | Parenthesis matching | +-----------------------------------------------------------------+ *) let lparen = UChar.of_char '(' let rparen = UChar.of_char ')' let lbrace = UChar.of_char '{' let rbrace = UChar.of_char '}' let lbracket = UChar.of_char '[' let rbracket = UChar.of_char ']' type search_result = | No_match_found | No_paren_found | Match_found of int let stylise_parenthesis text ?(paren = [(lparen, rparen); (lbrace, rbrace); (lbracket, rbracket)]) pos style_paren = if Array.length text > 0 then begin let rec rsearch idx left right depth = if idx >= Array.length text then No_match_found else let ch, _ = text.(idx) in if ch = right then if depth = 0 then Match_found idx else rsearch (idx + 1) left right (depth - 1) else if ch = left then rsearch (idx + 1) left right (depth + 1) else rsearch (idx + 1) left right depth in let rec lsearch idx left right depth = if idx < 0 then No_match_found else let ch, _ = text.(idx) in if ch = left then if depth = 0 then Match_found idx else lsearch (idx - 1) left right (depth - 1) else if ch = right then lsearch (idx - 1) left right (depth + 1) else lsearch (idx - 1) left right depth in let found = if pos = Array.length text then false else let ch, _ = text.(pos) in let rec loop = function | [] -> No_paren_found | (lparen, rparen) :: rest -> if ch = lparen then rsearch (pos + 1) lparen rparen 0 else if ch = rparen then lsearch (pos - 1) lparen rparen 0 else loop rest in match loop paren with | Match_found idx -> let ch, style = text.(idx) in text.(idx) <- (ch, LTerm_style.merge style_paren style); true | No_match_found -> true | No_paren_found -> false in if not found && pos > 0 then let ch, style = text.(pos - 1) in let rec loop = function | [] -> No_paren_found | (lparen, rparen) :: rest -> if ch = lparen then rsearch (pos + 1) lparen rparen 0 else if ch = rparen then lsearch (pos - 2) lparen rparen 0 else loop rest in match loop paren with | Match_found idx -> text.(pos - 1) <- (ch, LTerm_style.merge style_paren style); let ch, style = text.(idx) in text.(idx) <- (ch, LTerm_style.merge style_paren style) | No_match_found | No_paren_found -> () end (* +-----------------------------------------------------------------+ | Markup strings | +-----------------------------------------------------------------+ *) type item = | S of Zed_utf8.t | R of Zed_rope.t | B_bold of bool | E_bold | B_underline of bool | E_underline | B_blink of bool | E_blink | B_reverse of bool | E_reverse | B_fg of LTerm_style.color | E_fg | B_bg of LTerm_style.color | E_bg type markup = item list type eval_stack = { mutable q_bold : bool option list; mutable q_underline : bool option list; mutable q_blink : bool option list; mutable q_reverse : bool option list; mutable q_fg : LTerm_style.color option list; mutable q_bg : LTerm_style.color option list; } let markup_length markup = let rec loop len = function | [] -> len | S str :: rest -> loop (len + Zed_utf8.length str) rest | R str :: rest -> loop (len + Zed_rope.length str) rest | _ :: rest -> loop len rest in loop 0 markup let eval markup = let state = { q_bold = []; q_underline = []; q_blink = []; q_reverse = []; q_fg = []; q_bg = []; } in let arr = Array.make (markup_length markup) dummy in let rec copy_utf8 str ofs idx style = if ofs = String.length str then idx else begin let chr, ofs = Zed_utf8.unsafe_extract_next str ofs in Array.unsafe_set arr idx (chr, style); copy_utf8 str ofs (idx + 1) style end in let rec copy_rope zip idx style = if Zed_rope.Zip.at_eos zip then idx else begin let chr, zip = Zed_rope.Zip.next zip in Array.unsafe_set arr idx (chr, style); copy_rope zip (idx + 1) style end in let rec loop idx style = function | [] -> arr | S str :: rest -> loop (copy_utf8 str 0 idx style) style rest | R str :: rest -> loop (copy_rope (Zed_rope.Zip.make_f str 0) idx style) style rest | B_bold status :: rest -> state.q_bold <- style.bold :: state.q_bold; loop idx { style with bold = Some status } rest | E_bold :: rest -> begin match state.q_bold with | [] -> loop idx style rest | save :: l -> state.q_bold <- l; loop idx { style with bold = save } rest end | B_underline status :: rest -> state.q_underline <- style.underline :: state.q_underline; loop idx { style with underline = Some status } rest | E_underline :: rest -> begin match state.q_underline with | [] -> loop idx style rest | save :: l -> state.q_underline <- l; loop idx { style with underline = save } rest end | B_blink status :: rest -> state.q_blink <- style.blink :: state.q_blink; loop idx { style with blink = Some status } rest | E_blink :: rest -> begin match state.q_blink with | [] -> loop idx style rest | save :: l -> state.q_blink <- l; loop idx { style with blink = save } rest end | B_reverse color :: rest -> state.q_reverse <- style.reverse :: state.q_reverse; loop idx { style with reverse = Some color } rest | E_reverse :: rest -> begin match state.q_reverse with | [] -> loop idx style rest | save :: l -> state.q_reverse <- l; loop idx { style with reverse = save } rest end | B_fg color :: rest -> state.q_fg <- style.foreground :: state.q_fg; loop idx { style with foreground = Some color } rest | E_fg :: rest -> begin match state.q_fg with | [] -> loop idx style rest | save :: l -> state.q_fg <- l; loop idx { style with foreground = save } rest end | B_bg color :: rest -> state.q_bg <- style.background :: state.q_bg; loop idx { style with background = Some color } rest | E_bg :: rest -> begin match state.q_bg with | [] -> loop idx style rest | save :: l -> state.q_bg <- l; loop idx { style with background = save } rest end in loop 0 none markup (** {6 Styled formatters} *) let make_formatter ?read_color () = let style = Stack.create () in let content = ref [||] in let get_style () = if Stack.is_empty style then LTerm_style.none else Stack.top style and pop_style () = if Stack.is_empty style then () else ignore (Stack.pop style) and push_style sty = if Stack.is_empty style then Stack.push sty style else Stack.push (LTerm_style.merge (Stack.top style) sty) style in let put s pos len = let s = String.sub s pos len in content := Array.append !content (stylise s (get_style ())) in let flush () = () in let fmt = Format.make_formatter put flush in let get_content () = Format.pp_print_flush fmt () ; !content in begin match read_color with | None -> () | Some f -> Format.pp_set_tags fmt true; Format.pp_set_formatter_tag_functions fmt { Format. mark_open_tag = (fun a -> push_style (f a) ; ""); mark_close_tag = (fun _ -> pop_style (); ""); print_open_tag = (fun _ -> ()); print_close_tag = (fun _ -> ()); } ; end ; get_content, fmt let pp_with_style to_style = fun style fstr fmt -> let tag = to_style style in Format.pp_open_tag fmt tag; Format.kfprintf (fun fmt -> Format.pp_close_tag fmt ()) fmt fstr let kstyprintf ?read_color f fstr = let get_content, fmt = make_formatter ?read_color () in Format.kfprintf (fun _ -> f (get_content ())) fmt fstr let styprintf ?read_color fstr = kstyprintf ?read_color (fun x -> x) fstr lambda-term-1.9/src/lTerm_text.mli000066400000000000000000000070401254222632000171700ustar00rootroot00000000000000(* * lTerm_text.mli * -------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (** Styled text. *) open CamomileLibrary type t = (UChar.t * LTerm_style.t) array (** Type of a string with styles for each characters. *) (** {6 Conversions} *) val of_string : Zed_utf8.t -> t (** Creates a styled string from a string. All characters of the string have no style. *) val to_string : t -> Zed_utf8.t (** Returns the string part of a styled string. *) val of_string_maybe_invalid : string -> t (** Creates a styled string from a string. All characters of the string have no style. The string may contain invalid UTF-8 sequences, in which case invalid bytes are escaped with the syntax [\yXX]. *) val of_rope : Zed_rope.t -> t (** Creates a styled string from a rope. *) val to_rope : t -> Zed_rope.t (** Returns the string part of a styled string as a rope. *) val stylise : string -> LTerm_style.t -> t (** [stylise string style] creates a styled string with all styles set to [style]. *) (** {6 Parenthesis matching} *) val stylise_parenthesis : t -> ?paren : (UChar.t * UChar.t) list -> int -> LTerm_style.t -> unit (** [stylise_parenthesis text ?paren pos style] searchs for parenthesis group starting or ending at [pos] and apply them the style [style]. [paren] is the list of parenthesis recognized. *) (** {6 Markup strings} *) (** Markup strings are used to conveniently define styled strings. *) (** Type of an item in a markup string. *) type item = | S of Zed_utf8.t (** A UTF-8 encoded string. *) | R of Zed_rope.t (** A rope. *) | B_bold of bool (** Begins bold mode. *) | E_bold (** Ends bold mode. *) | B_underline of bool (** Begins underlined mode. *) | E_underline (** Ends underlined mode. *) | B_blink of bool (** Begins blinking mode. *) | E_blink (** Ends blinking mode. *) | B_reverse of bool (** Begins reverse video mode. *) | E_reverse (** Ends reverse video mode. *) | B_fg of LTerm_style.color (** Begins foreground color. *) | E_fg (** Ends foreground color. *) | B_bg of LTerm_style.color (** Begins background color. *) | E_bg (** Ends background color. *) type markup = item list (** Type of a markup string. *) val eval : markup -> t (** [eval makrup] evaluates a markup strings as a styled string. *) (** {6 Styled formatters} *) val make_formatter : ?read_color:(Format.tag -> LTerm_style.t) -> unit -> (unit -> t) * Format.formatter (** Create a formatter on a styled string. Returns a tuple [get_content, fmt]. Calling [get_content ()] will flush the formatter and output the resulting styled string. If a [read_color] function is provided, Format's tag are enabled and [read_color] is used to transform tags into styles. *) val pp_with_style : (LTerm_style.t -> Format.tag) -> (LTerm_style.t -> ('b, Format.formatter, unit, unit) format4 -> Format.formatter -> 'b) (** [pp_with_style f] will create a pretty printer analogous to {!stylise}, using f to encode style into tags. Will only work on a formatter with tag enabled. *) val styprintf : ?read_color:(Format.tag -> LTerm_style.t) -> ('a, Format.formatter, unit, t) format4 -> 'a (** Equivalent of {!Format.sprintf} for styled strings. *) val kstyprintf : ?read_color:(Format.tag -> LTerm_style.t) -> (t -> 'a) -> ('b, Format.formatter, unit, 'a) format4 -> 'b (** Equivalent of {!Format.ksprintf} for styled strings. *) lambda-term-1.9/src/lTerm_ui.ml000066400000000000000000000131571254222632000164560ustar00rootroot00000000000000(* * lTerm_ui.ml * ----------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) open LTerm_geom let return, (>>=) = Lwt.return, Lwt.(>>=) (* +-----------------------------------------------------------------+ | The UI type | +-----------------------------------------------------------------+ *) (* State of an UI. *) type state = | Init (* The UI has not yet been drawn. *) | Loop (* The UI is running. *) | Stop (* The UI has been stopped. *) type t = { term : LTerm.t; (* The terminal used for the UI. *) draw : t -> LTerm_draw.matrix -> unit; (* The draw function. *) mode : LTerm.mode; (* The previous mode of the terminal. *) mutable state : state; (* State of the UI. *) restore_state : bool; (* Whether to restore the state of the terminal when quiting. *) mutable size : LTerm_geom.size; (* The current size of the UI. *) mutable matrix_a : LTerm_draw.matrix; mutable matrix_b : LTerm_draw.matrix; (* The two matrices used for the rendering. *) mutable cursor_visible : bool; (* The cursor visible state. *) mutable cursor_position : LTerm_geom.coord; (* The cursor position. *) mutable draw_queued : bool; (* Is a draw operation queued ? *) mutable drawer : unit Lwt.t; (* The thread drawing the terminal. *) mutable drawing : bool; (* Are we drawing ? *) draw_error_push : exn option -> unit; draw_error_stream : exn Lwt_stream.t; (* Stream used to send drawing error to [loop]. *) } let check ui = if ui.state = Stop then failwith "The has been quited" (* +-----------------------------------------------------------------+ | Creation/quiting | +-----------------------------------------------------------------+ *) let create term ?(save_state = true) draw = LTerm.enter_raw_mode term >>= fun mode -> (if save_state then LTerm.save_state term else return ()) >>= fun () -> let stream, push = Lwt_stream.create () in return { term = term; draw = draw; mode = mode; state = Init; restore_state = save_state; size = LTerm.size term; matrix_a = [||]; matrix_b = [||]; cursor_visible = false; cursor_position = { row = 0; col = 0 }; draw_queued = false; drawer = return (); drawing = false; draw_error_push = push; draw_error_stream = stream; } let quit ui = check ui; ui.state <- Stop; ui.drawer >>= fun () -> LTerm.leave_raw_mode ui.term ui.mode >>= fun () -> if ui.restore_state then LTerm.show_cursor ui.term >>= fun () -> LTerm.load_state ui.term else return () (* +-----------------------------------------------------------------+ | Drawing | +-----------------------------------------------------------------+ *) let immediate_draw ui = fun () -> Lwt.catch (fun () -> (* Wait a bit in order not to redraw too often. *) Lwt.pause () >>= fun () -> ui.draw_queued <- false; if ui.state = Stop then return () else begin (* Allocate the first matrix if needed. *) if ui.matrix_a = [||] then ui.matrix_a <- LTerm_draw.make_matrix ui.size; (* Draw the screen *) ui.drawing <- true; (try ui.draw ui ui.matrix_a with exn -> ui.drawing <- false; raise exn); ui.drawing <- false; (* Rendering. *) LTerm.hide_cursor ui.term >>= fun () -> LTerm.render_update ui.term ui.matrix_b ui.matrix_a >>= fun () -> begin if ui.cursor_visible then LTerm.goto ui.term ui.cursor_position >>= fun () -> LTerm.show_cursor ui.term else return () end >>= fun () -> LTerm.flush ui.term >>= fun () -> (* Swap the two matrices. *) let a = ui.matrix_a and b = ui.matrix_b in ui.matrix_a <- b; ui.matrix_b <- a; return () end) (fun exn -> ui.draw_error_push (Some exn); return ()) let draw ui = check ui; ui.state <- Loop; (* If a draw operation is already queued, do nothing. *) if not ui.draw_queued then (* Wait for draw operation to finish before starting new one *) ui.drawer <- ui.drawer >>= immediate_draw ui (* +-----------------------------------------------------------------+ | Accessors | +-----------------------------------------------------------------+ *) let size ui = check ui; ui.size let cursor_visible ui = check ui; ui.cursor_visible let set_cursor_visible ui state = check ui; if state <> ui.cursor_visible then begin ui.cursor_visible <- state; if ui.state = Loop && not ui.drawing then draw ui end let cursor_position ui = check ui; ui.cursor_position let set_cursor_position ui coord = check ui; if coord <> ui.cursor_position then begin ui.cursor_position <- coord; if ui.state = Loop && not ui.drawing then draw ui end (* +-----------------------------------------------------------------+ | Loop | +-----------------------------------------------------------------+ *) let rec wait ui = check ui; if ui.state = Init then draw ui; Lwt.pick [LTerm.read_event ui.term; Lwt_stream.next ui.draw_error_stream >>= Lwt.fail] >>= fun ev -> match ev with | LTerm_event.Resize size -> ui.size <- size; (* New size, discard current matrices. *) ui.matrix_a <- [||]; ui.matrix_b <- [||]; draw ui; return ev | _ -> return ev lambda-term-1.9/src/lTerm_ui.mli000066400000000000000000000030041254222632000166150ustar00rootroot00000000000000(* * lTerm_ui.mli * ------------ * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (** High level function for writing full-screen applications *) type t (** Type of a user interface. *) val create : LTerm.t -> ?save_state : bool -> (t -> LTerm_draw.matrix -> unit) -> t Lwt.t (** [create term ?save_state draw] creates a new user interface. [draw] is used to draw the user interface. If [save_state] is [true] (the default) then the state of the terminal is saved. *) val quit : t -> unit Lwt.t (** [quit ()] quit the given ui and restore the terminal state. *) val size : t -> LTerm_geom.size (** [size ui] returns the current size of the terminal used by the given user-interface. It is updated by {!wait}. *) val draw : t -> unit (** [draw ui] enqueue a draw operation for the given UI. *) val cursor_visible : t -> bool (** [cursor_visible ui] returns [true] if the cursor is displayed in the UI. It is initially not visible. *) val set_cursor_visible : t -> bool -> unit (** [set_cursor_visible ui visible] sets the cursor visible state. *) val cursor_position : t -> LTerm_geom.coord (** [cursor_position ui] returns the position of the cursor inside the UI. *) val set_cursor_position : t -> LTerm_geom.coord -> unit (** [set_cursor_position ui coord] sets the position of the cursor inside the UI. *) val wait : t -> LTerm_event.t Lwt.t (** [wait ui] wait for an event. *) lambda-term-1.9/src/lTerm_unix.ml000066400000000000000000001222631254222632000170230ustar00rootroot00000000000000(* * lTerm_unix.ml * ------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) open CamomileLibraryDyn.Camomile open LTerm_key let return, (>>=), (>|=) = Lwt.return, Lwt.(>>=), Lwt.(>|=) external get_sigwinch : unit -> int option = "lt_unix_get_sigwinch" external get_system_encoding : unit -> string = "lt_unix_get_system_encoding" let sigwinch = get_sigwinch () (* Obtained by running the folliwing makefile in the "localedata" directory of the glibc: {[ include SUPPORTED all: @echo $(SUPPORTED-LOCALES) | sed 's/ /\n/g' | awk -F/ '$$1 ~ /[.]/ { next; }; { print " | \""$$1"\" -> \""$$2"\"" }' ]} *) let encoding_of_lang = function | "aa_DJ" -> "ISO-8859-1" | "aa_ER" -> "UTF-8" | "aa_ER@saaho" -> "UTF-8" | "aa_ET" -> "UTF-8" | "af_ZA" -> "ISO-8859-1" | "am_ET" -> "UTF-8" | "an_ES" -> "ISO-8859-15" | "ar_AE" -> "ISO-8859-6" | "ar_BH" -> "ISO-8859-6" | "ar_DZ" -> "ISO-8859-6" | "ar_EG" -> "ISO-8859-6" | "ar_IN" -> "UTF-8" | "ar_IQ" -> "ISO-8859-6" | "ar_JO" -> "ISO-8859-6" | "ar_KW" -> "ISO-8859-6" | "ar_LB" -> "ISO-8859-6" | "ar_LY" -> "ISO-8859-6" | "ar_MA" -> "ISO-8859-6" | "ar_OM" -> "ISO-8859-6" | "ar_QA" -> "ISO-8859-6" | "ar_SA" -> "ISO-8859-6" | "ar_SD" -> "ISO-8859-6" | "ar_SY" -> "ISO-8859-6" | "ar_TN" -> "ISO-8859-6" | "ar_YE" -> "ISO-8859-6" | "az_AZ" -> "UTF-8" | "as_IN" -> "UTF-8" | "ast_ES" -> "ISO-8859-15" | "be_BY" -> "CP1251" | "be_BY@latin" -> "UTF-8" | "bem_ZM" -> "UTF-8" | "ber_DZ" -> "UTF-8" | "ber_MA" -> "UTF-8" | "bg_BG" -> "CP1251" | "bn_BD" -> "UTF-8" | "bn_IN" -> "UTF-8" | "bo_CN" -> "UTF-8" | "bo_IN" -> "UTF-8" | "br_FR" -> "ISO-8859-1" | "br_FR@euro" -> "ISO-8859-15" | "bs_BA" -> "ISO-8859-2" | "byn_ER" -> "UTF-8" | "ca_AD" -> "ISO-8859-15" | "ca_ES" -> "ISO-8859-1" | "ca_ES@euro" -> "ISO-8859-15" | "ca_FR" -> "ISO-8859-15" | "ca_IT" -> "ISO-8859-15" | "crh_UA" -> "UTF-8" | "cs_CZ" -> "ISO-8859-2" | "csb_PL" -> "UTF-8" | "cv_RU" -> "UTF-8" | "cy_GB" -> "ISO-8859-14" | "da_DK" -> "ISO-8859-1" | "de_AT" -> "ISO-8859-1" | "de_AT@euro" -> "ISO-8859-15" | "de_BE" -> "ISO-8859-1" | "de_BE@euro" -> "ISO-8859-15" | "de_CH" -> "ISO-8859-1" | "de_DE" -> "ISO-8859-1" | "de_DE@euro" -> "ISO-8859-15" | "de_LU" -> "ISO-8859-1" | "de_LU@euro" -> "ISO-8859-15" | "dv_MV" -> "UTF-8" | "dz_BT" -> "UTF-8" | "el_GR" -> "ISO-8859-7" | "el_CY" -> "ISO-8859-7" | "en_AG" -> "UTF-8" | "en_AU" -> "ISO-8859-1" | "en_BW" -> "ISO-8859-1" | "en_CA" -> "ISO-8859-1" | "en_DK" -> "ISO-8859-1" | "en_GB" -> "ISO-8859-1" | "en_HK" -> "ISO-8859-1" | "en_IE" -> "ISO-8859-1" | "en_IE@euro" -> "ISO-8859-15" | "en_IN" -> "UTF-8" | "en_NG" -> "UTF-8" | "en_NZ" -> "ISO-8859-1" | "en_PH" -> "ISO-8859-1" | "en_SG" -> "ISO-8859-1" | "en_US" -> "ISO-8859-1" | "en_ZA" -> "ISO-8859-1" | "en_ZM" -> "UTF-8" | "en_ZW" -> "ISO-8859-1" | "es_AR" -> "ISO-8859-1" | "es_BO" -> "ISO-8859-1" | "es_CL" -> "ISO-8859-1" | "es_CO" -> "ISO-8859-1" | "es_CR" -> "ISO-8859-1" | "es_DO" -> "ISO-8859-1" | "es_EC" -> "ISO-8859-1" | "es_ES" -> "ISO-8859-1" | "es_ES@euro" -> "ISO-8859-15" | "es_GT" -> "ISO-8859-1" | "es_HN" -> "ISO-8859-1" | "es_MX" -> "ISO-8859-1" | "es_NI" -> "ISO-8859-1" | "es_PA" -> "ISO-8859-1" | "es_PE" -> "ISO-8859-1" | "es_PR" -> "ISO-8859-1" | "es_PY" -> "ISO-8859-1" | "es_SV" -> "ISO-8859-1" | "es_US" -> "ISO-8859-1" | "es_UY" -> "ISO-8859-1" | "es_VE" -> "ISO-8859-1" | "et_EE" -> "ISO-8859-1" | "eu_ES" -> "ISO-8859-1" | "eu_ES@euro" -> "ISO-8859-15" | "fa_IR" -> "UTF-8" | "ff_SN" -> "UTF-8" | "fi_FI" -> "ISO-8859-1" | "fi_FI@euro" -> "ISO-8859-15" | "fil_PH" -> "UTF-8" | "fo_FO" -> "ISO-8859-1" | "fr_BE" -> "ISO-8859-1" | "fr_BE@euro" -> "ISO-8859-15" | "fr_CA" -> "ISO-8859-1" | "fr_CH" -> "ISO-8859-1" | "fr_FR" -> "ISO-8859-1" | "fr_FR@euro" -> "ISO-8859-15" | "fr_LU" -> "ISO-8859-1" | "fr_LU@euro" -> "ISO-8859-15" | "fur_IT" -> "UTF-8" | "fy_NL" -> "UTF-8" | "fy_DE" -> "UTF-8" | "ga_IE" -> "ISO-8859-1" | "ga_IE@euro" -> "ISO-8859-15" | "gd_GB" -> "ISO-8859-15" | "gez_ER" -> "UTF-8" | "gez_ER@abegede" -> "UTF-8" | "gez_ET" -> "UTF-8" | "gez_ET@abegede" -> "UTF-8" | "gl_ES" -> "ISO-8859-1" | "gl_ES@euro" -> "ISO-8859-15" | "gu_IN" -> "UTF-8" | "gv_GB" -> "ISO-8859-1" | "ha_NG" -> "UTF-8" | "he_IL" -> "ISO-8859-8" | "hi_IN" -> "UTF-8" | "hne_IN" -> "UTF-8" | "hr_HR" -> "ISO-8859-2" | "hsb_DE" -> "ISO-8859-2" | "ht_HT" -> "UTF-8" | "hu_HU" -> "ISO-8859-2" | "hy_AM" -> "UTF-8" | "id_ID" -> "ISO-8859-1" | "ig_NG" -> "UTF-8" | "ik_CA" -> "UTF-8" | "is_IS" -> "ISO-8859-1" | "it_CH" -> "ISO-8859-1" | "it_IT" -> "ISO-8859-1" | "it_IT@euro" -> "ISO-8859-15" | "iu_CA" -> "UTF-8" | "iw_IL" -> "ISO-8859-8" | "ka_GE" -> "GEORGIAN-PS" | "kk_KZ" -> "PT154" | "kl_GL" -> "ISO-8859-1" | "km_KH" -> "UTF-8" | "kn_IN" -> "UTF-8" | "kok_IN" -> "UTF-8" | "ks_IN" -> "UTF-8" | "ks_IN@devanagari" -> "UTF-8" | "ku_TR" -> "ISO-8859-9" | "kw_GB" -> "ISO-8859-1" | "ky_KG" -> "UTF-8" | "lb_LU" -> "UTF-8" | "lg_UG" -> "ISO-8859-10" | "li_BE" -> "UTF-8" | "li_NL" -> "UTF-8" | "lij_IT" -> "UTF-8" | "lo_LA" -> "UTF-8" | "lt_LT" -> "ISO-8859-13" | "lv_LV" -> "ISO-8859-13" | "mai_IN" -> "UTF-8" | "mg_MG" -> "ISO-8859-15" | "mhr_RU" -> "UTF-8" | "mi_NZ" -> "ISO-8859-13" | "mk_MK" -> "ISO-8859-5" | "ml_IN" -> "UTF-8" | "mn_MN" -> "UTF-8" | "mr_IN" -> "UTF-8" | "ms_MY" -> "ISO-8859-1" | "mt_MT" -> "ISO-8859-3" | "my_MM" -> "UTF-8" | "nan_TW@latin" -> "UTF-8" | "nb_NO" -> "ISO-8859-1" | "nds_DE" -> "UTF-8" | "nds_NL" -> "UTF-8" | "ne_NP" -> "UTF-8" | "nl_AW" -> "UTF-8" | "nl_BE" -> "ISO-8859-1" | "nl_BE@euro" -> "ISO-8859-15" | "nl_NL" -> "ISO-8859-1" | "nl_NL@euro" -> "ISO-8859-15" | "nn_NO" -> "ISO-8859-1" | "nr_ZA" -> "UTF-8" | "nso_ZA" -> "UTF-8" | "oc_FR" -> "ISO-8859-1" | "om_ET" -> "UTF-8" | "om_KE" -> "ISO-8859-1" | "or_IN" -> "UTF-8" | "os_RU" -> "UTF-8" | "pa_IN" -> "UTF-8" | "pa_PK" -> "UTF-8" | "pap_AN" -> "UTF-8" | "pl_PL" -> "ISO-8859-2" | "ps_AF" -> "UTF-8" | "pt_BR" -> "ISO-8859-1" | "pt_PT" -> "ISO-8859-1" | "pt_PT@euro" -> "ISO-8859-15" | "ro_RO" -> "ISO-8859-2" | "ru_RU" -> "ISO-8859-5" | "ru_UA" -> "KOI8-U" | "rw_RW" -> "UTF-8" | "sa_IN" -> "UTF-8" | "sc_IT" -> "UTF-8" | "sd_IN" -> "UTF-8" | "sd_IN@devanagari" -> "UTF-8" | "se_NO" -> "UTF-8" | "shs_CA" -> "UTF-8" | "si_LK" -> "UTF-8" | "sid_ET" -> "UTF-8" | "sk_SK" -> "ISO-8859-2" | "sl_SI" -> "ISO-8859-2" | "so_DJ" -> "ISO-8859-1" | "so_ET" -> "UTF-8" | "so_KE" -> "ISO-8859-1" | "so_SO" -> "ISO-8859-1" | "sq_AL" -> "ISO-8859-1" | "sq_MK" -> "UTF-8" | "sr_ME" -> "UTF-8" | "sr_RS" -> "UTF-8" | "sr_RS@latin" -> "UTF-8" | "ss_ZA" -> "UTF-8" | "st_ZA" -> "ISO-8859-1" | "sv_FI" -> "ISO-8859-1" | "sv_FI@euro" -> "ISO-8859-15" | "sv_SE" -> "ISO-8859-1" | "sw_KE" -> "UTF-8" | "sw_TZ" -> "UTF-8" | "ta_IN" -> "UTF-8" | "te_IN" -> "UTF-8" | "tg_TJ" -> "KOI8-T" | "th_TH" -> "TIS-620" | "ti_ER" -> "UTF-8" | "ti_ET" -> "UTF-8" | "tig_ER" -> "UTF-8" | "tk_TM" -> "UTF-8" | "tl_PH" -> "ISO-8859-1" | "tn_ZA" -> "UTF-8" | "tr_CY" -> "ISO-8859-9" | "tr_TR" -> "ISO-8859-9" | "ts_ZA" -> "UTF-8" | "tt_RU" -> "UTF-8" | "tt_RU@iqtelif" -> "UTF-8" | "ug_CN" -> "UTF-8" | "uk_UA" -> "KOI8-U" | "ur_PK" -> "UTF-8" | "uz_UZ" -> "ISO-8859-1" | "uz_UZ@cyrillic" -> "UTF-8" | "ve_ZA" -> "UTF-8" | "vi_VN" -> "UTF-8" | "wa_BE" -> "ISO-8859-1" | "wa_BE@euro" -> "ISO-8859-15" | "wae_CH" -> "UTF-8" | "wo_SN" -> "UTF-8" | "xh_ZA" -> "ISO-8859-1" | "yi_US" -> "CP1255" | "yo_NG" -> "UTF-8" | "yue_HK" -> "UTF-8" | "zh_CN" -> "GB2312" | "zh_HK" -> "BIG5-HKSCS" | "zh_SG" -> "GB2312" | "zh_TW" -> "BIG5" | "zu_ZA" -> "ISO-8859-1" | _ -> "ASCII" let system_encoding = match get_system_encoding () with | "" -> begin match try Some (Sys.getenv "LANG") with Not_found -> None with | None -> "ASCII" | Some lang -> match try Some (String.index lang '.') with Not_found -> None with | None -> encoding_of_lang lang | Some idx -> String.sub lang (idx + 1) (String.length lang - idx - 1) end | enc -> enc (* +-----------------------------------------------------------------+ | Parsing of encoded characters | +-----------------------------------------------------------------+ *) class output_single (cell : UChar.t option ref) = object method put char = cell := Some char method flush () = () method close_out () = () end let parse_char encoding st first_byte = let cell = ref None in let output = new CharEncoding.convert_uchar_output encoding (new output_single cell) in let rec loop st = match !cell with | Some char -> return char | None -> Lwt_stream.next st >>= fun byte -> assert (output#output (String.make 1 byte) 0 1 = 1); output#flush (); loop st in Lwt.catch (fun () -> assert (output#output (String.make 1 first_byte) 0 1 = 1); Lwt_stream.parse st loop) (function | CharEncoding.Malformed_code | Lwt_stream.Empty -> return (UChar.of_char first_byte) | exn -> Lwt.fail exn) (* +-----------------------------------------------------------------+ | Input of escape sequence | +-----------------------------------------------------------------+ *) exception Not_a_sequence let parse_escape escape_time st = let buf = Buffer.create 32 in (* Read one character and add it to [buf]: *) let get () = Lwt.pick [Lwt_stream.get st; Lwt_unix.sleep escape_time >>= fun () -> return None] >>= fun ch -> match ch with | None -> (* If the rest is not immediatly available, conclude that this is not an escape sequence but just the escape key: *) Lwt.fail Not_a_sequence | Some('\x00' .. '\x1f' | '\x80' .. '\xff') -> (* Control characters and non-ascii characters are not part of escape sequences. *) Lwt.fail Not_a_sequence | Some ch -> Buffer.add_char buf ch; return ch in let rec loop () = get () >>= function | '0' .. '9' | ';' | '[' -> loop () | ch -> return (Buffer.contents buf) in get () >>= function | '[' | 'O' -> loop () | _ -> Lwt.fail Not_a_sequence (* +-----------------------------------------------------------------+ | Escape sequences mapping | +-----------------------------------------------------------------+ *) let controls = [| Char(UChar.of_char ' '); Char(UChar.of_char 'a'); Char(UChar.of_char 'b'); Char(UChar.of_char 'c'); Char(UChar.of_char 'd'); Char(UChar.of_char 'e'); Char(UChar.of_char 'f'); Char(UChar.of_char 'g'); Char(UChar.of_char 'h'); Tab; Enter; Char(UChar.of_char 'k'); Char(UChar.of_char 'l'); Char(UChar.of_char 'm'); Char(UChar.of_char 'n'); Char(UChar.of_char 'o'); Char(UChar.of_char 'p'); Char(UChar.of_char 'q'); Char(UChar.of_char 'r'); Char(UChar.of_char 's'); Char(UChar.of_char 't'); Char(UChar.of_char 'u'); Char(UChar.of_char 'v'); Char(UChar.of_char 'w'); Char(UChar.of_char 'x'); Char(UChar.of_char 'y'); Char(UChar.of_char 'z'); Escape; Char(UChar.of_char '\\'); Char(UChar.of_char ']'); Char(UChar.of_char '^'); Char(UChar.of_char '_'); |] let sequences = [| "[1~", { control = false; meta = false; shift = false; code = Home }; "[2~", { control = false; meta = false; shift = false; code = Insert }; "[3~", { control = false; meta = false; shift = false; code = Delete }; "[4~", { control = false; meta = false; shift = false; code = End }; "[5~", { control = false; meta = false; shift = false; code = Prev_page }; "[6~", { control = false; meta = false; shift = false; code = Next_page }; "[7~", { control = false; meta = false; shift = false; code = Home }; "[8~", { control = false; meta = false; shift = false; code = End }; "[11~", { control = false; meta = false; shift = false; code = F1 }; "[12~", { control = false; meta = false; shift = false; code = F2 }; "[13~", { control = false; meta = false; shift = false; code = F3 }; "[14~", { control = false; meta = false; shift = false; code = F4 }; "[15~", { control = false; meta = false; shift = false; code = F5 }; "[17~", { control = false; meta = false; shift = false; code = F6 }; "[18~", { control = false; meta = false; shift = false; code = F7 }; "[19~", { control = false; meta = false; shift = false; code = F8 }; "[20~", { control = false; meta = false; shift = false; code = F9 }; "[21~", { control = false; meta = false; shift = false; code = F10 }; "[23~", { control = false; meta = false; shift = false; code = F11 }; "[24~", { control = false; meta = false; shift = false; code = F12 }; "[1^", { control = true; meta = false; shift = false; code = Home }; "[2^", { control = true; meta = false; shift = false; code = Insert }; "[3^", { control = true; meta = false; shift = false; code = Delete }; "[4^", { control = true; meta = false; shift = false; code = End }; "[5^", { control = true; meta = false; shift = false; code = Prev_page }; "[6^", { control = true; meta = false; shift = false; code = Next_page }; "[7^", { control = true; meta = false; shift = false; code = Home }; "[8^", { control = true; meta = false; shift = false; code = End }; "[11^", { control = true; meta = false; shift = false; code = F1 }; "[12^", { control = true; meta = false; shift = false; code = F2 }; "[13^", { control = true; meta = false; shift = false; code = F3 }; "[14^", { control = true; meta = false; shift = false; code = F4 }; "[15^", { control = true; meta = false; shift = false; code = F5 }; "[17^", { control = true; meta = false; shift = false; code = F6 }; "[18^", { control = true; meta = false; shift = false; code = F7 }; "[19^", { control = true; meta = false; shift = false; code = F8 }; "[20^", { control = true; meta = false; shift = false; code = F9 }; "[21^", { control = true; meta = false; shift = false; code = F10 }; "[23^", { control = true; meta = false; shift = false; code = F11 }; "[24^", { control = true; meta = false; shift = false; code = F12 }; "[1$", { control = false; meta = false; shift = true; code = Home }; "[2$", { control = false; meta = false; shift = true; code = Insert }; "[3$", { control = false; meta = false; shift = true; code = Delete }; "[4$", { control = false; meta = false; shift = true; code = End }; "[5$", { control = false; meta = false; shift = true; code = Prev_page }; "[6$", { control = false; meta = false; shift = true; code = Next_page }; "[7$", { control = false; meta = false; shift = true; code = Home }; "[8$", { control = false; meta = false; shift = true; code = End }; "[1@", { control = true; meta = false; shift = true; code = Home }; "[2@", { control = true; meta = false; shift = true; code = Insert }; "[3@", { control = true; meta = false; shift = true; code = Delete }; "[4@", { control = true; meta = false; shift = true; code = End }; "[5@", { control = true; meta = false; shift = true; code = Prev_page }; "[6@", { control = true; meta = false; shift = true; code = Next_page }; "[7@", { control = true; meta = false; shift = true; code = Home }; "[8@", { control = true; meta = false; shift = true; code = End }; "[25~", { control = false; meta = false; shift = true; code = F3 }; "[26~", { control = false; meta = false; shift = true; code = F4 }; "[28~", { control = false; meta = false; shift = true; code = F5 }; "[29~", { control = false; meta = false; shift = true; code = F6 }; "[31~", { control = false; meta = false; shift = true; code = F7 }; "[32~", { control = false; meta = false; shift = true; code = F8 }; "[33~", { control = false; meta = false; shift = true; code = F9 }; "[34~", { control = false; meta = false; shift = true; code = F10 }; "[23$", { control = false; meta = false; shift = true; code = F11 }; "[24$", { control = false; meta = false; shift = true; code = F12 }; "[25^", { control = true; meta = false; shift = true; code = F3 }; "[26^", { control = true; meta = false; shift = true; code = F4 }; "[28^", { control = true; meta = false; shift = true; code = F5 }; "[29^", { control = true; meta = false; shift = true; code = F6 }; "[31^", { control = true; meta = false; shift = true; code = F7 }; "[32^", { control = true; meta = false; shift = true; code = F8 }; "[33^", { control = true; meta = false; shift = true; code = F9 }; "[34^", { control = true; meta = false; shift = true; code = F10 }; "[23@", { control = true; meta = false; shift = true; code = F11 }; "[24@", { control = true; meta = false; shift = true; code = F12 }; "[Z", { control = false; meta = false; shift = true; code = Tab }; "[A", { control = false; meta = false; shift = false; code = Up }; "[B", { control = false; meta = false; shift = false; code = Down }; "[C", { control = false; meta = false; shift = false; code = Right }; "[D", { control = false; meta = false; shift = false; code = Left }; "[a", { control = false; meta = false; shift = true; code = Up }; "[b", { control = false; meta = false; shift = true; code = Down }; "[c", { control = false; meta = false; shift = true; code = Right }; "[d", { control = false; meta = false; shift = true; code = Left }; "A", { control = false; meta = false; shift = false; code = Up }; "B", { control = false; meta = false; shift = false; code = Down }; "C", { control = false; meta = false; shift = false; code = Right }; "D", { control = false; meta = false; shift = false; code = Left }; "OA", { control = false; meta = false; shift = false; code = Up }; "OB", { control = false; meta = false; shift = false; code = Down }; "OC", { control = false; meta = false; shift = false; code = Right }; "OD", { control = false; meta = false; shift = false; code = Left }; "Oa", { control = true; meta = false; shift = false; code = Up }; "Ob", { control = true; meta = false; shift = false; code = Down }; "Oc", { control = true; meta = false; shift = false; code = Right }; "Od", { control = true; meta = false; shift = false; code = Left }; "OP", { control = false; meta = false; shift = false; code = F1 }; "OQ", { control = false; meta = false; shift = false; code = F2 }; "OR", { control = false; meta = false; shift = false; code = F3 }; "OS", { control = false; meta = false; shift = false; code = F4 }; "O2P", { control = false; meta = false; shift = true; code = F1 }; "O2Q", { control = false; meta = false; shift = true; code = F2 }; "O2R", { control = false; meta = false; shift = true; code = F3 }; "O2S", { control = false; meta = false; shift = true; code = F4 }; "O3P", { control = false; meta = true; shift = false; code = F1 }; "O3Q", { control = false; meta = true; shift = false; code = F2 }; "O3R", { control = false; meta = true; shift = false; code = F3 }; "O3S", { control = false; meta = true; shift = false; code = F4 }; "O4P", { control = false; meta = true; shift = true; code = F1 }; "O4Q", { control = false; meta = true; shift = true; code = F2 }; "O4R", { control = false; meta = true; shift = true; code = F3 }; "O4S", { control = false; meta = true; shift = true; code = F4 }; "O5P", { control = true; meta = false; shift = false; code = F1 }; "O5Q", { control = true; meta = false; shift = false; code = F2 }; "O5R", { control = true; meta = false; shift = false; code = F3 }; "O5S", { control = true; meta = false; shift = false; code = F4 }; "O6P", { control = true; meta = false; shift = true; code = F1 }; "O6Q", { control = true; meta = false; shift = true; code = F2 }; "O6R", { control = true; meta = false; shift = true; code = F3 }; "O6S", { control = true; meta = false; shift = true; code = F4 }; "O7P", { control = true; meta = true; shift = false; code = F1 }; "O7Q", { control = true; meta = true; shift = false; code = F2 }; "O7R", { control = true; meta = true; shift = false; code = F3 }; "O7S", { control = true; meta = true; shift = false; code = F4 }; "O8P", { control = true; meta = true; shift = true; code = F1 }; "O8Q", { control = true; meta = true; shift = true; code = F2 }; "O8R", { control = true; meta = true; shift = true; code = F3 }; "O8S", { control = true; meta = true; shift = true; code = F4 }; "[[A", { control = false; meta = false; shift = false; code = F1 }; "[[B", { control = false; meta = false; shift = false; code = F2 }; "[[C", { control = false; meta = false; shift = false; code = F3 }; "[[D", { control = false; meta = false; shift = false; code = F4 }; "[[E", { control = false; meta = false; shift = false; code = F5 }; "[H", { control = false; meta = false; shift = false; code = Home }; "[F", { control = false; meta = false; shift = false; code = End }; "OH", { control = false; meta = false; shift = false; code = Home }; "OF", { control = false; meta = false; shift = false; code = End }; "H", { control = false; meta = false; shift = false; code = Home }; "F", { control = false; meta = false; shift = false; code = End }; "[1;2A", { control = false; meta = false; shift = true; code = Up }; "[1;2B", { control = false; meta = false; shift = true; code = Down }; "[1;2C", { control = false; meta = false; shift = true; code = Right }; "[1;2D", { control = false; meta = false; shift = true; code = Left }; "[1;3A", { control = false; meta = true; shift = false; code = Up }; "[1;3B", { control = false; meta = true; shift = false; code = Down }; "[1;3C", { control = false; meta = true; shift = false; code = Right }; "[1;3D", { control = false; meta = true; shift = false; code = Left }; "[1;4A", { control = false; meta = true; shift = true; code = Up }; "[1;4B", { control = false; meta = true; shift = true; code = Down }; "[1;4C", { control = false; meta = true; shift = true; code = Right }; "[1;4D", { control = false; meta = true; shift = true; code = Left }; "[1;5A", { control = true; meta = false; shift = false; code = Up }; "[1;5B", { control = true; meta = false; shift = false; code = Down }; "[1;5C", { control = true; meta = false; shift = false; code = Right }; "[1;5D", { control = true; meta = false; shift = false; code = Left }; "[1;6A", { control = true; meta = false; shift = true; code = Up }; "[1;6B", { control = true; meta = false; shift = true; code = Down }; "[1;6C", { control = true; meta = false; shift = true; code = Right }; "[1;6D", { control = true; meta = false; shift = true; code = Left }; "[1;7A", { control = true; meta = true; shift = false; code = Up }; "[1;7B", { control = true; meta = true; shift = false; code = Down }; "[1;7C", { control = true; meta = true; shift = false; code = Right }; "[1;7D", { control = true; meta = true; shift = false; code = Left }; "[1;8A", { control = true; meta = true; shift = true; code = Up }; "[1;8B", { control = true; meta = true; shift = true; code = Down }; "[1;8C", { control = true; meta = true; shift = true; code = Right }; "[1;8D", { control = true; meta = true; shift = true; code = Left }; "[1;2P", { control = false; meta = false; shift = true; code = F1 }; "[1;2Q", { control = false; meta = false; shift = true; code = F2 }; "[1;2R", { control = false; meta = false; shift = true; code = F3 }; "[1;2S", { control = false; meta = false; shift = true; code = F4 }; "[1;3P", { control = false; meta = true; shift = false; code = F1 }; "[1;3Q", { control = false; meta = true; shift = false; code = F2 }; "[1;3R", { control = false; meta = true; shift = false; code = F3 }; "[1;3S", { control = false; meta = true; shift = false; code = F4 }; "[1;4P", { control = false; meta = true; shift = true; code = F1 }; "[1;4Q", { control = false; meta = true; shift = true; code = F2 }; "[1;4R", { control = false; meta = true; shift = true; code = F3 }; "[1;4S", { control = false; meta = true; shift = true; code = F4 }; "[1;5P", { control = true; meta = false; shift = false; code = F1 }; "[1;5Q", { control = true; meta = false; shift = false; code = F2 }; "[1;5R", { control = true; meta = false; shift = false; code = F3 }; "[1;5S", { control = true; meta = false; shift = false; code = F4 }; "[1;6P", { control = true; meta = false; shift = true; code = F1 }; "[1;6Q", { control = true; meta = false; shift = true; code = F2 }; "[1;6R", { control = true; meta = false; shift = true; code = F3 }; "[1;6S", { control = true; meta = false; shift = true; code = F4 }; "[1;7P", { control = true; meta = true; shift = false; code = F1 }; "[1;7Q", { control = true; meta = true; shift = false; code = F2 }; "[1;7R", { control = true; meta = true; shift = false; code = F3 }; "[1;7S", { control = true; meta = true; shift = false; code = F4 }; "[1;8P", { control = true; meta = true; shift = true; code = F1 }; "[1;8Q", { control = true; meta = true; shift = true; code = F2 }; "[1;8R", { control = true; meta = true; shift = true; code = F3 }; "[1;8S", { control = true; meta = true; shift = true; code = F4 }; "O1;2P", { control = false; meta = false; shift = true; code = F1 }; "O1;2Q", { control = false; meta = false; shift = true; code = F2 }; "O1;2R", { control = false; meta = false; shift = true; code = F3 }; "O1;2S", { control = false; meta = false; shift = true; code = F4 }; "O1;3P", { control = false; meta = true; shift = false; code = F1 }; "O1;3Q", { control = false; meta = true; shift = false; code = F2 }; "O1;3R", { control = false; meta = true; shift = false; code = F3 }; "O1;3S", { control = false; meta = true; shift = false; code = F4 }; "O1;4P", { control = false; meta = true; shift = true; code = F1 }; "O1;4Q", { control = false; meta = true; shift = true; code = F2 }; "O1;4R", { control = false; meta = true; shift = true; code = F3 }; "O1;4S", { control = false; meta = true; shift = true; code = F4 }; "O1;5P", { control = true; meta = false; shift = false; code = F1 }; "O1;5Q", { control = true; meta = false; shift = false; code = F2 }; "O1;5R", { control = true; meta = false; shift = false; code = F3 }; "O1;5S", { control = true; meta = false; shift = false; code = F4 }; "O1;6P", { control = true; meta = false; shift = true; code = F1 }; "O1;6Q", { control = true; meta = false; shift = true; code = F2 }; "O1;6R", { control = true; meta = false; shift = true; code = F3 }; "O1;6S", { control = true; meta = false; shift = true; code = F4 }; "O1;7P", { control = true; meta = true; shift = false; code = F1 }; "O1;7Q", { control = true; meta = true; shift = false; code = F2 }; "O1;7R", { control = true; meta = true; shift = false; code = F3 }; "O1;7S", { control = true; meta = true; shift = false; code = F4 }; "O1;8P", { control = true; meta = true; shift = true; code = F1 }; "O1;8Q", { control = true; meta = true; shift = true; code = F2 }; "O1;8R", { control = true; meta = true; shift = true; code = F3 }; "O1;8S", { control = true; meta = true; shift = true; code = F4 }; "[15;2~", { control = false; meta = false; shift = true; code = F5 }; "[17;2~", { control = false; meta = false; shift = true; code = F6 }; "[18;2~", { control = false; meta = false; shift = true; code = F7 }; "[19;2~", { control = false; meta = false; shift = true; code = F8 }; "[20;2~", { control = false; meta = false; shift = true; code = F9 }; "[21;2~", { control = false; meta = false; shift = true; code = F10 }; "[23;2~", { control = false; meta = false; shift = true; code = F11 }; "[24;2~", { control = false; meta = false; shift = true; code = F12 }; "[15;3~", { control = false; meta = true; shift = false; code = F5 }; "[17;3~", { control = false; meta = true; shift = false; code = F6 }; "[18;3~", { control = false; meta = true; shift = false; code = F7 }; "[19;3~", { control = false; meta = true; shift = false; code = F8 }; "[20;3~", { control = false; meta = true; shift = false; code = F9 }; "[21;3~", { control = false; meta = true; shift = false; code = F10 }; "[23;3~", { control = false; meta = true; shift = false; code = F11 }; "[24;3~", { control = false; meta = true; shift = false; code = F12 }; "[15;4~", { control = false; meta = true; shift = true; code = F5 }; "[17;4~", { control = false; meta = true; shift = true; code = F6 }; "[18;4~", { control = false; meta = true; shift = true; code = F7 }; "[19;4~", { control = false; meta = true; shift = true; code = F8 }; "[20;4~", { control = false; meta = true; shift = true; code = F9 }; "[21;4~", { control = false; meta = true; shift = true; code = F10 }; "[23;4~", { control = false; meta = true; shift = true; code = F11 }; "[24;4~", { control = false; meta = true; shift = true; code = F12 }; "[15;5~", { control = true; meta = false; shift = false; code = F5 }; "[17;5~", { control = true; meta = false; shift = false; code = F6 }; "[18;5~", { control = true; meta = false; shift = false; code = F7 }; "[19;5~", { control = true; meta = false; shift = false; code = F8 }; "[20;5~", { control = true; meta = false; shift = false; code = F9 }; "[21;5~", { control = true; meta = false; shift = false; code = F10 }; "[23;5~", { control = true; meta = false; shift = false; code = F11 }; "[24;5~", { control = true; meta = false; shift = false; code = F12 }; "[15;6~", { control = true; meta = false; shift = true; code = F5 }; "[17;6~", { control = true; meta = false; shift = true; code = F6 }; "[18;6~", { control = true; meta = false; shift = true; code = F7 }; "[19;6~", { control = true; meta = false; shift = true; code = F8 }; "[20;6~", { control = true; meta = false; shift = true; code = F9 }; "[21;6~", { control = true; meta = false; shift = true; code = F10 }; "[23;6~", { control = true; meta = false; shift = true; code = F11 }; "[24;6~", { control = true; meta = false; shift = true; code = F12 }; "[15;7~", { control = true; meta = true; shift = false; code = F5 }; "[17;7~", { control = true; meta = true; shift = false; code = F6 }; "[18;7~", { control = true; meta = true; shift = false; code = F7 }; "[19;7~", { control = true; meta = true; shift = false; code = F8 }; "[20;7~", { control = true; meta = true; shift = false; code = F9 }; "[21;7~", { control = true; meta = true; shift = false; code = F10 }; "[23;7~", { control = true; meta = true; shift = false; code = F11 }; "[24;7~", { control = true; meta = true; shift = false; code = F12 }; "[15;8~", { control = true; meta = true; shift = true; code = F5 }; "[17;8~", { control = true; meta = true; shift = true; code = F6 }; "[18;8~", { control = true; meta = true; shift = true; code = F7 }; "[19;8~", { control = true; meta = true; shift = true; code = F8 }; "[20;8~", { control = true; meta = true; shift = true; code = F9 }; "[21;8~", { control = true; meta = true; shift = true; code = F10 }; "[23;8~", { control = true; meta = true; shift = true; code = F11 }; "[24;8~", { control = true; meta = true; shift = true; code = F12 }; "[1;2H", { control = false; meta = false; shift = true; code = Home }; "[1;2F", { control = false; meta = false; shift = true; code = End }; "[1;3H", { control = false; meta = true; shift = false; code = Home }; "[1;3F", { control = false; meta = true; shift = false; code = End }; "[1;4H", { control = false; meta = true; shift = true; code = Home }; "[1;4F", { control = false; meta = true; shift = true; code = End }; "[1;5H", { control = true; meta = false; shift = false; code = Home }; "[1;5F", { control = true; meta = false; shift = false; code = End }; "[1;6H", { control = true; meta = false; shift = true; code = Home }; "[1;6F", { control = true; meta = false; shift = true; code = End }; "[1;7H", { control = true; meta = true; shift = false; code = Home }; "[1;7F", { control = true; meta = true; shift = false; code = End }; "[1;8H", { control = true; meta = true; shift = true; code = Home }; "[1;8F", { control = true; meta = true; shift = true; code = End }; "[2;2~", { control = false; meta = false; shift = true; code = Insert }; "[3;2~", { control = false; meta = false; shift = true; code = Delete }; "[5;2~", { control = false; meta = false; shift = true; code = Prev_page }; "[6;2~", { control = false; meta = false; shift = true; code = Next_page }; "[2;3~", { control = false; meta = true; shift = false; code = Insert }; "[3;3~", { control = false; meta = true; shift = false; code = Delete }; "[5;3~", { control = false; meta = true; shift = false; code = Prev_page }; "[6;3~", { control = false; meta = true; shift = false; code = Next_page }; "[2;4~", { control = false; meta = true; shift = true; code = Insert }; "[3;4~", { control = false; meta = true; shift = true; code = Delete }; "[5;4~", { control = false; meta = true; shift = true; code = Prev_page }; "[6;4~", { control = false; meta = true; shift = true; code = Next_page }; "[2;5~", { control = true; meta = false; shift = false; code = Insert }; "[3;5~", { control = true; meta = false; shift = false; code = Delete }; "[5;5~", { control = true; meta = false; shift = false; code = Prev_page }; "[6;5~", { control = true; meta = false; shift = false; code = Next_page }; "[2;6~", { control = true; meta = false; shift = true; code = Insert }; "[3;6~", { control = true; meta = false; shift = true; code = Delete }; "[5;6~", { control = true; meta = false; shift = true; code = Prev_page }; "[6;6~", { control = true; meta = false; shift = true; code = Next_page }; "[2;7~", { control = true; meta = true; shift = false; code = Insert }; "[3;7~", { control = true; meta = true; shift = false; code = Delete }; "[5;7~", { control = true; meta = true; shift = false; code = Prev_page }; "[6;7~", { control = true; meta = true; shift = false; code = Next_page }; "[2;8~", { control = true; meta = true; shift = true; code = Insert }; "[3;8~", { control = true; meta = true; shift = true; code = Delete }; "[5;8~", { control = true; meta = true; shift = true; code = Prev_page }; "[6;8~", { control = true; meta = true; shift = true; code = Next_page }; (* iTerm2 *) "[1;9A", { control = false; meta = true; shift = false; code = Up }; "[1;9B", { control = false; meta = true; shift = false; code = Down }; "[1;9C", { control = false; meta = true; shift = false; code = Right }; "[1;9D", { control = false; meta = true; shift = false; code = Left }; |] let () = Array.sort (fun (seq1, _) (seq2, _) -> String.compare seq1 seq2) sequences let find_sequence seq = let rec loop a b = if a = b then None else let c = (a + b) / 2 in let k, v = Array.unsafe_get sequences c in match String.compare seq k with | d when d < 0 -> loop a c | d when d > 0 -> loop (c + 1) b | _ -> Some v in loop 0 (Array.length sequences) let rec parse_event ?(escape_time = 0.1) encoding stream = Lwt_stream.next stream >>= fun byte -> match byte with | '\x1b' -> begin (* Escape sequences *) Lwt.catch (fun () -> (* Try to parse an escape seqsuence *) Lwt_stream.parse stream (parse_escape escape_time) >>= function | "[M" -> begin (* Mouse report *) let open LTerm_mouse in Lwt_stream.next stream >|= Char.code >>= fun mask -> Lwt_stream.next stream >|= Char.code >>= fun x -> Lwt_stream.next stream >|= Char.code >>= fun y -> try if mask = 0b00100011 then raise Exit; return (LTerm_event.Mouse { control = mask land 0b00010000 <> 0; meta = mask land 0b00001000 <> 0; shift = false; row = y - 33; col = x - 33; button = (match mask land 0b11000111 with | 0b00000000 -> Button1 | 0b00000001 -> Button2 | 0b00000010 -> Button3 | 0b01000000 -> Button4 | 0b01000001 -> Button5 | 0b01000010 -> Button6 | 0b01000011 -> Button7 | 0b01000100 -> Button8 | 0b01000101 -> Button9 | _ -> raise Exit); }) with Exit -> parse_event encoding stream end | seq -> match find_sequence seq with | Some key -> return (LTerm_event.Key key) | None -> return (LTerm_event.Sequence ("\x1b" ^ seq))) (function | Not_a_sequence -> begin (* If it is not, test if it is META+key. *) Lwt.pick [Lwt_stream.peek stream; Lwt_unix.sleep escape_time >>= fun () -> return None] >>= fun ch -> match ch with | None -> return (LTerm_event.Key { control = false; meta = false; shift = false; code = Escape }) | Some byte -> begin match byte with | '\x1b' -> begin (* Escape sequences *) Lwt.catch (fun () -> begin Lwt_stream.parse stream (fun stream -> Lwt_stream.junk stream >>= fun () -> Lwt.pick [Lwt_stream.peek stream; Lwt_unix.sleep escape_time >>= fun () -> return None] >>= fun ch -> match ch with | None -> Lwt.fail Not_a_sequence | Some _ -> parse_escape escape_time stream) end >>= fun seq -> match find_sequence seq with | Some key -> return (LTerm_event.Key { key with meta = true }) | None -> return (LTerm_event.Sequence ("\x1b\x1b" ^ seq))) (function | Not_a_sequence -> return (LTerm_event.Key { control = false; meta = false; shift = false; code = Escape }) | exn -> Lwt.fail exn) end | '\x00' .. '\x1b' -> (* Control characters *) Lwt_stream.junk stream >>= fun () -> let code = controls.(Char.code byte) in return (LTerm_event.Key { control = (match code with Char _ -> true | _ -> false); meta = true; shift = false; code }) | '\x7f' -> (* Backspace *) Lwt_stream.junk stream >>= fun () -> return (LTerm_event.Key { control = false; meta = true; shift = false; code = Backspace }) | '\x00' .. '\x7f' -> (* Other ascii characters *) Lwt_stream.junk stream >>= fun () -> return(LTerm_event.Key { control = false; meta = true; shift = false; code = Char(UChar.of_char byte) }) | byte' -> Lwt_stream.junk stream >>= fun () -> parse_char encoding stream byte' >>= fun code -> return (LTerm_event.Key { control = false; meta = true; shift = false; code = Char code }) end end | exn -> Lwt.fail exn) end | '\x00' .. '\x1f' -> (* Control characters *) let code = controls.(Char.code byte) in return (LTerm_event.Key { control = (match code with Char _ -> true | _ -> false); meta = false; shift = false; code }) | '\x7f' -> (* Backspace *) return (LTerm_event.Key { control = false; meta = false; shift = false; code = Backspace }) | '\x00' .. '\x7f' -> (* Other ascii characters *) return (LTerm_event.Key { control = false; meta = false; shift = false; code = Char(UChar.of_char byte) }) | _ -> (* Encoded characters *) parse_char encoding stream byte >>= fun code -> return (LTerm_event.Key { control = false; meta = false; shift = false; code = Char code }) lambda-term-1.9/src/lTerm_unix.mli000066400000000000000000000017161254222632000171730ustar00rootroot00000000000000(* * lTerm_unix.mli * -------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (** Unix specific functions *) open CamomileLibraryDyn.Camomile val sigwinch : int option (** The number of the signal used to indicate that the terminal size have changed. It is [None] on windows. *) val system_encoding : string (** The encoding used by the system. *) val parse_event : ?escape_time : float -> CharEncoding.t -> char Lwt_stream.t -> LTerm_event.t Lwt.t (** [parse_event encoding stream] parses one event from the given input stream. [encoding] is the character encoding used to decode non-ascii characters. It must be a converter from the stream encoding to "UCS-4BE". If an invalid sequence is encountered in the input, it fallbacks to Latin-1. [escape_time] is the time waited before returning the escape key. It defaults to [0.1]. *) lambda-term-1.9/src/lTerm_unix_stubs.c000066400000000000000000000024501254222632000200500ustar00rootroot00000000000000/* * lTerm_unix_stubs.c * ------------------ * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. */ #include "lTerm_config.h" #include #include #if defined(_WIN32) || defined(_WIN64) #include #include CAMLprim value lt_unix_get_sigwinch() { return Val_int(0); } CAMLprim value lt_unix_get_system_encoding() { return caml_copy_string(""); } #else #include #include #if defined(SYS_openbsd) # include #else # include #endif CAMLprim value lt_unix_get_sigwinch() { #ifdef SIGWINCH value result = caml_alloc_tuple(1); Field(result, 0) = Val_int(SIGWINCH); return result; #else return Val_int(0); #endif } CAMLprim value lt_unix_get_system_encoding() { /* Set the locale according to environment variables: */ const char *locale = setlocale(LC_CTYPE, ""); /* Get the codeset used by current locale: */ #if defined(SYS_openbsd) const char *codeset = locale_charset(); #else const char *codeset = nl_langinfo(CODESET); #endif /* Reset the locale: */ setlocale(LC_CTYPE, locale); /* If the encoding cannot be determined, just use ascii: */ return caml_copy_string(codeset ? codeset : "ASCII"); } #endif lambda-term-1.9/src/lTerm_widget.ml000066400000000000000000000112761254222632000173240ustar00rootroot00000000000000(* * lTerm_widget.ml * --------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) open CamomileLibraryDyn.Camomile open Lwt_react open LTerm_geom open LTerm_draw open LTerm_key open LTerm_style open LTerm_text open LTerm_widget_callbacks let return, (>>=) = Lwt.return, Lwt.(>>=) (* +-----------------------------------------------------------------+ | The widget class | +-----------------------------------------------------------------+ *) class t = LTerm_widget_base_impl.t (* +-----------------------------------------------------------------+ | Labels | +-----------------------------------------------------------------+ *) let newline = UChar.of_char '\n' let text_size str = let rec loop ofs rows cols max_cols = if ofs = String.length str then { rows; cols = max cols max_cols } else let chr, ofs = Zed_utf8.unsafe_extract_next str ofs in if chr = newline then if ofs = String.length str then { rows; cols = max cols max_cols } else loop ofs (rows + 1) 0 (max cols max_cols) else loop ofs rows (cols + 1) max_cols in loop 0 1 0 0 class label initial_text = object(self) inherit t "label" val mutable text = initial_text val mutable size_request = text_size initial_text method size_request = size_request val mutable style = LTerm_style.none method update_resources = style <- LTerm_resources.get_style self#resource_class self#resources method text = text method set_text t = text <- t; size_request <- text_size t; self#queue_draw method draw ctx focused = let { rows } = LTerm_draw.size ctx in let row = (rows - size_request.rows) / 2 in LTerm_draw.fill_style ctx style; LTerm_draw.draw_string_aligned ctx row H_align_center text end (* +-----------------------------------------------------------------+ | Boxes | +-----------------------------------------------------------------+ *) exception Out_of_range = LTerm_containers_impl.Out_of_range class type box = LTerm_containers_impl.box class hbox = LTerm_containers_impl.hbox class vbox = LTerm_containers_impl.vbox class frame = LTerm_containers_impl.frame class modal_frame = LTerm_containers_impl.modal_frame (* +-----------------------------------------------------------------+ | Lines | +-----------------------------------------------------------------+ *) class hline = object(self) inherit t "hline" val size_request = { rows = 1; cols = 0 } method size_request = size_request val mutable style = LTerm_style.none val mutable connection = LTerm_draw.Light method update_resources = let rc = self#resource_class and resources = self#resources in style <- LTerm_resources.get_style rc resources; connection <- LTerm_resources.get_connection (rc ^ ".connection") resources method draw ctx focused = let { rows } = LTerm_draw.size ctx in LTerm_draw.fill_style ctx style; draw_hline ctx (rows / 2) 0 (LTerm_draw.size ctx).cols connection end class vline = object(self) inherit t "vline" val size_request = { rows = 0; cols = 1 } method size_request = size_request val mutable style = LTerm_style.none val mutable connection = LTerm_draw.Light method update_resources = let rc = self#resource_class and resources = self#resources in style <- LTerm_resources.get_style rc resources; connection <- LTerm_resources.get_connection (rc ^ ".connection") resources method draw ctx focused = let { cols } = LTerm_draw.size ctx in LTerm_draw.fill_style ctx style; draw_vline ctx 0 (cols / 2) (LTerm_draw.size ctx).rows connection end (* +-----------------------------------------------------------------+ | Buttons | +-----------------------------------------------------------------+ *) class button = LTerm_buttons_impl.button class checkbutton = LTerm_buttons_impl.checkbutton class type ['a] radio = ['a] LTerm_buttons_impl.radio class ['a] radiogroup = ['a] LTerm_buttons_impl.radiogroup class ['a] radiobutton = ['a] LTerm_buttons_impl.radiobutton (* +-----------------------------------------------------------------+ | Running in a terminal | +-----------------------------------------------------------------+ *) let run = LTerm_running_impl.run let run_modal = LTerm_running_impl.run_modal let prepare_simple_run = LTerm_running_impl.prepare_simple_run lambda-term-1.9/src/lTerm_widget.mli000066400000000000000000000227761254222632000175040ustar00rootroot00000000000000(* * lTerm_widget.mli * ---------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (** Widgets for creating applications *) (** {6 Base class} *) (** The base class. The parameter is the initial resource class. The resource class is the first part of all resource keys used by the widget. For examples, buttons use the resources ["button.focused.foreground"], ["button.unfocused.bold"], ... so their resource class is ["button"]. *) class t : string -> object method children : t list (** The children of the widget. *) method parent : t option (** The parent of the widget, if any. *) method set_parent : t option -> unit (** Sets the parent of the widget. This also affect {!queue_draw}. *) method can_focus : bool (** Whether the widget can receive the focus or not. *) method queue_draw : unit (** Enqueue a redraw operation. If the widget has a parent, this is the same as calling the {!queue_draw} method of the parent, otherwise this does nothing. *) method set_queue_draw : (unit -> unit) -> unit (** [set_queue_draw f] sets the function called when the {!queue_draw} method is invoked, for this widget and all its children. *) method draw : LTerm_draw.context -> t -> unit (** [draw ctx focused] draws the widget on the given context. [focused] is the focused widget. *) method cursor_position : LTerm_geom.coord option (** Method invoked when the widget has the focus, it returns the position of the cursor inside the widget if it should be displayed. *) method allocation : LTerm_geom.rect (** The zone occuped by the widget. *) method set_allocation : LTerm_geom.rect -> unit (** Sets the zone occuped by the widget. *) method send_event : LTerm_event.t -> unit (** Send an event to the widget. If the widget cannot process the event, it is sent to the parent and so on. *) method on_event : ?switch : LTerm_widget_callbacks.switch -> (LTerm_event.t -> bool) -> unit (** [on_event ?switch f] calls [f] each time an event is received. If [f] returns [true], the event is not passed to other callbacks. *) method size_request : LTerm_geom.size (** The size wanted by the widget. *) method resources : LTerm_resources.t (** The set of resources used by the widget. *) method set_resources : LTerm_resources.t -> unit (** Sets the resources of the widget and of all its children. *) method resource_class : string (** The resource class of the widget. *) method set_resource_class : string -> unit (** Sets the resource class of the widget. This can be used to set an alternative style for the widget. *) method update_resources : unit (** Method invoked when the resources or the resource class of the widget change. The default function does nothing. *) end (** {6 Labels} *) (** A widget displaying a text. *) class label : string -> object inherit t method text : string (** The text of the label. *) method set_text : string -> unit end (** {6 Containers} *) exception Out_of_range (** Type of widgets displaying a list of widget. *) class type box = object inherit t method add : ?position : int -> ?expand : bool -> #t -> unit (** [add ?position ?expand widget] adds a widget to the box. If [expand] is [true] (the default) then [widget] will occupy as much space as possible. If [position] is not specified then the widget is appended to the end of the widget list. It raises {!Out_of_range} if the given position is negative or exceed the number of widgets. *) method remove : #t -> unit (** [remove widget] remove a widget from the box. *) end (** A widget displaying a list of widgets, listed horizontally. *) class hbox : box (** A widget displaying a list of widgets, listed vertically. *) class vbox : box (** A widget displayiing another widget in a box. *) class frame : object inherit t method set : #t -> unit (** Set the widget that is inside the frame. *) method empty : unit (** Remove the child of the frame. *) end (** A widget displaying a frame around child widget. Unlike {!frame}, the child widget is not expanded to take all available space; instead the child is centered and frame is drawn around it. This is a utility class for creation of modal dialogs and similar widgets. *) class modal_frame : object inherit frame end (** {6 Lines} *) (** A horizontal line. *) class hline : t (** A vertical line. *) class vline : t (** {6 Buttons} *) (** Normal button. *) class button : string -> object inherit t method label : string (** The text displayed on the button. *) method set_label : string -> unit method on_click : ?switch : LTerm_widget_callbacks.switch -> (unit -> unit) -> unit (** [on_click ?switch f] calls [f] when the button is clicked. *) end (** Checkbutton. A button that can be in active or inactive state. *) class checkbutton : string -> bool -> object inherit t method label : string (** The text displayed on the checkbutton. *) method state : bool (** The state of checkbutton; [true] means checked and [false] means unchecked. *) method set_label : string -> unit method on_click : ?switch : LTerm_widget_callbacks.switch -> (unit -> unit) -> unit (** [on_click ?switch f] calls [f] when the button state is changed. *) end class type ['a] radio = object method on : unit method off : unit method id : 'a end (** Radio group. Radio group governs the set of {!radio} objects. At each given moment of time only one of the objects in the "on" state and the rest are in the "off" state. *) class ['a] radiogroup : object method on_state_change : ?switch : LTerm_widget_callbacks.switch -> ('a option -> unit) -> unit (** [on_state_change ?switch f] calls [f] when the state of the group is changed. *) method state : 'a option (** The state of the group. Contains [Some id] with the id of "on" object in the group or None if no objects were added to the group yet. *) method register_object : 'a radio -> unit (** Adds radio object to the group *) method switch_to : 'a -> unit (** [switch_to id] switches radio group to the state [Some id], calls {!radio.on} method of the object with the given id and {!radio.off} method of all other objects added to the group. *) end (** Radiobutton. The button which implements {!radio} object contract, so can be added to {!radiogroup}. *) class ['a] radiobutton : 'a radiogroup -> string -> 'a -> object inherit t method state : bool (** The state of the button; [true] if button is "on" and [false] if the button is "off". *) method on : unit (** Switches the button state to "on". Affects only how the button is drawn, does not change the state of the group the button is added to. Use {!radiogroup.switch_to} instead. *) method off : unit (** Switches the button state to "off". Affects only how the button is drawn, does not change the state of the group the button is added to. Use {!radiogroup.switch_to} instead. *) method label : string (** The text displayed on the radiobutton. *) method set_label : string -> unit method id : 'a (** The id of the button. *) method on_click : ?switch:LTerm_widget_callbacks.switch -> (unit -> unit) -> unit (** [on_click ?switch f] calls [f] when the button is clicked. You probably want to use {!radiogroup.on_state_change} instead. *) end (** {6 Running in a terminal} *) val run : LTerm.t -> ?save_state : bool -> ?load_resources : bool -> ?resources_file : string -> #t -> 'a Lwt.t -> 'a Lwt.t (** [run term ?save_state widget w] runs on the given terminal using [widget] as main widget. It returns when [w] terminates. If [save_state] is [true] (the default) then the state of the terminal is saved and restored when [w] terminates. If [load_resources] is [true] (the default) then [resources_file] (which default to ".lambda-termrc" in the home directory) is loaded and the result is set to [w]. *) val run_modal : LTerm.t -> ?save_state : bool -> ?load_resources : bool -> ?resources_file : string -> t Lwt_react.event -> unit Lwt_react.event -> #t -> 'a Lwt.t -> 'a Lwt.t (** This function works in the same way as {!run} but also takes two {!Lwt_react.event} parameters. The first one should contain {!LTerm_widget.t} widget and makes it new topmost layer in UI. The second message removes the topmost level from UI. All layers are redrawn, from bottom to up, but only the topmost layer gets keyboard events delivered to it. This allows to implement things like modal dialogs. *) val prepare_simple_run : unit -> (#t -> 'a Lwt.t) * (#t -> unit -> unit) * (?step:React.step -> unit -> unit) * ('a -> unit) (** [prepare_simple_run ()] returns a tuple [(do_run, push_layer, pop_layer, exit)] -- functions useful for creating simple UI. [do_run w] where w is a widget runs the given widget in a terminal over stdout, loading resources from [.lambda-termrc], saving state and restoring it on exit from ui. Example: [do_run my_frame] [push_layer w] where w is a widget is a callback to add w as a new modal layer to UI. Example: [button#on_click (push_layer my_modal_dialog)]. [pop_layer] is a callback to destroy the topmost modal layer. Example: [cancel_button#on_click pop_layer]. [exit] is a callback to exit the UI. Example: [exit_button#on_click exit] *) lambda-term-1.9/src/lTerm_widget_callbacks.ml000066400000000000000000000027761254222632000213300ustar00rootroot00000000000000(* * lTerm_widget_callbacks.ml * --------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) let section = Lwt_log.Section.make "lambda-term(widget_callbacks)" (* +-----------------------------------------------------------------+ | Callbacks | +-----------------------------------------------------------------+ *) type switch = { mutable switch_state : (unit -> unit) list option } let register switch_opt seq f = match switch_opt with | None -> ignore (Lwt_sequence.add_l f seq) | Some switch -> match switch.switch_state with | Some l -> let node = Lwt_sequence.add_l f seq in switch.switch_state <- Some ((fun () -> Lwt_sequence.remove node) :: l) | None -> () let stop switch = match switch.switch_state with | Some l -> switch.switch_state <- None; List.iter (fun f -> f ()) l | None -> () let exec_callbacks seq x = Lwt_sequence.iter_l (fun f -> try f x with exn -> ignore (Lwt_log.error ~section ~exn "callback failed with")) seq let exec_filters seq x = Lwt_sequence.fold_l (fun f acc -> if acc then true else begin try f x with exn -> ignore (Lwt_log.error ~section ~exn "filter failed with"); false end) seq false lambda-term-1.9/src/lTerm_widget_callbacks.mli000066400000000000000000000010011254222632000214550ustar00rootroot00000000000000(* * lTerm_widget_callbacks.mli * ---------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) type switch (** Switches are used to stop signals. *) val register : switch option -> 'a Lwt_sequence.t -> 'a -> unit (** *) val stop : switch -> unit (** *) val exec_callbacks : ('a -> unit) Lwt_sequence.t -> 'a -> unit (** [apply_callbacks callbacks x] *) val exec_filters : ('a -> bool) Lwt_sequence.t -> 'a -> bool lambda-term-1.9/src/lTerm_windows.ml000066400000000000000000000123661254222632000175340ustar00rootroot00000000000000(* * lTerm_windows.ml * ---------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) open CamomileLibraryDyn.Camomile let return, (>>=), (>|=) = Lwt.return, Lwt.(>>=), Lwt.(>|=) external get_acp : unit -> int = "lt_windows_get_acp" external get_console_cp : unit -> int = "lt_windows_get_console_cp" external set_console_cp : int -> unit = "lt_windows_set_console_cp" external get_console_output_cp : unit -> int = "lt_windows_get_console_output_cp" external set_console_output_cp : int -> unit = "lt_windows_set_console_output_cp" type input = | Resize | Key of LTerm_key.t | Mouse of LTerm_mouse.t external read_console_input_job : Unix.file_descr -> [ `read_console_input ] Lwt_unix.job = "lt_windows_read_console_input_job" external read_console_input_result : [ `read_console_input ] Lwt_unix.job -> input = "lt_windows_read_console_input_result" external read_console_input_free : [ `read_console_input ] Lwt_unix.job -> unit = "lt_windows_read_console_input_free" let controls = [| UChar.of_char ' '; UChar.of_char 'a'; UChar.of_char 'b'; UChar.of_char 'c'; UChar.of_char 'd'; UChar.of_char 'e'; UChar.of_char 'f'; UChar.of_char 'g'; UChar.of_char 'h'; UChar.of_char 'i'; UChar.of_char 'j'; UChar.of_char 'k'; UChar.of_char 'l'; UChar.of_char 'm'; UChar.of_char 'n'; UChar.of_char 'o'; UChar.of_char 'p'; UChar.of_char 'q'; UChar.of_char 'r'; UChar.of_char 's'; UChar.of_char 't'; UChar.of_char 'u'; UChar.of_char 'v'; UChar.of_char 'w'; UChar.of_char 'x'; UChar.of_char 'y'; UChar.of_char 'z'; UChar.of_char '['; UChar.of_char '\\'; UChar.of_char ']'; UChar.of_char '^'; UChar.of_char '_'; |] let read_console_input fd = Lwt_unix.check_descriptor fd; Lwt_unix.execute_job (read_console_input_job (Lwt_unix.unix_file_descr fd)) read_console_input_result read_console_input_free >|= function | Key({ LTerm_key.code = LTerm_key.Char ch } as key) when UChar.code ch < 32 -> Key { key with LTerm_key.code = LTerm_key.Char controls.(UChar.code ch) } | input -> input type text_attributes = { foreground : int; background : int; } type console_screen_buffer_info = { size : LTerm_geom.size; cursor_position : LTerm_geom.coord; attributes : text_attributes; window : LTerm_geom.rect; maximum_window_size : LTerm_geom.size; } external get_console_screen_buffer_info : Unix.file_descr -> console_screen_buffer_info = "lt_windows_get_console_screen_buffer_info" let get_console_screen_buffer_info fd = Lwt_unix.check_descriptor fd; get_console_screen_buffer_info (Lwt_unix.unix_file_descr fd) type console_mode = { cm_echo_input : bool; cm_insert_mode : bool; cm_line_input : bool; cm_mouse_input : bool; cm_processed_input : bool; cm_quick_edit_mode : bool; cm_window_input : bool; } external get_console_mode : Unix.file_descr -> console_mode = "lt_windows_get_console_mode" external set_console_mode : Unix.file_descr -> console_mode -> unit = "lt_windows_set_console_mode" let get_console_mode fd = Lwt_unix.check_descriptor fd; get_console_mode (Lwt_unix.unix_file_descr fd) let set_console_mode fd mode = Lwt_unix.check_descriptor fd; set_console_mode (Lwt_unix.unix_file_descr fd) mode external get_console_cursor_info : Unix.file_descr -> int * bool = "lt_windows_get_console_cursor_info" external set_console_cursor_info : Unix.file_descr -> int -> bool -> unit = "lt_windows_set_console_cursor_info" let get_console_cursor_info fd = Lwt_unix.check_descriptor fd; get_console_cursor_info (Lwt_unix.unix_file_descr fd) let set_console_cursor_info fd size visible = Lwt_unix.check_descriptor fd; set_console_cursor_info (Lwt_unix.unix_file_descr fd) size visible external set_console_cursor_position : Unix.file_descr -> LTerm_geom.coord -> unit = "lt_windows_set_console_cursor_position" let set_console_cursor_position fd coord = Lwt_unix.check_descriptor fd; set_console_cursor_position (Lwt_unix.unix_file_descr fd) coord external set_console_text_attribute : Unix.file_descr -> text_attributes -> unit = "lt_windows_set_console_text_attribute" let set_console_text_attribute fd attrs = Lwt_unix.check_descriptor fd; set_console_text_attribute (Lwt_unix.unix_file_descr fd) attrs type char_info = { ci_char : UChar.t; ci_foreground : int; ci_background : int; } external write_console_output : Unix.file_descr -> char_info array array -> LTerm_geom.size -> LTerm_geom.coord -> LTerm_geom.rect -> LTerm_geom.rect = "lt_windows_write_console_output" let write_console_output fd chars size coord rect = Lwt_unix.check_descriptor fd; if Array.length chars <> size.LTerm_geom.rows then invalid_arg "LTerm_windows.write_console_output"; Array.iter (fun line -> if Array.length line <> size.LTerm_geom.cols then invalid_arg "LTerm_windows.write_console_output") chars; write_console_output (Lwt_unix.unix_file_descr fd) chars size coord rect external fill_console_output_character : Unix.file_descr -> UChar.t -> int -> LTerm_geom.coord -> int = "lt_windows_fill_console_output_character" let fill_console_output_character fd char count coord = Lwt_unix.check_descriptor fd; fill_console_output_character (Lwt_unix.unix_file_descr fd) char count coord lambda-term-1.9/src/lTerm_windows.mli000066400000000000000000000100321254222632000176710ustar00rootroot00000000000000(* * lTerm_windows.mli * ----------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (** Windows specific functions *) (** All these functions return [Lwt_sys.Not_available] on Unix. *) open CamomileLibrary (** {6 Codepage functions} *) val get_acp : unit -> int (** Returns the current ANSI codepage. *) val get_console_cp : unit -> int (** Returns the input codepage used by the console attached to the current process. *) val set_console_cp : int -> unit (** Sets the input codepage used by the console attached to the current process. *) val get_console_output_cp : unit -> int (** Returns the output codepage used by the console attached to the current process. *) val set_console_output_cp : int -> unit (** Sets the output codepage used by the console attached to the current process. *) (** {6 Console input} *) type input = | Resize | Key of LTerm_key.t | Mouse of LTerm_mouse.t val read_console_input : Lwt_unix.file_descr -> input Lwt.t (** [read_console_input fd] reads one input from the given file descriptor. *) (** {6 Console info} *) (** Type of text attributes. *) type text_attributes = { foreground : int; (** The foreground color. Only bits 0 to 3 matters, other are ignored. *) background : int; (** The background color. Only bits 0 to 3 matters, other are ignored. *) } (** Type of informations about a console. *) type console_screen_buffer_info = { size : LTerm_geom.size; (** The size of the console buffer. *) cursor_position : LTerm_geom.coord; (** The line and column of the cursor. *) attributes : text_attributes; (** Text attributes. *) window : LTerm_geom.rect; (** The displayed windows in the console buffer. *) maximum_window_size : LTerm_geom.size; (** The maximum window size for the current screen. *) } val get_console_screen_buffer_info : Lwt_unix.file_descr -> console_screen_buffer_info (** [get_console_screen_buffer_info fd] returns the current informations about the given console. *) (** {6 Console modes} *) (** Console modes. *) type console_mode = { cm_echo_input : bool; cm_insert_mode : bool; cm_line_input : bool; cm_mouse_input : bool; cm_processed_input : bool; cm_quick_edit_mode : bool; cm_window_input : bool; } val get_console_mode : Lwt_unix.file_descr -> console_mode (** Returns the mode of the given console. *) val set_console_mode : Lwt_unix.file_descr -> console_mode -> unit (** Sets the mode of the given console. *) (** {6 Console cursor} *) val get_console_cursor_info : Lwt_unix.file_descr -> int * bool (** Returns the size and visible status of the cursor on the given console. The size is a percentage between 1 and 100. *) val set_console_cursor_info : Lwt_unix.file_descr -> int -> bool -> unit (** [set_console_cursor_info fd size visible] sets the size and visible status of the cursor on the given console. *) val set_console_cursor_position : Lwt_unix.file_descr -> LTerm_geom.coord -> unit (** Move the cursor to the specified location in the screen buffer. *) (** {6 Text attributes} *) val set_console_text_attribute : Lwt_unix.file_descr -> text_attributes -> unit (** [set_console_text_attribute fd attributes] *) (** {6 Rendering} *) type char_info = { ci_char : UChar.t; (** The unicode character. *) ci_foreground : int; (** The foreground color. *) ci_background : int; (** The background color. *) } val write_console_output : Lwt_unix.file_descr -> char_info array array -> LTerm_geom.size -> LTerm_geom.coord -> LTerm_geom.rect -> LTerm_geom.rect (** [write_console_output fd chars size coord rect] writes the given matrix of characters with their attributes on the given console at given position. *) val fill_console_output_character : Lwt_unix.file_descr -> UChar.t -> int -> LTerm_geom.coord -> int (** [fill_console_output_character fd char count coord] writes [count] times [char] starting at [coord] on the given console. *) lambda-term-1.9/src/lTerm_windows_stubs.c000066400000000000000000000366151254222632000205710ustar00rootroot00000000000000/* * lTerm_windows_stubs.c * --------------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. */ /* Windows specific stubs */ #include #include #include #include #if defined(_WIN32) || defined(_WIN64) #include #include /* +-----------------------------------------------------------------+ | Codepage functions | +-----------------------------------------------------------------+ */ CAMLprim value lt_windows_get_acp() { return Val_int(GetACP()); } CAMLprim value lt_windows_get_console_cp() { return Val_int(GetConsoleCP()); } CAMLprim value lt_windows_set_console_cp(value cp) { if (!SetConsoleCP(Int_val(cp))) { win32_maperr(GetLastError()); uerror("SetConsoleCP", Nothing); } return Val_unit; } CAMLprim value lt_windows_get_console_output_cp() { return Val_int(GetConsoleOutputCP()); } CAMLprim value lt_windows_set_console_output_cp(value cp) { if (!SetConsoleOutputCP(Int_val(cp))) { win32_maperr(GetLastError()); uerror("SetConsoleOutputCP", Nothing); } return Val_unit; } /* +-----------------------------------------------------------------+ | Console input | +-----------------------------------------------------------------+ */ static WORD code_table[] = { VK_RETURN, VK_ESCAPE, VK_TAB, VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT, VK_F1, VK_F2, VK_F3, VK_F4, VK_F5, VK_F6, VK_F7, VK_F8, VK_F9, VK_F10, VK_F11, VK_F12, VK_NEXT, VK_PRIOR, VK_HOME, VK_END, VK_INSERT, VK_DELETE, VK_BACK }; struct job_read_console_input { struct lwt_unix_job job; HANDLE handle; INPUT_RECORD input; DWORD error_code; }; #define Job_read_console_input_val(v) *(struct job_read_console_input**)Data_custom_val(v) static void worker_read_console_input(struct job_read_console_input *job) { DWORD event_count; INPUT_RECORD *input = &(job->input); WORD code; int i; DWORD bs; for (;;) { if (!ReadConsoleInputW(job->handle, input, 1, &event_count)) { job->error_code = GetLastError(); return; } switch (input->EventType) { case KEY_EVENT: if (input->Event.KeyEvent.bKeyDown) { if (input->Event.KeyEvent.uChar.UnicodeChar) return; code = input->Event.KeyEvent.wVirtualKeyCode; for (i = 0; i < sizeof(code_table)/sizeof(code_table[0]); i++) if (code == code_table[i]) return; } break; case MOUSE_EVENT: { bs = input->Event.MouseEvent.dwButtonState; if (!(input->Event.MouseEvent.dwEventFlags & MOUSE_MOVED) && bs & (FROM_LEFT_1ST_BUTTON_PRESSED | FROM_LEFT_2ND_BUTTON_PRESSED | FROM_LEFT_3RD_BUTTON_PRESSED | FROM_LEFT_4TH_BUTTON_PRESSED | RIGHTMOST_BUTTON_PRESSED)) return; break; } case WINDOW_BUFFER_SIZE_EVENT: return; } } } CAMLprim value lt_windows_read_console_input_job(value val_fd) { struct job_read_console_input *job = lwt_unix_new(struct job_read_console_input); job->job.worker = (lwt_unix_job_worker)worker_read_console_input; job->handle = Handle_val(val_fd); job->error_code = 0; return lwt_unix_alloc_job(&(job->job)); } CAMLprim value lt_windows_read_console_input_result(value val_job) { INPUT_RECORD *input; DWORD cks, bs; WORD code; int i; CAMLparam1(val_job); CAMLlocal3(result, x, y); struct job_read_console_input *job = Job_read_console_input_val(val_job); if (job->error_code) { win32_maperr(job->error_code); uerror("ReadConsoleInput", Nothing); } input = &(job->input); switch (input->EventType) { case KEY_EVENT: { result = caml_alloc(1, 0); x = caml_alloc_tuple(4); Field(result, 0) = x; cks = input->Event.KeyEvent.dwControlKeyState; Field(x, 0) = Val_bool((cks & LEFT_CTRL_PRESSED) | (cks & RIGHT_CTRL_PRESSED)); Field(x, 1) = Val_bool((cks & LEFT_ALT_PRESSED) | (cks & RIGHT_ALT_PRESSED)); Field(x, 2) = Val_bool(cks & SHIFT_PRESSED); code = input->Event.KeyEvent.wVirtualKeyCode; for (i = 0; i < sizeof(code_table)/sizeof(code_table[0]); i++) if (code == code_table[i]) { Field(x, 3) = Val_int(i); CAMLreturn(result); } y = caml_alloc_tuple(1); Field(y, 0) = Val_int(input->Event.KeyEvent.uChar.UnicodeChar); Field(x, 3) = y; CAMLreturn(result); } case MOUSE_EVENT: { result = caml_alloc(1, 1); x = caml_alloc_tuple(6); Field(result, 0) = x; cks = input->Event.MouseEvent.dwControlKeyState; Field(x, 0) = Val_bool((cks & LEFT_CTRL_PRESSED) | (cks & RIGHT_CTRL_PRESSED)); Field(x, 1) = Val_bool((cks & LEFT_ALT_PRESSED) | (cks & RIGHT_ALT_PRESSED)); Field(x, 2) = Val_bool(cks & SHIFT_PRESSED); Field(x, 4) = Val_int(input->Event.MouseEvent.dwMousePosition.Y); Field(x, 5) = Val_int(input->Event.MouseEvent.dwMousePosition.X); bs = input->Event.MouseEvent.dwButtonState; if (bs & FROM_LEFT_1ST_BUTTON_PRESSED) Field(x, 3) = Val_int(0); else if (bs & FROM_LEFT_2ND_BUTTON_PRESSED) Field(x, 3) = Val_int(1); else if (bs & FROM_LEFT_3RD_BUTTON_PRESSED) Field(x, 3) = Val_int(2); else if (bs & FROM_LEFT_4TH_BUTTON_PRESSED) Field(x, 3) = Val_int(3); else Field(x, 3) = Val_int(4); CAMLreturn(result); } case WINDOW_BUFFER_SIZE_EVENT: CAMLreturn(Val_int(0)); } CAMLreturn(Val_int(0)); } CAMLprim value lt_windows_read_console_input_free(value val_job) { lwt_unix_free_job(&(Job_read_console_input_val(val_job))->job); return Val_unit; } /* +-----------------------------------------------------------------+ | Console informations | +-----------------------------------------------------------------+ */ CAMLprim value lt_windows_get_console_screen_buffer_info(value val_fd) { CAMLparam1(val_fd); CAMLlocal2(result, x); CONSOLE_SCREEN_BUFFER_INFO info; int color; if (!GetConsoleScreenBufferInfo(Handle_val(val_fd), &info)) { win32_maperr(GetLastError()); uerror("GetConsoleScreenBufferInfo", Nothing); } result = caml_alloc_tuple(5); x = caml_alloc_tuple(2); Field(x, 0) = Val_int(info.dwSize.Y); Field(x, 1) = Val_int(info.dwSize.X); Field(result, 0) = x; x = caml_alloc_tuple(2); Field(x, 0) = Val_int(info.dwCursorPosition.Y); Field(x, 1) = Val_int(info.dwCursorPosition.X); Field(result, 1) = x; x = caml_alloc_tuple(2); color = 0; if (info.wAttributes & FOREGROUND_RED) color |= 1; if (info.wAttributes & FOREGROUND_GREEN) color |= 2; if (info.wAttributes & FOREGROUND_BLUE) color |= 4; if (info.wAttributes & FOREGROUND_INTENSITY) color |= 8; Field(x, 0) = Val_int(color); color = 0; if (info.wAttributes & BACKGROUND_RED) color |= 1; if (info.wAttributes & BACKGROUND_GREEN) color |= 2; if (info.wAttributes & BACKGROUND_BLUE) color |= 4; if (info.wAttributes & BACKGROUND_INTENSITY) color |= 8; Field(x, 1) = Val_int(color); Field(result, 2) = x; x = caml_alloc_tuple(4); Field(x, 0) = Val_int(info.srWindow.Top); Field(x, 1) = Val_int(info.srWindow.Left); Field(x, 2) = Val_int(info.srWindow.Bottom + 1); Field(x, 3) = Val_int(info.srWindow.Right + 1); Field(result, 3) = x; x = caml_alloc_tuple(2); Field(x, 0) = Val_int(info.dwMaximumWindowSize.Y); Field(x, 1) = Val_int(info.dwMaximumWindowSize.X); Field(result, 4) = x; CAMLreturn(result); } /* +-----------------------------------------------------------------+ | Console mode | +-----------------------------------------------------------------+ */ CAMLprim value lt_windows_get_console_mode(value val_fd) { DWORD mode; value result; if (!GetConsoleMode(Handle_val(val_fd), &mode)) { win32_maperr(GetLastError()); uerror("GetConsoleMode", Nothing); } result = caml_alloc_tuple(7); Field(result, 0) = Val_bool(mode & ENABLE_ECHO_INPUT); Field(result, 1) = Val_bool(mode & ENABLE_INSERT_MODE); Field(result, 2) = Val_bool(mode & ENABLE_LINE_INPUT); Field(result, 3) = Val_bool(mode & ENABLE_MOUSE_INPUT); Field(result, 4) = Val_bool(mode & ENABLE_PROCESSED_INPUT); Field(result, 5) = Val_bool(mode & ENABLE_QUICK_EDIT_MODE); Field(result, 6) = Val_bool(mode & ENABLE_WINDOW_INPUT); return result; } CAMLprim value lt_windows_set_console_mode(value val_fd, value val_mode) { DWORD mode = 0; if (Bool_val(Field(val_mode, 0))) mode |= ENABLE_ECHO_INPUT; if (Bool_val(Field(val_mode, 1))) mode |= ENABLE_INSERT_MODE; if (Bool_val(Field(val_mode, 2))) mode |= ENABLE_LINE_INPUT; if (Bool_val(Field(val_mode, 3))) mode |= ENABLE_MOUSE_INPUT; if (Bool_val(Field(val_mode, 4))) mode |= ENABLE_PROCESSED_INPUT; if (Bool_val(Field(val_mode, 5))) mode |= ENABLE_QUICK_EDIT_MODE; if (Bool_val(Field(val_mode, 6))) mode |= ENABLE_WINDOW_INPUT; if (!SetConsoleMode(Handle_val(val_fd), mode)) { win32_maperr(GetLastError()); uerror("SetConsoleMode", Nothing); } return Val_unit; } /* +-----------------------------------------------------------------+ | Cursor | +-----------------------------------------------------------------+ */ CAMLprim value lt_windows_get_console_cursor_info(value val_fd) { CONSOLE_CURSOR_INFO info; value result; if (!GetConsoleCursorInfo(Handle_val(val_fd), &info)) { win32_maperr(GetLastError()); uerror("GetConsoleCursorInfo", Nothing); } result = caml_alloc_tuple(2); Field(result, 0) = Val_int(info.dwSize); Field(result, 1) = Val_bool(info.bVisible); return result; } CAMLprim value lt_windows_set_console_cursor_info(value val_fd, value val_size, value val_visible) { CONSOLE_CURSOR_INFO info; info.dwSize = Int_val(val_size); info.bVisible = Bool_val(val_visible); if (!SetConsoleCursorInfo(Handle_val(val_fd), &info)) { win32_maperr(GetLastError()); uerror("SetConsoleCursorInfo", Nothing); } return Val_unit; } CAMLprim value lt_windows_set_console_cursor_position(value val_fd, value val_coord) { COORD coord; coord.X = Int_val(Field(val_coord, 1)); coord.Y = Int_val(Field(val_coord, 0)); if (!SetConsoleCursorPosition(Handle_val(val_fd), coord)) { win32_maperr(GetLastError()); uerror("SetConsoleCursorPosition", Nothing); } return Val_unit; } /* +-----------------------------------------------------------------+ | Text attributes | +-----------------------------------------------------------------+ */ CAMLprim value lt_windows_set_console_text_attribute(value val_fd, value val_attrs) { int fg = Int_val(Field(val_attrs, 0)); int bg = Int_val(Field(val_attrs, 1)); WORD attrs = 0; if (fg & 1) attrs |= FOREGROUND_RED; if (fg & 2) attrs |= FOREGROUND_GREEN; if (fg & 4) attrs |= FOREGROUND_BLUE; if (fg & 8) attrs |= FOREGROUND_INTENSITY; if (bg & 1) attrs |= BACKGROUND_RED; if (bg & 2) attrs |= BACKGROUND_GREEN; if (bg & 4) attrs |= BACKGROUND_BLUE; if (bg & 8) attrs |= BACKGROUND_INTENSITY; if (!SetConsoleTextAttribute(Handle_val(val_fd), attrs)) { win32_maperr(GetLastError()); uerror("SetConsoleTextAttribute", Nothing); } return Val_unit; } /* +-----------------------------------------------------------------+ | Rendering | +-----------------------------------------------------------------+ */ CAMLprim value lt_windows_write_console_output(value val_fd, value val_chars, value val_size, value val_coord, value val_rect) { CAMLparam5(val_fd, val_chars, val_size, val_coord, val_rect); CAMLlocal1(result); value line, src; int fg, bg; WORD attrs; int lines = Int_val(Field(val_size, 0)); int columns = Int_val(Field(val_size, 1)); COORD size; COORD coord; SMALL_RECT rect; /* Convert characters */ CHAR_INFO *buffer = (CHAR_INFO*)lwt_unix_malloc(lines * columns * sizeof (CHAR_INFO)); int l, c; CHAR_INFO *dst = buffer; for (l = 0; l < lines; l++) { line = Field(val_chars, l); for (c = 0; c < columns; c++) { src = Field(line, c); dst->Char.UnicodeChar = Int_val(Field(src, 0)); fg = Int_val(Field(src, 1)); bg = Int_val(Field(src, 2)); attrs = 0; if (fg & 1) attrs |= FOREGROUND_RED; if (fg & 2) attrs |= FOREGROUND_GREEN; if (fg & 4) attrs |= FOREGROUND_BLUE; if (fg & 8) attrs |= FOREGROUND_INTENSITY; if (bg & 1) attrs |= BACKGROUND_RED; if (bg & 2) attrs |= BACKGROUND_GREEN; if (bg & 4) attrs |= BACKGROUND_BLUE; if (bg & 8) attrs |= BACKGROUND_INTENSITY; dst->Attributes = attrs; dst++; } } size.X = Int_val(Field(val_size, 1)); size.Y = Int_val(Field(val_size, 0)); coord.X = Int_val(Field(val_coord, 1)); coord.Y = Int_val(Field(val_coord, 0)); rect.Top = Int_val(Field(val_rect, 0)); rect.Left = Int_val(Field(val_rect, 1)); rect.Bottom = Int_val(Field(val_rect, 2)) - 1; rect.Right = Int_val(Field(val_rect, 3)) - 1; if (!WriteConsoleOutputW(Handle_val(val_fd), buffer, size, coord, &rect)) { free(buffer); win32_maperr(GetLastError()); uerror("WriteConsoleOutput", Nothing); } free(buffer); result = caml_alloc_tuple(4); Field(result, 0) = Val_int(rect.Top); Field(result, 1) = Val_int(rect.Left); Field(result, 2) = Val_int(rect.Bottom + 1); Field(result, 3) = Val_int(rect.Right + 1); CAMLreturn(result); } /* +-----------------------------------------------------------------+ | Filling | +-----------------------------------------------------------------+ */ CAMLprim value lt_windows_fill_console_output_character(value val_fd, value val_char, value val_count, value val_coord) { COORD coord; DWORD written; coord.X = Int_val(Field(val_coord, 1)); coord.Y = Int_val(Field(val_coord, 0)); if (!FillConsoleOutputCharacter(Handle_val(val_fd), Int_val(val_char), Int_val(val_count), coord, &written)) { win32_maperr(GetLastError()); uerror("FillConsoleOutputCharacter", Nothing); } return Val_int(written); } #else /* +-----------------------------------------------------------------+ | For unix | +-----------------------------------------------------------------+ */ #include #define NA(name, feature) \ CAMLprim value lt_windows_##name() \ { \ lwt_unix_not_available(feature); \ return Val_unit; \ } NA(get_acp, "GetACP") NA(get_console_cp, "GetConsoleCP") NA(set_console_cp, "SetConsoleCP") NA(get_console_output_cp, "GetConsoleOutputCP") NA(set_console_output_cp, "SetConsoleOutputCP") NA(read_console_input_job, "ReadConsoleInput") NA(read_console_input_result, "ReadConsoleInput") NA(read_console_input_free, "ReadConsoleInput") NA(set_console_text_attribute, "SetConsoleTextAttribute") NA(get_console_screen_buffer_info, "GetConsoleScreenBufferInfo") NA(get_console_cursor_info, "GetConsoleCursorInfo") NA(set_console_cursor_info, "SetConsoleCursorInfo") NA(write_console_output, "WriteConsoleOutput") NA(set_console_cursor_position, "SetConsoleCursorPosition") NA(get_console_mode, "GetConsoleMode") NA(set_console_mode, "SetConsoleMode") NA(fill_console_output_character, "FillConsoleOutputCharacter") #endif lambda-term-1.9/src/lambda-term.mldylib000066400000000000000000000010031254222632000200720ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 5d936aaba2dfc572b8b204c655535e07) LTerm LTerm_key LTerm_event LTerm_unix LTerm_windows LTerm_style LTerm_geom LTerm_draw LTerm_mouse LTerm_widget LTerm_widget_callbacks LTerm_edit LTerm_read_line LTerm_text LTerm_ui LTerm_resources LTerm_inputrc LTerm_history LTerm_color_mappings LTerm_resource_lexer widget_impl/LTerm_widget_base_impl widget_impl/LTerm_buttons_impl widget_impl/LTerm_containers_impl widget_impl/LTerm_running_impl widget_impl/LTerm_toplevel_impl # OASIS_STOP lambda-term-1.9/src/lambda-term.mllib000066400000000000000000000010031254222632000175350ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 5d936aaba2dfc572b8b204c655535e07) LTerm LTerm_key LTerm_event LTerm_unix LTerm_windows LTerm_style LTerm_geom LTerm_draw LTerm_mouse LTerm_widget LTerm_widget_callbacks LTerm_edit LTerm_read_line LTerm_text LTerm_ui LTerm_resources LTerm_inputrc LTerm_history LTerm_color_mappings LTerm_resource_lexer widget_impl/LTerm_widget_base_impl widget_impl/LTerm_buttons_impl widget_impl/LTerm_containers_impl widget_impl/LTerm_running_impl widget_impl/LTerm_toplevel_impl # OASIS_STOP lambda-term-1.9/src/liblambda-term_stubs.clib000066400000000000000000000002201254222632000212560ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: dff6f3d31800f198b7eea874f030ab42) lTerm_term_stubs.o lTerm_unix_stubs.o lTerm_windows_stubs.o # OASIS_STOP lambda-term-1.9/src/widget_impl/000077500000000000000000000000001254222632000166415ustar00rootroot00000000000000lambda-term-1.9/src/widget_impl/lTerm_buttons_impl.ml000066400000000000000000000110741254222632000230600ustar00rootroot00000000000000(* * lTerm_buttons_impl.ml * --------------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) open CamomileLibraryDyn.Camomile open LTerm_geom open LTerm_key open LTerm_widget_callbacks let section = Lwt_log.Section.make "lambda-term(buttons_impl)" class t = LTerm_widget_base_impl.t let space = Char(UChar.of_char ' ') class button initial_label = object(self) inherit t "button" as super method can_focus = true val click_callbacks = Lwt_sequence.create () method on_click ?switch f = register switch click_callbacks f val mutable size_request = { rows = 1; cols = 4 + Zed_utf8.length initial_label } method size_request = size_request val mutable label = initial_label method label = label method set_label text = label <- text; size_request <- { rows = 1; cols = 4 + Zed_utf8.length text }; self#queue_draw initializer self#on_event (function | LTerm_event.Key { control = false; meta = false; shift = false; code = Enter } -> exec_callbacks click_callbacks (); true | _ -> false) val mutable focused_style = LTerm_style.none val mutable unfocused_style = LTerm_style.none method update_resources = let rc = self#resource_class and resources = self#resources in focused_style <- LTerm_resources.get_style (rc ^ ".focused") resources; unfocused_style <- LTerm_resources.get_style (rc ^ ".unfocused") resources method private apply_style ctx focused = let style = if focused = (self :> t) then focused_style else unfocused_style in LTerm_draw.fill_style ctx style method draw ctx focused = let { rows; cols } = LTerm_draw.size ctx in let len = Zed_utf8.length label in self#apply_style ctx focused; LTerm_draw.draw_string ctx (rows / 2) ((cols - len - 4) / 2) (Printf.sprintf "< %s >" label) end class checkbutton initial_label initial_state = object(self) inherit button initial_label val mutable state = initial_state initializer self#on_event (function | LTerm_event.Key { control = false; meta = false; shift = false; code } when (code = Enter || code = space) -> state <- not state; (* checkbutton changes the state when clicked, so has to be redrawn *) self#queue_draw; exec_callbacks click_callbacks (); true | _ -> false); self#set_resource_class "checkbutton" method state = state method draw ctx focused = let { rows; cols } = LTerm_draw.size ctx in let checked = if state then "[x] " else "[ ] " in self#apply_style ctx focused; LTerm_draw.draw_string ctx (rows / 2) 0 (checked ^ label); end class type ['a] radio = object method on : unit method off : unit method id : 'a end class ['a] radiogroup = object(self) val state_change_callbacks = Lwt_sequence.create () method on_state_change ?switch f = register switch state_change_callbacks f val mutable state = None val mutable buttons = [] method state = state method register_object (button : 'a radio) = (* Switch the first button added to group to 'on' state *) if buttons = [] then button#on else (); buttons <- button :: buttons; () method switch_to some_id = let switch_button button = if button#id = some_id then button#on else button#off in List.iter switch_button buttons; state <- Some some_id; exec_callbacks state_change_callbacks state end class ['a] radiobutton (group : 'a radiogroup) initial_label (id : 'a) = object(self) inherit button initial_label val mutable state = false initializer self#on_event (function | LTerm_event.Key { control = false; meta = false; shift = false; code } when (code = Enter || code = space) -> if state (* no need to do anything if the button is on already *) then () else group#switch_to id; (* event is consumed in any case *) exec_callbacks click_callbacks (); true | _ -> false); self#set_resource_class "radiobutton"; group#register_object (self :> 'a radio) method draw ctx focused = let { rows; cols } = LTerm_draw.size ctx in let checked = if state then "(o) " else "( ) " in self#apply_style ctx focused; LTerm_draw.draw_string ctx (rows / 2) 0 (checked ^ self#label); method state = state method on = state <- true; self#queue_draw method off = state <- false; self#queue_draw method id = id end lambda-term-1.9/src/widget_impl/lTerm_containers_impl.ml000066400000000000000000000352731254222632000235360ustar00rootroot00000000000000open LTerm_geom class t = LTerm_widget_base_impl.t exception Out_of_range let rec insert x l n = if n < 0 then raise Out_of_range else if n = 0 then x :: l else match l with | [] -> raise Out_of_range | y :: l -> y :: insert x l (n - 1) type box_child = { widget : t; expand : bool; mutable length : int; } class type box = object inherit t method add : ?position : int -> ?expand : bool -> #t -> unit method remove : #t -> unit end class virtual abox rc = object(self) inherit t rc as super val mutable children = [] method children = List.map (fun child -> child.widget) children val mutable size_request = { rows = 0; cols = 0 } method size_request = size_request method private virtual compute_allocations : unit (* Compute sizes of children. *) method private virtual compute_size_request : unit (* Compute the size request. *) method set_allocation rect = super#set_allocation rect; self#compute_allocations method add : 'a. ?position : int -> ?expand : bool -> (#t as 'a) -> unit = fun ?position ?(expand = true) widget -> let child = { widget = (widget :> t); expand = expand; length = 0; } in (match position with | Some n -> children <- insert child children n | None -> children <- children @ [child]); widget#set_parent (Some (self :> t)); self#compute_size_request; self#compute_allocations; self#queue_draw method remove : 'a. (#t as 'a) -> unit = fun widget -> children <- List.filter (fun child -> if child.widget = (widget :> t) then (child.widget#set_parent None; false) else true) children; self#compute_size_request; self#compute_allocations; self#queue_draw end class hbox = object(self) inherit abox "hbox" method private compute_size_request = size_request <- ( List.fold_left (fun acc child -> let size = child.widget#size_request in { rows = max acc.rows size.rows; cols = acc.cols + size.cols }) { rows = 0; cols = 0 } children ) method private compute_allocations = let rect = self#allocation in let cols = rect.col2 - rect.col1 in let total_requested_cols = List.fold_left (fun acc child -> acc + child.widget#size_request.cols) 0 children in if total_requested_cols <= cols then begin (* There is enough space for everybody, we split free space between children that can expand. *) (* Count the number of children that can expand. *) let count_can_expand = List.fold_left (fun acc child -> if child.expand then acc + 1 else acc) 0 children in (* Divide free space between these children. *) let widthf = if count_can_expand = 0 then 0. else float (cols - total_requested_cols) /. float count_can_expand in let rec loop colf = function | [] -> () | [child] -> let width = cols - truncate colf in child.length <- width | child :: rest -> let req_cols = child.widget#size_request.cols in if child.expand then begin let col = truncate colf in let width = req_cols + truncate (colf +. widthf) - col in child.length <- width; loop (colf +. float req_cols +. widthf) rest end else begin child.length <- req_cols; loop (colf +. float req_cols) rest end in loop 0. children end else begin (* There is not enough space for everybody. *) if total_requested_cols = 0 then List.iter (fun child -> child.length <- 0) children else let rec loop col = function | [] -> () | [child] -> let width = cols - col in child.length <- width | child :: rest -> let width = child.widget#size_request.cols * cols / total_requested_cols in child.length <- width; loop (col + width) rest in loop 0 children end; ignore ( List.fold_left (fun col child -> child.widget#set_allocation { row1 = rect.row1; col1 = col; row2 = rect.row2; col2 = col + child.length; }; col + child.length) rect.col1 children ) method draw ctx focused = let rect = self#allocation in let rec loop col children = match children with | [] -> () | child :: rest -> child.widget#draw (LTerm_draw.sub ctx { row1 = 0; col1 = col; row2 = rect.row2 - rect.row1; col2 = col + child.length; }) focused; loop (col + child.length) rest in loop 0 children end class vbox = object(self) inherit abox "vbox" method private compute_size_request = size_request <- ( List.fold_left (fun acc child -> let size = child.widget#size_request in { rows = acc.rows + size.rows; cols = max acc.cols size.cols }) { rows = 0; cols = 0 } children ) method private compute_allocations = let rect = self#allocation in let rows = rect.row2 - rect.row1 in let total_requested_rows = List.fold_left (fun acc child -> acc + child.widget#size_request.rows) 0 children in if total_requested_rows <= rows then begin (* There is enough space for everybody, we split free space between children that can expand. *) (* Count the number of children that can expand. *) let count_can_expand = List.fold_left (fun acc child -> if child.expand then acc + 1 else acc) 0 children in (* Divide free space between these children. *) let heightf = if count_can_expand = 0 then 0. else float (rows - total_requested_rows) /. float count_can_expand in let rec loop rowf = function | [] -> () | [child] -> let height = rows - truncate rowf in child.length <- height | child :: rest -> let req_rows = child.widget#size_request.rows in if child.expand then begin let row = truncate rowf in let height = req_rows + truncate (rowf +. heightf) - row in child.length <- height; loop (rowf +. float req_rows +. heightf) rest end else begin child.length <- req_rows; loop (rowf +. float req_rows) rest end in loop 0. children end else begin (* There is not enough space for everybody. *) if total_requested_rows = 0 then List.iter (fun child -> child.length <- 0) children else let rec loop row = function | [] -> () | [child] -> let height = rows - row in child.length <- height | child :: rest -> let height = child.widget#size_request.rows * rows / total_requested_rows in child.length <- height; loop (row + height) rest in loop 0 children end; ignore ( List.fold_left (fun row child -> child.widget#set_allocation { row1 = row; col1 = rect.col1; row2 = row + child.length; col2 = rect.col2; }; row + child.length) rect.row1 children ) method draw ctx focused = let rect = self#allocation in let rec loop row children = match children with | [] -> () | child :: rest -> child.widget#draw (LTerm_draw.sub ctx { row1 = row; col1 = 0; row2 = row + child.length; col2 = rect.col2 - rect.col1; }) focused; loop (row + child.length) rest in loop 0 children end class frame = object(self) inherit t "frame" as super val mutable child = None method children = match child with | Some widget -> [widget] | None -> [] val mutable size_request = { rows = 2; cols = 2 } method size_request = size_request val mutable style = LTerm_style.none val mutable connection = LTerm_draw.Light method update_resources = let rc = self#resource_class and resources = self#resources in style <- LTerm_resources.get_style rc resources; connection <- LTerm_resources.get_connection (rc ^ ".connection") resources method private compute_size_request = match child with | Some widget -> let size = widget#size_request in size_request <- { rows = size.rows + 2; cols = size.cols + 2 } | None -> size_request <- { rows = 2; cols = 2 } method private compute_allocation = match child with | Some widget -> let rect = self#allocation in let row1 = min rect.row2 (rect.row1 + 1) and col1 = min rect.col2 (rect.col1 + 1) in widget#set_allocation { row1 = row1; col1 = col1; row2 = max row1 (rect.row2 - 1); col2 = max col1 (rect.col2 - 1); } | None -> () method set_allocation rect = super#set_allocation rect; self#compute_allocation method set : 'a. (#t as 'a) -> unit = fun widget -> child <- Some(widget :> t); widget#set_parent (Some (self :> t)); self#compute_size_request; self#compute_allocation; self#queue_draw method empty = match child with | Some widget -> widget#set_parent None; child <- None; self#compute_size_request; self#queue_draw | None -> () method draw ctx focused = let size = LTerm_draw.size ctx in LTerm_draw.fill_style ctx style; if size.rows >= 1 && size.cols >= 1 then begin LTerm_draw.draw_frame ctx { row1 = 0; col1 = 0; row2 = size.rows; col2 = size.cols } connection; if size.rows > 2 && size.cols > 2 then match child with | Some widget -> widget#draw (LTerm_draw.sub ctx { row1 = 1; col1 = 1; row2 = size.rows - 1; col2 = size.cols - 1 }) focused | None -> () end end class modal_frame = object(self) inherit frame val mutable work_area = None method private compute_allocation = match child with | Some widget -> (* The desired layout is as following: * * .............................. * . . * . --------------------- . * . || || . * . || child widget is || . * . || centered || . * . || || . * . --------------------- . * . . * .............................. *) let rect = self#allocation in (* First find out how much space we have *) let alloc_height = rect.row2 - rect.row1 in let alloc_width = rect.col2 - rect.col1 in (* Then how much child widget wants *) let request = widget#size_request in (* Now we calculate how big margins could be, taking into account: * - for vertical margin two lines of the frame and two empty lines * between it and the child widget * - for horizontal margin four lines of the frame and two empty lines * between it and the child widget *) let margin_height = max 0 (alloc_height - request.rows - 4) / 2 in let margin_width = max 0 (alloc_width - request.cols - 6) / 2 in (* the child widget would like to be here (again taking into account * frame lines and emty lines between frame and the child widget *) let desired_row1 = rect.row1 + margin_height + 2 in let desired_row2 = desired_row1 + request.rows in let desired_col1 = rect.col1 + margin_width + 3 in let desired_col2 = desired_col1 + request.cols in (* make sure we stay inside the modal_frame *) (* Remember that right and left margins for the widget inside the frame * are 3, and top and bottom margins are 2 *) let row1 = min desired_row1 (rect.row2 - 2) in let row2 = min desired_row2 (rect.row2 - 2) in let col1 = min desired_col1 (rect.col2 - 3) in let col2 = min desired_col2 (rect.col2 - 3) in (* now inform the child widget about its area *) widget#set_allocation { row1 = row1; col1 = col1; row2 = row2; col2 = col2; }; (* modal_frame is not going to touch anything outside of the child * widget and frame around *) work_area <- Some { row1 = max rect.row1 (row1 - 2); row2 = min rect.row2 (row2 + 2); col1 = max rect.col1 (col1 - 3); col2 = min rect.col2 (col2 + 3) }; | None -> () method draw ctx focused = match work_area with | None -> () | Some area -> let work_ctx = LTerm_draw.sub ctx area in (* modal_frame is drawing only inside centered area (the child widget * and frame around) so create appropriate drawing context *) let size = LTerm_draw.size work_ctx in if size.rows >= 1 && size.cols >= 1 then begin LTerm_draw.fill_style work_ctx style; LTerm_draw.clear work_ctx; let width = area.col2 - area.col1 in let height = area.row2 - area.row1 in (* outer part of the frame *) LTerm_draw.draw_frame work_ctx { row1 = 0; col1 = 0; row2 = height; col2 = width } connection; (* inner part of the frame *) LTerm_draw.draw_frame work_ctx { row1 = 0; col1 = 1; row2 = height; col2 = width - 1 } connection; if size.rows > 4 && size.cols > 6 then match child with | Some widget -> (* decorations around the child widget take 4 columns and 6 * rows *) let widget_ctx = LTerm_draw.sub work_ctx { row1 = 2; row2 = height - 2; col1 = 3; col2 = width - 3} in widget#draw widget_ctx focused | None -> () end initializer self#set_resource_class "modal_frame" end lambda-term-1.9/src/widget_impl/lTerm_running_impl.ml000066400000000000000000000122131254222632000230360ustar00rootroot00000000000000open Lwt open LTerm_geom type t = LTerm_widget_base_impl.t class toplevel = LTerm_toplevel_impl.toplevel (* for focus cycling *) let rec find_focusable widget = if widget#can_focus then Some widget else find_focusable_in_list widget#children and find_focusable_in_list = function | [] -> None | child :: rest -> match find_focusable child with | Some _ as some -> some | None -> find_focusable_in_list rest (* An event for the main loop. *) type 'a event = | Value of 'a (* A value from the waiter thread. *) | Event of LTerm_event.t (* A event from the terminal. *) let lambda_termrc = Filename.concat LTerm_resources.home ".lambda-termrc" let file_exists file = Lwt.catch (fun () -> Lwt_unix.access file [Unix.R_OK] >>= fun () -> return true) (function | Unix.Unix_error _ -> return false | exn -> Lwt.fail exn) let apply_resources ?cache load_resources resources_file widget = if load_resources then file_exists resources_file >>= fun has_resources -> match has_resources with | true -> LTerm_resources.load resources_file >>= fun resources -> widget#set_resources resources; begin match cache with | None -> () | Some c -> c := resources end; return () | false -> return () else return () let ref_focus widget = ref (match find_focusable widget with | Some w -> w | None -> widget) let run_modal term ?save_state ?(load_resources = true) ?(resources_file = lambda_termrc) push_event pop_event widget waiter = let widget = (widget :> t) in let resources_cache = ref LTerm_resources.empty in apply_resources ~cache:resources_cache load_resources resources_file widget >>= fun () -> (* The currently focused widget. *) let focused = ref_focus widget in (* Create a toplevel widget. *) let toplevel = new toplevel focused widget in (* Drawing function for toplevels. *) let draw_toplevel = ref (fun () -> ()) in (* Size for toplevels. *) let size_ref = ref { row1 = 0; col1 = 0; row2 = 0; col2 = 0 } in let layers = ref [toplevel] in let focuses = ref [focused] in (* Layer event handlers. *) let push_layer w = let new_focus = ref_focus w in let new_top = new toplevel new_focus w in new_top#set_queue_draw !draw_toplevel; new_top#set_allocation !size_ref; focuses := new_focus :: !focuses; layers := new_top :: !layers; new_top#set_resources !resources_cache; new_top#queue_draw in let pop_layer () = match !layers with | [_] -> failwith "Trying to destroy the only existing layer." | _ :: tl -> layers := tl; focuses := List.tl !focuses; (List.hd !layers)#queue_draw | [] -> failwith "Internal error: no idea how it happened." in (* Arm layer event handlers. *) toplevel#arm_layer_handlers push_event push_layer pop_event pop_layer; let draw ui matrix = let ctx = LTerm_draw.context matrix (LTerm_ui.size ui) in LTerm_draw.clear ctx; (* Draw the layers starting from the bottom *) let layers_rev = List.rev !layers in let focuses_rev = List.rev !focuses in List.iter2 (fun top focus -> top#draw ctx !focus) layers_rev focuses_rev; let current_focus = List.hd !focuses in match !current_focus#cursor_position with | Some coord -> let rect = !current_focus#allocation in LTerm_ui.set_cursor_visible ui true; LTerm_ui.set_cursor_position ui { row = rect.row1 + coord.row; col = rect.col1 + coord.col } | None -> LTerm_ui.set_cursor_visible ui false in LTerm_ui.create term ?save_state draw >>= fun ui -> draw_toplevel := (fun () -> LTerm_ui.draw ui); toplevel#set_queue_draw !draw_toplevel; let size = LTerm_ui.size ui in size_ref := { !size_ref with row2 = size.rows; col2 = size.cols}; toplevel#set_allocation !size_ref; (* Loop handling events. *) let waiter = waiter >|= fun x -> Value x in let rec loop () = let thread = LTerm_ui.wait ui >|= fun x -> Event x in choose [thread; waiter] >>= function | Event (LTerm_event.Resize size) -> size_ref := { !size_ref with row2 = size.rows; col2 = size.cols}; List.iter (fun top -> top#set_allocation !size_ref) !layers; loop () | Event ev -> !(List.hd !focuses)#send_event ev; loop () | Value value -> cancel thread; return value in Lwt.finalize loop (fun () -> LTerm_ui.quit ui) let run term ?save_state ?load_resources ?resources_file widget waiter = run_modal term ?save_state ?load_resources ?resources_file Lwt_react.E.never Lwt_react.E.never widget waiter let prepare_simple_run () = let waiter, wakener = wait () in let push_ev, push_ev_send = Lwt_react.E.create () in let pop_ev, pop_ev_send = Lwt_react.E.create () in let exit = wakeup wakener in let push_layer w = fun () -> push_ev_send (w :> t) in let pop_layer = pop_ev_send in let do_run w = Lazy.force LTerm.stdout >>= fun term -> run_modal term push_ev pop_ev w waiter in (do_run, push_layer, pop_layer, exit) lambda-term-1.9/src/widget_impl/lTerm_toplevel_impl.ml000066400000000000000000000070321254222632000232130ustar00rootroot00000000000000open LTerm_geom open LTerm_key class t = LTerm_widget_base_impl.t let make_widget_matrix root = let { rows; cols } = LTerm_geom.size_of_rect root#allocation in let m = Array.make_matrix rows cols None in let rec loop widget = if widget#can_focus then begin let rect = widget#allocation in for r = rect.row1 to rect.row2 - 1 do for c = rect.col1 to rect.col2 - 1 do m.(r).(c) <- Some widget done done end; List.iter loop widget#children in loop root; m let left coord = { coord with col = pred coord.col } let right coord = { coord with col = succ coord.col } let up coord = { coord with row = pred coord.row } let down coord = { coord with row = succ coord.row } let focus_to dir f root focused coord = let rect = root#allocation in let m = make_widget_matrix root in let rec loop coord = if coord.row < rect.row1 || coord.row >= rect.row2 || coord.col < rect.col1 || coord.col >= rect.col2 then None else match m.(coord.row).(coord.col) with | None -> loop (dir coord) | Some widget when widget = focused -> loop (dir coord) | Some widget -> let rect = widget#allocation in Some (widget, f rect coord) in loop coord let avg_col rect coord = { coord with col = (rect.col1 + rect.col2) / 2 } let avg_row rect coord = { coord with row = (rect.row1 + rect.row2) / 2 } let focus_left (* root focused coord *) = focus_to left avg_col let focus_right (* root focused coord *) = focus_to right avg_col let focus_up (* root focused coord *) = focus_to up avg_row let focus_down (* root focused coord *) = focus_to down avg_row class toplevel focused widget = object(self) inherit t "toplevel" as super val children = [widget] method children = children method draw ctx focused = widget#draw ctx focused val mutable coord = { row = 0; col = 0 } (* Coordinates of the cursor inside the screen. *) val mutable push_layer_handler = Lwt_react.E.never; val mutable pop_layer_handler = Lwt_react.E.never; method arm_layer_handlers (push_event : t Lwt_react.event) (push_handler : t -> unit) (pop_event : unit Lwt_react.event) (pop_handler : unit -> unit) = let open Lwt_react in push_layer_handler <- E.map push_handler push_event; pop_layer_handler <- E.map pop_handler pop_event method set_allocation rect = super#set_allocation rect; widget#set_allocation rect; let rect = !focused#allocation in coord <- { row = (rect.row1 + rect.row2) / 2; col = (rect.col1 + rect.col2) / 2 } method private move_focus direction = match direction (self :> t) !focused coord with | Some (widget, c) -> coord <- c; focused := widget; self#queue_draw | None -> () method private process_arrows = function | LTerm_event.Key { control = false; meta = false; shift = false; code = Left } -> self#move_focus focus_left; true | LTerm_event.Key { control = false; meta = false; shift = false; code = Right } -> self#move_focus focus_right; true | LTerm_event.Key { control = false; meta = false; shift = false; code = Up } -> self#move_focus focus_up; true | LTerm_event.Key { control = false; meta = false; shift = false; code = Down } -> self#move_focus focus_down; true | other_event -> false initializer widget#set_parent (Some (self :> t)); self#on_event self#process_arrows end lambda-term-1.9/src/widget_impl/lTerm_widget_base_impl.ml000066400000000000000000000045261254222632000236430ustar00rootroot00000000000000(* * lTerm_widget_base_impl.ml * --------------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) open LTerm_widget_callbacks open LTerm_geom class t initial_resource_class : object method children : t list method parent : t option method set_parent : t option -> unit method can_focus : bool method queue_draw : unit method set_queue_draw : (unit -> unit) -> unit method draw : LTerm_draw.context -> t -> unit method cursor_position : coord option method allocation : rect method set_allocation : rect -> unit method send_event : LTerm_event.t -> unit method on_event : ?switch : switch -> (LTerm_event.t -> bool) -> unit method size_request : size method resources : LTerm_resources.t method set_resources : LTerm_resources.t -> unit method resource_class : string method set_resource_class : string -> unit method update_resources : unit end = object(self) method children : t list = [] method can_focus = false val mutable parent : t option = None method parent = parent method set_parent opt = parent <- opt val mutable queue_draw = ignore method queue_draw = queue_draw () method set_queue_draw f = queue_draw <- f; List.iter (fun w -> w#set_queue_draw f) self#children method draw (ctx : LTerm_draw.context) (focused : t) = () method cursor_position = None val mutable allocation = { row1 = 0; col1 = 0; row2 = 0; col2 = 0 } method allocation = allocation method set_allocation rect = allocation <- rect val event_filters = Lwt_sequence.create () method send_event ev = if not (exec_filters event_filters ev) then match parent with | Some widget -> widget#send_event ev | None -> () method on_event ?switch f = register switch event_filters f val size_request = { rows = 0; cols = 0 } method size_request = size_request val mutable resource_class = initial_resource_class method resource_class = resource_class method set_resource_class rc = resource_class <- rc; self#update_resources val mutable resources = LTerm_resources.empty method resources = resources method set_resources res = resources <- res; self#update_resources; List.iter (fun w -> w#set_resources res) self#children method update_resources = () end lambda-term-1.9/style.css000066400000000000000000000050361254222632000154240ustar00rootroot00000000000000/* A style for ocamldoc. Daniel C. Buenzli, Jérémie Dimino */ body { padding: 0em; border: 0em; margin: 2em 10% 2em 10%; font-weight: normal; line-height: 130%; text-align: justify; background: white; color : black; min-width: 40ex; } pre, p, div, span, img, table, td, ol, ul, li { padding: 0em; border: 0em; margin: 0em } h1, h2, h3, h4, h5, h6, div.h7, div.h8, div.h9 { fontsize: 100%; margin-bottom: 1em padding: 1ex 0em 0em 0em; border: 0em; margin: 1em 0em 0em 0em; font-weight : bold; text-align: center; } h1 { font-size : 140% } h2, h3, h4, h5, h6, div.h7, div.h8, div.h9 { font-size : 100%; border-top-style : none; margin: 1ex 0em 0em 0em; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px; text-align: center; padding: 2px; } h2 { font-size : 120%; background-color: #90BDFF ; } h3 { background-color: #90DDFF; } h4 { background-color: #90EDFF; } h5 { background-color: #90FDFF; } h6 { background-color: #C0FFFF; } div.h7 { background-color: #E0FFFF; } div.h8 { background-color: #F0FFFF; } div.h9 { background-color: #FFFFFF; } .navbar { padding-bottom : 1em; margin-bottom: 1em; border-bottom: 1px solid #000000; border-bottom-style: dotted; } p { padding: 1em 0ex 0em 0em } a, a:link, a:visited, a:active, a:hover { color : #009; text-decoration: none } a:hover { color : #009; text-decoration : none; background-color: #5FFF88 } hr { border-style: none; } table { font-size : 100% /* Why ? */ } ul li { padding: 1em 0em 0em 0em; margin:0em 0em 0em 2.5ex } ol li { padding: 1em 0em 0em 0em; margin:0em 0em 0em 2em } pre { margin: 3ex 0em 1ex 0em; background-color: #edf0f9; } .keyword { font-weight: bold; color: #a020f0; } .keywordsign { font-weight: bold; color: #a020f0; } .typefieldcomment { color : #b22222; } .keywordsign { color: #a020f0; } .code { font-size: 100%; color: #5f5f5f; } .info { margin: 0em 0em 0em 2em } .comment { color : #b22222; } .constructor { color : #072 } .type { color : #228b22; } .string { color : #bc8f8f; } .warning { color : Red; font-weight : bold } div.sig_block { margin-left: 2em } .typetable { color : #b8860b; border-style : hidden } .indextable { border-style : hidden } .paramstable { border-style : hidden; padding: 5pt 5pt } .superscript { font-size : 80% } .subscript { font-size : 80% } lambda-term-1.9/tests/000077500000000000000000000000001254222632000147105ustar00rootroot00000000000000lambda-term-1.9/tests/history_stress_test.ml000066400000000000000000000046241254222632000214130ustar00rootroot00000000000000(* * history_stress_test.ml * ---------------------- * Copyright : (c) 2012, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (* Start n processes, adding entries [k, k + n, k + n * 2, ... k + n * count] to their history. Between each addition, they save their history to the same file. At the end the parent check that the history contains all numbers from [0] to [n - 1 + n * count]. *) let return, (>>=) = Lwt.return, Lwt.(>>=) let rec check nproc count n l = match l with | [] -> n = nproc * (count + 1) | p :: l -> n = p && check nproc count (n + 1) l let rec start_procs name fn nproc count k = if k = nproc then [] else let t = Lwt_process.exec (name, [|name; fn; string_of_int nproc; string_of_int count; string_of_int k|]) >>= fun status -> assert (status = Unix.WEXITED 0); return () in t :: start_procs name fn nproc count (k + 1) let () = match Sys.argv with | [|name; fn; s1; s2|] -> Lwt_main.run ( if Sys.file_exists fn then Sys.remove fn; let nproc = int_of_string s1 and count = int_of_string s2 in Lwt.join (start_procs name fn nproc count 0) >>= fun () -> let history = LTerm_history.create [] in LTerm_history.load history fn >>= fun () -> Sys.remove fn; if check nproc count 0 (List.sort compare (List.map int_of_string (LTerm_history.contents history))) then begin prerr_endline "success"; exit 0 end else begin prerr_endline "failure"; exit 1 end ) | [|name; fn; s1; s2; s3|] -> Lwt_main.run ( let nproc = int_of_string s1 and count = int_of_string s2 and start = int_of_string s3 in let history = LTerm_history.create [] in let rec loop i = if i >= count then return () else begin LTerm_history.add history (string_of_int (start + i * nproc)); assert (LTerm_history.length history = i + 1 && LTerm_history.old_count history = i); LTerm_history.save history fn >>= fun () -> loop (i + 1) end in loop 0 ) | _ -> Printf.eprintf "usage: %s \n" Sys.argv.(0); exit 2 lambda-term-1.9/tools/000077500000000000000000000000001254222632000147065ustar00rootroot00000000000000lambda-term-1.9/tools/lambda_term_actions.ml000066400000000000000000000025631254222632000212350ustar00rootroot00000000000000(* * lambda_term_actions.ml * ---------------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of Lambda-Term. *) (* List all available actions. *) let print_action length (action, doc) = print_string action; for i = String.length action to length do print_char ' ' done; print_string ": "; print_string doc; print_char '\n' let () = (* Collect actions. *) let edit_actions = ("insert(...)", "insert a character.") :: (List.map (fun (action, name) -> (name, Zed_edit.doc_of_action action)) Zed_edit.actions) @ (List.map (fun (action, name) -> (name, LTerm_edit.doc_of_action action)) LTerm_edit.actions) and read_line_actions = List.map (fun (action, name) -> (name, LTerm_read_line.doc_of_action action)) LTerm_read_line.actions in (* Search the longest line. *) let length = List.fold_left (fun acc (action, doc) -> max (String.length action) acc) 0 edit_actions in let length = List.fold_left (fun acc (action, doc) -> max (String.length action) acc) length read_line_actions in (* Print actions. *) print_string "General actions\n\ ===============\n\n"; List.iter (print_action length) edit_actions; print_string "\nRead-line actions\n\ =================\n\n"; List.iter (print_action length) read_line_actions; flush stdout