viewcvs.cgi/schema/schema_types.ml


open Printf ;;

module StringMap = Map.Make (String) ;;
module ValueSet = Set.Make (Value) ;;
module OrderedStringOption =
  struct
    type t = string option
    let compare = Pervasives.compare
  end
;;
module First = Set.Make (OrderedStringOption) ;;

exception XSI_validation_error of string ;;
exception XSD_validation_error of string ;;

type derivation = Extension | Restriction ;;

type value_constraint = Fixed of Value.t | Default of Value.t ;;

type ws_handling = WS_preserve | WS_replace | WS_collapse ;;

type facet =
  | F_length of int * bool
  | F_minLength of int * bool
  | F_maxLength of int * bool
  | F_pattern of Pcre.regexp
  | F_enumeration of ValueSet.t
  | F_whiteSpace of ws_handling * bool
  | F_maxInclusive of Value.t * bool
  | F_maxExclusive of Value.t * bool
  | F_minInclusive of Value.t * bool
  | F_minExclusive of Value.t * bool
  | F_totalDigits of int * bool
  | F_fractionDigits of int * bool
;;

type simple_type_def =
  | SBuilt_in of string
  | SUser_defined of string option * variety * facet list * simple_type_def ref

and variety =
  | V_atomic of simple_type_def ref
  | V_list of simple_type_def ref
  | V_union of simple_type_def ref list
;;

type att_decl = string * simple_type_def ref * value_constraint option ;;
type attribute_use = bool * att_decl * value_constraint option ;;

type term =
  | All of particle list
  | Choice of particle list
  | Sequence of particle list
  | Elt of elt_decl ref
and content_type =
  | CT_empty
  | CT_simple of simple_type_def
  | CT_model of particle * bool
  (* TODO move min and max directly on terms? *)
and particle = int * int option * term
and elt_decl = string * type_def ref * value_constraint option
and complex_type_def =
  | CBuilt_in of string
  | CUser_defined of
      string option * type_def ref * derivation *
      attribute_use list * content_type
and type_def = S of simple_type_def | C of complex_type_def
;;

type schema = {
  type_defs: type_def list;
  att_decls: att_decl list;
  elt_decls: elt_decl list
} ;;

let name_of_elt_decl (name, _, _) = name ;;
let name_of_type_def = function
  | S (SBuilt_in name) -> name
  | C (CBuilt_in name) -> name
  | S (SUser_defined (Some name, _, _, _)) -> name
  | S (SUser_defined (None, _, _, _)) -> "| UNNAMED |"
  | C (CUser_defined (Some name, _, _, _, _)) -> name
  | C (CUser_defined (None, _, _, _, _)) -> "| UNNAMED |"
;;
let name_of_attribute_use (_, (n, _, _), _) = n ;;

class type resolver =
  object
    method resolve_att: string -> att_decl ref
    method resolve_elt: string -> elt_decl ref
    method resolve_typ: string -> type_def ref
  end
;;

(* pretty printing *)

open Format ;;

let print_simple_type ppf = function
  | SBuilt_in n -> fprintf ppf "%s" n
  | _ -> assert false
;;
let print_att_decl ppf (name, st, constr) =
  fprintf ppf "@[{%s: %a}@]" name print_simple_type !st
;;
let rec print_elt_decl ppf (name, t, _) =
  fprintf ppf "@[%s%s:@ @[%a@]>@]" "<" name print_type !t
and print_type ppf = function
  | S s -> fprintf ppf "@[%a@]" print_simple_type s
  | C c -> fprintf ppf "@[%a@]" print_complex_type c
and print_complex_type ppf = function
  | CBuilt_in n -> fprintf ppf "@[%s@]" n
  | CUser_defined (_, _, _, _, ct) -> fprintf ppf "@[%a@]" print_ct ct
and print_ct ppf = function
  | CT_empty -> fprintf ppf "@[EMPTY@]"
  | CT_simple s -> print_simple_type ppf s
  | CT_model (p, _) -> print_particle ppf p
and print_particle ppf (min, max, term) =
  fprintf ppf "@[%a%s@]"
    print_term term
    (match min,max with
    | 1, Some 1 -> ""
    | 1, None -> "+"
    | 0, None -> "*"
    | min, None -> sprintf "{%d,*}" min
    | min, Some max -> sprintf "{%d,%d}" min max)
and print_term ppf = function
  | Elt elt_decl_ref -> print_elt_decl ppf !elt_decl_ref
  | Choice p ->
      fprintf ppf "@[[%t]@]"
        (fun ppf ->
          let rec aux = function
            | [] -> ()
            | hd::[] -> fprintf ppf "@[%a@]" print_particle hd
            | hd::tl -> fprintf ppf "@[%a@]@ | " print_particle hd; aux tl
          in
          aux p)
  | Sequence p ->
      fprintf ppf "@[[%t]@]"
        (fun ppf ->
          let rec aux = function
            | [] -> ()
            | hd::[] -> fprintf ppf "@[%a@]" print_particle hd
            | hd::tl -> fprintf ppf "@[%a@];@ " print_particle hd; aux tl
          in
          aux p)
  | _ -> assert false
;;

let rec normalize_ws =
  let ws_RE = Pcre.regexp "[\t\r\n]" in
  let spaces_RE = Pcre.regexp "[ ]+" in
  fun handling s ->
  match handling with
  | WS_preserve -> s
  | WS_replace -> Pcre.replace ~rex:ws_RE ~templ:" " s
  | WS_collapse ->
      Pcre.replace ~rex:spaces_RE ~templ:" " (normalize_ws WS_replace s)
;;

1
2	open Printf ;;
3
4	module StringMap = Map.Make (String) ;;
5	module ValueSet = Set.Make (Value) ;;
6	module OrderedStringOption =
7	struct
8	type t = string option
9	let compare = Pervasives.compare
10	end
11	;;
12	module First = Set.Make (OrderedStringOption) ;;
13
14	exception XSI_validation_error of string ;;
15	exception XSD_validation_error of string ;;
16
17	type derivation = Extension \| Restriction ;;
18
19	type value_constraint = Fixed of Value.t \| Default of Value.t ;;
20
21	type ws_handling = WS_preserve \| WS_replace \| WS_collapse ;;
22
23	type facet =
24	\| F_length of int * bool
25	\| F_minLength of int * bool
26	\| F_maxLength of int * bool
27	\| F_pattern of Pcre.regexp
28	\| F_enumeration of ValueSet.t
29	\| F_whiteSpace of ws_handling * bool
30	\| F_maxInclusive of Value.t * bool
31	\| F_maxExclusive of Value.t * bool
32	\| F_minInclusive of Value.t * bool
33	\| F_minExclusive of Value.t * bool
34	\| F_totalDigits of int * bool
35	\| F_fractionDigits of int * bool
36	;;
37
38	type simple_type_def =
39	\| SBuilt_in of string
40	\| SUser_defined of string option * variety * facet list * simple_type_def ref
41
42	and variety =
43	\| V_atomic of simple_type_def ref
44	\| V_list of simple_type_def ref
45	\| V_union of simple_type_def ref list
46	;;
47
48	type att_decl = string * simple_type_def ref * value_constraint option ;;
49	type attribute_use = bool * att_decl * value_constraint option ;;
50
51	type term =
52	\| All of particle list
53	\| Choice of particle list
54	\| Sequence of particle list
55	\| Elt of elt_decl ref
56	and content_type =
57	\| CT_empty
58	\| CT_simple of simple_type_def
59	\| CT_model of particle * bool
60	(* TODO move min and max directly on terms? *)
61	and particle = int * int option * term
62	and elt_decl = string * type_def ref * value_constraint option
63	and complex_type_def =
64	\| CBuilt_in of string
65	\| CUser_defined of
66	string option * type_def ref * derivation *
67	attribute_use list * content_type
68	and type_def = S of simple_type_def \| C of complex_type_def
69	;;
70
71	type schema = {
72	type_defs: type_def list;
73	att_decls: att_decl list;
74	elt_decls: elt_decl list
75	} ;;
76
77	let name_of_elt_decl (name, _, _) = name ;;
78	let name_of_type_def = function
79	\| S (SBuilt_in name) -> name
80	\| C (CBuilt_in name) -> name
81	\| S (SUser_defined (Some name, _, _, _)) -> name
82	\| S (SUser_defined (None, _, _, _)) -> "\| UNNAMED \|"
83	\| C (CUser_defined (Some name, _, _, _, _)) -> name
84	\| C (CUser_defined (None, _, _, _, _)) -> "\| UNNAMED \|"
85	;;
86	let name_of_attribute_use (_, (n, _, _), _) = n ;;
87
88	class type resolver =
89	object
90	method resolve_att: string -> att_decl ref
91	method resolve_elt: string -> elt_decl ref
92	method resolve_typ: string -> type_def ref
93	end
94	;;
95
96	(* pretty printing *)
97
98	open Format ;;
99
100	let print_simple_type ppf = function
101	\| SBuilt_in n -> fprintf ppf "%s" n
102	\| _ -> assert false
103	;;
104	let print_att_decl ppf (name, st, constr) =
105	fprintf ppf "@[{%s: %a}@]" name print_simple_type !st
106	;;
107	let rec print_elt_decl ppf (name, t, _) =
108	fprintf ppf "@[%s%s:@ @[%a@]>@]" "<" name print_type !t
109	and print_type ppf = function
110	\| S s -> fprintf ppf "@[%a@]" print_simple_type s
111	\| C c -> fprintf ppf "@[%a@]" print_complex_type c
112	and print_complex_type ppf = function
113	\| CBuilt_in n -> fprintf ppf "@[%s@]" n
114	\| CUser_defined (_, _, _, _, ct) -> fprintf ppf "@[%a@]" print_ct ct
115	and print_ct ppf = function
116	\| CT_empty -> fprintf ppf "@[EMPTY@]"
117	\| CT_simple s -> print_simple_type ppf s
118	\| CT_model (p, _) -> print_particle ppf p
119	and print_particle ppf (min, max, term) =
120	fprintf ppf "@[%a%s@]"
121	print_term term
122	(match min,max with
123	\| 1, Some 1 -> ""
124	\| 1, None -> "+"
125	\| 0, None -> "*"
126	\| min, None -> sprintf "{%d,*}" min
127	\| min, Some max -> sprintf "{%d,%d}" min max)
128	and print_term ppf = function
129	\| Elt elt_decl_ref -> print_elt_decl ppf !elt_decl_ref
130	\| Choice p ->
131	fprintf ppf "@[[%t]@]"
132	(fun ppf ->
133	let rec aux = function
134	\| [] -> ()
135	\| hd::[] -> fprintf ppf "@[%a@]" print_particle hd
136	\| hd::tl -> fprintf ppf "@[%a@]@ \| " print_particle hd; aux tl
137	in
138	aux p)
139	\| Sequence p ->
140	fprintf ppf "@[[%t]@]"
141	(fun ppf ->
142	let rec aux = function
143	\| [] -> ()
144	\| hd::[] -> fprintf ppf "@[%a@]" print_particle hd
145	\| hd::tl -> fprintf ppf "@[%a@];@ " print_particle hd; aux tl
146	in
147	aux p)
148	\| _ -> assert false
149	;;
150
151	let rec normalize_ws =
152	let ws_RE = Pcre.regexp "[\t\r\n]" in
153	let spaces_RE = Pcre.regexp "[ ]+" in
154	fun handling s ->
155	match handling with
156	\| WS_preserve -> s
157	\| WS_replace -> Pcre.replace ~rex:ws_RE ~templ:" " s
158	\| WS_collapse ->
159	Pcre.replace ~rex:spaces_RE ~templ:" " (normalize_ws WS_replace s)
160	;;
161