Skip to content
This repository
Newer
Older
100644 189 lines (169 sloc) 7.987 kb
fccc6851 » MLstate
2011-06-21 Initial open-source release
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 module B = Base
19 let eprintf fmt = Format.kfprintf (fun _ -> Format.pp_print_flush Format.err_formatter ()) Format.err_formatter fmt
20 let (<|) f a = f a
21 let (|>) a f = f a
22 let ( @* ) g f x = g(f(x))
23 module O = Ocaml
24 module Cons = O.Cons
25 module G = Grammar
26 module T = Tools
27 module L = B.List
28 module A = B.Array
29 module S = B.String
30 module C = B.Char
31
32 let us = S.unsafe_sub
33
34 (* Unescape string: "\\n" --> "\n" etc., fairly complete wrt. ocaml string escapes. *)
35
36 let is_lu ch = C.is_lower ch || C.is_upper ch
37 let is_hex c = (c >= '0' && c <= '9') || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F')
38
39 let c3i c1 c2 c3 = ((C.code c1)-48)*100+((C.code c2)-48)*10+((C.code c3)-48)
40 let c2h c1 c2 = (C.hexa_value (c1))*16+(C.hexa_value c2)
41
42 let unescape s =
43 let l = S.length s in
44 let r = S.copy s in
45 let rec aux i j =
46 if i < l
47 then
48 (match s.[i] with
49 | '\\' ->
50 let k = i + 1 in
51 if k < l
52 then
53 (match s.[k] with
54 | '\\' -> (r.[j] <- '\\'; aux (i+2) (j+1))
55 | '"' -> (r.[j] <- '"'; aux (i+2) (j+1))
56 | '\'' -> (r.[j] <- '\''; aux (i+2) (j+1))
57 | 'n' -> (r.[j] <- '\n'; aux (i+2) (j+1))
58 | 'r' -> (r.[j] <- '\r'; aux (i+2) (j+1))
59 | 't' -> (r.[j] <- '\t'; aux (i+2) (j+1))
60 | 'b' -> (r.[j] <- '\b'; aux (i+2) (j+1))
61 | ' ' -> (r.[j] <- ' '; aux (i+2) (j+1))
62 | '0'..'9' ->
63 (if k + 3 < l
64 then
65 (match s.[k+1],s.[k+2] with
66 | ('0'..'9','0'..'9') -> (r.[j] <- C.chr (c3i s.[k] s.[k+1] s.[k+2]); aux (i+4) (j+1))
67 | _ -> (r.[j] <- '\\'; r.[j+1] <- s.[k]; aux (i+2) (j+2)))
68 else (r.[j] <- '\\'; r.[j+1] <- s.[k]; aux (i+2) (j+2)))
69 | 'x' ->
70 (if k + 3 < l
71 then
72 (match s.[k+1],s.[k+2] with
73 | (ch1,ch2) when (is_hex ch1 && is_hex ch2) ->
74 (r.[j] <- C.chr (c2h s.[k+1] s.[k+2]); aux (i+4) (j+1))
75 | _ -> (r.[j] <- '\\'; r.[j+1] <- s.[k]; aux (i+2) (j+2)))
76 else (r.[j] <- '\\'; r.[j+1] <- s.[k]; aux (i+2) (j+2)))
77 | ch -> (r.[j] <- '\\'; r.[j+1] <- ch; aux (i+2) (j+2)))
78 else (r.[j] <- '\\'; aux (i+1) (j+1))
79 | ch -> (r.[j] <- ch; aux (i+1) (j+1)))
80 else j
81 in
82 us r 0 (aux 0 0)
83
84 (*unescape "\\r\\n\\t\\b\\\\\\\"\\'\048\x61\n" = "\r\n\t\b\\\"'0a\n";;*)
85
86 let geteqstr str = unescape (S.strip_quotes str)
87
88 (*geteqstr "\"abc\\r\\n\"" = "abc\r\n";;*)
89
90 let pre_map lst =
91 L.map (function
92 | (G.Raw (name,(pre,opts),sects)) ->
93 let pre = geteqstr pre in
94 (pre,G.Raw (name,(pre,opts),sects))
95 | _ -> raise (Failure "pre_map")) lst
96
97 let parse_str v = function
98 | (_v,t_opt,Some (l,_opts),fs_opt) ->
99 (match fs_opt, t_opt with
100 | (Some (fs,_),_) -> "("^fs^" ("^v^"))"
101 | (_,None) -> v
102 | (_,Some (O.TypeConst O.TypeUnit)) -> "((function \"()\" -> () | _ -> raise (Failure \"unit_of_string\")) ("^v^"))"
103 | (_,Some (O.TypeConst O.TypeBool)) -> "(bool_of_string ("^v^"))"
104 | (_,Some (O.TypeConst O.TypeInt)) -> "(int_of_string ("^v^"))"
105 | (_,Some (O.TypeConst O.TypeInt64)) -> "(Int64.of_string ("^v^"))"
106 | (_,Some (O.TypeName (_,["int64"]))) -> "(Int64.of_string ("^v^"))"
107 | (_,Some (O.TypeConst O.TypeFloat)) -> "(float_of_string ("^v^"))"
108 | (_,Some (O.TypeConst O.TypeString)) -> v
109 | (_,Some (O.TypeName ([O.TypeConst O.TypeString], ["list"]))) -> "(Str.split (Str.regexp_string \";\") ("^v^"))"
110 | (_,Some t) ->
111 OcamlPrint.Output.type_expr stderr t; prerr_newline (); flush stderr;
112 failwith "Can't convert such a type from string.")
113 | _ -> v
114
115 let parse_null = function
116 | (_v,t_opt,Some (l,_opts),fs_opt) ->
117 (match fs_opt, t_opt with
118 | (Some (fs,_),_) -> false
119 | (_,None) -> true
120 | (_,Some (O.TypeConst O.TypeUnit)) -> false
121 | (_,Some (O.TypeConst O.TypeBool)) -> false
122 | (_,Some (O.TypeConst O.TypeInt)) -> false
123 | (_,Some (O.TypeConst O.TypeInt64)) -> false
124 | (_,Some (O.TypeName (_,["int64"]))) -> false
125 | (_,Some (O.TypeConst O.TypeFloat)) -> false
126 | (_,Some (O.TypeConst O.TypeString)) -> true
127 | (_,Some (O.TypeName ([O.TypeConst O.TypeString], ["list"]))) -> false
128 | (_,Some t) ->
129 OcamlPrint.Output.type_expr stderr t; prerr_newline (); flush stderr;
130 failwith "Can't convert such a type from string.")
131 | _ -> true
132
133 let has_lu str =
134 let len = S.length str in
135 let rec aux n = if n >= len then false else if is_lu str.[n] then true else aux (n+1) in
136 aux 0
137
138 let get_sect name i = function
139 | (_v,t_opt,Some (l,opts),fs_opt) as sect ->
140 (*eprintf "opts: %s\n" (S.concat "," opts); flush stderr;*)
141 let idx = string_of_int (i+1) in
142 let ls = geteqstr l in
143 let lslen = S.length ls in
144 let _lws = if L.mem "m" opts then "_lws" else "" in
145 let _ci = if L.mem "i" opts && has_lu ls then "_ci" else "" in
146 let skip1 = if L.mem "s" opts then "let p = skip_sptab str strlen p in\n " else "" in
147 let skip2 = if L.mem "l" opts then "let p = skip_lws str strlen p in\n " else "" in
148 let pn = parse_null sect in
149 let s = if pn then "v" else "s" in
150 let getstr = "let (p,_l,"^s^idx^") = (upto_mark"^_lws^_ci^" "^l^" "^(string_of_int lslen)^" str strlen p) in\n " in
151 let trim = if L.mem "t" opts then "let "^s^idx^" = rmldtrsp0 "^s^idx^" _l in\n " else "" in
152 let getv = if pn then "" else "let v"^idx^" = "^(parse_str ("s"^idx) sect)^" in\n " in
153 skip1^skip2^getstr^trim^getv
154 | _ -> name
155
156 let get_sects name opts = function
157 | [] -> ("%n", "", name)
158 | sects ->
159 (*eprintf "name(2): %s opts=%s\n" name (S.concat "," opts); flush stderr;*)
160 let lets = L.mapi (fun i sect -> (get_sect name i sect)) sects in
161 let skip = if L.mem "s" opts then "let p = skip_sptab str strlen p in\n " else "" in
162 let vs = L.mapi (fun i _ -> "v"^(string_of_int (i+1))) sects in
163 ("p",
164 "\n let p = %n in\n "^skip^(S.concat "" lets),
165 "("^name^" ("^(S.concat ", " vs)^"))")
166
167 let rec map_pre_to_cons lst pre =
168 match L.fold_left (fun l (p,n) -> if p = pre then n::l else l) [] lst with
169 | [] -> eprintf "map_pre_to_cons: no matches\n"; flush stderr; ("%n","","<no matches>")
170 | [(G.Raw (name,(p,opts),sects))] -> get_sects name opts sects
171 | raws -> eprintf "map_pre_to_cons: multiple matches\n"; flush stderr; ("%n","","<multiple matches>")
172
173 let do_it types name lst file =
174 let hdrs = L.fold_left (fun l r -> match r with G.Raw (_,(p,_),_) ->
175 let p = unescape (S.strip_quotes p) in
176 if S.length p >= 1 then p::l else l | _ -> l) [] lst in
177 let premap = pre_map lst in
178 eprintf "mkrp: Generating %s/%s\n" (Unix.getcwd()) file;
179 Mkrp.mktab1
180 ~ci:true
181 ~from_n:true
182 ~str_to_arg:(map_pre_to_cons premap)
183 ~prefix:name
184 ~header:"open HttpTools\nopen HttpServerCore\n"
185 ~argtys:[("str","string");("strlen","int")]
186 ~intype:"rawmsg"
187 ~restype:"int * rawmsg"
188 ~errordef:[]
189 file (Array.of_list hdrs) 2 0
Something went wrong with that request. Please try again.