package jsonxt

  1. Overview
  2. Docs

Source file writer_file.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
module type Intf = sig
  val json_to_file : string -> 'a Json_internal.constrained -> (unit, string) result
  val json_to_file_exn : string -> 'a Json_internal.constrained -> unit
  val json_to_channel :  out_channel -> 'a Json_internal.constrained -> (unit, string) result
  val json_to_channel_exn :  out_channel -> 'a Json_internal.constrained -> unit
  val json_to_file_hum : string -> 'a Json_internal.constrained -> (unit, string) result
  val json_to_file_hum_exn : string -> 'a Json_internal.constrained -> unit
  val json_to_channel_hum :  out_channel -> 'a Json_internal.constrained -> (unit, string) result
  val json_to_channel_hum_exn :  out_channel -> 'a Json_internal.constrained -> unit
  val to_file : string -> 'a Json_internal.constrained -> unit
  val to_file_hum : string -> 'a Json_internal.constrained -> unit
  val to_channel :  out_channel -> 'a Json_internal.constrained -> unit
  val to_channel_hum :  out_channel -> 'a Json_internal.constrained -> unit
  val stream_to_channel : out_channel -> 'a Json_internal.constrained Stream.t -> unit
  val stream_to_file : string -> 'a Json_internal.constrained Stream.t -> unit
end

module Make (Compliance : Compliance.S) : Intf = struct

  let nibble_to_hex i = char_of_int (if i > 9 then 65 + i - 10 else 48 + i)

  let add_hex_byte oc i =
    output_char oc (nibble_to_hex ((i lsr 4) land 0x0f));
    output_char oc (nibble_to_hex (i land 0x0f))

  let escape oc s =
    let add_char = output_char oc in
    let add_string = output_string oc in
    let l = String.length s in
    for i = 0 to l - 1 do
      match s.[i] with
      | '"'    -> add_string "\\\""
      | '\\'   -> add_string "\\\\"
      | '\b'   -> add_string "\\b"
      | '\012' -> add_string "\\f"
      | '\n'   -> add_string "\\n"
      | '\r'   -> add_string "\\r"
      | '\t'   -> add_string "\\t"
      | '\x00'..'\x1F'
      | '\x7F' as c ->
        add_string "\\u00";  add_hex_byte oc (int_of_char c)
      | _      -> add_char s.[i]
    done
   
  let json_to_channel_fmt oc json ~eol ~incr ~psep = 
    let add_char = output_char oc in
    let add_string = output_string oc in
    let add_quote_string s = add_char '"'; escape oc s; add_char '"' in
    let add_int i = add_string (string_of_int i) in
    let add_float f = add_string (Compliance.number_to_string f) in
    let psep = ":" ^ psep in
    let rec fmt off value =
      match value with
      | `Assoc o ->
        let ldr = String.make off ' ' in
        add_char '{'; add_string eol; json_assoc (off + incr) o;
        add_string eol; add_string ldr; add_char '}'
      | `List l ->
        let ldr = String.make off ' ' in
        add_char '['; add_string eol; json_list (off + incr) l;
        add_string eol; add_string ldr; add_char ']'
      | `Null -> add_string "null"
      | `Bool b -> add_string (string_of_bool b)
      | `Int i -> add_int i
      | `Intlit s -> add_string s
      | `Float f -> add_float f
      | `Floatlit s -> add_string s
      | `String s -> add_quote_string s
      | `Stringlit s -> add_string s
      | `Tuple t ->
        let ldr = String.make off ' ' in
        add_char '('; add_string eol; json_list (off + incr) t;
        add_string eol; add_string ldr; add_char ')'
      | `Variant v ->
        let ldr = String.make off ' ' in
        add_char '<'; add_string eol;  variant (off + incr) v;
        add_string eol; add_string ldr; add_char '>'
    and json_assoc off o =
      let ldr = String.make off ' ' in
      let sep = ref ldr in
      let newsep = "," ^ eol ^ ldr in
      List.iter (fun v -> add_string !sep; sep := newsep; pair off v ) o
    and pair off (k, v) = add_quote_string k; add_string psep; fmt off v
    and json_list off l =
      let ldr = String.make off ' ' in
      let sep = ref ldr in
      let newsep = "," ^ eol ^ ldr in
      List.iter (fun v -> add_string !sep; sep := newsep; fmt off v ) l
    and variant off (k, j) =
      add_quote_string k;
      match j with
      | Some j -> add_string psep; fmt (off + incr) j
      | None -> ()
    in
    fmt 0 json;
    add_string eol

  let json_to_channel' = json_to_channel_fmt ~eol:"" ~incr:0 ~psep:""
  let json_to_channel_hum' = json_to_channel_fmt ~eol:"\n" ~incr:2 ~psep:" "

  let json_to_channel oc json =
    try Ok (json_to_channel' oc json) with
    | Failure err -> Error err

  let json_to_channel_hum oc json =
    try Ok (json_to_channel_hum' oc json) with
    | Failure err -> Error err

  let json_to_channel_exn = json_to_channel'
  let json_to_channel_hum_exn = json_to_channel_hum'

  let json_to_file file json =
    let oc = open_out file in
    let res = json_to_channel oc json in
    close_out oc;
    res

  let json_to_file_hum file json =
    let oc = open_out file in
    let res = json_to_channel_hum oc json in
    close_out oc;
    res

  let json_to_file_exn file json =
    let oc = open_out file in
    try (json_to_channel' oc json; close_out oc) with
    | exn -> close_out oc; raise exn

  let json_to_file_hum_exn file json =
    let oc = open_out file in
    try (json_to_channel_hum' oc json; close_out oc) with
    | exn -> close_out oc; raise exn

  let to_file = json_to_file_exn
  let to_file_hum = json_to_file_hum_exn
  let to_channel = json_to_channel_exn
  let to_channel_hum = json_to_channel_hum_exn

  let stream_to_channel oc stream =
    Stream.iter (fun json -> json_to_channel_exn oc json; output_char oc '\n') stream

  let stream_to_file file stream =
    let oc = open_out file in
    try (stream_to_channel oc stream; close_out oc) with
    | exn -> close_out oc; raise exn
end