ledit-2.03/0000755006260700512610000000000011714435504012742 5ustar derauglaaosterocledit-2.03/Makefile0000600006260700512610000000407511471442273014401 0ustar derauglaaosteroc# $Id: Makefile,v 1.28 2010-11-19 09:34:51 deraugla Exp $ BINDIR=/usr/local/bin LIBDIR=/usr/local/lib MANDIR=/usr/local/man/man1 OCAMLC=ocamlc OCAMLOPT=ocamlopt CAMLP5=camlp5r -I ext OBJS=cursor.cmo ledit.cmo go.cmo OTHER_OBJS=unix.cma -I `camlp5 -where` gramlib.cma OTHER_XOBJS=unix.cmxa -I `camlp5 -where` gramlib.cmxa TARGET=ledit.out MKDIR=mkdir -p EXT=ext/pa_def.cmo ext/pa_local.cmo CUSTOM=-custom LEDIT_LIBDIR=$(shell $(OCAMLC) -where)/ledit all: $(EXT) $(TARGET) ledit.1 all: ledit.cma opt: ledit.cmxa $(TARGET): $(OBJS) $(OCAMLC) $(CUSTOM) $(OTHER_OBJS) $(OBJS) -o $(TARGET) $(TARGET:.out=.opt): $(OBJS:.cmo=.cmx) $(OCAMLOPT) $(OTHER_XOBJS) $(OBJS:.cmo=.cmx) -o $(TARGET:.out=.opt) ledit.1: ledit.1.tpl go.ml VERSION=`sed -n -e 's/^.* version = "\(.*\)".*$$/\1/p' go.ml`; \ sed s/LEDIT_VERSION/$$VERSION/ ledit.1.tpl > ledit.1 ledit.cma: cursor.cmo ledit.cmo $(OCAMLC) -a -o $@ $^ ledit.cmxa: cursor.cmx ledit.cmx $(OCAMLOPT) -a -o $@ $^ clean: /bin/rm -f *.cm[iox] *.pp[oi] *.o ext/*.cm[io] *.bak $(TARGET) ledit.1 rm -f ledit.cma ledit.cmxa *.a rm -f META install: -$(MKDIR) $(BINDIR) $(MANDIR) -cp ledit.out $(BINDIR)/ledit -cp ledit.1 $(MANDIR)/ledit.1 install-lib: META -$(MKDIR) $(LEDIT_LIBDIR) cp META $(LEDIT_LIBDIR)/ cp ledit.cma ledit.cmi cursor.cmi $(LEDIT_LIBDIR)/ if [ -f ledit.cmxa ] ; then cp ledit.cmxa ledit.a $(LEDIT_LIBDIR)/ ; fi META: META.tpl VERSION=`sed -n -e 's/^.* version = "\(.*\)".*$$/\1/p' go.ml`; \ sed s/LEDIT_VERSION/$$VERSION/ META.tpl > META depend: > .depend.new for i in $(OBJS:.cmo=.ml); do \ $(CAMLP5) pr_depend.cmo $$i >> .depend.new; \ done mv .depend .depend.old mv .depend.new .depend include .depend ext/%.cmo: ext/%.ml camlp5r -I ext -loc loc $< -o ext/$*.ppo $(OCAMLC) -I `camlp5 -where` -c -impl ext/$*.ppo rm -f ext/$*.ppo %.cmo: %.ml $(CAMLP5) $< -o $*.ppo $(OCAMLC) -I `camlp5 -where` -c -impl $*.ppo /bin/rm -f $*.ppo %.cmx: %.ml $(CAMLP5) $< -o $*.ppo $(OCAMLOPT) -I `camlp5 -where` -c -impl $*.ppo /bin/rm -f $*.ppo %.cmi: %.mli $(CAMLP5) $< -o $*.ppi $(OCAMLC) -c -intf $*.ppi /bin/rm -f $*.ppi ledit-2.03/ledit.1.tpl0000644006260700512610000002025211470757710014731 0ustar derauglaaosteroc.TH LEDIT 1 "Wed Jan 23, 2008" "INRIA" .SH NAME ledit \- line editor, version LEDIT_VERSION .SH SYNOPSIS .B ledit [-h \fIfile\fP] [-x] [-t] [-l \fIlength\fP] [-a | -u] [\fIcommand options\fP] .SH DESCRIPTION The command \fIledit\fP allows to edit lines one by one when running an interactive command. When typing a line, some keys with control or meta are interpreted: it is possible to insert characters in the middle of the line, go to the beginning or the end of the line, get a previous line, search for a line with a pattern, etc. .SH OPTIONS The options are: .TP .B -h \fIfile\fP Save the lines typed (history) in \fIfile\fP. The default is to have them only in memory (so, they are lost at the end of the program). .TP .B -x Extend the history file (given in option "-h") if it already exists. The default is to truncate the history file. .TP .B -t Display the sequences generated by the keys (for debugging). .TP .B -v Print ledit version and exit. .TP .B -l \fIlength\fP Tells that \fIlength\fP is the maximum line length displayed. If the line edited is longer than this length, the line scrolls horizontally, while editing. The default value is 70. .TP .B -a Ascii encoding: characters whose code is greater than 128 are displayed with a backslash followed by their code. .TP .B -u Unicode encoding: the terminal must have been set in unicode mode. See commands \fBunicode_start\fP and \fBunicode_stop\fP. .TP \fIcommand options\fP Runs the command \fIcommand\fP and its possible options. This must be the last option of ledit. The default value is "cat". .SH KEYS BINDINGS When ledit starts, some default key bindings are defined. The can be completed with a "leditrc" file. See the section \fBLEDITRC\fP. In the following lines, the caret sign "^" means "control" and the sequence "M-" means "meta" (either with the "meta" prefix, or by pressing the "escape" key before). Examples: .TP 1.0i ^a press the "control" key, then press "a", then release "a", then release "control". .TP M-a press the "meta" key, then press "a", then release "a", then release "meta", or: press and release the "escape" key, then press and release "a" (the manipulation with "meta" may not work in some systems: in this case, use the manipulation with "escape"). .PP The default editing commands are: .nf ^a : beginning of line ^e : end of line ^f : forward char ^b : backward char M-f : forward word M-b : backard word TAB : complete file name ^p : previous line in history ^n : next line in history M-< : first line in history M-> : last line in history ^r : reverse search in history (see below) ^d : delete char (or EOF if the line is empty) ^h : (or backspace) backward delete char ^t : transpose chars M-c : capitalize word M-u : upcase word M-l : downcase word M-d : kill word M-^h : (or M-del or M-backspace) backward kill word ^q : insert next char M-/ : expand abbreviation ^k : cut until end of line ^y : paste ^u : line discard ^l : redraw current line ^g : abort prefix ^c : interrupt ^z : suspend ^\\ : quit return : send line ^x : send line and show next history line other : insert char .fi The arrow keys can be used, providing your keyword returns standard key sequences: .nf up arrow : previous line in history down arrow : next line in history right arrow : forward char left arrow : backward char .fi Other keys: .nf home : beginning of line end : end of line delete : delete char page up : previous line in history page down : next line in history shift home : beginning of history shift end : end of history .fi .SH REVERSE SEARCH The reverse search in incremental, i.e. \fIledit\fP backward searchs in the history a line holding the characters typed. If you type "a", its search the first line before the current line holding an "a" and displays it. If you then type a "b", its search a line holding "ab", and so on. If you type ^h (or backspace), it returns to the previous line found. To cancel the search, type ^g. To find another line before holding the same string, type ^r. To stop the editing and display the current line found, type "escape" (other commands of the normal editing, different from ^h, ^g, and ^r stop the editing too). Summary of reverse search commands: .nf ^g : abort search ^r : search previous same pattern ^h : (or backspace) search without the last char del : search without the last char any other command : stop search and show the line found .fi .SH LEDITRC If the environment variable LEDITRC is set, it contains the name of the leditrc file. Otherwise it is the file named ".leditrc" in user's home directory. When starting, ledit reads this file, if it exists, to modify or complete the default bindings. If this file is changed while reading lines, it is read again to take the new file into account. Bindings lines are the ones which start with a string defining the key sequence and follow with a colon and a binding. A binding is either a string or a command. The other lines are ignored For example,the line: .nf "\\C-a": beginning-of-line .fi binds the sequence "control-a" to the command "beginning-of-line". The key sequence may contain the specific meta-sequences: .nf \\C- followed by a key: "control" of this key \\M- followed by a key: "meta" of this key \\e the "escape" key \\nnn where nnn is one, two, or three octal digits, or: \\xnn where nn is one or two hexadecimal digits: the binary representation of a byte \\a bell = \\C-g \\b backspace = \\C-h \\d delete = \\277 \\f form feed = \\C-l \\n newline = \\C-j \\r carriage return = \\C-m \\t tabulation = \\C-i \\v vertical tabulation = \\C-k .fi The commands are: .nf abort: do nothing accept-line: send the current line backward-char: move the cursor to the previous character backward-delete-char: delete the previous character backward-kill-word: delete the previous word backward-word: move the cursor before the previous word beginning-of-history: display the first line of the history beginning-of-line: move the cursor at the beginning of the line capitalize-word: uppercase the first char and lowercase the rest delete-char: delete the character under the cursor delete-char-or-end-of-file: same but eof if no character in the line downcase-word: lowercase whole word end-of-history: display the last line of the history end-of-line: move the cursor to the end of the line expand-abbrev: try to complete the word by looking at the history expand-to-file-name: try to complete the word from a file name forward-char: move the cursor after the next word forward-word: move the cursor to the next character interrupt: interrupt command (send control-C) kill-line: delete from the cursor to the end and save in buffer kill-word: delete the next word next-history: display the next line of the history operate-and-get-next: send line and display the next history line previous-history: display the previous line of the history quit: quit ledit quoted-insert: insert the next character as it is redraw-current-line: redisplay the current line reverse-search-history: backward search in the history suspend: suspend ledit (send control-Z) transpose-chars: exchange the last two characters unix-line-discard: kill current line upcase-word: uppercase whole word yank: insert kill buffer .fi .SH KNOWN BUGS If \fIledit\fP has been launched in a shell script, the suspend command kills it and its command... Use "exec ledit comm" instead of "ledit comm". .br The suspend command stops \fIledit\fP but not the called program. Do not do this if the called program is not waiting on standard input. .br In some systems (e.g. alpha), pasting two many characters works bad and may block the terminal. Probably a kernel problem. No solution. .SH SEE ALSO unicode_start(1), unicode_stop(1). .SH AUTHOR Daniel de Rauglaudre, at INRIA, france. .br daniel.de_rauglaudre@inria.fr ledit-2.03/LICENSE0000600006260700512610000000270111714435154013740 0ustar derauglaaosterocCopyright (c) 2001-2012, Daniel de Rauglaudre, Inria. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of INRIA nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY INRIA 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 INRIA OR 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. ledit-2.03/CHANGES0000644006260700512610000001020711714435154013736 0ustar derauglaaosterocLedit Version 2.03 ------------------ - [08 Feb 2012] Changed to accept Ledit.input_line even if stdin is not a terminal. Ledit Version 2.02.1 -------------------- - [19 Nov 2010] Included patches for Debian. Ledit Version 2.02.0 -------------------- - [17 Nov 2010] Fixed bug: failed if history file contained characters whose code >= 128. Ledit Version 2.02 ------------------ - [16 Nov 2010] Added complete-file-name (linked to TAB). - [17 Apr 2009] Fixed bug: "self-insert" did not work as command in .leditrc nor in reverse search. Ledit Version 2.01 ------------------ - [22 May 2008] Changed in Makefile "+camlp5" into "`camlp5 -where`". Ledit Version 2.00 ------------------ - [22 Jan 2008] Fixed bug "unix-line-discard": erased the entire line instead of just from beginning to cursor. - [18 Jan 2008] Added ability to have a file ".leditrc" in one's home directory (or in environment variable LEDITRC) containing user's bindings. This file can be changed while running ledit, the changes are immediately taken into account. See man page. Ledit Version 1.17 ------------------ - [16 Jan 2008] The binds to Delete_char do not raise End_of_file any more. Added bind Delete_char_or_end_of_file for control-D. Added sequences: * Delete (esc [ 3 ~) = Delete_char * Page Up (esc [ 5 ~) = Previous_history * Page Down (esc [ 6 ~) = Next_history * Home (esc O H or esc [ H) = Beginning_of_line * End (esc O F or esc [ F) = End_of_line * Shift Home (esc [ 2 H) = Beginning_of_history * Shift End (esc [ 2 F) = End_of_history - [16 Jan 2008] Added option "-t" for sequences traces (for debugging). - [01 Jan 2008] (internal) Rewritten the code in 'revised syntax' (it was in a special syntax close to revised syntax). Ledit Version 1.16 ------------------ - [29 Dec 2007] Adapted for Camlp5 "strict" mode. - [16 Jul 2007] Fixed bug: parentheses did not balance in case of string. E.g. : (foijeoif) balance, but not ("foijfe"). Ledit Version 1.15 ------------------ - [16 Jul 2007] Adapted for Camlp5. Ledit Version 1.14 ------------------ - [28 Jun 2007] Adapted for Camlp4s 4.02 - [30 Mar 2007] Fixed bug: reverse incremental search did not work. Ledit Version 1.13 ------------------ - [20 Mar 2007] Added options specifying encoding: -a for Ascii -u for Utf-8. Ledit Version 1.12 ------------------ - [03 Jan 2007] Changed man page ledit.l into ledit.1 Ledit Version 1.11 ------------------ - [15 Aug 2001] Added licence (open source) Ledit Version 1.10 ------------------ - [03 Jul 2001] The history now includes also the last input line not yet validated. Ledit Version 1.9 ----------------- - [25 Jun 2001] (internal) Updated for new revised syntax of sequences; added a printer pr_local for the "local" statement Ledit Version 1.8 ----------------- - [08 Jun 2001] Added O-sequences (esc-O) and ^[OA ^[OB ^[OC ^[OD Ledit Version 1.7 ----------------- - Added Transpose_chars (^t) Capitalize_word (M-c or esc c) Upcase_word (M-u or esc u) Downcase_word (M-l or esc l) Ledit Version 1.6 ----------------- - Added hack to avoid Fatal error: uncaught exception Sys_error("Bad file number") which sometimes happens when exiting ledit Ledit Version 1.5 ----------------- - Fixed bug shell prompt sometimes displayed to early when quitting ledit. Ledit Version 1.4 ----------------- - Added M-backspace or M-delete for backward-kill-word - Tabulations are expanded - Fixed bug printing chars between ascii 128 to ascii 159 - "-c" optional: "ledit comm args" <=> "ledit -c comm args" Ledit Version 1.3 ----------------- - Added expand abbrev M-/ - Added suspend ^z - Fixed bug ^l (refresh line) Ledit Version 1.2 ----------------- - Possible use of keyboard arrows - Fixed bug: ^q was not interpreted - If the environment variable LC_CTYPE is iso_8859_1, chars whose code > 128 are printed directly (else using backslash and code number). - Option -v print ledit version and exit. Ledit Version 1.1 ----------------- - First distributed version Wed Feb 19 08:38:38 MET 1997 - Fix bug excessive slowness when pasting as input of ledit ledit-2.03/ledit.ml0000600006260700512610000014463611714435154014404 0ustar derauglaaosteroc(***********************************************************************) (* *) (* Ledit *) (* *) (* Daniel de Rauglaudre, INRIA Rocquencourt *) (* *) (* Copyright 2001-2010 Institut National de Recherche en Informatique *) (* et Automatique. Distributed only by permission. *) (* *) (***********************************************************************) (* $Id: ledit.ml,v 1.68 2012-02-08 09:03:40 deraugla Exp $ *) #load "pa_local.cmo"; #load "pa_def.cmo"; #load "pa_fstream.cmo"; open Printf; type encoding = [ Ascii | Iso_8859 | Utf_8 ]; module A : sig value encoding : ref encoding; module Char : sig type t = 'abstract; value of_ascii : char -> t; value to_ascii : t -> option char; value is_word_char : t -> bool; value ctrl_val : t -> option t; value meta_ctrl_val : t -> option t; value not_ascii_val : t -> option (t * t * t); value uppercase : t -> t; value lowercase : t -> t; value parse : Stream.t char -> t; value to_string : t -> string; value input : in_channel -> t; value read : unit -> t; value print : t -> unit; value prerr : t -> unit; value prerr_backsp : t -> unit; end; module String : sig type t = 'abstract; value empty : t; value of_char : Char.t -> t; value of_ascii : string -> t; value length : t -> int; value set : t -> int -> Char.t -> unit; value get : t -> int -> Char.t; value sub : t -> int -> int -> t; value concat : t -> t -> t; value input_line : in_channel -> t; value output : out_channel -> t -> unit; end; end = struct value encoding = ref Iso_8859; value char_code = Char.code; value nbc c = if Char.code c < 0b10000000 then 1 else if Char.code c < 0b11000000 then -1 else if Char.code c < 0b11100000 then 2 else if Char.code c < 0b11110000 then 3 else if Char.code c < 0b11111000 then 4 else if Char.code c < 0b11111100 then 5 else if Char.code c < 0b11111110 then 6 else -1 ; module Char = struct type t = string; value of_ascii c = String.make 1 c; value to_ascii c = if String.length c = 1 && Char.code c.[0] < 128 then Some c.[0] else None ; value is_word_char c = if String.length c = 1 then match c.[0] with [ 'a'..'z' | 'A'..'Z' | '0'..'9' | '_' -> True | x -> if Char.code x < 128 then False else match encoding.val with [ Ascii -> False | Iso_8859 -> Char.code x >= 160 | Utf_8 -> assert False ] ] else True ; value ctrl_val c = if String.length c = 1 then let c = c.[0] in if Char.code c < 32 || Char.code c == 127 then Some (String.make 1 (Char.chr (127 land (Char.code c + 64)))) else None else None ; value meta_ctrl_val c = if String.length c = 1 then let c = c.[0] in if Char.code c >= 128 && Char.code c < 160 then Some (String.make 1 (Char.chr (127 land (Char.code c + 64)))) else None else None ; value not_ascii_val c = if String.length c = 1 then let c = c.[0] in if Char.code c >= 128 then let c1 = Char.chr (Char.code c / 100 + Char.code '0') in let c2 = Char.chr (Char.code c mod 100 / 10 + Char.code '0') in let c3 = Char.chr (Char.code c mod 10 + Char.code '0') in Some (String.make 1 c1, String.make 1 c2, String.make 1 c3) else None else None ; value uppercase c = match encoding.val with [ Ascii | Iso_8859 -> String.uppercase c | Utf_8 -> if String.length c = 1 then if Char.code c.[0] < 128 then String.uppercase c else c else c ] ; value lowercase c = match encoding.val with [ Ascii | Iso_8859 -> String.lowercase c | Utf_8 -> if String.length c = 1 then if Char.code c.[0] < 128 then String.lowercase c else c else c ] ; value to_string s = s; value get_char f = match encoding.val with [ Ascii | Iso_8859 -> String.make 1 (f ()) | Utf_8 -> let c = f () in let nbc = nbc c in if nbc < 0 then "?" else if nbc = 1 then String.make 1 c else loop (String.make 1 c) (nbc - 1) where rec loop s n = if n = 0 then s else let c = f () in if Char.code c < 0b10000000 then "?" else if Char.code c > 0b10111111 then "?" else loop (s ^ String.make 1 c) (n - 1) ] ; value input ic = get_char (fun () -> input_char ic); value read = let buff = " " in fun () -> get_char (fun () -> let len = Unix.read Unix.stdin buff 0 1 in if len == 0 then raise End_of_file else buff.[0]) ; value parse s = get_char (fun () -> Stream.next s); value print c = if String.length c = 1 && c.[0] = '\n' then print_newline () else print_string c ; value prerr c = output_string stderr c; value prerr_backsp c = do { if encoding.val = Utf_8 && Char.code c.[0] >= 228 && Char.code c.[0] <= 233 then (* hack for Chinese; it seems that terminals (at least "konsole" and "xterm") need 2 backspaces to put the cursor on the glyph. *) output_char stderr '\b' else (); output_char stderr '\b'; }; end; module String = struct type t = array string; value empty = [| |]; value of_char c = [| c |]; value of_ascii s = Array.init (String.length s) (fun i -> if char_code s.[i] < 128 then String.make 1 s.[i] else invalid_arg "A.String.of_ascii") ; value length = Array.length; value set = Array.set; value get = Array.get; value sub = Array.sub; value concat = Array.append; value input_line ic = let s = input_line ic in match encoding.val with [ Ascii | Iso_8859 -> Array.init (String.length s) (fun i -> String.make 1 s.[i]) | Utf_8 -> loop [] 0 where rec loop list i = if i >= String.length s then Array.of_list (List.rev list) else let n = nbc s.[i] in if n < 0 then loop ["?" :: list] (i + 1) else loop [String.sub s i n :: list] (i + n) ] ; value output oc s = Array.iter (output_string oc) s; end; end ; DEFINE CTRL(x) = EVAL (Char.chr (Char.code x - (Char.code 'a' - 1))); DEFINE META(x) = EVAL (Char.chr (Char.code x + 128)); DEFINE DEL = '\127'; DEFINE ESC = '\027'; value max_len = ref 70; value set_max_len x = max_len.val := if x > 3 then x else failwith "set_max_len" ; value son = ref None; value set_son_pid pid = son.val := Some pid; type command = [ Abort | Accept_line | Backward_char | Backward_delete_char | Backward_kill_word | Backward_word | Beginning_of_history | Beginning_of_line | Capitalize_word | Complete_file_name | Delete_char | Delete_char_or_end_of_file | Downcase_word | End_of_history | End_of_line | Expand_abbrev | Forward_char | Forward_word | Insert of string | Interrupt | Kill_line | Kill_word | Next_history | Operate_and_get_next | Previous_history | Quit | Quoted_insert | Redraw_current_line | Reverse_search_history | Self_insert | Sequence of string | Suspend | Transpose_chars | Unix_line_discard | Upcase_word | Yank ] ; type istate = [ Normal of string | Quote ]; value meta_as_escape = ref True; value unset_meta_as_escape () = meta_as_escape.val := False; value set_utf8 () = A.encoding.val := Utf_8; value set_ascii () = A.encoding.val := Ascii; (* key binding tree *) type kb_tree = [ KB_tree of list kb_node | KB_comm of command | KB_none ] and kb_node = { char : char; son : kb_tree }; value hex_value c = match c with [ '0'..'9' -> Some (Char.code c - Char.code '0') | 'a'..'f' -> Some (Char.code c - Char.code 'a' + 10) | 'A'..'F' -> Some (Char.code c - Char.code 'A' + 10) | _ -> None ] ; value oct_value c = match c with [ '0'..'7' -> Some (Char.code c - Char.code '0') | _ -> None ] ; value rec next_char s i = if i < String.length s then let (c, i) = if s.[i] = '\\' then if i + 1 < String.length s then match s.[i+1] with [ 'C' -> if i + 3 < String.length s && s.[i+2] = '-' then let c = s.[i+3] in if Char.code c >= 64 && Char.code c <= 95 then (Char.chr (Char.code c - 64), i + 4) else if Char.code c >= 96 && Char.code c <= 127 then (Char.chr (Char.code c - 96), i + 4) else (s.[i], i + 1) else (s.[i], i + 1) | 'M' -> if i + 2 < String.length s && s.[i+2] = '-' then match next_char s (i + 3) with [ Some (c, j) -> if Char.code c < 128 then (Char.chr (Char.code c + 128), j) else (s.[i], i + 1) | None -> (s.[i], i + 1) ] else (s.[i], i + 1) | 'e' -> ('\027', i + 2) | '\\' -> ('\\', i + 2) | '"' -> ('"', i + 2) | ''' -> (''', i + 2) | 'a' -> ('\007', i + 2) | 'b' -> ('\b', i + 2) | 'd' -> ('\255', i + 2) | 'f' -> ('\012', i + 2) | 'n' -> ('\n', i + 2) | 'r' -> ('\r', i + 2) | 't' -> ('\009', i + 2) | 'v' -> ('\011', i + 2) | 'x' -> if i + 2 < String.length s then match hex_value s.[i+2] with [ Some v -> if i + 3 < String.length s then match hex_value s.[i+3] with [ Some v1 -> (Char.chr (16 * v + v1), i + 4) | None -> (Char.chr v, i + 3) ] else (Char.chr v, i + 3) | None -> (s.[i], i + 1) ] else (s.[i], i + 1) | c -> match oct_value s.[i+1] with [ Some v -> if i + 2 < String.length s then match oct_value s.[i+2] with [ Some v1 -> let v = 8 * v + v1 in if i + 3 < String.length s then match oct_value s.[i+3] with [ Some v1 -> let v1 = 8 * v + v1 in if v1 <= 255 then (Char.chr v1, i + 4) else (Char.chr v, i + 3) | None -> (Char.chr v, i + 3) ] else (Char.chr v, i + 3) | None -> (Char.chr v, i + 2) ] else (Char.chr v, i + 2) | None -> (s.[i], i + 1) ] ] else (s.[i], i + 1) else (s.[i], i + 1) in Some (c, i) else None ; value insert_command s comm kb = let rec insert_in_tree i kb = match next_char s i with [ Some (c, i) -> let cnl = match kb with [ KB_tree cnl -> cnl | KB_comm _ | KB_none -> [] ] in KB_tree (insert_in_node_list (c, i) cnl) | None -> KB_comm comm ] and insert_in_node_list (c, i) = fun [ [] -> [{char = c; son = insert_in_tree i (KB_tree [])}] | [n :: nl] -> if c < n.char then [{char = c; son = insert_in_tree i (KB_tree [])}; n :: nl] else if c > n.char then [n :: insert_in_node_list (c, i) nl] else [{char = n.char; son = insert_in_tree i n.son} :: nl] ] in insert_in_tree 0 kb ; value init_default_commands kb = List.fold_left (fun kb (key, bind) -> insert_command key bind kb) kb [("\\C-a", Beginning_of_line); ("\\C-e", End_of_line); ("\\C-f", Forward_char); ("\\C-b", Backward_char); ("\\C-p", Previous_history); ("\\C-n", Next_history); ("\\C-r", Reverse_search_history); ("\\C-d", Delete_char_or_end_of_file); ("\\C-h", Backward_delete_char); ("\\177", Backward_delete_char); ("\\C-i", Complete_file_name); ("\\C-t", Transpose_chars); ("\\C-q", Quoted_insert); ("\\C-k", Kill_line); ("\\C-y", Yank); ("\\C-u", Unix_line_discard); ("\\C-l", Redraw_current_line); ("\\C-g", Abort); ("\\C-c", Interrupt); ("\\C-z", Suspend); ("\\C-\\", Quit); ("\\n", Accept_line); ("\\C-x", Operate_and_get_next); ("\\ef", Forward_word); ("\\eb", Backward_word); ("\\ec", Capitalize_word); ("\\eu", Upcase_word); ("\\el", Downcase_word); ("\\e<", Beginning_of_history); ("\\e>", End_of_history); ("\\ed", Kill_word); ("\\e\\C-h", Backward_kill_word); ("\\e\\177", Backward_kill_word); ("\\e/", Expand_abbrev); ("\\e[A", Previous_history); (* Up arrow *) ("\\e[B", Next_history); (* Down arrow *) ("\\e[C", Forward_char); (* Left arrow *) ("\\e[D", Backward_char); (* Right arrow *) ("\\e[3~", Delete_char); (* Delete *) ("\\e[H", Beginning_of_line); (* Home *) ("\\e[F", End_of_line); (* End *) ("\\e[5~", Previous_history); (* Page Up *) ("\\e[6~", Next_history); (* Page Down *) ("\\e[2H", Beginning_of_history); (* Shift Home *) ("\\e[2F", End_of_history); (* Shift End *) ("\\e[OA", Previous_history); ("\\e[OC", Forward_char); ("\\e[OD", Backward_char); ("\\e[OH", Beginning_of_line) :: if meta_as_escape.val then [("\\M-b", Backward_word); ("\\M-c", Capitalize_word); ("\\M-d", Kill_word); ("\\M-f", Forward_word); ("\\M-l", Downcase_word); ("\\M-u", Upcase_word); ("\\M-<", Beginning_of_history); ("\\M->", End_of_history); ("\\M-/", Expand_abbrev); ("\\M-\\C-h", Backward_kill_word); ("\\M-\\127", Backward_kill_word)] else []] ; (* Reading the leditrc file *) value rev_implode l = let s = String.create (List.length l) in loop (String.length s - 1) l where rec loop i = fun [ [c :: l] -> do { String.unsafe_set s i c; loop (i - 1) l } | [] -> s ] ; value rec parse_string rev_cl = fparser [ [: `'"' :] -> rev_implode rev_cl | [: `'\\'; `c; r = parse_string [c; '\\' :: rev_cl] :] -> r | [: `c; r = parse_string [c :: rev_cl] :] -> r ] ; value rec skip_to_eos = fparser [ [: `_; r = skip_to_eos :] -> r | [: :] -> () ] ; value rec skip_spaces = fparser [ [: `(' ' | '\t'); r = skip_spaces :] -> r | [: `'#'; r = skip_to_eos :] -> r | [: :] -> () ] ; value rec parse_command rev_cl = fparser [ [: `('a'..'z' | 'A'..'Z' | '-' as c); r = parse_command [c :: rev_cl] :] -> r | [: :] -> rev_implode rev_cl ] ; type binding = [ B_string of string | B_comm of string ]; value parse_binding = fparser [ [: `'"'; s = parse_string [] :] -> B_string s | [: c = parse_command [] :] -> B_comm c ] ; value parse_line = fparser [ [: `'"'; key = parse_string []; _ = skip_spaces; `':'; _ = skip_spaces; binding = parse_binding; _ = skip_spaces; _ = Fstream.empty :] -> (key, binding) ] ; value command_of_name = do { let ht = Hashtbl.create 1 in let add = Hashtbl.add ht in add "abort" Abort; add "accept-line" Accept_line; add "backward-char" Backward_char; add "backward-delete-char" Backward_delete_char; add "backward-kill-word" Backward_kill_word; add "backward-word" Backward_word; add "beginning-of-history" Beginning_of_history; add "beginning-of-line" Beginning_of_line; add "capitalize-word" Capitalize_word; add "delete-char" Delete_char; add "delete-char-or-end-of-file" Delete_char_or_end_of_file; add "downcase-word" Downcase_word; add "end-of-history" End_of_history; add "end-of-line" End_of_line; add "expand-abbrev" Expand_abbrev; add "complete-file-name" Complete_file_name; add "forward-char" Forward_char; add "forward-word" Forward_word; add "interrupt" Interrupt; add "kill-line" Kill_line; add "kill-word" Kill_word; add "next-history" Next_history; add "operate-and-get-next" Operate_and_get_next; add "previous-history" Previous_history; add "quit" Quit; add "quoted-insert" Quoted_insert; add "redraw-current-line" Redraw_current_line; add "reverse-search-history" Reverse_search_history; add "self-insert" Self_insert; add "suspend" Suspend; add "transpose-chars" Transpose_chars; add "unix-line-discard" Unix_line_discard; add "upcase-word" Upcase_word; add "yank" Yank; fun name -> try Some (Hashtbl.find ht name) with [ Not_found -> None (*failwith ("command not found: " ^ name)*) ] }; value init_file_commands kb fname = let ic = open_in fname in loop kb where rec loop kb = match try Some (input_line ic) with [ End_of_file -> None ] with [ Some s -> let kb = match parse_line (Fstream.of_string s) with [ Some ((key, B_string s), _) -> let s = loop [] 0 where rec loop rev_cl i = match next_char s i with [ Some (c, i) -> loop [c :: rev_cl] i | None -> rev_implode rev_cl ] in insert_command key (Insert s) kb | Some ((key, B_comm comm_name), _) -> match command_of_name comm_name with [ Some comm -> insert_command key comm kb | None -> kb ] | None -> kb ] in loop kb | None -> do { close_in ic; kb } ] ; type line = { buf : mutable A.String.t; cur : mutable int; len : mutable int } ; type abbrev_data = { hist : list A.String.t; rpos : int; clen : int; abbr : A.String.t; found : list A.String.t } ; type state = { od : line; nd : line; line : line; leditrc_name : string; leditrc_mtime : mutable float; last_line : mutable A.String.t; istate : mutable istate; shift : mutable int; cut : mutable A.String.t; init_kb : mutable option kb_tree; total_kb : mutable option kb_tree; last_comm : mutable command; histfile : mutable option out_channel; history : mutable Cursor.t A.String.t; abbrev : mutable option abbrev_data; complete_fn : mutable int; complete_fn_screen : mutable int} ; value eval_comm s st = let rec search_in_tree i kb = if i = String.length s then match kb with [ KB_tree _ -> Some None | KB_comm comm -> Some (Some comm) | KB_none -> None ] else let c = s.[i] in match kb with [ KB_tree cnl -> search_in_node_list c (i + 1) cnl | KB_comm _ | KB_none -> None ] and search_in_node_list c i = fun [ [] -> None | [n :: nl] -> if c < n.char then None else if c > n.char then search_in_node_list c i nl else search_in_tree i n.son ] in let kb = let leditrc_mtime = if Sys.file_exists st.leditrc_name then let stat = Unix.stat st.leditrc_name in if stat.Unix.st_mtime > st.leditrc_mtime then Some stat.Unix.st_mtime else None else None in match (leditrc_mtime, st.total_kb) with [ (None, Some kb) -> kb | _ -> do { let init_kb = match st.init_kb with [ Some kb -> kb | None -> do { let kb = init_default_commands KB_none in st.init_kb := Some kb; kb } ] in let total_kb = match leditrc_mtime with [ Some mtime -> do { st.leditrc_mtime := mtime; init_file_commands init_kb st.leditrc_name } | None -> init_kb ] in st.total_kb := Some total_kb; total_kb } ] in search_in_tree 0 kb ; value put_bs st c = A.Char.prerr_backsp c; value put_space st = output_char stderr ' '; value put_newline st = prerr_endline ""; value flush_out st = flush stderr; value bell () = do { prerr_string "\007"; flush stderr }; value saved_tcio = try Some (Unix.tcgetattr Unix.stdin) with [ Unix.Unix_error _ _ _ -> None ] ; value edit_tcio = ref None; value set_edit () = match saved_tcio with [ Some _ -> let tcio = match edit_tcio.val with [ Some e -> e | None -> do { let tcio = Unix.tcgetattr Unix.stdin in tcio.Unix.c_echo := False; tcio.Unix.c_icanon := False; tcio.Unix.c_vmin := 1; tcio.Unix.c_isig := False; tcio.Unix.c_ixon := False; edit_tcio.val := Some tcio; tcio } ] in Unix.tcsetattr Unix.stdin Unix.TCSADRAIN tcio | None -> () ] and unset_edit () = match saved_tcio with [ Some tcio -> Unix.tcsetattr Unix.stdin Unix.TCSADRAIN tcio | None -> () ] ; value line_set_nth_char line i c = if i == A.String.length line.buf then line.buf := A.String.concat line.buf (A.String.of_char c) else A.String.set line.buf i c ; value line_to_nd st = do { let rec line_rec i = do { if i == st.line.cur then st.nd.cur := st.nd.len else (); if i < st.line.len then do { let c = A.String.get st.line.buf i in if c = A.Char.of_ascii '\t' then for i = st.nd.len + 1 to (st.nd.len + 8) / 8 * 8 do { line_set_nth_char st.nd st.nd.len (A.Char.of_ascii ' '); st.nd.len := st.nd.len + 1; } else if match A.Char.ctrl_val c with [ Some c -> do { line_set_nth_char st.nd st.nd.len (A.Char.of_ascii '^'); line_set_nth_char st.nd (st.nd.len + 1) c; st.nd.len := st.nd.len + 2; True } | None -> False ] then () else match A.encoding.val with [ Ascii -> match A.Char.not_ascii_val c with [ Some (c1, c2, c3) -> do { line_set_nth_char st.nd st.nd.len (A.Char.of_ascii '\\'); line_set_nth_char st.nd (st.nd.len + 1) c1; line_set_nth_char st.nd (st.nd.len + 2) c2; line_set_nth_char st.nd (st.nd.len + 3) c3; st.nd.len := st.nd.len + 4; } | None -> do { line_set_nth_char st.nd st.nd.len c; st.nd.len := st.nd.len + 1 } ] | Iso_8859 -> match A.Char.meta_ctrl_val c with [ Some c -> do { line_set_nth_char st.nd st.nd.len (A.Char.of_ascii 'M'); line_set_nth_char st.nd (st.nd.len + 1) (A.Char.of_ascii '-'); line_set_nth_char st.nd (st.nd.len + 2) (A.Char.of_ascii '^'); line_set_nth_char st.nd (st.nd.len + 3) c; st.nd.len := st.nd.len + 4 } | None -> do { line_set_nth_char st.nd st.nd.len c; st.nd.len := st.nd.len + 1 } ] | Utf_8 -> do { line_set_nth_char st.nd st.nd.len c; st.nd.len := st.nd.len + 1 } ]; line_rec (i + 1) } else if st.nd.len > max_len.val then do { let shift = if st.nd.cur - st.shift >= 0 && st.nd.cur - st.shift < max_len.val - 2 then st.shift else if st.nd.cur < max_len.val - 3 then 0 else st.nd.cur - max_len.val / 2 in for i = 0 to max_len.val - 3 do { let ni = i + shift in A.String.set st.nd.buf i (if ni < st.nd.len then A.String.get st.nd.buf ni else A.Char.of_ascii ' '); }; A.String.set st.nd.buf (max_len.val - 2) (A.Char.of_ascii ' '); A.String.set st.nd.buf (max_len.val - 1) (if shift = 0 then A.Char.of_ascii '>' else if st.nd.len - shift < max_len.val - 2 then A.Char.of_ascii '<' else A.Char.of_ascii '*'); st.nd.cur := st.nd.cur - shift; st.nd.len := max_len.val; st.shift := shift } else st.shift := 0 } in st.nd.len := 0; line_rec 0 }; value display st = disp_rec 0 where rec disp_rec i = if i < st.nd.len then do { if i >= st.od.len || A.String.get st.od.buf i <> A.String.get st.nd.buf i then do { while i < st.od.cur do { st.od.cur := st.od.cur - 1; put_bs st (A.String.get st.od.buf i); }; while st.od.cur < i do { let c = A.String.get st.nd.buf st.od.cur in st.od.cur := st.od.cur + 1; A.Char.prerr c; }; let c = A.String.get st.nd.buf i in line_set_nth_char st.od i c; st.od.cur := st.od.cur + 1; A.Char.prerr c } else (); disp_rec (i + 1) } else do { if st.od.len > st.nd.len then do { while st.od.cur < st.od.len do { let c = if st.od.cur < st.nd.len then A.String.get st.nd.buf st.od.cur else A.Char.of_ascii ' ' in A.Char.prerr c; st.od.cur := st.od.cur + 1; }; while st.od.cur > st.nd.len do { st.od.cur := st.od.cur - 1; put_bs st (A.String.get st.od.buf st.od.cur); put_space st; put_bs st (A.Char.of_ascii ' '); } } else (); st.od.len := st.nd.len; while st.od.cur < st.nd.cur do { A.Char.prerr (A.String.get st.nd.buf st.od.cur); st.od.cur := st.od.cur + 1; }; while st.od.cur > st.nd.cur do { st.od.cur := st.od.cur - 1; put_bs st (A.String.get st.nd.buf st.od.cur); }; flush_out st } ; value update_output st = do {line_to_nd st; display st}; value balance_paren st c = match A.Char.to_ascii c with [ Some (')' | ']' | '}' as c) -> let i = find_lparen c (st.line.cur - 2) where rec find_lparen r i = if i < 0 then i else match A.Char.to_ascii (A.String.get st.line.buf i) with [ Some (')' | ']' | '}' as c) -> find_lparen r (find_lparen c (i - 1) - 1) | Some '(' -> if r == ')' then i else -1 | Some '[' -> if r == ']' then i else -1 | Some '{' -> if r == '}' then i else -1 | Some '"' -> let rec skip_string i = if i < 0 then i else if A.String.get st.line.buf i = A.Char.of_ascii '"' then i - 1 else skip_string (i - 1) in find_lparen r (skip_string (i - 1)) | _ -> find_lparen r (i - 1) ] in if i >= 0 then do { let c = st.line.cur in st.line.cur := i; update_output st; st.line.cur := c; let _ = Unix.select [Unix.stdin] [] [] 1.0 in () } else () | Some _ | None -> () ] ; value delete_char st = do { st.line.len := st.line.len - 1; for i = st.line.cur to st.line.len - 1 do { A.String.set st.line.buf i (A.String.get st.line.buf (i + 1)); } }; value insert_char st x = do { for i = st.line.len downto st.line.cur + 1 do { line_set_nth_char st.line i (A.String.get st.line.buf (i - 1)); }; st.line.len := st.line.len + 1; line_set_nth_char st.line st.line.cur x }; value move_in_word buf e f g = move_rec where rec move_rec i = if e i then i else if A.Char.is_word_char (A.String.get buf i) then f move_rec i else g move_rec i ; value forward_move line = move_in_word line.buf (fun i -> i == line.len); value backward_move line = move_in_word line.buf (fun i -> i == -1); value forward_word line = let i = line.cur in let i = forward_move line (fun _ i -> i) (fun mv i -> mv (i + 1)) i in forward_move line (fun mv i -> mv (i + 1)) (fun _ i -> i) i ; value backward_word line = let i = line.cur - 1 in let i = backward_move line (fun _ i -> i) (fun mv i -> mv (i - 1)) i in backward_move line (fun mv i -> mv (i - 1)) (fun _ i -> i) i + 1 ; value get_word_len st = let i = st.line.cur - 1 in i - backward_move st.line (fun mv i -> mv (i - 1)) (fun _ i -> i) i ; value kill_word st = let i = st.line.cur in let i = forward_move st.line (fun _ i -> i) (fun mv i -> do { delete_char st; mv i }) i in forward_move st.line (fun mv i -> do { delete_char st; mv i }) (fun _ i -> i) i ; value backward_kill_word st = do { let k = backward_word st.line in let sh = st.line.cur - k in st.line.len := st.line.len - sh; for i = k to st.line.len - 1 do { A.String.set st.line.buf i (A.String.get st.line.buf (i + sh)); }; k }; value capitalize_word st = let i = st.line.cur in let i0 = forward_move st.line (fun _ i -> i) (fun mv i -> mv (i + 1)) i in forward_move st.line (fun mv i -> do { let f = if i == i0 then A.Char.uppercase else A.Char.lowercase in A.String.set st.line.buf i (f (A.String.get st.line.buf i)); mv (i + 1) }) (fun _ i -> i) i0 ; value upcase_word st = let i = st.line.cur in let i = forward_move st.line (fun _ i -> i) (fun mv i -> mv (i + 1)) i in forward_move st.line (fun mv i -> do { let f = A.Char.uppercase in A.String.set st.line.buf i (f (A.String.get st.line.buf i)); mv (i + 1) }) (fun _ i -> i) i ; value downcase_word st = let i = st.line.cur in let i = forward_move st.line (fun _ i -> i) (fun mv i -> mv (i + 1)) i in forward_move st.line (fun mv i -> do { let f = A.Char.lowercase in A.String.set st.line.buf i (f (A.String.get st.line.buf i)); mv (i + 1) }) (fun _ i -> i) i ; value transpose_chars st = if st.line.cur == st.line.len then do { let c = A.String.get st.line.buf (st.line.cur - 1) in A.String.set st.line.buf (st.line.cur - 1) (A.String.get st.line.buf (st.line.cur - 2)); A.String.set st.line.buf (st.line.cur - 2) c; } else do { let c = A.String.get st.line.buf st.line.cur in A.String.set st.line.buf st.line.cur (A.String.get st.line.buf (st.line.cur - 1)); A.String.set st.line.buf (st.line.cur - 1) c; st.line.cur := st.line.cur + 1 } ; value set_line st str = do { st.line.len := 0; st.line.cur := 0; for i = 0 to A.String.length str - 1 do { insert_char st (A.String.get str i); st.line.cur := st.line.len; } }; value save_if_last st = if Cursor.is_last_line st.history then st.last_line := A.String.sub st.line.buf 0 st.line.len else () ; value previous_history st = try do { save_if_last st; Cursor.before st.history; set_line st (Cursor.peek st.history) } with [ Cursor.Failure -> bell () ] ; value next_history st = try do {Cursor.after st.history; set_line st (Cursor.peek st.history)} with [ Cursor.Failure -> set_line st st.last_line ] ; value reverse_search_history st = let question str = List.fold_left A.String.concat (A.String.of_ascii "(reverse-i-search)'") [str; A.String.of_ascii "': "] in let make_line str fstr = do { st.line.cur := 0; st.line.len := 0; let len = A.String.length str in for i = 0 to len - 1 do { insert_char st (A.String.get str i); st.line.cur := st.line.cur + 1; }; let len = A.String.length fstr in for i = 0 to len - 1 do { insert_char st (A.String.get fstr i); st.line.cur := st.line.cur + 1; } } in let initial_str = A.String.sub st.line.buf 0 st.line.len in let rec find_line (cnt, fstr) str = find_rec 0 0 where rec find_rec ifstr istr = if istr == A.String.length str then (cnt, fstr) else if ifstr == A.String.length fstr then if try do {Cursor.before st.history; True} with [ Cursor.Failure -> False ] then find_line (cnt + 1, Cursor.peek st.history) str else do {bell (); (cnt, fstr)} else if A.String.get str istr <> A.String.get fstr ifstr then find_rec (ifstr + 1) 0 else find_rec (ifstr + 1) (istr + 1) in let rec incr_search (cnt, fstr) str = do { let q = question str in make_line q fstr; st.line.cur := A.String.length q - 3; update_output st; let c = A.Char.read () in let s = A.Char.to_string c in match eval_comm s st with [ Some (Some comm) -> match comm with [ Backward_delete_char -> if A.String.length str == 0 then incr_search (cnt, fstr) str else do { let str = A.String.sub str 0 (A.String.length str - 1) in for i = 1 to cnt do { Cursor.after st.history }; incr_search (find_line (0, initial_str) str) str } | Reverse_search_history -> let (cnt, fstr) = try do { Cursor.before st.history; find_line (cnt + 1, Cursor.peek st.history) str } with [ Cursor.Failure -> do {bell (); (cnt, initial_str)} ] in incr_search (cnt, fstr) str | Abort -> do { for i = 1 to cnt do { Cursor.after st.history }; bell (); initial_str } | Self_insert -> let str = A.String.concat str (A.String.of_char c) in incr_search (find_line (cnt, fstr) str) str | _ -> fstr ] | Some None -> if s = "\027" then fstr else let str = A.String.concat str (A.String.of_char c) in incr_search (find_line (cnt, fstr) str) str | None -> let str = A.String.concat str (A.String.of_char c) in incr_search (find_line (cnt, fstr) str) str ] } in let fstr = incr_search (0, initial_str) A.String.empty in make_line A.String.empty fstr ; value rec beginning_of_history st = do { save_if_last st; Cursor.goto_first st.history; try set_line st (Cursor.peek st.history) with [ Cursor.Failure -> bell () ] }; value rec end_of_history st = do { Cursor.goto_last st.history; set_line st st.last_line }; value rec back_search st ad hist rpos = match hist with [ [] -> do { for i = 0 to A.String.length ad.abbr - 1 do { insert_char st (A.String.get ad.abbr i); st.line.cur := st.line.cur + 1; }; bell () } | [l :: ll] -> let i = A.String.length l - rpos in if i <= 0 then back_search st ad ll 0 else let i = backward_word {buf = l; cur = i; len = A.String.length l} in if A.String.length l - i < A.String.length ad.abbr then back_search st ad [l :: ll] (A.String.length l - i) else if A.String.sub l i (A.String.length ad.abbr) = ad.abbr then let i1 = forward_word {buf = l; cur = i; len = A.String.length l} in let f = A.String.sub l i (i1 - i) in if List.mem f ad.found then back_search st ad [l :: ll] (A.String.length l - i) else do { let ad = {hist = [l :: ll]; rpos = A.String.length l - i1; clen = i1 - i; abbr = ad.abbr; found = [f :: ad.found]} in st.abbrev := Some ad; for i = 0 to A.String.length f - 1 do { insert_char st (A.String.get f i); st.line.cur := st.line.cur + 1; } } else back_search st ad [l :: ll] (A.String.length l - i) ] ; value expand_abbrev st abbrev = do { let ad = match abbrev with [ Some x -> x | None -> let len = get_word_len st in let abbr = A.String.sub st.line.buf (st.line.cur - len) len in let line_beg = A.String.sub st.line.buf 0 (st.line.cur - len) in let line_end = A.String.sub st.line.buf st.line.cur (st.line.len - st.line.cur) in {hist = [line_beg :: Cursor.get_all st.history @ [line_end]]; rpos = 0; clen = len; abbr = abbr; found = [abbr]} ] in for i = 1 to ad.clen do { st.line.cur := st.line.cur - 1; delete_char st; }; back_search st ad ad.hist ad.rpos; update_output st }; value start_with s s_ini = let len = String.length s_ini in String.length s >= len && String.sub s 0 len = s_ini ; value insert_string st s = do { String.iter (fun c -> do { insert_char st (A.Char.of_ascii c); st.line.cur := st.line.cur + 1 }) s }; value is_directory fn = try Sys.is_directory fn with [ Sys_error _ -> False ] ; value print_file_list st max_flen nb_by_line dirname files = do { loop 0 files where rec loop n = fun [ [file :: files] -> do { if n = nb_by_line then do { prerr_endline ""; loop 0 [file :: files] } else do { prerr_string file; let fn = Filename.concat dirname file in if is_directory fn then prerr_string Filename.dir_sep else prerr_string " "; if n < nb_by_line - 1 then do { prerr_string (String.make (max_flen + 1 - String.length file) ' '); } else (); loop (n + 1) files; } } | [] -> () ]; }; value rev_take n list = loop [] n list where rec loop rev_list n = fun [ [x :: l] -> if n = 0 then (rev_list, [x :: l]) else loop [x :: rev_list] (n - 1) l | [] -> (rev_list, []) ] ; value max_lines_in_screen = ref 24; value complete_file_name st = do { let s = loop "" (st.line.cur - 1) where rec loop s i = if i < 0 then s else match A.Char.to_ascii (A.String.get st.line.buf i) with [ Some c -> match c with [ 'a'..'z' | 'A'..'Z' | '0'..'9' | '.' | '_' | '-' | '/' | '#' | '~' -> loop (String.make 1 c ^ s) (i - 1) | _ -> s ] | None -> s ] in let dirname = Filename.dirname s in let basename = Filename.basename s in if is_directory dirname then do { let files = Array.to_list (Sys.readdir dirname) in let (files, basename) = if s = "" then (files, "") else if s = Filename.current_dir_name ^ Filename.dir_sep then (files, "") else if s = Filename.parent_dir_name ^ Filename.dir_sep then (files, "") else if basename = Filename.current_dir_name && s <> Filename.concat dirname basename then (files, "") else ([Filename.current_dir_name; Filename.parent_dir_name :: files], basename) in let files = List.filter (fun fn -> start_with fn basename) files in let files = List.sort compare files in let max_flen = List.fold_left (fun max_len fn -> max max_len (String.length fn)) 0 files in let nb_by_line = max 1 ((max_len.val + 2) / (max_flen + 2)) in let nfiles = List.length files in let nb_lines = (nfiles + nb_by_line - 1) / nb_by_line in let mlis = max_lines_in_screen.val - 1 in let nb_screens = (nb_lines + mlis - 1) / mlis in let (files_to_display, screen_nb) = if nb_screens <= 1 then (files, 0) else do { let nb_files_by_screen = nb_by_line * mlis in let screen_nb = st.complete_fn_screen mod nb_screens in let rev_files = loop screen_nb files where rec loop n files = let (rev_files, rest) = rev_take nb_files_by_screen files in if n = 0 then rev_files else loop (n - 1) rest in st.complete_fn_screen := st.complete_fn_screen + 1; (List.rev (if screen_nb < nb_screens - 1 then ["..." :: rev_files] else rev_files), screen_nb) } in match files with [ [] -> () | [fname] -> do { let len = String.length basename in let s = String.sub fname len (String.length fname - len) in insert_string st s; let fn = Filename.concat dirname fname in if is_directory fn then insert_string st Filename.dir_sep else insert_string st " "; update_output st } | [file :: files] -> do { let common = loop file files where rec loop common = fun [ [file :: files] -> if start_with file common then loop common files else if common = "" then "" else loop (String.sub common 0 (String.length common - 1)) [file :: files] | [] -> common ] in let len = String.length basename in if String.length common > len then do { let s = String.sub common len (String.length common - len) in insert_string st s; update_output st; } else (); put_newline st; st.od.cur := 0; st.od.len := 0; prerr_string "*** files"; if nb_screens > 1 then eprintf " (%d/%d)" (screen_nb + 1) nb_screens else (); prerr_endline " ***"; print_file_list st max_flen nb_by_line dirname files_to_display; put_newline (); flush stderr; update_output st; } ] } else () }; value rec update_line st comm c = do { let abbrev = st.abbrev in st.abbrev := None; if comm = Complete_file_name then do { st.complete_fn := st.complete_fn + 1 } else do { st.complete_fn := 0; st.complete_fn_screen := 0; }; match comm with [ Beginning_of_line -> if st.line.cur > 0 then do {st.line.cur := 0; update_output st} else () | End_of_line -> if st.line.cur < st.line.len then do { st.line.cur := st.line.len; update_output st } else () | Forward_char -> if st.line.cur < st.line.len then do { st.line.cur := st.line.cur + 1; update_output st } else () | Backward_char -> if st.line.cur > 0 then do { st.line.cur := st.line.cur - 1; update_output st } else () | Forward_word -> if st.line.cur < st.line.len then do { st.line.cur := forward_word st.line; update_output st } else () | Backward_word -> if st.line.cur > 0 then do { st.line.cur := backward_word st.line; update_output st } else () | Capitalize_word -> if st.line.cur < st.line.len then do { st.line.cur := capitalize_word st; update_output st } else () | Upcase_word -> if st.line.cur < st.line.len then do { st.line.cur := upcase_word st; update_output st } else () | Downcase_word -> if st.line.cur < st.line.len then do { st.line.cur := downcase_word st; update_output st } else () | Previous_history -> do {previous_history st; update_output st} | Next_history -> do {next_history st; update_output st} | Beginning_of_history -> do {beginning_of_history st; update_output st} | End_of_history -> do {end_of_history st; update_output st} | Reverse_search_history -> do {reverse_search_history st; update_output st} | Delete_char_or_end_of_file -> do { if st.line.len = 0 then raise End_of_file else (); if st.line.cur < st.line.len then do {delete_char st; update_output st} else () } | Delete_char -> do { if st.line.cur < st.line.len then do {delete_char st; update_output st} else () } | Backward_delete_char -> if st.line.cur > 0 then do { st.line.cur := st.line.cur - 1; delete_char st; update_output st } else () | Transpose_chars -> if st.line.len > 1 && st.line.cur > 0 then do { transpose_chars st; update_output st } else () | Kill_word -> if st.line.cur < st.line.len then do { st.line.cur := kill_word st; update_output st } else () | Backward_kill_word -> if st.line.cur > 0 then do { st.line.cur := backward_kill_word st; update_output st } else () | Quoted_insert -> st.istate := Quote | Sequence s -> st.istate := Normal s | Self_insert -> do { insert_char st c; st.line.cur := st.line.cur + 1; balance_paren st c; update_output st } | Insert s -> do { let strm = Stream.of_string s in try while True do { insert_char st (A.Char.parse strm); st.line.cur := st.line.cur + 1; } with [ Stream.Failure -> () ]; update_output st } | Expand_abbrev -> expand_abbrev st abbrev | Complete_file_name -> complete_file_name st | Redraw_current_line -> do { put_newline st; st.od.cur := 0; st.od.len := 0; update_output st } | Kill_line -> do { st.cut := A.String.sub st.line.buf st.line.cur (st.line.len - st.line.cur); if st.line.len > st.line.cur then do { st.line.len := st.line.cur; update_output st } else () } | Unix_line_discard -> if st.line.cur > 0 then do { let len = st.line.len - st.line.cur in for i = 0 to len - 1 do { A.String.set st.line.buf i (A.String.get st.line.buf (st.line.cur + i)); }; st.line.cur := 0; st.line.len := len; update_output st } else () | Yank -> if A.String.length st.cut > 0 then do { for i = 0 to A.String.length st.cut - 1 do { insert_char st (A.String.get st.cut i); st.line.cur := st.line.cur + 1; }; update_output st } else () | Abort -> bell () | Interrupt -> do { if st.line.cur > 0 then do { st.line.cur := 0; st.line.len := 0; update_output st } else (); match son.val with [ Some pid -> Unix.kill pid Sys.sigint | _ -> () ] } | Suspend -> do { unset_edit (); Unix.kill (Unix.getpid ()) Sys.sigtstp; set_edit (); st.od.cur := 0; st.od.len := 0; update_output st } | Quit -> match son.val with [ Some pid -> Unix.kill pid Sys.sigquit | _ -> () ] | _ -> () ] }; value save_history st line = let last_line = try Cursor.peek_last st.history with [ Cursor.Failure -> A.String.empty ] in if line <> last_line && line <> A.String.empty then do { Cursor.insert_last st.history line; match st.histfile with [ Some fdo -> do { A.String.output fdo line; output_char fdo '\n'; flush fdo } | None -> () ] } else () ; value trace_sequences = ref False; local st = {od = {buf = A.String.empty; cur = 0; len = 0}; nd = {buf = A.String.empty; cur = 0; len = 0}; line = {buf = A.String.empty; cur = 0; len = 0}; leditrc_name = try Sys.getenv "LEDITRC" with [ Not_found -> try Filename.concat (Sys.getenv "HOME") ".leditrc" with [ Not_found -> ".leditrc" ] ] ; leditrc_mtime = 0.0; last_line = A.String.empty; istate = Normal ""; shift = 0; init_kb = None; total_kb = None; cut = A.String.empty; last_comm = Accept_line; histfile = None; history = Cursor.create (); abbrev = None; complete_fn = 0; complete_fn_screen = 0} in value edit_line () = do { let rec edit_loop () = do { let c = A.Char.read () in if trace_sequences.val then do { put_newline st; eprintf "<%s>\n" (String.escaped (A.Char.to_string c)); st.od.cur := 0; st.od.len := 0; update_output st } else (); let comm = match st.istate with [ Quote -> Self_insert | Normal s -> let s = s ^ A.Char.to_string c in match eval_comm s st with [ Some (Some comm) -> comm | Some None -> Sequence s | None -> Self_insert ] ] in st.istate := Normal ""; st.last_comm := comm; match comm with [ Accept_line | Operate_and_get_next -> do { let v_max_len = max_len.val in max_len.val := 10000; update_output st; max_len.val := v_max_len; put_newline st; let line = A.String.sub st.line.buf 0 st.line.len in st.abbrev := None; save_history st line; line } | _ -> do { update_line st comm c; edit_loop () } ] } in st.od.len := 0; st.od.cur := 0; st.line.len := 0; st.line.cur := 0; if st.last_comm = Operate_and_get_next then try do { (* small temporization to give time to ledit associated command to display the line sent; this is not ideal because we should wait for the associated command prompt, but we do not know when it happens *) let _ = Unix.select [] [] [] 0.001 in Cursor.after st.history; set_line st (Cursor.peek st.history); update_output st } with [ Cursor.Failure -> () ] else Cursor.goto_last st.history; edit_loop () } and open_histfile trunc file = do { if not trunc then match try Some (open_in file) with _ -> None with [ Some fi -> do { try while True do { Cursor.insert st.history (A.String.input_line fi); } with [ End_of_file -> () ]; close_in fi } | _ -> () ] else (); let fd = Unix.openfile file ([Unix.O_WRONLY; Unix.O_CREAT] @ (if trunc then [Unix.O_TRUNC] else [])) 0o666 in let fdo = Unix.out_channel_of_descr fd in if not trunc then seek_out fdo (out_channel_length fdo) else (); st.histfile := Some fdo } and close_histfile () = match st.histfile with [ Some fdo -> close_out fdo | None -> () ] ; value (set_prompt, get_prompt, input_a_char) = let prompt = ref "" and buff = ref A.String.empty and ind = ref 1 in let set_prompt x = prompt.val := x and get_prompt () = prompt.val and input_a_char ic = if ic != stdin then A.Char.input ic else do { if ind.val > A.String.length buff.val then do { prerr_string prompt.val; flush stderr; try do { set_edit (); buff.val := edit_line (); unset_edit ()} with e -> do { unset_edit (); raise e }; ind.val := 0 } else (); let c = if ind.val == A.String.length buff.val then A.Char.of_ascii '\n' else A.String.get buff.val ind.val in ind.val := ind.val + 1; c } in (set_prompt, get_prompt, input_a_char) ; value input_char ic = A.Char.to_string (input_a_char ic); ledit-2.03/go.ml0000600006260700512610000001142011714435154013670 0ustar derauglaaosteroc(***********************************************************************) (* *) (* Ledit *) (* *) (* Daniel de Rauglaudre, INRIA Rocquencourt *) (* *) (* Copyright 2001-2010 Institut National de Recherche en Informatique *) (* et Automatique. Distributed only by permission. *) (* *) (***********************************************************************) (* $Id: go.ml,v 1.55 2012-02-08 09:03:40 deraugla Exp $ *) open Ledit; open Sys; value version = "2.03"; value usage () = do { prerr_string "Usage: "; prerr_string argv.(0); prerr_endline " [options] [comm [args]]"; prerr_endline " -a : ascii encoding"; prerr_endline " -h file : history file"; prerr_endline " -x : don't remove old contents of history"; prerr_endline " -l len : line max length"; prerr_endline " -t : trace sequences (for debugging)"; prerr_endline " -u : utf-8 encoding"; prerr_endline " -v : prints ledit version and exit"; prerr_endline "Exec comm [args] as child process"; }; value get_arg i = if i >= Array.length argv then do { usage (); exit 1 } else argv.(i); value histfile = ref ""; value trunc = ref True; value comm = ref "cat"; value args = ref [| "cat" |]; arg_loop 1 where rec arg_loop i = if i < Array.length argv then arg_loop (match argv.(i) with [ "-a" -> do { set_ascii (); i + 1 } | "-h" -> do { histfile.val := get_arg (i + 1); i + 2 } | "-help" -> do { usage (); exit 0 } | "-l" -> do { let x = get_arg (i + 1) in try set_max_len (int_of_string x) with _ -> do { usage (); exit 1 }; i + 2 } | "-x" -> do { trunc.val := False; i + 1 } | "-t" -> do { trace_sequences.val := True; i + 1 } | "-u" -> do { set_utf8 (); unset_meta_as_escape (); i + 1 } | "-v" -> do { Printf.printf "Ledit version %s\n" version; flush stdout; exit 0 } | _ -> if i < Array.length argv then do { if argv.(i).[0] = '-' then do { prerr_endline ("Illegal option " ^ argv.(i)); prerr_endline "Use option -help for usage"; exit 1 } else do { comm.val := argv.(i); args.val := Array.sub argv i (Array.length argv - i); Array.length argv } } else Array.length argv ]) else () ; value string_of_signal = fun [ 2 -> "Interrupted" | 3 -> "Quit" | 10 -> "Bus error" | 11 -> "Segmentation fault" | x -> "Signal " ^ string_of_int x ] ; value rec read_loop () = do { try let c = input_char stdin in if c = "\n" then print_newline () else print_string c with [ Break -> () ]; read_loop () }; value stupid_hack_to_avoid_sys_error_at_exit () = Unix.dup2 (Unix.openfile "/dev/null" [Unix.O_WRONLY] 0) Unix.stdout ; value go () = let (id, od) = Unix.pipe () in let pid = Unix.fork () in if pid < 0 then failwith "fork" else if pid > 0 then do { Unix.dup2 od Unix.stdout; Unix.close id; Unix.close od; set_son_pid pid; let _ = (signal sigchld (Signal_handle (fun _ -> match snd (Unix.waitpid [Unix.WNOHANG] pid) with [ Unix.WSIGNALED sign -> do { prerr_endline (string_of_signal sign); flush stderr; raise End_of_file } | _ -> raise End_of_file ])) : signal_behavior) in try do { if histfile.val <> "" then open_histfile trunc.val histfile.val else (); catch_break True; read_loop () } with x -> do { let _ = (signal sigchld Signal_ignore : signal_behavior) in try do { Unix.close Unix.stdout; let _ = Unix.wait () in () } with [ Unix.Unix_error _ _ _ -> () ]; stupid_hack_to_avoid_sys_error_at_exit (); match x with [ End_of_file -> () | _ -> do { prerr_string "(ledit) "; flush stderr; raise x } ] } } else do { Unix.dup2 id Unix.stdin; Unix.close id; Unix.close od; Unix.execvp comm.val args.val } ; value handle f a = try f a with [ Unix.Unix_error code fname param -> do { Printf.eprintf "Unix error: %s\nOn function %s %s\n" (Unix.error_message code) fname param; flush stderr; exit 2 } | e -> Printexc.catch raise e ] ; handle go (); ledit-2.03/.cvsignore0000600006260700512610000000004410437204225014723 0ustar derauglaaosteroc*.cm[oi] *.pp[oi] ledit.out ledit.1 ledit-2.03/cursor.ml0000600006260700512610000000461110736505204014601 0ustar derauglaaosteroc(***********************************************************************) (* *) (* Ledit *) (* *) (* Daniel de Rauglaudre, INRIA Rocquencourt *) (* *) (* Copyright 2001-2006 Institut National de Recherche en Informatique *) (* et Automatique. Distributed only by permission. *) (* *) (***********************************************************************) (* $Id: cursor.ml,v 1.8 2008-01-01 18:46:28 deraugla Exp $ *) type t 'a = { before : mutable list 'a; current : mutable option 'a; after : mutable list 'a } ; exception Failure; value create () = {before = []; current = None; after = []}; value before c = match c.before with [ [] -> raise Failure | [x :: l] -> do { match c.current with [ Some y -> c.after := [y :: c.after] | _ -> () ]; c.current := Some x; c.before := l } ] ; value after c = match c.current with [ None -> raise Failure | Some y -> do { c.before := [y :: c.before]; match c.after with [ [] -> c.current := None | [x :: l] -> do { c.current := Some x; c.after := l } ] } ] ; value is_last_line c = c.current = None; value insert c x = do { match c.current with [ Some y -> c.before := [y :: c.before] | None -> () ]; c.current := Some x }; value insert_last c x = match c.current with [ Some _ -> c.after := c.after @ [x] | None -> c.current := Some x ] ; value peek c = match c.current with [ Some y -> y | None -> raise Failure ] ; value peek_last c = let rec peek_rec = fun [ [] -> raise Failure | [x] -> x | [_ :: l] -> peek_rec l ] in match (c.before, c.current, c.after) with [ (_, Some x, []) -> x | ([x :: _], None, []) -> x | (_, _, l) -> peek_rec l ] ; value rec goto_first c = try while True do { before c } with [ Failure -> () ] ; value rec goto_last c = try while True do { after c } with [ Failure -> () ] ; value get_all c = let end_list = match c.current with [ Some y -> [y :: c.after] | None -> c.after ] in List.rev_append c.before end_list ; ledit-2.03/META.tpl0000644006260700512610000000025711471442273014216 0ustar derauglaaosterocname="ledit" version="LEDIT_VERSION" description="Line editing for interactive commands" requires="unix,camlp5.gramlib" archive(byte)="ledit.cma" archive(native)="ledit.cmxa" ledit-2.03/leditrc0000644006260700512610000000236111470757710014322 0ustar derauglaaosteroc"\C-a": beginning-of-line "\C-e": end-of-line "\C-f": forward-char "\C-b": backward-char "\C-p": previous-history "\C-n": next-history "\C-r": reverse-search-history "\C-d": delete-char-or-end-of-file "\C-h": backward-delete-char "\177": backward-delete-char "\C-i": complete-file-name "\C-t": transpose-chars "\C-q": quoted-insert "\C-k": kill-line "\C-y": yank "\C-u": unix-line-discard "\C-l": redraw-current-line "\C-g": abort "\C-c": interrupt "\C-z": suspend "\C-\": quit "\n": accept-line "\C-x": operate-and-get-next "\ef": forward-word "\eb": backward-word "\ec": capitalize-word "\eu": upcase-word "\el": downcase-word "\e<": beginning-of-history "\e>": end-of-history "\ed": kill-word "\e\C-h": backward-kill-word "\e\177": backward-kill-word "\e/": expand-abbrev "\e[A": previous-history # Up arrow "\e[B": next-history # Down arrow "\e[C": forward-char # Left arrow "\e[D": backward-char # Right arrow "\e[3~": delete-char # Delete "\e[H": beginning-of-line # Home "\e[F": end-of-line # End "\e[5~": previous-history # Page Up "\e[6~": next-history # Page Down "\e[2H": beginning-of-history # Shift Home "\e[2F": end-of-history # Shift End "\e[OA": previous-history "\e[OC": forward-char "\e[OD": backward-char "\e[OH": beginning-of-line ledit-2.03/.depend0000600006260700512610000000023007312616672014173 0ustar derauglaaosteroccursor.cmo: cursor.cmi cursor.cmx: cursor.cmi ledit.cmo: cursor.cmi ledit.cmi ledit.cmx: cursor.cmx ledit.cmi go.cmo: ledit.cmi go.cmx: ledit.cmx ledit-2.03/README0000600006260700512610000000104111714435154013607 0ustar derauglaaosteroc OVERVIEW: Ledit is a line editor, allowing to use control commands like in emacs or in shells (bash, tcsh). To be used with interactive commands. It is written in OCaml and uses the library unix.cma. To compile, you need OCaml and Camlp5. They are free of charge and downloadable on the Web. COPYRIGHT: All files in this distribution are copyright 2001-2012 Institut National de Recherche en Informatique et Automatique (Inria). BUG REPORTS AND USER FEEDBACK: Send your bug reports by E-mail to: daniel.de_rauglaudre@inria.fr ledit-2.03/ext/0000755006260700512610000000000011714435504013542 5ustar derauglaaosterocledit-2.03/ext/pa_local.ml0000644006260700512610000000277710546675226015674 0ustar derauglaaosteroc(***********************************************************************) (* *) (* Ledit *) (* *) (* Daniel de Rauglaudre, INRIA Rocquencourt *) (* *) (* Copyright 2001-2007 Institut National de Recherche en Informatique *) (* et Automatique. Distributed only by permission. *) (* *) (***********************************************************************) (* $Id: pa_local.ml,v 1.4 2007-01-03 09:42:46 deraugla Exp $ *) #load "pa_extend.cmo"; #load "q_MLast.cmo"; open Pcaml; value expr_of_patt p = let loc = MLast.loc_of_patt p in match p with [ <:patt< $lid:x$ >> -> <:expr< $lid:x$ >> | _ -> Stdpp.raise_with_loc loc (Stream.Error "identifier expected") ] ; EXTEND str_item: [ [ "local"; rf = [ "rec" -> True | -> False ]; lb = LIST1 let_binding SEP "and"; "in"; "value"; rf1 = [ "rec" -> True | -> False ]; lb1 = LIST1 let_binding SEP "and" -> let pl = List.map fst lb1 in let el = List.map expr_of_patt pl in <:str_item< value ($list:pl$) = let $opt:rf$ $list:lb$ in let $opt:rf1$ $list:lb1$ in ($list:el$) >> ] ] ; END; ledit-2.03/ext/pa_def.ml0000644006260700512610000002116510646632113015315 0ustar derauglaaosteroc(* $Id: pa_def.ml,v 1.3 2007-07-16 09:03:07 deraugla Exp $ *) #load "pa_extend.cmo"; #load "q_MLast.cmo"; #load "pa_macro.cmo"; open Pcaml; Stdpp.loc_name.val := "loc"; type item_or_def 'a = [ SdStr of 'a | SdDef of string and option (list string * MLast.expr) | SdUnd of string | SdNop ] ; value rec list_remove x = fun [ [(y, _) :: l] when y = x -> l | [d :: l] -> [d :: list_remove x l] | [] -> [] ] ; value defined = ref (IFDEF CAMLP5 THEN [("CAMLP5", None)] ELSE [] END); value is_defined i = List.mem_assoc i defined.val; value loc = Grammar.loc_of_token_interval 0 0; value _loc = loc; value subst mloc env = loop where rec loop = fun [ <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> let pel = List.map (fun (p, e) -> (p, loop e)) pel in <:expr< let $opt:rf$ $list:pel$ in $loop e$ >> | <:expr< if $e1$ then $e2$ else $e3$ >> -> <:expr< if $loop e1$ then $loop e2$ else $loop e3$ >> | <:expr< $e1$ $e2$ >> -> <:expr< $loop e1$ $loop e2$ >> | <:expr< $lid:x$ >> | <:expr< $uid:x$ >> as e -> try <:expr< $anti:List.assoc x env$ >> with [ Not_found -> e ] | <:expr< ( $list:x$ ) >> -> <:expr< ( $list:List.map loop x$ ) >> | <:expr< { $list:pel$ } >> -> let pel = List.map (fun (p, e) -> (p, loop e)) pel in <:expr< { $list:pel$ } >> | e -> e ] ; value substp mloc env = loop where rec loop = fun [ <:expr< $e1$ $e2$ >> -> <:patt< $loop e1$ $loop e2$ >> | <:expr< $chr:c$ >> -> <:patt< $chr:c$ >> | <:expr< $lid:x$ >> -> try <:patt< $anti:List.assoc x env$ >> with [ Not_found -> <:patt< $lid:x$ >> ] | <:expr< $uid:x$ >> -> try <:patt< $anti:List.assoc x env$ >> with [ Not_found -> <:patt< $uid:x$ >> ] | <:expr< $int:x$ >> -> <:patt< $int:x$ >> | <:expr< ( $list:x$ ) >> -> <:patt< ( $list:List.map loop x$ ) >> | <:expr< { $list:pel$ } >> -> let ppl = List.map (fun (p, e) -> (p, loop e)) pel in <:patt< { $list:ppl$ } >> | x -> Stdpp.raise_with_loc mloc (Failure "this macro cannot be used in a pattern (see its definition)") ] ; value cannot_eval e = let loc = MLast.loc_of_expr e in Stdpp.raise_with_loc loc (Stream.Error "can't eval") ; value rec eval = fun [ <:expr< Char.chr $e$ >> -> match eval e with [ <:expr< $int:i$ >> -> let c = Char.escaped (Char.chr (int_of_string i)) in <:expr< $chr:c$ >> | e -> cannot_eval e ] | <:expr< Char.code $e$ >> -> match eval e with [ <:expr< $chr:c$ >> -> let i = string_of_int (Char.code (Token.eval_char c)) in <:expr< $int:i$ >> | e -> cannot_eval e ] | <:expr< $op$ $x$ $y$ >> -> let f = eval op in let x = eval x in let y = eval y in match (x, y) with [ (<:expr< $int:x$ >>, <:expr< $int:y$ >>) -> let x = int_of_string x in let y = int_of_string y in match f with [ <:expr< $lid:"+"$ >> -> <:expr< $int:string_of_int (x + y)$ >> | <:expr< $lid:"-"$ >> -> <:expr< $int:string_of_int (x - y)$ >> | <:expr< $lid:"lor"$ >> -> let s = Printf.sprintf "0o%o" (x lor y) in <:expr< $int:s$ >> | _ -> cannot_eval op ] | _ -> cannot_eval op ] | <:expr< $uid:x$ >> as e -> try match List.assoc x defined.val with [ _ -> e ] with [ Not_found -> e ] | <:expr< $lid:_$ >> | <:expr< $chr:_$ >> | <:expr< $int:_$ >> as e -> e | e -> cannot_eval e ] ; value may_eval = fun [ <:expr< EVAL $e$ >> -> eval e | e -> e ] ; value incorrect_number loc l1 l2 = Stdpp.raise_with_loc loc (Failure (Printf.sprintf "expected %d parameters; found %d" (List.length l2) (List.length l1))) ; value first_pos = IFDEF CAMLP5 THEN Stdpp.first_pos ELSE fst END; value define eo x = do { let gloc = loc in match eo with [ Some ([], e) -> EXTEND expr: LEVEL "simple" [ [ UIDENT $x$ -> may_eval (Pcaml.expr_reloc (fun _ -> loc) (first_pos gloc) e) ] ] ; patt: LEVEL "simple" [ [ UIDENT $x$ -> let p = substp loc [] e in Pcaml.patt_reloc (fun _ -> loc) (first_pos gloc) p ] ] ; END | Some (sl, e) -> EXTEND expr: LEVEL "apply" [ [ UIDENT $x$; param = SELF -> let el = match param with [ <:expr< ($list:el$) >> -> el | e -> [e] ] in if List.length el = List.length sl then let env = List.combine sl el in let e = subst loc env e in may_eval (Pcaml.expr_reloc (fun _ -> loc) (first_pos gloc) e) else incorrect_number loc el sl ] ] ; patt: LEVEL "simple" [ [ UIDENT $x$; param = SELF -> let pl = match param with [ <:patt< ($list:pl$) >> -> pl | p -> [p] ] in if List.length pl = List.length sl then let env = List.combine sl pl in let p = substp loc env e in Pcaml.patt_reloc (fun _ -> loc) (first_pos gloc) p else incorrect_number loc pl sl ] ] ; END | None -> () ]; defined.val := [(x, eo) :: defined.val]; } ; value undef x = try do { let eo = List.assoc x defined.val in match eo with [ Some ([], _) -> do { DELETE_RULE expr: UIDENT $x$ END; DELETE_RULE patt: UIDENT $x$ END; } | Some (_, _) -> do { DELETE_RULE expr: UIDENT $x$; SELF END; DELETE_RULE patt: UIDENT $x$; SELF END; } | None -> () ]; defined.val := list_remove x defined.val; } with [ Not_found -> () ] ; EXTEND GLOBAL: expr patt str_item sig_item; str_item: FIRST [ [ x = macro_def -> match x with [ SdStr [si] -> si | SdStr sil -> <:str_item< declare $list:sil$ end >> | SdDef x eo -> do { define eo x; <:str_item< declare end >> } | SdUnd x -> do { undef x; <:str_item< declare end >> } | SdNop -> <:str_item< declare end >> ] ] ] ; macro_def: [ [ "DEFINE"; i = uident; def = opt_macro_value -> SdDef i def | "UNDEF"; i = uident -> SdUnd i | "IFDEF"; i = uident; "THEN"; d = str_item_or_macro; "END" -> if is_defined i then d else SdNop | "IFDEF"; i = uident; "THEN"; d1 = str_item_or_macro; "ELSE"; d2 = str_item_or_macro; "END" -> if is_defined i then d1 else d2 | "IFNDEF"; i = uident; "THEN"; d = str_item_or_macro; "END" -> if is_defined i then SdNop else d | "IFNDEF"; i = uident; "THEN"; d1 = str_item_or_macro; "ELSE"; d2 = str_item_or_macro; "END" -> if is_defined i then d2 else d1 ] ] ; str_item_or_macro: [ [ d = macro_def -> d | si = LIST1 str_item -> SdStr si ] ] ; opt_macro_value: [ [ "("; pl = LIST1 LIDENT SEP ","; ")"; "="; e = expr -> Some (pl, e) | "="; e = expr -> Some ([], e) | -> None ] ] ; expr: LEVEL "top" [ [ "IFDEF"; idl = LIST1 id_then_expr SEP "ELSIFDEF"; "ELSE"; e2 = expr; "END" -> loop idl where rec loop = fun [ [(i, e) :: idl] -> if is_defined i then e else loop idl | [] -> e2 ] | "IFNDEF"; i = uident; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" -> if is_defined i then e2 else e1 ] ] ; id_then_expr: [ [ i = uident; "THEN"; e = expr -> (i, e) ] ] ; expr: LEVEL "simple" [ [ LIDENT "__FILE__" -> <:expr< $str:Pcaml.input_file.val$ >> ] ] ; patt: [ [ "IFDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; "END" -> if is_defined i then p1 else p2 | "IFNDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; "END" -> if is_defined i then p2 else p1 ] ] ; uident: [ [ i = UIDENT -> i ] ] ; END; Pcaml.add_option "-D" (Arg.String (define None)) " Define for IFDEF instruction." ; Pcaml.add_option "-U" (Arg.String undef) " Undefine for IFDEF instruction." ; if Sys.ocaml_version >= "3.07" then defined.val := [("OCAML_307", None) :: defined.val] else (); if Sys.ocaml_version >= "3.08" then defined.val := [("OCAML_308", None) :: defined.val] else (); if Sys.ocaml_version >= "3.09" then defined.val := [("OCAML_309", None) :: defined.val] else (); ledit-2.03/ext/pr_local.ml0000644006260700512610000000440010546675226015676 0ustar derauglaaosteroc(* $Id: pr_local.ml,v 1.2 2007-01-03 09:42:46 deraugla Exp $ *) (* Copyright (c) 2001-2007 INRIA *) #load "q_MLast.cmo"; #load "pa_extfun.cmo"; open Pcaml; open Spretty; value _loc = Token.dummy_loc; value expr e dg k = pr_expr.pr_fun "top" e dg k; value patt e dg k = pr_patt.pr_fun "top" e dg k; value expr_fun_args ge = Extfun.apply pr_expr_fun_args.val ge; value is_local_def p pel1 pel2 e = try let dl1 = let pl = match p with [ <:patt< ($list:pl$) >> -> pl | p -> [p] ] in List.map (fun [ <:patt< $lid:s$ >> -> s | _ -> raise Not_found ]) pl in let (dl2, el) = let (pl, el) = List.split pel2 in let dl2 = List.map (fun [ <:patt< $lid:s$ >> -> s | _ -> raise Not_found ]) pl in (dl2, el) in let dl3 = let el = match e with [ <:expr< ($list:el$) >> -> el | e -> [e] ] in List.map (fun [ <:expr< $lid:s$ >> -> s | _ -> raise Not_found ]) el in dl1 = dl2 && dl1 = dl3 with [ Not_found -> False ] ; value rec list elem = fun [ [] -> fun _ k -> k | [x] -> fun dg k -> [: `elem x dg k :] | [x :: l] -> fun dg k -> [: `elem x "" [: :]; list elem l dg k :] ] ; value rec listwbws elem b sep el k = match el with [ [] -> [: b; k :] | [x] -> [: `elem b x k :] | [x :: l] -> [: `elem b x [: :]; listwbws elem [: `sep :] sep l k :] ] ; value rec bind_list b pel k = match pel with [ [pe] -> let_binding b pe k | pel -> Vbox [: `HVbox [: :]; listwbws let_binding b (S LR "and") pel k :] ] and let_binding b (p, e) k = BEbox [: let_binding0 [: b; `patt p "" [: :] :] e [: :]; k :] and let_binding0 b e k = let (pl, e) = expr_fun_args e in [: `HVbox [: `HVbox b; `HOVbox (list patt pl "" [: `S LR "=" :]) :]; `expr e "" k :] ; let lev = find_pr_level "top" pr_str_item.pr_levels in lev.pr_rules := extfun lev.pr_rules with [ <:str_item< value $p$ = let $p1$ = $e1$ in let $list:pel2$ in $e$ >> when is_local_def p [(p1, e1)] pel2 e -> fun curr next _ k -> let pel1 = [(p1, e1)] in let r = [: :] in [: `Vbox [: `HVbox [: :]; `bind_list [: `S LR "local"; r :] pel1 [: `S LR "in" :]; curr <:str_item< value $list:pel2$ >> "" k :] :] ]; ledit-2.03/ledit.spec0000600006260700512610000000123207452530443014707 0ustar derauglaaosteroc# $Id: ledit.spec,v 1.6 2002-04-03 07:37:07 ddr Exp $ Name: ledit Version: 1.11 Release: 1 Packager: Daniel de Rauglaudre Summary: Line editor Source0: ledit-%{version}.tar.gz Copyright: BSD Group: Development/Tools URL: http://cristal.inria.fr/~ddr/ BuildRoot: /var/tmp/ledit %description A line editor for interactive programs. %prep %setup %build make %install mkdir -p $RPM_BUILD_ROOT%{_prefix}/bin $RPM_BUILD_ROOT%{_prefix}/man/manl cp ledit.out $RPM_BUILD_ROOT%{_prefix}/bin/ledit cp ledit.l $RPM_BUILD_ROOT%{_prefix}/man/manl/ledit.l %clean rm -rf $RPM_BUILD_ROOT %files %{_prefix}/bin/ledit %{_prefix}/man/manl/ledit.l ledit-2.03/cursor.mli0000600006260700512610000000224710736505204014755 0ustar derauglaaosteroc(***********************************************************************) (* *) (* Ledit *) (* *) (* Daniel de Rauglaudre, INRIA Rocquencourt *) (* *) (* Copyright 2001-2008 Institut National de Recherche en Informatique *) (* et Automatique. Distributed only by permission. *) (* *) (***********************************************************************) (* $Id: cursor.mli,v 1.7 2008-01-01 18:46:28 deraugla Exp $ *) type t 'a = 'x; exception Failure; value create : unit -> t 'a; value before : t 'a -> unit; value after : t 'a -> unit; value insert : t 'a -> 'a -> unit; value insert_last : t 'a -> 'a -> unit; value peek : t 'a -> 'a; value peek_last : t 'a -> 'a; value goto_first : t 'a -> unit; value goto_last : t 'a -> unit; value get_all : t 'a -> list 'a; value is_last_line : t 'a -> bool; ledit-2.03/ledit.mli0000600006260700512610000000227010743346540014541 0ustar derauglaaosteroc(***********************************************************************) (* *) (* Ledit *) (* *) (* Daniel de Rauglaudre, INRIA Rocquencourt *) (* *) (* Copyright 1997-2008 Institut National de Recherche en Informatique *) (* et Automatique. Distributed only by permission. *) (* *) (***********************************************************************) (* $Id: ledit.mli,v 1.13 2008-01-16 09:24:48 deraugla Exp $ *) value input_char : in_channel -> string; value set_prompt : string -> unit; value get_prompt : unit -> string; value open_histfile : bool -> string -> unit; value close_histfile : unit -> unit; value set_max_len : int -> unit; value set_son_pid : int -> unit; value unset_meta_as_escape : unit -> unit; value set_utf8 : unit -> unit; value set_ascii : unit -> unit; value trace_sequences : ref bool;