sequence.ml 6.64 KB
Newer Older
1 2 3 4 5 6 7
type error = 
  | CopyTag of Types.t * Types.t 
  | CopyAttr of Types.t * Types.t
  | UnderTag of Types.t * exn
exception Error of error


8
let nil_atom = Atoms.V.mk_ascii "nil"
9
let nil_type = Types.atom (Atoms.atom nil_atom)
10
let nil_node = Types.cons nil_type
11
let nil_cst  = Types.Atom nil_atom
12 13

let decompose t =
14
  (Types.Atom.has_atom t nil_atom,
15 16 17
   Types.Product.get t)

module V = Types.Positive
18
module H = Map.Make(Types)
19
module H2 = Map.Make(Custom.Pair(Types)(Types))
20

21 22 23 24 25 26 27 28 29
let memoize f =
  let memo = ref H.empty in
  fun t ->
    try H.find t !memo
    with Not_found ->
      let z = f t in
      memo := H.add t z !memo;
      z

30
let mapping f t queue =
31
  let memo = ref H.empty in
32
  let rec aux t =
33
    try H.find t !memo
34 35
    with Not_found ->
      let v = V.forward () in
36
      memo := H.add t v !memo;
37
      let (has_nil,rect) = decompose t in
38
      let l = List.map (fun (t1,t2) -> f t1 (aux t2)) rect in
39 40 41 42
      let l = if has_nil then queue :: l else l in
      V.define v (V.cup l);
      v
  in
43
  aux t
44 45

let aux_concat = mapping (fun t v -> V.times (V.ty t) v)
46
let aux_flatten t = mapping aux_concat t (V.ty nil_type)
47
let aux_map f t = 
48
  let f = memoize f in 
49
  mapping (fun t v -> V.times (V.ty (f t)) v) t (V.ty nil_type)
50 51 52

let solve x = Types.descr (V.solve x)

53

54
let concat t1 t2 = solve (aux_concat t1 (V.ty t2))
55
let flatten t = let t = Types.normalize t in solve (aux_flatten t)
56 57
let map f t = solve (aux_map f t)

58 59 60 61 62 63 64 65 66 67 68 69 70 71

let map_mono t =
  let ts = ref [] in
  let vs = ref [] in
  let r =
    mapping (fun t v ->
	       let v' = V.forward () in
	       ts := t :: !ts; vs := v' :: !vs;
	       V.times v' v) t (V.ty nil_type) in
  !ts, (fun fts ->
	  List.iter2 (fun t v -> V.define v (V.ty t)) fts !vs;
	  solve r)


72 73 74 75 76
let recurs f =
  let n = Types.make () in
  Types.define n (f n);
  Types.internalize n

77
let star_node t = recurs (fun n -> Types.cup nil_type (Types.times t n ))
78

79
let any_node = star_node (Types.cons Types.any)
80
let any = Types.descr any_node
81 82 83
let seqseq = Types.descr (star_node any_node)

let star t = Types.descr (star_node (Types.cons t))
84
let plus t = let t = Types.cons t in Types.times t (star_node t)
85
let string = star (Types.Char.any)  
86

87 88 89
let option t =
  Types.cup (Types.times t nil_node) nil_type

90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108
let repet min max t =
  let t = Types.cons t in
  let tail = match max with
    | None -> star_node t
    | Some m -> 
	let rec aux accu l = function
	  | 0 -> Types.cons accu
	  | m -> 
	      let l = Types.times t (Types.cons l) in
	      aux (Types.cup accu l) l (pred m)
	in 
	aux Types.empty nil_type m
  in
  let rec aux = function
    | 0 -> tail
    | n -> Types.cons (Types.times t (aux (pred n)))
  in
  Types.descr (aux min)

109
(* Mmmmh, it may be faster to add pi1(rect) and iterate over pi2(rect) ... ? *)
110
let approx t =
111
  let memo = ref H.empty in
112 113
  let res = ref Types.empty in
  let rec aux t =
114
    try H.find t !memo
115
    with Not_found ->
116
      memo := H.add t () !memo;
117 118 119 120 121
      let rect = Types.Product.get t in
      List.iter (fun (t1,t2) -> res := Types.cup t1 !res; aux t2) rect;
  in
  aux t;
  !res
122

123 124

let precise = ref true
125
  
126 127
(* Note: the precision of this implementation depends on the constraint...
   This is bad and should be fixed. *)
128 129 130 131 132
let map_tree cstr f seq =
  let memo = ref H2.empty in
  let rec aux cstr t =
    let x = (cstr,t) in
    try H2.find x !memo
133 134
    with Not_found ->
      let v = V.forward () in
135 136
      memo := H2.add x v !memo;
      let v' = mapping (descr_aux cstr) t (V.ty nil_type) in
137 138
      V.define v v';
      v
139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155
  and descr_aux cstr t v =
    let cstr0 = 
      if !precise then Types.Product.normal ~kind:`XML cstr
      else [] in
    let cstr_tag = 
      if !precise then Types.Product.pi1 cstr0
      else Types.any in

    let (result,residual) = f (star cstr) t in
    let f2 cstr_attr cstr1 (attr,child) = 
      let cstr_sub = 
	if !precise then (
	  if not (Types.subtype attr cstr_attr) then
	    raise (Error (CopyAttr (attr,cstr_attr)));
	  approx (Types.Product.constraint_on_2 cstr1 attr))
	else Types.any in
      V.times (V.ty attr) (aux cstr_sub child) in
156
    let f1 (tag,x) =
157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172
      let cstr1 =
	if !precise then (
	  if not (Types.subtype tag cstr_tag) then
	    raise (Error (CopyTag (tag,cstr_tag)));
	  Types.Product.normal 
	    (Types.Product.constraint_on_2 cstr0 tag))
	else [] in
      let cstr_attr = 
	if !precise then Types.Product.pi1 cstr1
	else Types.any in
      try
	let x = V.cup (List.map (f2 cstr_attr cstr1) (Types.Product.get x)) in
	V.xml (V.ty tag) x
      with exn ->
	raise (Error (UnderTag (tag,exn)))
    in
173 174 175 176 177 178 179
    let iter = List.map f1 (Types.Product.get ~kind:`XML residual) in
    let resid = Types.Product.other ~kind:`XML residual in
    let iter = if Types.is_empty resid then iter else V.ty resid :: iter in
    let result = aux_concat result v in
    if iter = [] then result else
      V.cup [V.times (V.cup iter) v; result ]
  in
180 181
  let cstr = if !precise then approx cstr else Types.any in
  Types.descr (V.solve (aux cstr seq))
182

183
let map_tree_mono domain seq =
184
  let inp = ref Types.empty in
185 186
  let ts = ref [] in
  let vs = ref [] in
187

188 189 190 191 192 193 194 195 196 197
  let memo = ref H.empty in
  let rec aux t =
    try H.find t !memo
    with Not_found ->
      let v = V.forward () in
      memo := H.add t v !memo;
      let v' = mapping descr_aux t (V.ty nil_type) in
      V.define v v';
      v
  and descr_aux t v =
198
    inp := Types.cup !inp t;
199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215
    let residual = Types.diff t domain in

    let f2 (attr,child) = V.times (V.ty attr) (aux child) in
    let f1 (tag,x) =
      let x = V.cup (List.map f2 (Types.Product.get x)) in
      V.xml (V.ty tag) x in
    let iter = List.map f1 (Types.Product.get ~kind:`XML residual) in
    let resid = Types.Product.other ~kind:`XML residual in
    let iter = if Types.is_empty resid then iter else V.ty resid :: iter in

    let result = V.forward () in
    ts := (Types.cap domain t) :: !ts; vs := (result,v) :: !vs;
    if iter = [] then result else
    V.cup [V.times (V.cup iter) v; result ]

  in
  let r = aux seq in
216
  !inp, !ts, (fun fts ->
217 218 219 220 221
	  List.iter2 (fun t (result,v) -> V.define result (aux_concat t v))
	    fts !vs;
	  solve r)

(* TODO: avoid flushing the memo between calls to mapping inside map_tree *)
222 223 224 225 226 227

let seq_of_list l =
  let times' t acc = Types.times (Types.cons t) (Types.cons acc) in
  List.fold_right times' l nil_type


228 229 230
let char_latin1 = Types.char (Chars.mk_classes [ (0,255) ])
let string_latin1 = star char_latin1

231 232 233 234 235 236 237 238 239 240 241 242 243 244 245

let any_xtransformable =
  Types.descr
    (recurs 
       (fun n -> 
	  let elt = 
	    Types.xml 
	      Types.any_node
	      (Types.cons (Types.times Types.any_node n))
	  in
	  let non_elt = Types.neg (Types.xml Types.any_node Types.any_node)
	  in
	  let t = Types.cons (Types.cup elt non_elt) in
	  Types.cup nil_type (Types.times t n)))

246
let ub_concat t = star (approx (Types.cap any t))