Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

377 lines (318 sloc) 9.64 kb
(*
* Copyright (c) 2010 Thomas Gazagnaire <thomas@gazagnaire.org>
* See the COPYING file included in this distribution for licensing details
*)
open Abnf_syntaxtree
open Printf
type t =
| T_sep
| T_char
| T_string
| T_constant of string
| T_var of string
| T_mu of string * t
| T_tuple of t list
| T_sum of t list
| T_list of t
| T_array of t
| T_int of int (* size of the integer *)
| T_bigint
| T_option of t
let rec pp = function
| T_sep -> "SEP"
| T_char -> "CHAR"
| T_string -> "STRING"
| T_constant s -> sprintf "CONSTANT(%s)" s
| T_var s -> sprintf "VAR(%s)" s
| T_mu (s, t) -> sprintf "MU(%s, %s)" s (pp t)
| T_tuple s -> sprintf "TUPLE(%s)" (String.concat ", " (List.map pp s))
| T_sum s -> sprintf "SUM(%s)" (String.concat ", " (List.map pp s))
| T_list s -> sprintf "LIST(%s)" (pp s)
| T_array s -> sprintf "ARRAY(%s)" (pp s)
| T_int i -> sprintf "INT(%d)" i
| T_bigint -> "BIGINT"
| T_option t -> sprintf "OPTION(%s)" (pp t)
let is_sep = function
| T_mu (_, T_sep)
| T_sep -> true
| _ -> false
let is_char = function
| T_mu (_, T_char)
| T_char -> true
| _ -> false
let is_string = function
| T_mu (_, T_string)
| T_string -> true
| s -> is_char s
let is_constant = function
| T_mu (_, T_constant _)
| T_constant _ -> true
| _ -> false
let cleanup l =
List.filter (fun x -> not (is_constant x || is_sep x)) l
let string_of_constant = function
| T_mu (_, T_constant u)
| T_constant u -> u
| _ -> failwith "string_of_constant"
let is_sum = function
| T_mu (_, T_sum _)
| T_sum _ -> true
| _ -> false
let is_nice_variant = function
| T_mu (u, _) -> true
| T_tuple ( t :: _ )
| t -> is_constant t
let get_variant_constr = function
| T_mu (u, _) -> u
| T_tuple ( t :: _ )
| t -> string_of_constant t
let is_well_formed_sum s =
let l = ref [] in
let aux t =
if is_nice_variant t then begin
let u = get_variant_constr t in
(* eprintf "WF: %s // %s\n" u (String.concat "." !l); *)
if not (List.mem u !l) then begin
l := u :: !l;
true
end else begin
false
end
end else
true in
List.for_all aux s
let rec fold_left f init t =
let res = f init t in
match t with
| T_sep
| T_char
| T_string
| T_constant _
| T_var _
| T_mu _
| T_int _
| T_bigint -> res
| T_tuple tl
| T_sum tl -> List.fold_left f res tl
| T_list t
| T_array t
| T_option t -> f res t
let exists f t =
fold_left (fun accu t -> accu || f t) false t
type decl = {
name : string;
t : t;
}
type env = {
rules : (string, rule) Hashtbl.t;
mutable top : string list; (* Top-level rule name(s) *)
}
(* XXX: my first guess was to add all the top nodes + nodes corresponding to
variant types; however this doesn't work because of possible cycles.
So need to think a bit more about that ... *)
let make_env rules =
(* XXX: let top = Abnf_ops.Graph.top_nodes rules in *)
let top = Abnf_ops.Graph.topological_sort rules in
{
rules = rules;
top = top;
}
let find_rule env name =
Hashtbl.find env.rules name
let is_toplevel env name =
List.mem name env.top
let add_toplevel env name =
if not (List.mem name env.top) then
env.top <- name :: env.top
let t_of_terminal = function
| UPALPHA
| LOALPHA
| ALPHA
| BIT
| CHAR
| CR
| CTL
| DQUOTE
| HEXDIGIT
| HTAB
| LF
| OCTET
| SP
| VCHAR -> T_char
| WSP
| LWSP -> T_sep
| CRLF -> T_string
| DIGIT -> T_int 1
let t_of_alt r s = match r,s with
| T_sum u, T_sum v when List.for_all is_char u && List.for_all is_char v ->
T_char
| T_sum u, T_sum v when List.for_all is_string u && List.for_all is_string v ->
T_string
| T_sum u, T_sum v ->
T_sum (u @ v)
| T_sum u, v when List.for_all is_char u && is_char v ->
T_char
| T_sum u, v when List.for_all is_string u && is_string v ->
T_string
| T_sum u, v ->
T_sum (u @ [v])
| u, T_sum v when is_char u && List.for_all is_char v ->
T_char
| u, T_sum v when is_string u && List.for_all is_string v ->
T_string
| u, T_sum v ->
T_sum (u :: v)
| u, v when is_char u && is_char v ->
T_char
| u, v when is_string u && is_string v ->
T_string
| u, v ->
T_sum [u; v]
let t_of_concat r s = match r,s with
| T_tuple u, T_tuple v -> T_tuple (u @ v)
| T_tuple u, v -> T_tuple (u @ [v])
| u , T_tuple v -> T_tuple (u :: v)
| T_char , T_char
| T_char , T_string
| T_string , T_char
| T_string , T_string -> T_string
| T_sep , T_sep -> T_sep
| T_int i , T_int j -> T_int (i + j)
| T_bigint , T_int _
| T_bigint , T_bigint
| T_int _ , T_bigint -> T_bigint
| T_list x , T_list y
| x , T_list y
| T_list x , y when x=y-> T_list x
| T_list x , T_sep
| T_sep , T_list x -> T_list x
| u , v -> T_tuple [u; v]
let rec t_of_rule ?root env = function
| S_terminal t -> t_of_terminal t
| S_string s ->
T_constant s
| S_concat (r,s) ->
t_of_concat (t_of_rule ?root env r) (t_of_rule ?root env s)
| S_reference str ->
if root = Some str then
T_var str
else if is_toplevel env str then begin
let new_env = { env with top = [ str ] } in
(* eprintf "REF: %s (%s)\n" str (String.concat ", " new_env.top); *)
let t = t_of_rule ~root:str new_env (find_rule env str) in
T_mu (str, t)
end else begin
let new_env = if root <> None then { env with top = str :: env.top } else env in
(* eprintf "VAR: %s (%s)\n" str (String.concat ", " new_env.top); *)
t_of_rule ?root new_env (find_rule env str)
end
| S_alt (r,s) -> t_of_alt (t_of_rule ?root env r) (t_of_rule ?root env s)
| S_bracket r -> t_of_rule ?root env r
| S_element_list (_,None,r)
| S_repetition (_,None,r) ->
(match t_of_rule ?root env r with
| T_char -> T_string
| T_string -> T_string
| T_int _
| T_bigint -> T_bigint
| t -> T_list t)
| S_element_list (Some 0,Some 1,r)
| S_repetition (Some 0,Some 1,r) ->
T_option (t_of_rule ?root env r)
| S_element_list (_,Some k,r)
| S_repetition(_,Some k,r) ->
(match t_of_rule ?root env r with
| T_char -> T_string
| T_int i -> T_int (i+k)
| T_bigint -> T_bigint
| t -> T_array t)
| S_hex_range _ -> T_char
| S_any_except (r,_) ->
(match t_of_rule ?root env r with
| T_char -> T_string
| T_int _
| T_bigint -> T_bigint
| t -> T_list t)
(* WARNING: This function modifies the environnement *)
let decl_of_rd env name rule =
let t = t_of_rule env rule in
(* XXX: If the rule is a variant, then add it the the top-level rules *)
(* if not (is_toplevel env name) && is_sum t then
add_toplevel env name; *)
{
name = name;
t = t;
}
let ocamlify name =
(* Need to copy the string if it is used by someone else; but don't think it's the case here *)
for i = 0 to String.length name - 1 do
if name.[i] >= 'A' && name.[i] < 'Z' then
name.[i] <- Char.lowercase name.[i]
else if name.[i] = '-' then
name.[i] <- '_'
done;
name
let string_of_nice_variant ss = function
| T_tuple (T_constant u :: v)
| T_tuple (T_mu (u,_) :: v) ->
(match List.map ss (cleanup v) with
| [] -> sprintf "'%s" (ocamlify u)
| args -> sprintf "'%s of %s" (ocamlify u) (String.concat " * " args))
| T_constant u ->
sprintf "'%s" (ocamlify u)
| T_mu (u,t) ->
if is_sum t then
sprintf "%s" (ocamlify u)
else
sprintf "'%s of %s" (ocamlify u) (ocamlify u)
| _ ->
failwith "string_of_nice_sum is not up-to-date with is_nice_sum"
let string_of_sum ss s =
let wf = is_well_formed_sum s in
let aux (i, l) t =
let r =
if wf && is_nice_variant t then
string_of_nice_variant ss t
else
if is_constant t then
sprintf "%s" (ocamlify (string_of_constant t))
else
sprintf "`a%i of %s" i (ss t) in
(i+1, r :: l) in
let _, l = List.fold_left aux (1,[]) s in
sprintf "[ %s ]" (String.concat " | " (List.rev l))
let (<<=) i k =
10. ** (float i) <= 2. ** (float k)
let rec string_of_t = function
| T_sep -> "unit"
| T_char -> "char"
| T_string -> "string"
| T_constant _ -> "unit"
| T_mu (v,_) -> ocamlify v
| T_var v -> ocamlify v
| T_list l -> sprintf "%s list" (string_of_t l)
| T_array a -> sprintf "%s array" (string_of_t a)
| T_option o -> sprintf "%s option" (string_of_t o)
| T_int i when i <<= 31 -> "int"
| T_int i when i <<= 32 -> "int32"
| T_int i when i <<= 64 -> "int64"
| T_int _ | T_bigint -> "Bigint.t"
| T_tuple [t] -> sprintf "%s" (string_of_t t)
| T_tuple t ->
(* XXX: here we can do better in some cases, ie. create a record if the names are meanigful *)
sprintf "(%s)" (String.concat " * " (List.map string_of_t (cleanup t)))
| T_sum s ->
string_of_sum string_of_t s
let string_of_decl d =
Printf.sprintf "%s = %s" (ocamlify d.name) (string_of_t d.t)
let to_string rules =
let env = make_env rules in
let decls = Hashtbl.fold (fun name r accu -> decl_of_rd env name r :: accu) rules [] in
let aux d =
if is_toplevel env d.name then
string_of_decl d
else
"" in
sprintf "type %s" (String.concat "\n and " (List.map aux decls))
let dump rules =
printf "(* autogenerated file *)\n\n%s" (to_string rules)
Jump to Line
Something went wrong with that request. Please try again.