Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Tag: 0.3
Fetching contributors…

Cannot retrieve contributors at this time

367 lines (292 sloc) 11.164 kB
(***********************************************************************)
(* *)
(* Copyright 2012 OCamlPro *)
(* Copyright 2012 INRIA *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Public License version 3.0. *)
(* *)
(* TypeRex is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
(* GNU General Public License for more details. *)
(* *)
(***********************************************************************)
type value =
| Bool of bool
| Int of int
| String of string
| Symbol of string
| Ident of string
| List of value list (* [ .. ] *)
| Group of value list (* ( .. ) *)
| Option of value * value list (* ... { ... } *)
type section = {
kind : string;
name : string;
items: item list
}
and item =
| Section of section
| Variable of string * value
type file = {
contents: item list;
filename: string;
}
let empty = {
contents = [];
filename = "<none>";
}
let variables items =
let l = List.fold_left (fun accu -> function
| Variable (k,v) -> (k,v) :: accu
| _ -> accu
) [] items in
List.rev l
let sections items =
let l = List.fold_left (fun accu -> function
| Section s -> (s.kind, s) :: accu
| _ -> accu
) [] items in
List.rev l
exception Bad_format of string
let bad_format fmt =
Printf.kprintf
(fun str -> raise (Bad_format (Printf.sprintf "Bad format! %s" str)))
fmt
let rec is_valid items fields =
List.for_all (function
| Variable (f, _) -> List.mem f fields
| Section s -> is_valid s.items fields
) items
let invalid_fields items fields =
let rec aux accu = function
| Variable(f,_) -> if List.mem f fields then accu else f :: accu
| Section s -> List.fold_left aux accu s.items in
List.fold_left aux [] items
let rec kind = function
| Bool b -> Printf.sprintf "bool(%b)" b
| Int i -> Printf.sprintf "int(%d)" i
| Ident i -> Printf.sprintf "ident(%s)" i
| Symbol s -> Printf.sprintf "symbol(%s)" s
| String s -> Printf.sprintf "string(%S)" s
| List l -> Printf.sprintf "list(%s)" (kinds l)
| Group g -> Printf.sprintf "group(%s)" (kinds g)
| Option(o,l) -> Printf.sprintf "option(%s,%s)" (kind o) (kinds l)
and kinds l =
Printf.sprintf "{%s}" (String.concat " " (List.map kind l))
(* Base parsing functions *)
let parse_bool = function
| Bool b -> b
| x -> bad_format "Expecting a bool, got %s" (kind x)
let parse_int = function
| Int i -> i
| x -> bad_format "Expecting an int, got %s" (kind x)
let parse_ident = function
| Ident i -> i
| x -> bad_format "Expecting an ident, got %s" (kind x)
let parse_symbol = function
| Symbol s -> s
| x -> bad_format "Expecting a symbol, got %s" (kind x)
let parse_string = function
| String s -> s
| x -> bad_format "Expecting a string, got %s" (kind x)
let parse_list fn = function
| List s -> List.map fn s
| x -> bad_format "Expecting a list, got %s" (kind x)
let parse_group fn = function
| Group g -> List.map fn g
| x -> bad_format "Expecting a group, got %s" (kind x)
let parse_option f g = function
| Option (k,l) -> f k, List.map g l
| k -> f k, []
let parse_single_option f g = function
| Option (k,[v]) -> f k, Some (g v)
| k -> f k, None
let parse_string_option f = function
| Option (k,l) -> parse_string k, Some (f l)
| k -> parse_string k, None
let parse_string_list = parse_list parse_string
let parse_string_pair_of_list = function
| [String x; String y] -> (x,y)
| x -> bad_format "Expecting a pair of strings, got %s" (kinds x)
let parse_string_pair = function
| List [String x; String y] -> (x,y)
| x -> bad_format "Expecting a pair of strings, got %s"(kind x)
let parse_single_string = function
| [String x] -> x
| x -> bad_format "Expecting a single string, got %s" (kinds x)
let parse_or fns v =
let dbg = List.map fst fns in
let rec aux = function
| [] ->
bad_format "Expecting %s, got %s" (String.concat " or " dbg) (kind v)
| (_,h)::t ->
try h v
with Bad_format _ -> aux t in
aux fns
let parse_sequence fns v =
match v with
| List l ->
let rec aux = function
| (_,f) :: fns, h :: t -> f h :: aux (fns, t)
| [], [] -> []
| _ ->
bad_format
"Expecting %s, got %d values"
(String.concat ", " (List.map fst fns))
(List.length l) in
aux (fns, l)
| x -> bad_format "Expecting a list, got %s" (kind x)
let make_string str = String str
let make_ident str = Ident str
let make_symbol str = Symbol str
let make_bool b = Bool b
let make_int i = Int i
let make_list fn l = List (List.map fn l)
let make_group fn g = Group (List.map fn g)
let make_option f g (v,l) = Option (f v, List.map g l)
let make_pair f (k,v) = List [f k; f v]
let make_string_pair = make_pair make_string
(* Printing *)
let rec string_of_value = function
| Symbol s
| Ident s -> Printf.sprintf "%s" s
| Int i -> Printf.sprintf "%d" i
| Bool b -> Printf.sprintf "%b" b
| String s -> Printf.sprintf "%S" s
| List l -> Printf.sprintf "[%s]" (string_of_values l)
| Group g -> Printf.sprintf "(%s)" (string_of_values g)
| Option(v,l) -> Printf.sprintf "%s {%s}" (string_of_value v) (string_of_values l)
and string_of_values l =
String.concat " " (List.map string_of_value l)
let incr tab = " " ^ tab
let rec string_of_item_aux tab = function
| Variable (i, v) -> Printf.sprintf "%s%s: %s" tab i (string_of_value v)
| Section s ->
Printf.sprintf "%s%s %S {\n%s\n}"
tab s.kind s.name
(string_of_items_aux (incr tab) s.items)
and string_of_items_aux tab is =
String.concat "\n" (List.map (string_of_item_aux tab) is)
let string_of_item = string_of_item_aux ""
let string_of_items = string_of_items_aux ""
let string_of_file f = string_of_items f.contents
(* Reading section contents *)
let assoc items n parse =
try parse (List.assoc n (variables items))
with Not_found -> bad_format "Field %S is missing" n
let get_all_section_by_kind items kind =
try List.map snd (List.find_all (fun (k,_) -> k=kind) (sections items))
with Not_found -> bad_format "Section kind %S is missing" kind
let get_section_by_kind items kind =
try snd (List.find (fun (k,_) -> k=kind) (sections items))
with Not_found -> bad_format "Section kind %S is missing" kind
let assoc_sections items kind parse =
List.map parse (get_all_section_by_kind items kind)
let assoc_option items n parse =
try Some (parse (List.assoc n (variables items)))
with Not_found -> None
let assoc_default d items n parse =
try parse (List.assoc n (variables items))
with Not_found -> d
let assoc_list items n parse =
try parse (List.assoc n (variables items))
with Not_found -> []
let assoc_string_list s n =
assoc_list s n (parse_list parse_string)
(* transform: "foo" (< "1", > "2") => "foo" (< "1"), "foo" (>"2") *)
let rec parse_constraints name = function
| [] -> []
| (Symbol r) :: (String v) :: [] ->
[ ((name,None), Some (r, v)) ]
| (Symbol r) :: (String v) :: (Symbol ",") :: t ->
((name,None), Some (r, v)) :: parse_constraints name t
| x -> bad_format "Expecting a constraint, got %s" (kinds x)
(* contains only "," *)
let rec parse_and_formula_aux = function
| [] -> []
| [String name] -> [ ((name,None), None) ]
| [Option(String name, g)] -> parse_constraints name g
| [Group g] -> parse_and_formula_aux g
| [ x ] -> bad_format "Expecting string or group, got %s" (kind x)
| e1 :: e2 -> parse_and_formula_aux [e1] @ parse_and_formula_aux e2
let parse_and_formula = function
| List l -> parse_and_formula_aux l
| x -> bad_format "Expecting list, got %s" (kind x)
(* contains only "|" *)
let rec parse_or_formula_aux = function
| [] -> []
| [String name] -> [ ((name,None), None) ]
| [Option(String name, g)] -> parse_constraints name g
| [Group g] -> parse_or_formula_aux g
| [ x ] -> bad_format "Expecting string or group, got %s" (kind x)
| e1 :: Symbol "|" :: e2 -> parse_or_formula_aux [e1] @ parse_or_formula_aux e2
| _ -> bad_format "Expecting a 'or' formula"
let parse_or_formula = function
| List l -> parse_or_formula_aux l
| x -> bad_format "Expecting list, got %s" (kind x)
let rec parse_cnf_formula_aux = function
| [] -> []
| e1 :: e2 -> parse_or_formula_aux [e1] :: parse_cnf_formula_aux e2
let parse_cnf_formula = function
| List l -> parse_cnf_formula_aux l
| x -> bad_format "Expecting list, got %s" (kind x)
let make_constraint = function
| (name,_), None -> String name
| (name,_), Some (r,v) -> Option (String name, [Symbol r; String v])
let make_and_formula_aux l =
List.map make_constraint l
let make_and_formula l =
List (make_and_formula_aux l)
let make_cnf_formula l =
let cnf =
List.fold_left (fun cnf l ->
let orl = List.map make_constraint l in
let orl =
List.fold_left (fun orl elt ->
match orl with
| [] -> [elt]
| _ -> elt :: Symbol "|" :: orl
) [] orl in
match orl with
| [] -> cnf
| [c] -> c :: cnf
| _ -> (Group orl) :: cnf
) [] l in
List cnf
let parse_relop = function
| "=" -> `Eq
| ">=" -> `Geq
| ">" -> `Gt
| "<=" -> `Leq
| "<" -> `Lt
| _ -> invalid_arg "parse_relop"
let parse_constraint = function
| List [ Symbol r; String v ] ->
(try (parse_relop r, Types.OCaml_V.of_string v)
with _ -> bad_format "Expecting a relop, got %s" r)
| x -> bad_format "Expecting a constraint, got %s" (kind x)
let string_of_relop = function
| `Eq -> "="
| `Geq -> ">="
| `Gt -> ">"
| `Leq -> "<="
| `Lt -> "<"
| _ -> invalid_arg "parse_relop"
let make_constraint (r, v) =
List [
Symbol (string_of_relop r);
String (Types.OCaml_V.to_string v);
]
let parse_env_variable v =
let l = parse_sequence [
("ident" , parse_ident);
("symbol", parse_symbol);
("string", parse_string);
] v in
match l with
| [ident; symbol; string] -> (ident, symbol, string)
| _ -> assert false
let make_env_variable (ident, symbol, string) =
List [make_ident ident; make_symbol symbol; make_string string]
Jump to Line
Something went wrong with that request. Please try again.