diff --git a/Makefile b/Makefile index 9f341a4..377de83 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ # Build the cpdf command line tools and top level -MODS = cpdfyojson cpdfstream tjutil tjutf16 tjllist tjparsermonad tjjson \ - cpdfxmlm cpdferror cpdfjson cpdfstrftime cpdfcoord cpdfattach \ +MODS = cpdfyojson cpdfxmlm \ + cpdferror cpdfjson cpdfstrftime cpdfcoord cpdfattach \ cpdfpagespec cpdfposition cpdf cpdfcommand SOURCES = $(foreach x,$(MODS),$(x).ml $(x).mli) cpdfcommandrun.ml diff --git a/cpdfstream.ml b/cpdfstream.ml deleted file mode 100644 index 2bfef70..0000000 --- a/cpdfstream.ml +++ /dev/null @@ -1,236 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -type 'a t = 'a cell option -and 'a cell = { mutable count : int; mutable data : 'a data } -and 'a data = - Sempty - | Scons of 'a * 'a data - | Sapp of 'a data * 'a data - | Slazy of 'a data Lazy.t - | Sgen of 'a gen - | Sbuffio : buffio -> char data -and 'a gen = { mutable curr : 'a option option; func : int -> 'a option } -and buffio = - { ic : in_channel; buff : bytes; mutable len : int; mutable ind : int } - -exception Failure -exception Error of string - -let count = function - | None -> 0 - | Some { count } -> count -let data = function - | None -> Sempty - | Some { data } -> data - -let fill_buff b = - b.len <- input b.ic b.buff 0 (Bytes.length b.buff); b.ind <- 0 - - -let rec get_data : type v. int -> v data -> v data = fun count d -> match d with - (* Returns either Sempty or Scons(a, _) even when d is a generator - or a buffer. In those cases, the item a is seen as extracted from - the generator/buffer. - The count parameter is used for calling `Sgen-functions'. *) - Sempty | Scons (_, _) -> d - | Sapp (d1, d2) -> - begin match get_data count d1 with - Scons (a, d11) -> Scons (a, Sapp (d11, d2)) - | Sempty -> get_data count d2 - | _ -> assert false - end - | Sgen {curr = Some None} -> Sempty - | Sgen ({curr = Some(Some a)} as g) -> - g.curr <- None; Scons(a, d) - | Sgen g -> - begin match g.func count with - None -> g.curr <- Some(None); Sempty - | Some a -> Scons(a, d) - (* Warning: anyone using g thinks that an item has been read *) - end - | Sbuffio b -> - if b.ind >= b.len then fill_buff b; - if b.len == 0 then Sempty else - let r = Bytes.unsafe_get b.buff b.ind in - (* Warning: anyone using g thinks that an item has been read *) - b.ind <- succ b.ind; Scons(r, d) - | Slazy f -> get_data count (Lazy.force f) - - -let rec peek_data : type v. v cell -> v option = fun s -> - (* consult the first item of s *) - match s.data with - Sempty -> None - | Scons (a, _) -> Some a - | Sapp (_, _) -> - begin match get_data s.count s.data with - Scons(a, _) as d -> s.data <- d; Some a - | Sempty -> None - | _ -> assert false - end - | Slazy f -> s.data <- (Lazy.force f); peek_data s - | Sgen {curr = Some a} -> a - | Sgen g -> let x = g.func s.count in g.curr <- Some x; x - | Sbuffio b -> - if b.ind >= b.len then fill_buff b; - if b.len == 0 then begin s.data <- Sempty; None end - else Some (Bytes.unsafe_get b.buff b.ind) - - -let peek = function - | None -> None - | Some s -> peek_data s - - -let rec junk_data : type v. v cell -> unit = fun s -> - match s.data with - Scons (_, d) -> s.count <- (succ s.count); s.data <- d - | Sgen ({curr = Some _} as g) -> s.count <- (succ s.count); g.curr <- None - | Sbuffio b -> - if b.ind >= b.len then fill_buff b; - if b.len == 0 then s.data <- Sempty - else (s.count <- (succ s.count); b.ind <- succ b.ind) - | _ -> - match peek_data s with - None -> () - | Some _ -> junk_data s - - -let junk = function - | None -> () - | Some data -> junk_data data - -let rec nget_data n s = - if n <= 0 then [], s.data, 0 - else - match peek_data s with - Some a -> - junk_data s; - let (al, d, k) = nget_data (pred n) s in a :: al, Scons (a, d), succ k - | None -> [], s.data, 0 - - -let npeek_data n s = - let (al, d, len) = nget_data n s in - s.count <- (s.count - len); - s.data <- d; - al - - -let npeek n = function - | None -> [] - | Some d -> npeek_data n d - -let next s = - match peek s with - Some a -> junk s; a - | None -> raise Failure - - -let empty s = - match peek s with - Some _ -> raise Failure - | None -> () - - -let iter f strm = - let rec do_rec () = - match peek strm with - Some a -> junk strm; ignore(f a); do_rec () - | None -> () - in - do_rec () - - -(* Stream building functions *) - -let from f = Some {count = 0; data = Sgen {curr = None; func = f}} - -let of_list l = - Some {count = 0; data = List.fold_right (fun x l -> Scons (x, l)) l Sempty} - - -let of_string s = - let count = ref 0 in - from (fun _ -> - (* We cannot use the index passed by the [from] function directly - because it returns the current stream count, with absolutely no - guarantee that it will start from 0. For example, in the case - of [Stream.icons 'c' (Stream.from_string "ab")], the first - access to the string will be made with count [1] already. - *) - let c = !count in - if c < String.length s - then (incr count; Some s.[c]) - else None) - - -let of_bytes s = - let count = ref 0 in - from (fun _ -> - let c = !count in - if c < Bytes.length s - then (incr count; Some (Bytes.get s c)) - else None) - - -let of_channel ic = - Some {count = 0; - data = Sbuffio {ic = ic; buff = Bytes.create 4096; len = 0; ind = 0}} - - -(* Stream expressions builders *) - -let iapp i s = Some {count = 0; data = Sapp (data i, data s)} -let icons i s = Some {count = 0; data = Scons (i, data s)} -let ising i = Some {count = 0; data = Scons (i, Sempty)} - -let lapp f s = - Some {count = 0; data = Slazy (lazy(Sapp (data (f ()), data s)))} - -let lcons f s = Some {count = 0; data = Slazy (lazy(Scons (f (), data s)))} -let lsing f = Some {count = 0; data = Slazy (lazy(Scons (f (), Sempty)))} - -let sempty = None -let slazy f = Some {count = 0; data = Slazy (lazy(data (f ())))} - -(* For debugging use *) - -let rec dump : type v. (v -> unit) -> v t -> unit = fun f s -> - print_string "{count = "; - print_int (count s); - print_string "; data = "; - dump_data f (data s); - print_string "}"; - print_newline () -and dump_data : type v. (v -> unit) -> v data -> unit = fun f -> - function - Sempty -> print_string "Sempty" - | Scons (a, d) -> - print_string "Scons ("; - f a; - print_string ", "; - dump_data f d; - print_string ")" - | Sapp (d1, d2) -> - print_string "Sapp ("; - dump_data f d1; - print_string ", "; - dump_data f d2; - print_string ")" - | Slazy _ -> print_string "Slazy" - | Sgen _ -> print_string "Sgen" - | Sbuffio _ -> print_string "Sbuffio" diff --git a/cpdfstream.mli b/cpdfstream.mli deleted file mode 100644 index 91d95bb..0000000 --- a/cpdfstream.mli +++ /dev/null @@ -1,111 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Streams and parsers. *) - -type 'a t -(** The type of streams holding values of type ['a]. *) - -exception Failure -(** Raised by parsers when none of the first components of the stream - patterns is accepted. *) - -exception Error of string -(** Raised by parsers when the first component of a stream pattern is - accepted, but one of the following components is rejected. *) - - -(** {1 Stream builders} *) - -val from : (int -> 'a option) -> 'a t -(** [Stream.from f] returns a stream built from the function [f]. - To create a new stream element, the function [f] is called with - the current stream count. The user function [f] must return either - [Some ] for a value or [None] to specify the end of the - stream. - - Do note that the indices passed to [f] may not start at [0] in the - general case. For example, [[< '0; '1; Stream.from f >]] would call - [f] the first time with count [2]. -*) - -val of_list : 'a list -> 'a t -(** Return the stream holding the elements of the list in the same - order. *) - -val of_string : string -> char t -(** Return the stream of the characters of the string parameter. *) - -val of_bytes : bytes -> char t -(** Return the stream of the characters of the bytes parameter. - @since 4.02.0 *) - -val of_channel : in_channel -> char t -(** Return the stream of the characters read from the input channel. *) - - -(** {1 Stream iterator} *) - -val iter : ('a -> unit) -> 'a t -> unit -(** [Stream.iter f s] scans the whole stream s, applying function [f] - in turn to each stream element encountered. *) - - -(** {1 Predefined parsers} *) - -val next : 'a t -> 'a -(** Return the first element of the stream and remove it from the - stream. - @raise Cpdfstream.Failure if the stream is empty. *) - -val empty : 'a t -> unit -(** Return [()] if the stream is empty, else raise {!Cpdfstream.Failure}. *) - - -(** {1 Useful functions} *) - -val peek : 'a t -> 'a option -(** Return [Some] of "the first element" of the stream, or [None] if - the stream is empty. *) - -val junk : 'a t -> unit -(** Remove the first element of the stream, possibly unfreezing - it before. *) - -val count : 'a t -> int -(** Return the current count of the stream elements, i.e. the number - of the stream elements discarded. *) - -val npeek : int -> 'a t -> 'a list -(** [npeek n] returns the list of the [n] first elements of - the stream, or all its remaining elements if less than [n] - elements are available. *) - -(**/**) - -(* The following is for system use only. Do not call directly. *) - -val iapp : 'a t -> 'a t -> 'a t -val icons : 'a -> 'a t -> 'a t -val ising : 'a -> 'a t - -val lapp : (unit -> 'a t) -> 'a t -> 'a t -val lcons : (unit -> 'a) -> 'a t -> 'a t -val lsing : (unit -> 'a) -> 'a t - -val sempty : 'a t -val slazy : (unit -> 'a t) -> 'a t - -val dump : ('a -> unit) -> 'a t -> unit diff --git a/tjjson.ml b/tjjson.ml deleted file mode 100644 index 016be2c..0000000 --- a/tjjson.ml +++ /dev/null @@ -1,288 +0,0 @@ -(* With regard to tjjson.ml(i), tjllist.ml(i), tjbase64.ml(i), - * tjparserMonad.ml(i), tjutil.ml(i), tjutf16.ml(i): *) - -(* Copyright (c) 2011 Yoshihiro Imai - -Permission is hereby granted, free of charge, to any person obtaining -a copy of this software and associated documentation files (the -"Software"), to deal in the Software without restriction, including -without limitation the rights to use, copy, modify, merge, publish, -distribute, sublicense, and/or sell copies of the Software, and to -permit persons to whom the Software is furnished to do so, subject to -the following conditions: - -The above copyright notice and this permission notice shall be -included in all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE -LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION -OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION -WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.*) - -open Tjutil -open Tjparsermonad -module P = Tjparsermonad - -type t = - | String of string - | Number of string (* float is not appropriate for decoding 64bit int *) - | Object of obj - | Array of t list - | Bool of bool - | Null -and obj = (string * t) list - -exception JSON_NotObject of t -exception JSON_InvalidField of (string) -exception JSON_CastErr of string -exception JSON_UnknownErr of string - -(* CR jfuruse: it uses string concat. Very bad efficiency. *) -let show = - let rec show_aux depth = function - | String s -> "str(" ^s^ ")" - | Number x -> !%"num(%s)" x - | Object fs -> - let indent d = String.make d '\t' in - "{\n" - ^indent depth^ slist (",\n"^ indent depth) (fun (k,v) -> k^":"^ (show_aux (depth+1)) v) fs - ^"\n"^indent(depth-1)^"}" - | Array xs -> "[" ^slist "," (show_aux depth) xs ^ "]" - | Bool true -> "TRUE" - | Bool false -> "FALSE" - | Null -> "NULL" - in - show_aux 1 - - let rec format_list sep f ppf = function - | [] -> () - | [x] -> f ppf x - | x::xs -> f ppf x; Format.fprintf ppf sep; format_list sep f ppf xs - - (* CR jfuruse: Need test! *) - let rec format ppf = - let open Format in - function - | String s -> - let buf = Buffer.create (String.length s * 2) in - Buffer.add_char buf '"'; - for i = 0 to String.length s - 1 do - let c = String.unsafe_get s i in - match c with - | '"' -> Buffer.add_string buf "\\\"" - | '\\' -> Buffer.add_string buf "\\\\" - | '\b' -> Buffer.add_string buf "\\b" - | '\012' -> Buffer.add_string buf "\\f" - | '\n' -> Buffer.add_string buf "\\n" - | '\r' -> Buffer.add_string buf "\\r" - | '\t' -> Buffer.add_string buf "\\t" - | _ when Char.code c <= 32 && c <> ' ' -> - Printf.ksprintf (Buffer.add_string buf) "\\u%04X" (Char.code c) - | _ -> Buffer.add_char buf c - done; - Buffer.add_char buf '"'; - pp_print_string ppf (Buffer.contents buf) - | Number s -> fprintf ppf "%s" s - | Object o -> - fprintf ppf "{ @[%a }@]" - (format_list ",@ " (fun ppf (s,v) -> fprintf ppf "@[\"%s\": @[<2>%a@]@]" s format v)) o - | Array ts -> - fprintf ppf "[ @[%a ]@]" - (format_list ",@ " format) ts - | Bool b -> fprintf ppf "%b" b - | Null -> fprintf ppf "null" - -let getf field t = - match t with - | Object o -> - begin try List.assoc field o with - | _ -> raise (JSON_InvalidField (field)) - end - | _ -> raise (JSON_NotObject t) - -let getf_opt field t = - match t with - | Object o -> - begin try Some (List.assoc field o) with - | _ -> None - end - | _ -> None - -let as_bool = function - | Bool true -> true - | Bool false -> false - | v -> raise (JSON_CastErr ("as_bool:" ^ show v)) - -let as_object = function - | Object obj -> obj - | v -> raise (JSON_CastErr ("as_object:" ^ show v)) - -let as_float = function - | Number s -> float_of_string s (* may fail, or returns wrong result *) - | v -> raise (JSON_CastErr ("as_float:" ^ show v)) - -let as_string = function - | String s -> s - | v -> raise (JSON_CastErr ("as_string:" ^ show v)) - -let as_list = function - | Array l -> l - | v -> raise (JSON_CastErr ("as_list:" ^ show v)) - -let as_int = function - | Number s -> int_of_string s (* may fail, or returns wrong result *) - | v -> raise (JSON_CastErr ("as_int:" ^ show v)) - - -(*parser*) - -let whitespace = many (char '\n' <|> char ' ' <|> char '\t' <|> char '\r') - -let string s = - let rec iter i = - if i < String.length s then - char s.[i] >> iter (i+1) - else return s - in - iter 0 - -(* -let alp = - char1 >>= fun c -> if c<>' ' && c<>'\n' && c<>'\t' && c<>'\r' then return c else error"" - -let alps0 = many alp -let alps = alp >>= fun c -> many alp >>= fun cs -> return (string_of_chars (c::cs)) -*) - -type token = - | ObjOpen - | ObjClose - | ListOpen - | ListClose - | Comma - | Colon - - | TTrue - | TFalse - | TNull - | TString of string - | TNumber of string (* we keep the string repr. *) - -let lit_string = - let four_hex_digits = - let hex = char1 >>= function - | '0'..'9' | 'A'..'F' | 'a'..'f' as c -> return c - | _ -> error "" - in - hex >>= fun d1 -> hex >>= fun d2 -> hex >>= fun d3 -> hex >>= fun d4 -> - let s = string_of_chars [d1;d2;d3;d4] in - let n = int_of_string ("0x" ^ Tjutf16.utf16c_to_utf8c s) in - let m, n1 = n / (16*16), n mod (16*16) in - let n3,n2 = m / (16*16), m mod (16*16) in - let cs = List.map char_of_int - begin match [n3;n2;n1] with - | [0; 0; _] -> [n1] - | [0; _; _] -> [n2; n1] - | _ -> [n3; n2; n1] - end - in - return (string_of_chars cs) - in - let lit_char = - char1 >>= function - | '\"' -> error "" - | '\\' -> char1 >>= - begin function - | '\"' | '\\' | '/' as c -> return (string1 c) - | 'b' -> return "\b" - | 'f' -> return "\x0c" - | 'n' -> return "\n" - | 'r' -> return "\r" - | 't' -> return "\t" - | 'u' -> four_hex_digits - | _ -> error "" - end - | c -> return (string1 c) - in - char '\"' >> many lit_char >>= fun ss -> char '\"' >> return (TString (slist "" id ss)) - -let digits = - let digit = - char1 >>= function - | '0'..'9' | '-' | '.' | 'e' | 'E' | '+' as c -> return c - | _ -> error "digit" - in - many1 digit >>= (return $ string_of_chars) - -let lit_number = (* TODO *) - (* We cannot simply use [float_of_string] here, if we want to handle int64. - int64 and double are both 64bits, which means double cannot express all the int64!!! - *) - digits >>= fun x -> return (TNumber x) - -let token1 = - let aux = - (char '{' >> return ObjOpen) - <|> - (char '}' >> return ObjClose) - <|> - (char '[' >> return ListOpen) - <|> - (char ']' >> return ListClose) - <|> - (char ',' >> return Comma) - <|> - (char ':' >> return Colon) - <|> - (string "true" >> return TTrue) - <|> - (string "false" >> return TFalse) - <|> - (string "null" >> return TNull) - <|> - lit_string - <|> - lit_number - in - whitespace >> aux - -let token t = - token1 >>= fun x -> if t = x then return t else error "token" - -let json_string = - token1 >>= function TString s -> return s | _ -> error "json_string" - -let json_number = - token1 >>= function TNumber x -> return x | _ -> error "json_number" - -let rec json (): t P.t = - begin - let field = - json_string >>= fun key -> token Colon >> json () >>= fun v -> return (key, v) - in - (token ObjOpen >> sep (token Comma) field >>= fun fields -> token ObjClose >> - return @@ Object fields) - <|> - (token ListOpen >>= (fun _ -> sep (token Comma) (json()) >>= fun vs -> opt (token Comma) >> token ListClose >> - return @@ Array vs)) - <|> - (token TTrue >> return (Bool true)) - <|> - (token TFalse >> return (Bool false)) - <|> - (token TNull >> return Null) - <|> - (json_string >>= fun s -> return @@ String s) - <|> - (json_number >>= fun x -> return @@ Number x) - end - - -let parse_ch ch = run_ch (json()) ch - -let parse s = run_string (json()) s - -let parse_function f = run_function (json()) f diff --git a/tjjson.mli b/tjjson.mli deleted file mode 100644 index 9ad10ce..0000000 --- a/tjjson.mli +++ /dev/null @@ -1,38 +0,0 @@ -type t = - String of string - | Number of string (* We keep its string repr. *) - | Object of obj - | Array of t list - | Bool of bool - | Null -and obj = (string * t) list - -exception JSON_NotObject of t -exception JSON_InvalidField of string -exception JSON_CastErr of string -exception JSON_UnknownErr of string - -(** {6 Printer and formatter} *) -val show : t -> string -val format : Format.formatter -> t -> unit - -(** {6 Object field access} *) - -val getf : string -> t -> t -(** Get field from an object. Failure raises an exception. *) - -val getf_opt : string -> t -> t option -(** Get field from an object. Failure is reported as [None] *) - -(** {6 Coercions. They may fail and raise JSON_CastErr.} *) -val as_bool : t -> bool -val as_object : t -> obj -val as_float : t -> float -val as_string : t -> string -val as_list : t -> t list -val as_int : t -> int - -(** {6 Parsers} *) -val parse_ch : in_channel -> t -val parse : string -> t -val parse_function : (bytes -> int -> int) -> t diff --git a/tjllist.ml b/tjllist.ml deleted file mode 100644 index c728991..0000000 --- a/tjllist.ml +++ /dev/null @@ -1,97 +0,0 @@ -open Tjutil - -type 'a llist = Nil | Cons of 'a * 'a llist Lazy.t - -type 'a t = 'a llist Lazy.t - -let to_list ll = - let rec to_list st = function - | Nil -> List.rev st - | Cons (x, xs) -> - to_list (x :: st) (Lazy.force xs) - in - to_list [] ll - -let hd = function | Nil -> failwith "hd" | Cons (x, _xs) -> x -let tl = function | Nil -> failwith "tl" | Cons (_x, xs) -> !$xs - -let rec take n l = - match n, l with - | 0, _ -> [] - | _n, Nil -> [] - | n, Cons (x, xs) -> x :: take (n-1) !$xs - -let rec map f = function - | Nil -> Nil - | Cons (x, xs) -> Cons (f x, lazy (map f !$xs)) - -let rec repeat x = Cons (x, lazy (repeat x));; - -let rec app xs ys = - match xs with - | Nil -> ys - | Cons (x, xs) -> Cons (x, lazy (app (!$ xs) ys)) - -let rec combine xs ys = - match (xs,ys) with - | Cons(x,xs),Cons(y,ys) -> Cons((x,y), lazy (combine !$xs !$ys)) - | _ -> Nil - -let rec filter f xs = - match xs with - | Nil -> Nil - | Cons(x, xs) when f x -> Cons (x, lazy (filter f !$xs)) - | Cons(_x, xs) -> filter f !$xs - -let rec concat xss = - match xss with - | Nil -> Nil - | Cons(Nil, xss') -> concat !$xss' - | Cons(Cons(x,lazy xs'), xss') -> Cons(x, lazy (concat (Cons(xs', xss')))) - -let rec unfoldr f b = - match f b with - | Some (a, new_b) -> Cons(a, lazy (unfoldr f new_b)) - | None -> Nil - -let continually make = - let f () = try Some(make (), ()) with _ -> None in - unfoldr f () - -(* int llist *) -let rec from n = Cons (n, lazy (from (n+1))) - - -(* llist <--> stream *) -let rec of_stream str = - try - Cons (Cpdfstream.next str, lazy (of_stream str)) - with - | Cpdfstream.Failure -> Nil - -let sllist ?(items:int=20) delim show l = - let fin = take items l in - if List.length fin <= items then - slist delim show fin - else - slist delim show fin ^ "..." - -(* string -> llist *) -let of_string = - of_stream $ Cpdfstream.of_string - -let of_function f = - let buf = Bytes.create 1024 in - - let rec fill () = - let read = f buf 1024 in - if read = 0 then Nil - else Cons (Bytes.unsafe_get buf 0, lazy (use read 1)) - - and use read pos = - if read <= pos then fill () - else Cons (Bytes.unsafe_get buf pos, lazy (use read (pos+1))) - - in - - fill () diff --git a/tjllist.mli b/tjllist.mli deleted file mode 100644 index 7963680..0000000 --- a/tjllist.mli +++ /dev/null @@ -1,29 +0,0 @@ -type 'a llist = Nil | Cons of 'a * 'a llist Lazy.t -(** It is a lazy list, but the first element is already forced *) - -type 'a t = 'a llist Lazy.t - -val hd : 'a llist -> 'a -val tl : 'a llist -> 'a llist -val take : int -> 'a llist -> 'a list -val map : ('a -> 'b) -> 'a llist -> 'b llist -val repeat : 'a -> 'a llist -val app : 'a llist -> 'a llist -> 'a llist -val combine : 'a llist -> 'b llist -> ('a * 'b) llist -val filter : ('a -> bool) -> 'a llist -> 'a llist -val concat : 'a llist llist -> 'a llist -val unfoldr : ('b -> ('a * 'b) option) -> 'b -> 'a llist -val continually : (unit -> 'a) -> 'a llist - -val from : int -> int llist - -val of_stream : 'a Cpdfstream.t -> 'a llist -val sllist : ?items:int -> string -> ('a -> string) -> 'a llist -> string -val of_string : string -> char llist - -val of_function : (bytes -> int -> int) -> char llist -(** [of_function f]: [f buf len] is a filler, a function to fill [buf] - with at most [len] chars. If it reaches the end of the input it returns [0]. -*) - -val to_list : 'a llist -> 'a list diff --git a/tjparsermonad.ml b/tjparsermonad.ml deleted file mode 100644 index 7abf840..0000000 --- a/tjparsermonad.ml +++ /dev/null @@ -1,164 +0,0 @@ -open Tjutil -open Tjllist - -type ts = char llist -type state = int * int * (char list * char * char list) -type error = state * string -type 'a t = state -> ts -> ('a * state * ts, error) either - -exception ParseError of string - -let lt_pos (l1,p1,_) (l2,p2,_) = - if l1 < l2 then true - else if l1 = l2 then p1 < p2 - else false - -let eplus (st1,msg1) (st2,msg2) = - if lt_pos st1 st2 then (st2,msg2) else (st1,msg1) - -let showerr ((line,pos,(pre,c,post)),msg) = - !%"line %d, %d: %s: pre=%S char=%C post=%S" line pos msg - (string_of_chars pre) - c - (string_of_chars post) - -let return : 'a -> 'a t = - fun x -> - fun state code -> Inl (x, state, code) - - -let error msg = fun state _code -> Inr (state, msg) - -let (>>=) : 'a t -> ('a -> 'b t) -> 'b t = - fun p f -> - fun state code -> - match p state code with - | Inl (x, state', ts) -> f x state' ts - | Inr err -> Inr err - -let (>>) : 'a t -> 'b t -> 'b t = - fun p1 p2 -> - p1 >>= fun _ -> p2 - -let (<.<) : 'a t -> 'b t -> 'a t = - fun p1 p2 -> - p1 >>= fun x -> p2 >> return x - -let ( ^? ) : 'a t -> string -> 'a t = - fun p msg -> - fun state code -> - match p state code with - | Inl l -> Inl l - | Inr (st,msg0) -> Inr (st,msg ^": "^msg0) - - (* (<|>) : 'a m -> 'a m -> 'a m *) -let (<|>) : 'a t -> 'a t -> 'a t = - fun p1 p2 -> - fun state code -> - match p1 state code with - | Inl (x1, state', ts) -> Inl (x1, state', ts) - | Inr err1 -> - begin match p2 state code with - | Inl (x2, state', ts) -> Inl (x2,state',ts) - | Inr err2 -> Inr (eplus err1 err2) - end - -(* -let (<|?>) p1 p2 = fun state code -> - match p1 state code with - | Inl (x1, state', ts) -> Inl (x1, state', ts) - | Inr err1 -> - print_endline err1; - begin match p2 state code with - | Inl (x2, state', ts) -> Inl (x2,state',ts) - | Inr err2 -> Inr (eplus err1 err2) - end -*) - -let rec many : 'a t -> ('a list) t = - fun p -> - (p >>= fun x -> many p >>= fun xs -> return (x::xs)) - <|> (return []) - -let many1 p = - p >>= fun x -> many p >>= fun xs -> return (x::xs) - -let sep separator p = - (p >>= fun x -> many (separator >> p) >>= fun xs -> return (x::xs)) - <|> (return []) - - -let opt : 'a t -> ('a option) t = - fun p -> - (p >>= fun x -> return (Some x)) <|> (return None) - - -let _char1_with_debug state = function - | Nil -> Inr (state,"(Nil)") - | Cons (x,xs) -> - let next (pre,x0, _) = - let pre' = if List.length pre < 100 then pre @ [x0] - else List.tl pre @ [x0] - in - (pre' , x, take 100 !$xs) - in - match x, state with - | '\n', (line,_pos,cs) -> - Inl (x,(line+1,-1, next cs), !$xs) - | _, (line,pos,cs) -> - Inl (x,(line, pos+1, next cs),!$xs) - -let char1_without_debug state = function - | Nil -> Inr (state,"(Nil)") - | Cons (x,xs) -> Inl (x, state, !$xs) - -let char1 = char1_without_debug - -let char_when f = char1 >>= fun c -> - if f c then return c - else error (!%"(char:'%c')" c) - -let char c = char_when ((=) c) - -let keyword w = - let rec iter i = - if i < String.length w then - char w.[i] >> iter (i+1) - else return w - in - iter 0 - -let make_ident f = - many1 (char_when f) >>= fun cs -> - return (string_of_chars cs) - -let int = - opt (char '-') >>= fun minus -> - make_ident (function '0'..'9' -> true | _ -> false) >>= fun s -> - return - begin match minus with - | None -> int_of_string s - | Some _ -> - int_of_string s - end - -let run p state ts = - match p state ts with - | Inl (x,_state',_xs) -> x - | Inr err -> - raise (ParseError (showerr err)) - -let init_state = (1, 0, ([],'_',[])) - -let run_ch p ch = - run p init_state (of_stream (Cpdfstream.of_channel ch)) - -let run_stdin p = run_ch p stdin - -let run_file p filename = - open_in_with filename (fun ch -> run_ch p ch) - -let run_string p s = - run p init_state (of_string s) - -let run_function p f = - run p init_state (of_function f) diff --git a/tjparsermonad.mli b/tjparsermonad.mli deleted file mode 100644 index 44402e3..0000000 --- a/tjparsermonad.mli +++ /dev/null @@ -1,38 +0,0 @@ -type ts -type state -type error -type 'a t - -val error : string -> 'a t -val showerr : error -> string - -val return : 'a -> 'a t -val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t - -val ( >> ) : 'a t -> 'b t -> 'b t -val ( <.< ) : 'a t -> 'b t -> 'a t -val ( ^? ) : 'a t -> string -> 'a t -val ( <|> ) : 'a t -> 'a t -> 'a t - -val many : 'a t -> 'a list t -val many1 : 'a t -> 'a list t -val sep : 'a t -> 'b t -> 'b list t -val opt : 'a t -> 'a option t - -val char1 : char t -exception ParseError of string - -val char_when : (char -> bool) -> char t -val char : char -> char t -val keyword : string -> string t -val make_ident : (char -> bool) -> string t -val int : int t - -val init_state : state - -(* They may raise ParseError exception *) -val run_ch : 'a t -> in_channel -> 'a -val run_stdin : 'a t -> 'a -val run_file : 'a t -> string -> 'a -val run_string : 'a t -> string -> 'a -val run_function : 'a t -> (bytes -> int -> int) -> 'a diff --git a/tjutf16.ml b/tjutf16.ml deleted file mode 100644 index 7ad3659..0000000 --- a/tjutf16.ml +++ /dev/null @@ -1,23 +0,0 @@ -open Tjutil - -let rec (>>) x n = - if n > 0 then (x >> (n-1)) / 2 - else x - -(* CR jfuruse: I bet it is equivalent with (lsr) *) -let (>>) x n = - let res = x >> n in - assert (x lsr n = res); - res - -let utf16c_to_utf8c(x) = - let n = int_of_string("0x" ^ x) in - if n < 0x80 then - to_hex n - else begin - (if n < 0x800 then - to_hex((n >> 6) land 0x1f lor 0xc0) - else - to_hex ((n >> 12) lor 0xe0) ^ to_hex((n >> 6) land 0x3f lor 0x80)) - ^ to_hex (n land 0x3f lor 0x80) - end diff --git a/tjutf16.mli b/tjutf16.mli deleted file mode 100644 index d467091..0000000 --- a/tjutf16.mli +++ /dev/null @@ -1 +0,0 @@ -val utf16c_to_utf8c : string -> string diff --git a/tjutil.ml b/tjutil.ml deleted file mode 100644 index c3d6ceb..0000000 --- a/tjutil.ml +++ /dev/null @@ -1,44 +0,0 @@ -external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" - -let ($) g f = fun x -> g (f x) -let id x = x -let tee f x = ignore @@ f x; x - -let (!%) = Printf.sprintf -let (!$) x = Lazy.force x - -let slist delim show l = - String.concat delim @@ List.map show l - -let string_of_chars = slist "" (String.make 1) - -let string1 c = String.make 1 c - -type ('l, 'r) either = Inl of 'l | Inr of 'r - -let maybe f x = - try Inl (f x) with e -> Inr e -let value = function - Inl v -> v | Inr e -> raise e - -let open_with (opn, close) filepath f = - let ch = opn filepath in - value @@ tee (fun _ -> close ch) (maybe f ch) - -let open_in_with filepath f = open_with (open_in, close_in) filepath f - -let to_hex n = - let to_char = function - | x when 0<=x && x<=9 -> (string_of_int x).[0] - | x when 10<=x && x<=15 -> char_of_int (int_of_char 'A'+(x-10)) - | _ -> failwith"tohex MNH" - in - let rec iter store n = - if n < 16 then - to_char n :: store - else - let r,q = n / 16, n mod 16 in - iter (to_char q :: store) r - in - if n < 0 then raise (Invalid_argument (!%"to_hex: (%d)" n)) - else string_of_chars @@ iter [] n diff --git a/tjutil.mli b/tjutil.mli deleted file mode 100644 index 08819a7..0000000 --- a/tjutil.mli +++ /dev/null @@ -1,11 +0,0 @@ -external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" -val ( $ ) : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b -val id : 'a -> 'a -val ( !% ) : ('a, unit, string) format -> 'a -val ( !$ ) : 'a Lazy.t -> 'a -val slist : string -> ('a -> string) -> 'a list -> string -val string_of_chars : char list -> string -val string1 : char -> string -type ('a, 'b) either = Inl of 'a | Inr of 'b -val open_in_with : string -> (in_channel -> 'a) -> 'a -val to_hex : int -> string