Indentation
This commit is contained in:
parent
00c1b4cf93
commit
cb8a3bbb41
1 changed files with 188 additions and 188 deletions
376
cbor/CBOR.ml
376
cbor/CBOR.ml
|
|
@ -13,216 +13,216 @@ let fail fmt = ksprintf (fun s -> raise (Error s)) fmt
|
||||||
|
|
||||||
module Encode = struct
|
module Encode = struct
|
||||||
|
|
||||||
let start () = Buffer.create 10
|
let start () = Buffer.create 10
|
||||||
|
|
||||||
let init b ~maj add =
|
let init b ~maj add =
|
||||||
assert (maj >= 0 && maj < 8);
|
assert (maj >= 0 && maj < 8);
|
||||||
assert (add >= 0 && add < 32);
|
assert (add >= 0 && add < 32);
|
||||||
Buffer.add_char b @@ char_of_int @@ (maj lsl 5) lor add
|
Buffer.add_char b @@ char_of_int @@ (maj lsl 5) lor add
|
||||||
|
|
||||||
let put_n b n f x =
|
let put_n b n f x =
|
||||||
let s = Bytes.create n in
|
let s = Bytes.create n in
|
||||||
f s 0 x;
|
f s 0 x;
|
||||||
Buffer.add_string b (Bytes.unsafe_to_string s)
|
Buffer.add_string b (Bytes.unsafe_to_string s)
|
||||||
|
|
||||||
let max_uint32 =
|
let max_uint32 =
|
||||||
match Sys.word_size with
|
match Sys.word_size with
|
||||||
| 32 -> max_int (* max signed int, but on 32-bit this is enough *)
|
| 32 -> max_int (* max signed int, but on 32-bit this is enough *)
|
||||||
| _ -> int_of_string "0xFF_FF_FF_FF" (* so that it compiles on 32-bit *)
|
| _ -> int_of_string "0xFF_FF_FF_FF" (* so that it compiles on 32-bit *)
|
||||||
|
|
||||||
let put b ~maj n =
|
let put b ~maj n =
|
||||||
assert (n >= 0);
|
assert (n >= 0);
|
||||||
if n < 24 then
|
if n < 24 then
|
||||||
init b ~maj n
|
init b ~maj n
|
||||||
else if n < 256 then
|
else if n < 256 then
|
||||||
begin init b ~maj 24; Buffer.add_char b @@ char_of_int n end
|
begin init b ~maj 24; Buffer.add_char b @@ char_of_int n end
|
||||||
else if n < 65536 then
|
else if n < 65536 then
|
||||||
begin init b ~maj 25; put_n b 2 BE.set_int16 n end
|
begin init b ~maj 25; put_n b 2 BE.set_int16 n end
|
||||||
else if n <= max_uint32 then
|
else if n <= max_uint32 then
|
||||||
begin init b ~maj 26; put_n b 4 BE.set_int32 @@ Int32.of_int n end
|
begin init b ~maj 26; put_n b 4 BE.set_int32 @@ Int32.of_int n end
|
||||||
else
|
else
|
||||||
begin init b ~maj 27; put_n b 8 BE.set_int64 @@ Int64.of_int n end
|
begin init b ~maj 27; put_n b 8 BE.set_int64 @@ Int64.of_int n end
|
||||||
|
|
||||||
let int b n =
|
let int b n =
|
||||||
let (maj,n) = if n < 0 then 1, -1 - n else 0, n in
|
let (maj,n) = if n < 0 then 1, -1 - n else 0, n in
|
||||||
put b ~maj n
|
put b ~maj n
|
||||||
|
|
||||||
let hex_char x =
|
let hex_char x =
|
||||||
assert (x >= 0 && x < 16);
|
assert (x >= 0 && x < 16);
|
||||||
if x <= 9 then Char.chr @@ Char.code '0' + x
|
if x <= 9 then Char.chr @@ Char.code '0' + x
|
||||||
else Char.chr @@ Char.code 'a' + x - 10
|
else Char.chr @@ Char.code 'a' + x - 10
|
||||||
|
|
||||||
let to_hex s =
|
let to_hex s =
|
||||||
let r = Bytes.create (String.length s * 2) in
|
let r = Bytes.create (String.length s * 2) in
|
||||||
for i = 0 to String.length s - 1 do
|
for i = 0 to String.length s - 1 do
|
||||||
Bytes.set r (i*2) @@ hex_char @@ Char.code s.[i] lsr 4;
|
Bytes.set r (i*2) @@ hex_char @@ Char.code s.[i] lsr 4;
|
||||||
Bytes.set r (i*2+1) @@ hex_char @@ Char.code s.[i] land 0b1111;
|
Bytes.set r (i*2+1) @@ hex_char @@ Char.code s.[i] land 0b1111;
|
||||||
done;
|
done;
|
||||||
Bytes.to_string r
|
Bytes.to_string r
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
module Simple = struct
|
module Simple = struct
|
||||||
|
|
||||||
type t =
|
type t =
|
||||||
[ `Null
|
[ `Null
|
||||||
| `Undefined
|
| `Undefined
|
||||||
| `Simple of int
|
| `Simple of int
|
||||||
| `Bool of bool
|
| `Bool of bool
|
||||||
| `Int of int
|
| `Int of int
|
||||||
| `Float of float
|
| `Float of float
|
||||||
| `Bytes of string
|
| `Bytes of string
|
||||||
| `Text of string
|
| `Text of string
|
||||||
| `Array of t list
|
| `Array of t list
|
||||||
| `Map of (t * t) list
|
| `Map of (t * t) list
|
||||||
]
|
]
|
||||||
|
|
||||||
let encode item =
|
let encode item =
|
||||||
let open Encode in
|
let open Encode in
|
||||||
let b = start () in
|
let b = start () in
|
||||||
let rec write = function
|
let rec write = function
|
||||||
| `Null -> put b ~maj:7 22;
|
| `Null -> put b ~maj:7 22;
|
||||||
| `Undefined -> put b ~maj:7 23;
|
| `Undefined -> put b ~maj:7 23;
|
||||||
| `Bool false -> put b ~maj:7 20;
|
| `Bool false -> put b ~maj:7 20;
|
||||||
| `Bool true -> put b ~maj:7 21;
|
| `Bool true -> put b ~maj:7 21;
|
||||||
| `Simple n when (n >= 0 && n <= 23) || (n >= 32 && n <= 255) -> put b ~maj:7 n
|
| `Simple n when (n >= 0 && n <= 23) || (n >= 32 && n <= 255) -> put b ~maj:7 n
|
||||||
| `Simple n -> fail "encode: simple(%d)" n
|
| `Simple n -> fail "encode: simple(%d)" n
|
||||||
| `Int n -> int b n
|
| `Int n -> int b n
|
||||||
| `Float f -> init b ~maj:7 27; put_n b 8 BE.set_double f
|
| `Float f -> init b ~maj:7 27; put_n b 8 BE.set_double f
|
||||||
| `Bytes s -> put b ~maj:2 (String.length s); Buffer.add_string b s
|
| `Bytes s -> put b ~maj:2 (String.length s); Buffer.add_string b s
|
||||||
| `Text s -> put b ~maj:3 (String.length s); Buffer.add_string b s
|
| `Text s -> put b ~maj:3 (String.length s); Buffer.add_string b s
|
||||||
| `Array l -> put b ~maj:4 (List.length l); List.iter write l
|
| `Array l -> put b ~maj:4 (List.length l); List.iter write l
|
||||||
| `Map m -> put b ~maj:5 (List.length m); List.iter (fun (a,b) -> write a; write b) m
|
| `Map m -> put b ~maj:5 (List.length m); List.iter (fun (a,b) -> write a; write b) m
|
||||||
in
|
in
|
||||||
write item;
|
write item;
|
||||||
Buffer.contents b
|
Buffer.contents b
|
||||||
|
|
||||||
let need (s,i) n =
|
let need (s,i) n =
|
||||||
if n > String.length s || !i + n > String.length s then
|
if n > String.length s || !i + n > String.length s then
|
||||||
fail "truncated: len %d pos %d need %d" (String.length s) !i n;
|
fail "truncated: len %d pos %d need %d" (String.length s) !i n;
|
||||||
let j = !i in
|
let j = !i in
|
||||||
i := !i + n;
|
i := !i + n;
|
||||||
j
|
j
|
||||||
|
|
||||||
let get_byte (s,_ as r) = int_of_char @@ s.[need r 1]
|
let get_byte (s,_ as r) = int_of_char @@ s.[need r 1]
|
||||||
let get_n (s,_ as r) n f = f s @@ need r n
|
let get_n (s,_ as r) n f = f s @@ need r n
|
||||||
let get_s (s,_ as r) n = String.sub s (need r n) n
|
let get_s (s,_ as r) n = String.sub s (need r n) n
|
||||||
|
|
||||||
let get_additional byte1 = byte1 land 0b11111
|
let get_additional byte1 = byte1 land 0b11111
|
||||||
let is_indefinite byte1 = get_additional byte1 = 31
|
let is_indefinite byte1 = get_additional byte1 = 31
|
||||||
|
|
||||||
let int64_max_int = Int64.of_int max_int
|
let int64_max_int = Int64.of_int max_int
|
||||||
let two_min_int32 = 2 * Int32.to_int Int32.min_int
|
let two_min_int32 = 2 * Int32.to_int Int32.min_int
|
||||||
|
|
||||||
let extract_number byte1 r =
|
let extract_number byte1 r =
|
||||||
match get_additional byte1 with
|
match get_additional byte1 with
|
||||||
| n when n < 24 -> n
|
| n when n < 24 -> n
|
||||||
| 24 -> get_byte r
|
| 24 -> get_byte r
|
||||||
| 25 -> get_n r 2 SE.get_uint16
|
| 25 -> get_n r 2 SE.get_uint16
|
||||||
| 26 ->
|
| 26 ->
|
||||||
let n = Int32.to_int @@ get_n r 4 SE.get_int32 in
|
let n = Int32.to_int @@ get_n r 4 SE.get_int32 in
|
||||||
if n < 0 then n - two_min_int32 else n
|
if n < 0 then n - two_min_int32 else n
|
||||||
| 27 ->
|
| 27 ->
|
||||||
let n = get_n r 8 SE.get_int64 in
|
let n = get_n r 8 SE.get_int64 in
|
||||||
if n > int64_max_int || n < 0L then fail "extract_number: %Lu" n;
|
if n > int64_max_int || n < 0L then fail "extract_number: %Lu" n;
|
||||||
Int64.to_int n
|
Int64.to_int n
|
||||||
| n -> fail "bad additional %d" n
|
| n -> fail "bad additional %d" n
|
||||||
|
|
||||||
let get_float16 s i =
|
let get_float16 s i =
|
||||||
let half = Char.code s.[i] lsl 8 + Char.code s.[i+1] in
|
let half = Char.code s.[i] lsl 8 + Char.code s.[i+1] in
|
||||||
let mant = half land 0x3ff in
|
let mant = half land 0x3ff in
|
||||||
let value =
|
let value =
|
||||||
match (half lsr 10) land 0x1f with (* exp *)
|
match (half lsr 10) land 0x1f with (* exp *)
|
||||||
| 31 when mant = 0 -> infinity
|
| 31 when mant = 0 -> infinity
|
||||||
| 31 -> nan
|
| 31 -> nan
|
||||||
| 0 -> ldexp (float mant) ~-24
|
| 0 -> ldexp (float mant) ~-24
|
||||||
| exp -> ldexp (float @@ mant + 1024) (exp - 25)
|
| exp -> ldexp (float @@ mant + 1024) (exp - 25)
|
||||||
in
|
in
|
||||||
if half land 0x8000 = 0 then value else ~-. value
|
if half land 0x8000 = 0 then value else ~-. value
|
||||||
|
|
||||||
exception Break
|
exception Break
|
||||||
|
|
||||||
let extract_list byte1 r f =
|
let extract_list byte1 r f =
|
||||||
if is_indefinite byte1 then
|
if is_indefinite byte1 then
|
||||||
let l = ref [] in
|
let l = ref [] in
|
||||||
try while true do l := f r :: !l done; assert false with Break -> List.rev !l
|
try while true do l := f r :: !l done; assert false with Break -> List.rev !l
|
||||||
else
|
else
|
||||||
let n = extract_number byte1 r in Array.to_list @@ Array.init n (fun _ -> f r)
|
let n = extract_number byte1 r in Array.to_list @@ Array.init n (fun _ -> f r)
|
||||||
|
|
||||||
let rec extract_pair r =
|
let rec extract_pair r =
|
||||||
let a = extract r in
|
let a = extract r in
|
||||||
let b = try extract r with Break -> fail "extract_pair: unexpected break" in
|
let b = try extract r with Break -> fail "extract_pair: unexpected break" in
|
||||||
a,b
|
a,b
|
||||||
and extract_string byte1 r f =
|
and extract_string byte1 r f =
|
||||||
if is_indefinite byte1 then
|
if is_indefinite byte1 then
|
||||||
|
let b = Buffer.create 10 in
|
||||||
|
try while true do Buffer.add_string b (f @@ extract r) done; assert false with Break -> Buffer.contents b
|
||||||
|
else
|
||||||
|
let n = extract_number byte1 r in get_s r n
|
||||||
|
and extract r =
|
||||||
|
let byte1 = get_byte r in
|
||||||
|
match byte1 lsr 5 with
|
||||||
|
| 0 -> `Int (extract_number byte1 r)
|
||||||
|
| 1 -> `Int (-1 - extract_number byte1 r)
|
||||||
|
| 2 -> `Bytes (extract_string byte1 r (function `Bytes s -> s | _ -> fail "extract: not a bytes chunk"))
|
||||||
|
| 3 -> `Text (extract_string byte1 r (function `Text s -> s | _ -> fail "extract: not a text chunk"))
|
||||||
|
| 4 -> `Array (extract_list byte1 r extract)
|
||||||
|
| 5 -> `Map (extract_list byte1 r extract_pair)
|
||||||
|
| 6 -> let _tag = extract_number byte1 r in extract r
|
||||||
|
| 7 ->
|
||||||
|
begin match get_additional byte1 with
|
||||||
|
| n when n < 20 -> `Simple n
|
||||||
|
| 20 -> `Bool false
|
||||||
|
| 21 -> `Bool true
|
||||||
|
| 22 -> `Null
|
||||||
|
| 23 -> `Undefined
|
||||||
|
| 24 -> `Simple (get_byte r)
|
||||||
|
| 25 -> `Float (get_n r 2 get_float16)
|
||||||
|
| 26 -> `Float (get_n r 4 SE.get_float)
|
||||||
|
| 27 -> `Float (get_n r 8 SE.get_double)
|
||||||
|
| 31 -> raise Break
|
||||||
|
| a -> fail "extract: (7,%d)" a
|
||||||
|
end
|
||||||
|
| _ -> assert false
|
||||||
|
|
||||||
|
let decode_partial s =
|
||||||
|
let i = ref 0 in
|
||||||
|
let x = try extract (s,i) with Break -> fail "decode: unexpected break" in
|
||||||
|
x, String.sub s !i (String.length s - !i)
|
||||||
|
|
||||||
|
let decode s : t =
|
||||||
|
let x, rest = decode_partial s in
|
||||||
|
if rest = "" then x
|
||||||
|
else fail "decode: extra data: len %d pos %d" (String.length s) (String.length s - String.length rest)
|
||||||
|
|
||||||
|
let to_diagnostic item =
|
||||||
let b = Buffer.create 10 in
|
let b = Buffer.create 10 in
|
||||||
try while true do Buffer.add_string b (f @@ extract r) done; assert false with Break -> Buffer.contents b
|
let put = Buffer.add_string b in
|
||||||
else
|
let rec write = function
|
||||||
let n = extract_number byte1 r in get_s r n
|
| `Null -> put "null"
|
||||||
and extract r =
|
| `Bool false -> put "false"
|
||||||
let byte1 = get_byte r in
|
| `Bool true -> put "true"
|
||||||
match byte1 lsr 5 with
|
| `Simple n -> bprintf b "simple(%d)" n
|
||||||
| 0 -> `Int (extract_number byte1 r)
|
| `Undefined -> put "undefined"
|
||||||
| 1 -> `Int (-1 - extract_number byte1 r)
|
| `Int n -> bprintf b "%d" n
|
||||||
| 2 -> `Bytes (extract_string byte1 r (function `Bytes s -> s | _ -> fail "extract: not a bytes chunk"))
|
| `Float f ->
|
||||||
| 3 -> `Text (extract_string byte1 r (function `Text s -> s | _ -> fail "extract: not a text chunk"))
|
begin match classify_float f with
|
||||||
| 4 -> `Array (extract_list byte1 r extract)
|
| FP_nan -> put "NaN"
|
||||||
| 5 -> `Map (extract_list byte1 r extract_pair)
|
| FP_infinite -> put (if f < 0. then "-Infinity" else "Infinity")
|
||||||
| 6 -> let _tag = extract_number byte1 r in extract r
|
| FP_zero | FP_normal | FP_subnormal -> bprintf b "%g" f
|
||||||
| 7 ->
|
end
|
||||||
begin match get_additional byte1 with
|
| `Bytes s -> bprintf b "h'%s'" (Encode.to_hex s)
|
||||||
| n when n < 20 -> `Simple n
|
| `Text s -> bprintf b "\"%s\"" s
|
||||||
| 20 -> `Bool false
|
| `Array l ->
|
||||||
| 21 -> `Bool true
|
put "[";
|
||||||
| 22 -> `Null
|
l |> list_iteri (fun i x -> if i <> 0 then put ", "; write x);
|
||||||
| 23 -> `Undefined
|
put "]"
|
||||||
| 24 -> `Simple (get_byte r)
|
| `Map m ->
|
||||||
| 25 -> `Float (get_n r 2 get_float16)
|
put "{";
|
||||||
| 26 -> `Float (get_n r 4 SE.get_float)
|
m |> list_iteri (fun i (k,v) -> if i <> 0 then put ", "; write k; put ": "; write v);
|
||||||
| 27 -> `Float (get_n r 8 SE.get_double)
|
put "}"
|
||||||
| 31 -> raise Break
|
in
|
||||||
| a -> fail "extract: (7,%d)" a
|
write item;
|
||||||
end
|
Buffer.contents b
|
||||||
| _ -> assert false
|
|
||||||
|
|
||||||
let decode_partial s =
|
|
||||||
let i = ref 0 in
|
|
||||||
let x = try extract (s,i) with Break -> fail "decode: unexpected break" in
|
|
||||||
x, String.sub s !i (String.length s - !i)
|
|
||||||
|
|
||||||
let decode s : t =
|
|
||||||
let x, rest = decode_partial s in
|
|
||||||
if rest = "" then x
|
|
||||||
else fail "decode: extra data: len %d pos %d" (String.length s) (String.length s - String.length rest)
|
|
||||||
|
|
||||||
let to_diagnostic item =
|
|
||||||
let b = Buffer.create 10 in
|
|
||||||
let put = Buffer.add_string b in
|
|
||||||
let rec write = function
|
|
||||||
| `Null -> put "null"
|
|
||||||
| `Bool false -> put "false"
|
|
||||||
| `Bool true -> put "true"
|
|
||||||
| `Simple n -> bprintf b "simple(%d)" n
|
|
||||||
| `Undefined -> put "undefined"
|
|
||||||
| `Int n -> bprintf b "%d" n
|
|
||||||
| `Float f ->
|
|
||||||
begin match classify_float f with
|
|
||||||
| FP_nan -> put "NaN"
|
|
||||||
| FP_infinite -> put (if f < 0. then "-Infinity" else "Infinity")
|
|
||||||
| FP_zero | FP_normal | FP_subnormal -> bprintf b "%g" f
|
|
||||||
end
|
|
||||||
| `Bytes s -> bprintf b "h'%s'" (Encode.to_hex s)
|
|
||||||
| `Text s -> bprintf b "\"%s\"" s
|
|
||||||
| `Array l ->
|
|
||||||
put "[";
|
|
||||||
l |> list_iteri (fun i x -> if i <> 0 then put ", "; write x);
|
|
||||||
put "]"
|
|
||||||
| `Map m ->
|
|
||||||
put "{";
|
|
||||||
m |> list_iteri (fun i (k,v) -> if i <> 0 then put ", "; write k; put ": "; write v);
|
|
||||||
put "}"
|
|
||||||
in
|
|
||||||
write item;
|
|
||||||
Buffer.contents b
|
|
||||||
|
|
||||||
end (* Simple *)
|
end (* Simple *)
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue