Commit f6e08541 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-02-23 14:27:37 by afrisch] Various

Original author: afrisch
Date: 2005-02-23 14:27:38+00:00
parent 9404175b
...@@ -7,16 +7,267 @@ type 'a regexp = ...@@ -7,16 +7,267 @@ type 'a regexp =
| Plus of 'a regexp | Plus of 'a regexp
| Trans of 'a | Trans of 'a
(*
type 'a re = type 'a re =
| RSeq of 'a re list | RSeq of 'a re list
| RAlt of 'a re list | RAlt of 'a re list
| RTrans of 'a | RTrans of 'a
| RStar of 'a re | RStar of 'a re
| RPlus of 'a re | RPlus of 'a re
*)
module type S = sig
type t
val equal: t -> t -> bool
val compare: t -> t -> int
val hash: t -> int
end
module Decompile(H : Hashtbl.S)(S : S) = struct
type atom =
| AStar of trie
| APlus of trie
| ATrans of S.t
and trie =
| AEmpty
| AEps
| ABranch of atom list * trie * trie * bool * int * int
(* Branching atom, left, right,
nullable,
hash,
uid *)
type 'a re = trie
let empty = AEmpty
let epsilon = AEps
let nullable = function
| AEmpty -> false
| AEps -> true
| ABranch (_,_,_,n,_,_) -> n
(*
let size = function
| AEmpty -> 0
| AEps -> 0
| ABranch (_,_,_,_,_,_,sz) -> sz
*)
let compare_trie t1 t2 = match t1,t2 with
| AEmpty, AEmpty | AEps, AEps -> 0
| AEmpty, _ -> -1 | _,AEmpty -> 1
| AEps, _ -> -1 | _, AEps -> 1
| ABranch (_,_,_,_,_,id1), ABranch (_,_,_,_,_,id2) -> id1 - id2
let equal_atom a1 a2 = match a1,a2 with
| AStar t1, AStar t2 | APlus t1, APlus t2 -> t1 == t2
| ATrans t1, ATrans t2 -> S.equal t1 t2
| _ -> false
let rec equal_atom_list a1 a2 = match a1,a2 with
| [],[] -> true
| hd1::tl1,hd2::tl2 -> equal_atom hd1 hd2 && equal_atom_list tl1 tl2
| _ -> false
let compare_atom a1 a2 = match a1,a2 with
| AStar t1, AStar t2 | APlus t1, APlus t2 -> compare_trie t1 t2
| AStar _, _ -> -1 | _, AStar _ -> 1
| APlus _, _ -> -1 | _, APlus _ -> 1
| ATrans t1, ATrans t2 -> S.compare t1 t2
let hash_trie = function
| AEmpty -> 0
| AEps -> 1
| ABranch (_,_,_,_,h,_) -> h
let hash_atom = function
| AStar t -> 17 * (hash_trie t)
| APlus t -> 1 + 17 * (hash_trie t)
| ATrans t -> 2 + 17 * (S.hash t)
let rec hash_atom_list = function
| hd::tl -> hash_atom hd + 17 * (hash_atom_list tl)
| [] -> 0
module T = struct
type t = atom list * trie * trie * int
let equal (a,ay,an,_) (b,by,bn,_) =
(equal_atom_list a b) && (ay == by) && (an == bn)
let hash (a,ay,an,h) =
h
end
module HT = Hashtbl.Make(T)
let branches = HT.create 17
let uid = ref 0
let branch0 a ay an =
let h = hash_atom_list a + 17 * (hash_trie ay) + 257 * (hash_trie an) in
let b = (a,ay,an,h) in
try HT.find branches b
with Not_found ->
let h = T.hash b in
incr uid;
let x = ABranch (a,ay,an,nullable an,h,!uid) in
HT.add branches b x;
x
let branch a ay an =
assert (List.length a > 0);
match ay,an with
| ABranch (b,by,bn,_,_,_), AEmpty -> branch0 (a @ b) by bn
| AEmpty, AEmpty -> AEmpty
| _ -> branch0 a ay an
module Decompile(H : Hashtbl.S)(S : Set.OrderedType) = struct let rec opt = function
| ABranch (a,ay,an,_,_,_) -> branch0 a ay (opt an)
| AEmpty -> AEps
| t -> t
let rec factor accu ctx x y = match x,y with
| hd1::tl1, hd2::tl2 when equal_atom hd1 hd2 ->
factor (hd1::accu) (hd1::ctx) tl1 tl2
| _ -> List.rev accu, ctx,x,y
let rec get_seq accu = function
| ABranch (a,AEps,AEmpty,_,_,_) -> Some a
| AEps -> Some []
| _ -> None
let get_seq = get_seq []
let apply_factor f r =
branch0 f r AEmpty
let apply_ctx ctx r =
List.fold_right (fun a r -> branch0 a r AEmpty) ctx r
let star x r = match x with
| AEmpty | AEps -> AEps
| t -> branch0 [ AStar t ] r AEmpty
(* (AB)*A ==> A(BA)*
BA(BA)* ==> (BA)+ *)
let rec create_plus ctx = function
| AStar x :: follow ->
(match get_seq x with
| Some s ->
let (accu,ctx,s,follow) = factor [] ctx s follow in
let s = s @ accu in
let rec aux accu = function
| ctx,[] ->
create_plus
(APlus (apply_factor accu AEps) :: ctx)
follow
| a::b,c::d when equal_atom a c -> aux (a::accu) (b,d)
| _ -> create_plus (AStar x :: ctx) follow
in
aux [] (ctx,s)
| None -> create_plus (AStar x :: ctx) follow)
| x :: follow -> create_plus (x :: ctx) follow
| [] -> List.rev ctx
let rec size = function
| AEps -> 1
| AEmpty -> 0
| ABranch (a,ay,an,_,_,_) ->
if (ay == an) then 1 + (size ay)
else 3 + (size ay) + (size an)
let choose u v =
if size u > size v then v else u
let rec alt t1 t2 = match t1,t2 with
| AEmpty,t | t,AEmpty -> t
| AEps,t | t,AEps -> opt t
| ABranch (_,_,_,_,_,id1), ABranch (_,_,_,_,_,id2) when id1 = id2 -> t1
| ABranch (al,ay,an,_,_,_), ABranch (bl,by,bn,_,_,_) ->
let (accu,_,al,bl) = factor [] [] al bl in
match accu with
| [] ->
(* let u = br al ay (alt an t2)
and v = br bl by (alt bn t1) in
choose u v *)
br al ay (alt an t2)
| _ ->
let t1 = br al ay AEps in
let t2 = br bl by AEps in
branch accu (alt t1 t2) (alt an bn)
and br a ay an =
match a with
| [] -> alt ay an
| l -> branch a ay an
and seq t1 t2 = match t1,t2 with
| AEmpty,_|_,AEmpty -> AEmpty
| AEps,t | t,AEps -> t
| ABranch (a,ay,an,_,_,_), t2 ->
(* (alt
(branch a (seq ay t2) AEmpty)
(seq an t2) )
*)
(branch a (seq ay t2) (seq an t2))
let rtrans t = branch [ATrans t] AEps AEmpty
let star = function
| AEmpty | AEps -> AEps
| t -> branch [AStar t] AEps AEmpty
let rseq r1 r2 = match r1,r2 with
| Epsilon, z | z, Epsilon -> z
| Empty, _ | _, Empty -> Empty
| x,y -> Seq (x,y)
let ralt r1 r2 = match r1,r2 with
| Empty, z | z, Empty -> z
| x,y -> Alt (x,y)
let rec minim = function
| AEmpty -> AEmpty
| AEps -> AEps
| ABranch (a,ay,(ABranch (b,by,bn,_,_,_) as an),_,_,_) as br
when ay != an ->
choose (branch b (minim by) (branch a (minim ay) bn)) br
| br -> br
let rec minim_trie r =
let r' = minim r in
if (size r' < size r) then minim_trie r' else r
let rec regexp r =
let r = minim_trie r in
match r with
| AEmpty -> Empty
| AEps -> Epsilon
| ABranch (a,ay,an,_,_,_) when ay == an ->
let a = create_plus [] a in
rseq (ralt (regexp_atom_list a) Epsilon) (regexp ay)
| ABranch (a,ay,an,_,_,_) when ay == an ->
let a = create_plus [] a in
rseq (ralt (regexp_atom_list a) Epsilon) (regexp ay)
| ABranch (a,ay,an,_,_,_) ->
let a = create_plus [] a in
ralt (rseq (regexp_atom_list a) (regexp ay)) (regexp an)
and regexp_atom_list = function
| hd::tl -> rseq (regexp_atom hd) (regexp_atom_list tl)
| [] -> Epsilon
and regexp_atom = function
| AStar t -> Star (regexp t)
| APlus t -> Plus (regexp t)
| ATrans t -> Trans t
(*
let rec compare s1 s2 = let rec compare s1 s2 =
if s1 == s2 then 0 if s1 == s2 then 0
else match (s1,s2) with else match (s1,s2) with
...@@ -90,6 +341,19 @@ module Decompile(H : Hashtbl.S)(S : Set.OrderedType) = struct ...@@ -90,6 +341,19 @@ module Decompile(H : Hashtbl.S)(S : Set.OrderedType) = struct
else x2::(merge l1 y2) else x2::(merge l1 y2)
| [], l | l,[] -> l | [], l | l,[] -> l
let sort l =
let rec initlist = function
| [] -> []
| e::rest -> [e] :: initlist rest in
let rec merge2 = function
| l1::l2::rest -> merge l1 l2 :: merge2 rest
| x -> x in
let rec mergeall = function
| [] -> []
| [l] -> l
| llist -> mergeall (merge2 llist) in
mergeall (initlist l)
let rec sub l1 l2 = let rec sub l1 l2 =
(compare l1 l2 = 0) || (compare l1 l2 = 0) ||
match (l1,l2) with match (l1,l2) with
...@@ -113,7 +377,6 @@ module Decompile(H : Hashtbl.S)(S : Set.OrderedType) = struct ...@@ -113,7 +377,6 @@ module Decompile(H : Hashtbl.S)(S : Set.OrderedType) = struct
if (List.exists (sub x) accu) || (List.exists (sub x) rest) if (List.exists (sub x) accu) || (List.exists (sub x) rest)
then simplify_alt accu rest then simplify_alt accu rest
else simplify_alt (x::accu) rest else simplify_alt (x::accu) rest
let alt s1 s2 = let alt s1 s2 =
let s1 = match s1 with RAlt x -> x | x -> [x] in let s1 = match s1 with RAlt x -> x | x -> [x] in
...@@ -168,6 +431,8 @@ module Decompile(H : Hashtbl.S)(S : Set.OrderedType) = struct ...@@ -168,6 +431,8 @@ module Decompile(H : Hashtbl.S)(S : Set.OrderedType) = struct
| RStar _ as s -> s | RStar _ as s -> s
| RPlus s -> RStar s | RPlus s -> RStar s
| s -> RStar s | s -> RStar s
*)
type 'a slot = { type 'a slot = {
mutable weight : int; mutable weight : int;
...@@ -204,7 +469,7 @@ module Decompile(H : Hashtbl.S)(S : Set.OrderedType) = struct ...@@ -204,7 +469,7 @@ module Decompile(H : Hashtbl.S)(S : Set.OrderedType) = struct
s.ok <- true; s.ok <- true;
let (tr,f) = trans n in let (tr,f) = trans n in
if f then add_trans s final epsilon; if f then add_trans s final epsilon;
List.iter (fun (l,dst) -> add_trans s (conv dst) (RTrans l)) tr; List.iter (fun (l,dst) -> add_trans s (conv dst) (rtrans l)) tr;
); );
s in s in
......
...@@ -9,7 +9,14 @@ type 'a regexp = ...@@ -9,7 +9,14 @@ type 'a regexp =
| Plus of 'a regexp | Plus of 'a regexp
| Trans of 'a | Trans of 'a
module Decompile(H : Hashtbl.S)(S : Set.OrderedType) module type S = sig
type t
val equal: t -> t -> bool
val compare: t -> t -> int
val hash: t -> int
end
module Decompile(X : Hashtbl.S)(S : S)
: sig : sig
val decompile: (H.key -> (S.t * H.key) list * bool) -> H.key -> S.t regexp val decompile: (X.key -> (S.t * X.key) list * bool) -> X.key -> S.t regexp
end end
...@@ -262,13 +262,6 @@ let get_qual name table get_name = ...@@ -262,13 +262,6 @@ let get_qual name table get_name =
try Ns.QName.equal (get_name x) name try Ns.QName.equal (get_name x) name
with Invalid_argument _ -> false) with Invalid_argument _ -> false)
table table
let get_unqual name table get_name =
List.find
(fun x ->
try Utf8.equal (snd (get_name x)) name
with Invalid_argument _ -> false)
table
let get_type name schema = get_qual name schema.types name_of_type_definition let get_type name schema = get_qual name schema.types name_of_type_definition
let get_attribute name schema = let get_attribute name schema =
...@@ -300,37 +293,6 @@ let get_component kind name schema = ...@@ -300,37 +293,6 @@ let get_component kind name schema =
| Some `Model_group -> mod_group () | Some `Model_group -> mod_group ()
| None -> tries [ elt; typ; att; att_group; mod_group ] | None -> tries [ elt; typ; att; att_group; mod_group ]
let get_type name schema =
get_unqual name schema.types name_of_type_definition
let get_attribute name schema =
get_unqual name schema.attributes name_of_attribute_declaration
let get_element name schema =
get_unqual name schema.elements name_of_element_declaration
let get_attribute_group name schema =
get_unqual name schema.attribute_groups name_of_attribute_group_definition
let get_model_group name schema =
get_unqual name schema.model_groups name_of_model_group_definition
(* policy for unqualified schema component resolution. The order should
* be consistent with Typer.find_schema_descr *)
let get_unqual_component kind name schema =
let rec tries = function
| [] -> raise Not_found
| hd :: tl -> (try hd () with Not_found -> tries tl)
in
let elt () = Element (get_element name schema) in
let typ () = Type (get_type name schema) in
let att () = Attribute (get_attribute name schema) in
let att_group () = Attribute_group (get_attribute_group name schema) in
let mod_group () = Model_group (get_model_group name schema) in
match kind with
| Some `Element -> elt ()
| Some `Type -> typ ()
| Some `Attribute -> att ()
| Some `Attribute_group -> att_group ()
| Some `Model_group -> mod_group ()
| None -> tries [ elt; typ; att; att_group; mod_group ]
let string_of_component_kind (kind: component_kind) = let string_of_component_kind (kind: component_kind) =
match kind with match kind with
| Some `Type -> "type" | Some `Type -> "type"
......
...@@ -52,7 +52,6 @@ val get_model_group: Ns.qname -> schema -> model_group_definition ...@@ -52,7 +52,6 @@ val get_model_group: Ns.qname -> schema -> model_group_definition
*) *)
val get_component: component_kind -> Ns.qname -> schema -> component val get_component: component_kind -> Ns.qname -> schema -> component
val get_unqual_component: component_kind -> Utf8.t -> schema -> component
val iter_types: schema -> (type_definition -> unit) -> unit val iter_types: schema -> (type_definition -> unit) -> unit
val iter_attributes: schema -> (attribute_declaration -> unit) -> unit val iter_attributes: schema -> (attribute_declaration -> unit) -> unit
......
...@@ -468,7 +468,7 @@ let schema_of_uri uri = ...@@ -468,7 +468,7 @@ let schema_of_uri uri =
| CT_empty -> | CT_empty ->
CT_model (particle, mixed) CT_model (particle, mixed)
| CT_model (p, _) -> | CT_model (p, _) ->
let model = Sequence (p::[particle]) in let model = Sequence [p;particle] in
CT_model (particle_model 1 (Some 1) model, mixed) CT_model (particle_model 1 (Some 1) model, mixed)
| CT_simple _ -> assert false | CT_simple _ -> assert false
in in
...@@ -516,7 +516,7 @@ let schema_of_uri uri = ...@@ -516,7 +516,7 @@ let schema_of_uri uri =
and parse_particle n = and parse_particle n =
let min, max = parse_min_max n in let min, max = parse_min_max n in
let model mg = particle_model min max mg in let model mg = particle_model min max mg in
let elt e n = particle min max (Elt e) [ n ] false in let elt e n = particle min max (Elt e) [ n ] (min = 0) in
match _tag n with match _tag n with
| "xsd:element" -> | "xsd:element" ->
(match _may_qname_attr "ref" n with (match _may_qname_attr "ref" n with
......
...@@ -10,6 +10,8 @@ open Value ...@@ -10,6 +10,8 @@ open Value
module QTable = Hashtbl.Make(Ns.QName) module QTable = Hashtbl.Make(Ns.QName)
let ppf = Format.std_formatter
(** {2 Misc} *) (** {2 Misc} *)
let empty_string = string_utf8 (Utf8.mk "") let empty_string = string_utf8 (Utf8.mk "")
...@@ -389,6 +391,13 @@ and validate_content_type ctx content_type = ...@@ -389,6 +391,13 @@ and validate_content_type ctx content_type =
get ctx get ctx
and validate_particle ctx particle = and validate_particle ctx particle =
(*
Format.fprintf ppf "Particle first";
List.iter (fun n -> Format.fprintf ppf "%a;" Ns.QName.print n)
particle.part_first;
Format.fprintf ppf "@.";
*)
let rec validate_once ~cont_ok ~cont_failure = let rec validate_once ~cont_ok ~cont_failure =
do_pcdata ctx; do_pcdata ctx;
match peek ctx with match peek ctx with
...@@ -396,7 +405,8 @@ and validate_particle ctx particle = ...@@ -396,7 +405,8 @@ and validate_particle ctx particle =
when List.exists (Ns.QName.equal qname) particle.part_first -> when List.exists (Ns.QName.equal qname) particle.part_first ->
validate_term ctx particle.part_term; validate_term ctx particle.part_term;
cont_ok () cont_ok ()
| ev -> cont_failure ev | ev ->
cont_failure ev
in in
let rec required = function let rec required = function
| 0 -> () | 0 -> ()
...@@ -404,8 +414,10 @@ and validate_particle ctx particle = ...@@ -404,8 +414,10 @@ and validate_particle ctx particle =
validate_once validate_once
~cont_ok:(fun () -> required (pred n)) ~cont_ok:(fun () -> required (pred n))
~cont_failure:(fun event -> ~cont_failure:(fun event ->
error ~ctx (sprintf "Unexpected content: %s" if particle.part_nullable then ()
(string_of_event event))) else
error ~ctx (sprintf "Unexpected content: %s"
(string_of_event event)))
in in
let rec optional = function let rec optional = function
| None -> | None ->
......
...@@ -1339,25 +1339,29 @@ struct ...@@ -1339,25 +1339,29 @@ struct
let is_regexp t = subtype t seqs_descr let is_regexp t = subtype t seqs_descr
module S = struct type nd = { id : int;
type t = { id : int;
mutable def : d list; mutable def : d list;
mutable state : [ `Expand | `None | `Marked | `Named of U.t ] } mutable state : [ `Expand | `None | `Marked | `Named of U.t ] }
and d = and d =
| Name of U.t | Name of U.t
| Regexp of t Pretty.regexp | Regexp of nd Pretty.regexp
| Atomic of (Format.formatter -> unit) | Atomic of (Format.formatter -> unit)
| Pair of t * t | Pair of nd * nd
| Char of Chars.V.t | Char of Chars.V.t
| Xml of [ `Tag of (Format.formatter -> unit) | `Type of t ] * t * t | Xml of [ `Tag of (Format.formatter -> unit) | `Type of nd ] * nd * nd
| Record of (bool * t) label_map * bool * bool | Record of (bool * nd) label_map * bool * bool
| Arrows of (t * t) list * (t * t) list | Arrows of (nd * nd) list * (nd * nd) list
| Neg of t | Neg of nd
| Abs of t | Abs of nd
let compare x y = x.id - y.id let compare x y = x.id - y.id
module S = struct
type t = nd
let compare x y = x.id - y.id
let hash x = x.id
let equal x y = x.id = y.id
end end
module Decompile = Pretty.Decompile(DescrHash)(S) module Decompile = Pretty.Decompile(DescrHash)(S)
open S
module DescrPairMap = Map.Make(Custom.Pair(Descr)(Descr)) module DescrPairMap = Map.Make(Custom.Pair(Descr)(Descr))
...@@ -1487,7 +1491,6 @@ struct ...@@ -1487,7 +1491,6 @@ struct
slot slot
and decompile d = and decompile d =
let r =
Decompile.decompile Decompile.decompile
(fun t -> (fun t ->
let tr = Product.get t in let tr = Product.get t in
...@@ -1495,8 +1498,7 @@ struct ...@@ -1495,8 +1498,7 @@ struct
let tr = List.map (fun (l,t) -> prepare l, t) tr in let tr = List.map (fun (l,t) -> prepare l, t) tr in
tr, Atoms.contains nil_atom t.atoms) tr, Atoms.contains nil_atom t.atoms)
d in d
r