remove old json stuff
This commit is contained in:
John Whitington
parent
86e0ce6f2f
commit
6acae6e5ce
4
Makefile
4
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
|
||||
|
|
|
|||
236
cpdfstream.ml
236
cpdfstream.ml
|
|
@ -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"
|
||||
111
cpdfstream.mli
111
cpdfstream.mli
|
|
@ -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 <value>] 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
|
||||
288
tjjson.ml
288
tjjson.ml
|
|
@ -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
|
||||
38
tjjson.mli
38
tjjson.mli
|
|
@ -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
|
||||
97
tjllist.ml
97
tjllist.ml
|
|
@ -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 ()
|
||||
29
tjllist.mli
29
tjllist.mli
|
|
@ -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
|
||||
164
tjparsermonad.ml
164
tjparsermonad.ml
|
|
@ -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)
|
||||
|
|
@ -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
|
||||
23
tjutf16.ml
23
tjutf16.ml
|
|
@ -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
|
||||
|
|
@ -1 +0,0 @@
|
|||
val utf16c_to_utf8c : string -> string
|
||||
44
tjutil.ml
44
tjutil.ml
|
|
@ -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
|
||||
11
tjutil.mli
11
tjutil.mli
|
|
@ -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
|
||||
Loading…
Reference in New Issue