| 1 |
(* TODO:
|
| 2 |
- rewrite type-checking of operators to propagate constraint
|
| 3 |
- optimize computation of pattern free variables
|
| 4 |
- check whether it is worth using recursive hash-consing internally
|
| 5 |
*)
|
| 6 |
|
| 7 |
|
| 8 |
let warning loc msg =
|
| 9 |
Format.fprintf !Location.warning_ppf "Warning %a:@\n%a%s@\n"
|
| 10 |
Location.print_loc loc
|
| 11 |
Location.html_hilight loc
|
| 12 |
msg
|
| 13 |
|
| 14 |
(* I. Transform the abstract syntax of types and patterns into
|
| 15 |
the internal form *)
|
| 16 |
|
| 17 |
open Location
|
| 18 |
open Ast
|
| 19 |
open Ident
|
| 20 |
|
| 21 |
module S = struct type t = string let compare = compare end
|
| 22 |
module TypeEnv = Map.Make(S)
|
| 23 |
|
| 24 |
exception NonExhaustive of Types.descr
|
| 25 |
exception Constraint of Types.descr * Types.descr
|
| 26 |
exception ShouldHave of Types.descr * string
|
| 27 |
exception ShouldHave2 of Types.descr * string * Types.descr
|
| 28 |
exception WrongLabel of Types.descr * label
|
| 29 |
exception UnboundId of id
|
| 30 |
exception Error of string
|
| 31 |
|
| 32 |
let raise_loc loc exn = raise (Location (loc,exn))
|
| 33 |
let error loc msg = raise_loc loc (Error msg)
|
| 34 |
|
| 35 |
(* Schema datastructures *)
|
| 36 |
|
| 37 |
module StringSet = Set.Make (String)
|
| 38 |
let schemas = State.ref "Typer.schemas" StringSet.empty (* just to remember imported schemas *)
|
| 39 |
|
| 40 |
let schema_types = State.ref "Typer.schema_types" (Hashtbl.create 51)
|
| 41 |
let schema_elements = State.ref "Typer.schema_elements" (Hashtbl.create 51)
|
| 42 |
let schema_attributes : (string * string, Types.descr) Hashtbl.t ref =
|
| 43 |
State.ref "Typer.schema_attributes" (Hashtbl.create 51)
|
| 44 |
|
| 45 |
|
| 46 |
(* Eliminate Recursion, propagate Sequence Capture Variables *)
|
| 47 |
|
| 48 |
let rec seq_vars accu = function
|
| 49 |
| Epsilon | Elem _ -> accu
|
| 50 |
| Seq (r1,r2) | Alt (r1,r2) -> seq_vars (seq_vars accu r1) r2
|
| 51 |
| Star r | WeakStar r -> seq_vars accu r
|
| 52 |
| SeqCapture (v,r) -> seq_vars (IdSet.add v accu) r
|
| 53 |
|
| 54 |
type derecurs_slot = {
|
| 55 |
ploc : Location.loc;
|
| 56 |
pid : int;
|
| 57 |
mutable ploop : bool;
|
| 58 |
mutable pdescr : derecurs option
|
| 59 |
} and derecurs =
|
| 60 |
| PAlias of derecurs_slot
|
| 61 |
| PType of Types.descr
|
| 62 |
| POr of derecurs * derecurs
|
| 63 |
| PAnd of derecurs * derecurs
|
| 64 |
| PDiff of derecurs * derecurs
|
| 65 |
| PTimes of derecurs * derecurs
|
| 66 |
| PXml of derecurs * derecurs
|
| 67 |
| PArrow of derecurs * derecurs
|
| 68 |
| POptional of derecurs
|
| 69 |
| PRecord of bool * derecurs label_map
|
| 70 |
| PCapture of id
|
| 71 |
| PConstant of id * Types.const
|
| 72 |
| PRegexp of derecurs_regexp * derecurs
|
| 73 |
and derecurs_regexp =
|
| 74 |
| PEpsilon
|
| 75 |
| PElem of derecurs
|
| 76 |
| PSeq of derecurs_regexp * derecurs_regexp
|
| 77 |
| PAlt of derecurs_regexp * derecurs_regexp
|
| 78 |
| PStar of derecurs_regexp
|
| 79 |
| PWeakStar of derecurs_regexp
|
| 80 |
|
| 81 |
let rec hash_derecurs = function
|
| 82 |
| PAlias s ->
|
| 83 |
s.pid
|
| 84 |
| PType t ->
|
| 85 |
1 + 17 * (Types.hash_descr t)
|
| 86 |
| POr (p1,p2) ->
|
| 87 |
2 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
|
| 88 |
| PAnd (p1,p2) ->
|
| 89 |
3 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
|
| 90 |
| PDiff (p1,p2) ->
|
| 91 |
4 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
|
| 92 |
| PTimes (p1,p2) ->
|
| 93 |
5 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
|
| 94 |
| PXml (p1,p2) ->
|
| 95 |
6 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
|
| 96 |
| PArrow (p1,p2) ->
|
| 97 |
7 + 17 * (hash_derecurs p1) + 257 * (hash_derecurs p2)
|
| 98 |
| POptional p ->
|
| 99 |
8 + 17 * (hash_derecurs p)
|
| 100 |
| PRecord (o,r) ->
|
| 101 |
(if o then 9 else 10) + 17 * (LabelMap.hash hash_derecurs r)
|
| 102 |
| PCapture x ->
|
| 103 |
11 + 17 * (Id.hash x)
|
| 104 |
| PConstant (x,c) ->
|
| 105 |
12 + 17 * (Id.hash x) + 257 * (Types.hash_const c)
|
| 106 |
| PRegexp (p,q) ->
|
| 107 |
13 + 17 * (hash_derecurs_regexp p) + 257 * (hash_derecurs q)
|
| 108 |
and hash_derecurs_regexp = function
|
| 109 |
| PEpsilon ->
|
| 110 |
1
|
| 111 |
| PElem p ->
|
| 112 |
2 + 17 * (hash_derecurs p)
|
| 113 |
| PSeq (p1,p2) ->
|
| 114 |
3 + 17 * (hash_derecurs_regexp p1) + 257 * (hash_derecurs_regexp p2)
|
| 115 |
| PAlt (p1,p2) ->
|
| 116 |
4 + 17 * (hash_derecurs_regexp p1) + 257 * (hash_derecurs_regexp p2)
|
| 117 |
| PStar p ->
|
| 118 |
5 + 17 * (hash_derecurs_regexp p)
|
| 119 |
| PWeakStar p ->
|
| 120 |
6 + 17 * (hash_derecurs_regexp p)
|
| 121 |
|
| 122 |
let rec equal_derecurs p1 p2 = (p1 == p2) || match p1,p2 with
|
| 123 |
| PAlias s1, PAlias s2 ->
|
| 124 |
s1 == s2
|
| 125 |
| PType t1, PType t2 ->
|
| 126 |
Types.equal_descr t1 t2
|
| 127 |
| POr (p1,q1), POr (p2,q2)
|
| 128 |
| PAnd (p1,q1), PAnd (p2,q2)
|
| 129 |
| PDiff (p1,q1), PDiff (p2,q2)
|
| 130 |
| PTimes (p1,q1), PTimes (p2,q2)
|
| 131 |
| PXml (p1,q1), PXml (p2,q2)
|
| 132 |
| PArrow (p1,q1), PArrow (p2,q2) ->
|
| 133 |
(equal_derecurs p1 p2) && (equal_derecurs q1 q2)
|
| 134 |
| POptional p1, POptional p2 ->
|
| 135 |
equal_derecurs p1 p2
|
| 136 |
| PRecord (o1,r1), PRecord (o2,r2) ->
|
| 137 |
(o1 == o2) && (LabelMap.equal equal_derecurs r1 r2)
|
| 138 |
| PCapture x1, PCapture x2 ->
|
| 139 |
Id.equal x1 x2
|
| 140 |
| PConstant (x1,c1), PConstant (x2,c2) ->
|
| 141 |
(Id.equal x1 x2) && (Types.equal_const c1 c2)
|
| 142 |
| PRegexp (p1,q1), PRegexp (p2,q2) ->
|
| 143 |
(equal_derecurs_regexp p1 p2) && (equal_derecurs q1 q2)
|
| 144 |
| _ -> false
|
| 145 |
and equal_derecurs_regexp r1 r2 = match r1,r2 with
|
| 146 |
| PEpsilon, PEpsilon ->
|
| 147 |
true
|
| 148 |
| PElem p1, PElem p2 ->
|
| 149 |
equal_derecurs p1 p2
|
| 150 |
| PSeq (p1,q1), PSeq (p2,q2)
|
| 151 |
| PAlt (p1,q1), PAlt (p2,q2) ->
|
| 152 |
(equal_derecurs_regexp p1 p2) && (equal_derecurs_regexp q1 q2)
|
| 153 |
| PStar p1, PStar p2
|
| 154 |
| PWeakStar p1, PWeakStar p2 ->
|
| 155 |
equal_derecurs_regexp p1 p2
|
| 156 |
| _ -> false
|
| 157 |
|
| 158 |
module DerecursTable = Hashtbl.Make(
|
| 159 |
struct
|
| 160 |
type t = derecurs
|
| 161 |
let hash = hash_derecurs
|
| 162 |
let equal = equal_derecurs
|
| 163 |
end
|
| 164 |
)
|
| 165 |
|
| 166 |
module RE = Hashtbl.Make(
|
| 167 |
struct
|
| 168 |
type t = derecurs_regexp * derecurs
|
| 169 |
let hash (p,q) =
|
| 170 |
(hash_derecurs_regexp p) + 17 * (hash_derecurs q)
|
| 171 |
let equal (p1,q1) (p2,q2) =
|
| 172 |
(equal_derecurs_regexp p1 p2) && (equal_derecurs q1 q2)
|
| 173 |
end
|
| 174 |
)
|
| 175 |
|
| 176 |
|
| 177 |
let counter = State.ref "Typer.counter - derecurs" 0
|
| 178 |
let mk_slot loc =
|
| 179 |
incr counter;
|
| 180 |
{ ploop = false; ploc = loc; pid = !counter; pdescr = None }
|
| 181 |
|
| 182 |
let rec derecurs env p = match p.descr with
|
| 183 |
| PatVar v ->
|
| 184 |
(try PAlias (TypeEnv.find v env)
|
| 185 |
with Not_found ->
|
| 186 |
raise_loc_generic p.loc ("Undefined type/pattern " ^ v))
|
| 187 |
| SchemaVar (kind, schema, item) ->
|
| 188 |
let try_elt () = fst (Hashtbl.find !schema_elements (schema, item)) in
|
| 189 |
let try_typ () = Hashtbl.find !schema_types (schema, item) in
|
| 190 |
let try_att () = Hashtbl.find !schema_attributes (schema, item) in
|
| 191 |
(match kind with
|
| 192 |
| `Element ->
|
| 193 |
(try
|
| 194 |
PType (try_elt ())
|
| 195 |
with Not_found ->
|
| 196 |
failwith (Printf.sprintf
|
| 197 |
"No element named '%s' found in schema '%s'" item schema))
|
| 198 |
| `Type ->
|
| 199 |
(try
|
| 200 |
PType (try_typ ())
|
| 201 |
with Not_found ->
|
| 202 |
failwith (Printf.sprintf
|
| 203 |
"No type named '%s' found in schema '%s'" item schema))
|
| 204 |
| `Attribute ->
|
| 205 |
(try
|
| 206 |
PType (try_att ())
|
| 207 |
with Not_found ->
|
| 208 |
failwith (Printf.sprintf
|
| 209 |
"No attribute named '%s' found in schema '%s'" item schema))
|
| 210 |
| `Any ->
|
| 211 |
PType
|
| 212 |
(try try_elt () with Not_found ->
|
| 213 |
(try try_typ () with Not_found ->
|
| 214 |
(try try_att () with Not_found ->
|
| 215 |
failwith (Printf.sprintf
|
| 216 |
"No item named '%s' found in schema '%s'" item schema)))))
|
| 217 |
| Recurs (p,b) -> derecurs (derecurs_def env b) p
|
| 218 |
| Internal t -> PType t
|
| 219 |
| Or (p1,p2) -> POr (derecurs env p1, derecurs env p2)
|
| 220 |
| And (p1,p2) -> PAnd (derecurs env p1, derecurs env p2)
|
| 221 |
| Diff (p1,p2) -> PDiff (derecurs env p1, derecurs env p2)
|
| 222 |
| Prod (p1,p2) -> PTimes (derecurs env p1, derecurs env p2)
|
| 223 |
| XmlT (p1,p2) -> PXml (derecurs env p1, derecurs env p2)
|
| 224 |
| Arrow (p1,p2) -> PArrow (derecurs env p1, derecurs env p2)
|
| 225 |
| Optional p -> POptional (derecurs env p)
|
| 226 |
| Record (o,r) -> PRecord (o, LabelMap.map (derecurs env) r)
|
| 227 |
| Capture x -> PCapture x
|
| 228 |
| Constant (x,c) -> PConstant (x,c)
|
| 229 |
| Regexp (r,q) ->
|
| 230 |
let constant_nil t v =
|
| 231 |
PAnd (t, PConstant (v, Types.Atom Sequence.nil_atom)) in
|
| 232 |
let vars = seq_vars IdSet.empty r in
|
| 233 |
let q = IdSet.fold constant_nil (derecurs env q) vars in
|
| 234 |
let r = derecurs_regexp (fun p -> p) env r in
|
| 235 |
PRegexp (r, q)
|
| 236 |
and derecurs_regexp vars env = function
|
| 237 |
| Epsilon ->
|
| 238 |
PEpsilon
|
| 239 |
| Elem p ->
|
| 240 |
PElem (vars (derecurs env p))
|
| 241 |
| Seq (p1,p2) ->
|
| 242 |
PSeq (derecurs_regexp vars env p1, derecurs_regexp vars env p2)
|
| 243 |
| Alt (p1,p2) ->
|
| 244 |
PAlt (derecurs_regexp vars env p1, derecurs_regexp vars env p2)
|
| 245 |
| Star p ->
|
| 246 |
PStar (derecurs_regexp vars env p)
|
| 247 |
| WeakStar p ->
|
| 248 |
PWeakStar (derecurs_regexp vars env p)
|
| 249 |
| SeqCapture (x,p) ->
|
| 250 |
derecurs_regexp (fun p -> PAnd (vars p, PCapture x)) env p
|
| 251 |
|
| 252 |
|
| 253 |
and derecurs_def env b =
|
| 254 |
let b = List.map (fun (v,p) -> (v,p,mk_slot p.loc)) b in
|
| 255 |
let env = List.fold_left (fun env (v,p,s) -> TypeEnv.add v s env) env b in
|
| 256 |
List.iter (fun (v,p,s) -> s.pdescr <- Some (derecurs env p)) b;
|
| 257 |
env
|
| 258 |
|
| 259 |
(* Stratification and recursive hash-consing *)
|
| 260 |
|
| 261 |
type descr =
|
| 262 |
| IType of Types.descr
|
| 263 |
| IOr of descr * descr
|
| 264 |
| IAnd of descr * descr
|
| 265 |
| IDiff of descr * descr
|
| 266 |
| ITimes of slot * slot
|
| 267 |
| IXml of slot * slot
|
| 268 |
| IArrow of slot * slot
|
| 269 |
| IOptional of descr
|
| 270 |
| IRecord of bool * slot label_map
|
| 271 |
| ICapture of id
|
| 272 |
| IConstant of id * Types.const
|
| 273 |
and slot = {
|
| 274 |
mutable fv : fv option;
|
| 275 |
mutable hash : int option;
|
| 276 |
mutable rank1: int; mutable rank2: int;
|
| 277 |
mutable gen1 : int; mutable gen2: int;
|
| 278 |
mutable d : descr option
|
| 279 |
}
|
| 280 |
|
| 281 |
let descr s =
|
| 282 |
match s.d with
|
| 283 |
| Some d -> d
|
| 284 |
| None -> assert false
|
| 285 |
|
| 286 |
let gen = ref 0
|
| 287 |
let rank = ref 0
|
| 288 |
|
| 289 |
let rec hash_descr = function
|
| 290 |
| IType x -> Types.hash_descr x
|
| 291 |
| IOr (d1,d2) -> 1 + 17 * (hash_descr d1) + 257 * (hash_descr d2)
|
| 292 |
| IAnd (d1,d2) -> 2 + 17 * (hash_descr d1) + 257 * (hash_descr d2)
|
| 293 |
| IDiff (d1,d2) -> 3 + 17 * (hash_descr d1) + 257 * (hash_descr d2)
|
| 294 |
| IOptional d -> 4 + 17 * (hash_descr d)
|
| 295 |
| ITimes (s1,s2) -> 5 + 17 * (hash_slot s1) + 257 * (hash_slot s2)
|
| 296 |
| IXml (s1,s2) -> 6 + 17 * (hash_slot s1) + 257 * (hash_slot s2)
|
| 297 |
| IArrow (s1,s2) -> 7 + 17 * (hash_slot s1) + 257 * (hash_slot s2)
|
| 298 |
| IRecord (o,r) -> (if o then 8 else 9) + 17 * (LabelMap.hash hash_slot r)
|
| 299 |
| ICapture x -> 10 + 17 * (Id.hash x)
|
| 300 |
| IConstant (x,y) -> 11 + 17 * (Id.hash x) + 257 * (Types.hash_const y)
|
| 301 |
and hash_slot s =
|
| 302 |
if s.gen1 = !gen then 13 * s.rank1
|
| 303 |
else (
|
| 304 |
incr rank;
|
| 305 |
s.rank1 <- !rank; s.gen1 <- !gen;
|
| 306 |
hash_descr (descr s)
|
| 307 |
)
|
| 308 |
|
| 309 |
let rec equal_descr d1 d2 =
|
| 310 |
match (d1,d2) with
|
| 311 |
| IType x1, IType x2 -> Types.equal_descr x1 x2
|
| 312 |
| IOr (x1,y1), IOr (x2,y2)
|
| 313 |
| IAnd (x1,y1), IAnd (x2,y2)
|
| 314 |
| IDiff (x1,y1), IDiff (x2,y2) -> (equal_descr x1 x2) && (equal_descr y1 y2)
|
| 315 |
| IOptional x1, IOptional x2 -> equal_descr x1 x2
|
| 316 |
| ITimes (x1,y1), ITimes (x2,y2)
|
| 317 |
| IXml (x1,y1), IXml (x2,y2)
|
| 318 |
| IArrow (x1,y1), IArrow (x2,y2) -> (equal_slot x1 x2) && (equal_slot y1 y2)
|
| 319 |
| IRecord (o1,r1), IRecord (o2,r2) ->
|
| 320 |
(o1 = o2) && (LabelMap.equal equal_slot r1 r2)
|
| 321 |
| ICapture x1, ICapture x2 -> Id.equal x1 x2
|
| 322 |
| IConstant (x1,y1), IConstant (x2,y2) ->
|
| 323 |
(Id.equal x1 x2) && (Types.equal_const y1 y2)
|
| 324 |
| _ -> false
|
| 325 |
and equal_slot s1 s2 =
|
| 326 |
((s1.gen1 = !gen) && (s2.gen2 = !gen) && (s1.rank1 = s2.rank2))
|
| 327 |
||
|
| 328 |
((s1.gen1 <> !gen) && (s2.gen2 <> !gen) && (
|
| 329 |
incr rank;
|
| 330 |
s1.rank1 <- !rank; s1.gen1 <- !gen;
|
| 331 |
s2.rank2 <- !rank; s2.gen2 <- !gen;
|
| 332 |
equal_descr (descr s1) (descr s2)
|
| 333 |
))
|
| 334 |
|
| 335 |
module Arg = struct
|
| 336 |
type t = slot
|
| 337 |
|
| 338 |
let hash s =
|
| 339 |
match s.hash with
|
| 340 |
| Some h -> h
|
| 341 |
| None ->
|
| 342 |
incr gen; rank := 0;
|
| 343 |
let h = hash_slot s in
|
| 344 |
s.hash <- Some h;
|
| 345 |
h
|
| 346 |
|
| 347 |
let equal s1 s2 =
|
| 348 |
(s1 == s2) ||
|
| 349 |
(incr gen; rank := 0;
|
| 350 |
let e = equal_slot s1 s2 in
|
| 351 |
(* if e then Printf.eprintf "Recursive hash-consig: Equal\n"; *)
|
| 352 |
e)
|
| 353 |
end
|
| 354 |
module SlotTable = Hashtbl.Make(Arg)
|
| 355 |
|
| 356 |
let rec fv_slot s =
|
| 357 |
match s.fv with
|
| 358 |
| Some x -> x
|
| 359 |
| None ->
|
| 360 |
if s.gen1 = !gen then IdSet.empty
|
| 361 |
else (s.gen1 <- !gen; fv_descr (descr s))
|
| 362 |
and fv_descr = function
|
| 363 |
| IType _ -> IdSet.empty
|
| 364 |
| IOr (d1,d2)
|
| 365 |
| IAnd (d1,d2)
|
| 366 |
| IDiff (d1,d2) -> IdSet.cup (fv_descr d1) (fv_descr d2)
|
| 367 |
| IOptional d -> fv_descr d
|
| 368 |
| ITimes (s1,s2)
|
| 369 |
| IXml (s1,s2)
|
| 370 |
| IArrow (s1,s2) -> IdSet.cup (fv_slot s1) (fv_slot s2)
|
| 371 |
| IRecord (o,r) ->
|
| 372 |
List.fold_left IdSet.cup IdSet.empty (LabelMap.map_to_list fv_slot r)
|
| 373 |
| ICapture x | IConstant (x,_) -> IdSet.singleton x
|
| 374 |
|
| 375 |
|
| 376 |
let compute_fv s =
|
| 377 |
match s.fv with
|
| 378 |
| Some x -> ()
|
| 379 |
| None ->
|
| 380 |
incr gen;
|
| 381 |
let x = fv_slot s in
|
| 382 |
s.fv <- Some x
|
| 383 |
|
| 384 |
|
| 385 |
let todo_fv = ref []
|
| 386 |
|
| 387 |
let mk () =
|
| 388 |
let s =
|
| 389 |
{ d = None;
|
| 390 |
fv = None;
|
| 391 |
hash = None;
|
| 392 |
rank1 = 0; rank2 = 0;
|
| 393 |
gen1 = 0; gen2 = 0 } in
|
| 394 |
todo_fv := s :: !todo_fv;
|
| 395 |
s
|
| 396 |
|
| 397 |
let flush_fv () =
|
| 398 |
List.iter compute_fv !todo_fv;
|
| 399 |
todo_fv := []
|
| 400 |
|
| 401 |
let compile_slot_hash = DerecursTable.create 67
|
| 402 |
let compile_hash = DerecursTable.create 67
|
| 403 |
|
| 404 |
let defs = ref []
|
| 405 |
|
| 406 |
let rec compile p =
|
| 407 |
try DerecursTable.find compile_hash p
|
| 408 |
with Not_found ->
|
| 409 |
let c = real_compile p in
|
| 410 |
DerecursTable.replace compile_hash p c;
|
| 411 |
c
|
| 412 |
and real_compile = function
|
| 413 |
| PAlias v ->
|
| 414 |
if v.ploop then
|
| 415 |
raise_loc_generic v.ploc ("Unguarded recursion on type/pattern");
|
| 416 |
v.ploop <- true;
|
| 417 |
let r = match v.pdescr with Some x -> compile x | _ -> assert false in
|
| 418 |
v.ploop <- false;
|
| 419 |
r
|
| 420 |
| PType t -> IType t
|
| 421 |
| POr (t1,t2) -> IOr (compile t1, compile t2)
|
| 422 |
| PAnd (t1,t2) -> IAnd (compile t1, compile t2)
|
| 423 |
| PDiff (t1,t2) -> IDiff (compile t1, compile t2)
|
| 424 |
| PTimes (t1,t2) -> ITimes (compile_slot t1, compile_slot t2)
|
| 425 |
| PXml (t1,t2) -> IXml (compile_slot t1, compile_slot t2)
|
| 426 |
| PArrow (t1,t2) -> IArrow (compile_slot t1, compile_slot t2)
|
| 427 |
| POptional t -> IOptional (compile t)
|
| 428 |
| PRecord (o,r) -> IRecord (o, LabelMap.map compile_slot r)
|
| 429 |
| PConstant (x,v) -> IConstant (x,v)
|
| 430 |
| PCapture x -> ICapture x
|
| 431 |
| PRegexp (r,q) -> compile_regexp r q
|
| 432 |
and compile_regexp r q =
|
| 433 |
let memo = RE.create 17 in
|
| 434 |
let rec aux accu r q =
|
| 435 |
if RE.mem memo (r,q) then accu
|
| 436 |
else (
|
| 437 |
RE.add memo (r,q) ();
|
| 438 |
match r with
|
| 439 |
| PEpsilon ->
|
| 440 |
(match q with
|
| 441 |
| PRegexp (r,q) -> aux accu r q
|
| 442 |
| _ -> (compile q) :: accu)
|
| 443 |
| PElem p -> ITimes (compile_slot p, compile_slot q) :: accu
|
| 444 |
| PSeq (r1,r2) -> aux accu r1 (PRegexp (r2,q))
|
| 445 |
| PAlt (r1,r2) -> aux (aux accu r1 q) r2 q
|
| 446 |
| PStar r1 -> aux (aux accu r1 (PRegexp (r,q))) PEpsilon q
|
| 447 |
| PWeakStar r1 -> aux (aux accu PEpsilon q) r1 (PRegexp (r,q))
|
| 448 |
)
|
| 449 |
in
|
| 450 |
let accu = aux [] r q in
|
| 451 |
match accu with
|
| 452 |
| [] -> assert false
|
| 453 |
| p::l -> List.fold_left (fun acc p -> IOr (p,acc)) p l
|
| 454 |
and compile_slot p =
|
| 455 |
try DerecursTable.find compile_slot_hash p
|
| 456 |
with Not_found ->
|
| 457 |
let s = mk () in
|
| 458 |
defs := (s,p) :: !defs;
|
| 459 |
DerecursTable.add compile_slot_hash p s;
|
| 460 |
s
|
| 461 |
|
| 462 |
|
| 463 |
let rec flush_defs () =
|
| 464 |
match !defs with
|
| 465 |
| [] -> ()
|
| 466 |
| (s,p)::t -> defs := t; s.d <- Some (compile p); flush_defs ()
|
| 467 |
|
| 468 |
let typ_nodes = SlotTable.create 67
|
| 469 |
let pat_nodes = SlotTable.create 67
|
| 470 |
|
| 471 |
let rec typ = function
|
| 472 |
| IType t -> t
|
| 473 |
| IOr (s1,s2) -> Types.cup (typ s1) (typ s2)
|
| 474 |
| IAnd (s1,s2) -> Types.cap (typ s1) (typ s2)
|
| 475 |
| IDiff (s1,s2) -> Types.diff (typ s1) (typ s2)
|
| 476 |
| ITimes (s1,s2) -> Types.times (typ_node s1) (typ_node s2)
|
| 477 |
| IXml (s1,s2) -> Types.xml (typ_node s1) (typ_node s2)
|
| 478 |
| IArrow (s1,s2) -> Types.arrow (typ_node s1) (typ_node s2)
|
| 479 |
| IOptional s -> Types.Record.or_absent (typ s)
|
| 480 |
| IRecord (o,r) -> Types.record' (o, LabelMap.map typ_node r)
|
| 481 |
| ICapture x | IConstant (x,_) -> assert false
|
| 482 |
|
| 483 |
and typ_node s : Types.node =
|
| 484 |
try SlotTable.find typ_nodes s
|
| 485 |
with Not_found ->
|
| 486 |
let x = Types.make () in
|
| 487 |
SlotTable.add typ_nodes s x;
|
| 488 |
Types.define x (typ (descr s));
|
| 489 |
x
|
| 490 |
|
| 491 |
let rec pat d : Patterns.descr =
|
| 492 |
if IdSet.is_empty (fv_descr d)
|
| 493 |
then Patterns.constr (typ d)
|
| 494 |
else pat_aux d
|
| 495 |
|
| 496 |
|
| 497 |
and pat_aux = function
|
| 498 |
| IOr (s1,s2) -> Patterns.cup (pat s1) (pat s2)
|
| 499 |
| IAnd (s1,s2) -> Patterns.cap (pat s1) (pat s2)
|
| 500 |
| IDiff (s1,s2) when IdSet.is_empty (fv_descr s2) ->
|
| 501 |
let s2 = Types.neg (typ s2) in
|
| 502 |
Patterns.cap (pat s1) (Patterns.constr s2)
|
| 503 |
| IDiff _ ->
|
| 504 |
raise (Patterns.Error "Difference not allowed in patterns")
|
| 505 |
| ITimes (s1,s2) -> Patterns.times (pat_node s1) (pat_node s2)
|
| 506 |
| IXml (s1,s2) -> Patterns.xml (pat_node s1) (pat_node s2)
|
| 507 |
| IOptional _ ->
|
| 508 |
raise (Patterns.Error "Optional field not allowed in record patterns")
|
| 509 |
| IRecord (o,r) ->
|
| 510 |
let pats = ref [] in
|
| 511 |
let aux l s =
|
| 512 |
if IdSet.is_empty (fv_slot s) then typ_node s
|
| 513 |
else
|
| 514 |
( pats := Patterns.record l (pat_node s) :: !pats;
|
| 515 |
Types.any_node )
|
| 516 |
in
|
| 517 |
let constr = Types.record' (o,LabelMap.mapi aux r) in
|
| 518 |
List.fold_left Patterns.cap (Patterns.constr constr) !pats
|
| 519 |
(* TODO: can avoid constr when o=true, and all fields have fv *)
|
| 520 |
| ICapture x -> Patterns.capture x
|
| 521 |
| IConstant (x,c) -> Patterns.constant x c
|
| 522 |
| IArrow _ ->
|
| 523 |
raise (Patterns.Error "Arrow not allowed in patterns")
|
| 524 |
| IType _ -> assert false
|
| 525 |
|
| 526 |
and pat_node s : Patterns.node =
|
| 527 |
try SlotTable.find pat_nodes s
|
| 528 |
with Not_found ->
|
| 529 |
let x = Patterns.make (fv_slot s) in
|
| 530 |
SlotTable.add pat_nodes s x;
|
| 531 |
Patterns.define x (pat (descr s));
|
| 532 |
x
|
| 533 |
|
| 534 |
let glb = State.ref "Typer.glb_env" TypeEnv.empty
|
| 535 |
|
| 536 |
let register_global_types b =
|
| 537 |
List.iter
|
| 538 |
(fun (v,p) ->
|
| 539 |
if TypeEnv.mem v !glb
|
| 540 |
then raise_loc_generic p.loc ("Multiple definition for type " ^ v)
|
| 541 |
) b;
|
| 542 |
let old_glb = !glb in
|
| 543 |
try
|
| 544 |
glb := derecurs_def !glb b;
|
| 545 |
let b = List.map (fun (v,p) -> (v,p,compile (derecurs !glb p))) b in
|
| 546 |
flush_defs ();
|
| 547 |
flush_fv ();
|
| 548 |
let b =
|
| 549 |
List.map
|
| 550 |
(fun (v,p,s) ->
|
| 551 |
if not (IdSet.is_empty (fv_descr s)) then
|
| 552 |
raise_loc_generic p.loc
|
| 553 |
"Capture variables are not allowed in types";
|
| 554 |
let t = typ s in
|
| 555 |
if (p.loc <> noloc) && (Types.is_empty t) then
|
| 556 |
warning p.loc
|
| 557 |
("This definition yields an empty type for " ^ v);
|
| 558 |
(v,t)) b in
|
| 559 |
List.iter (fun (v,t) -> Types.Print.register_global v t) b
|
| 560 |
with e ->
|
| 561 |
glb := old_glb;
|
| 562 |
raise e
|
| 563 |
|
| 564 |
let dump_global_types ppf =
|
| 565 |
TypeEnv.iter (fun v _ -> Format.fprintf ppf " %s" v) !glb
|
| 566 |
|
| 567 |
|
| 568 |
let typ p =
|
| 569 |
let s = compile_slot (derecurs !glb p) in
|
| 570 |
flush_defs ();
|
| 571 |
flush_fv ();
|
| 572 |
if IdSet.is_empty (fv_slot s) then typ_node s
|
| 573 |
else raise_loc_generic p.loc "Capture variables are not allowed in types"
|
| 574 |
|
| 575 |
let pat p =
|
| 576 |
let s = compile_slot (derecurs !glb p) in
|
| 577 |
flush_defs ();
|
| 578 |
flush_fv ();
|
| 579 |
try pat_node s
|
| 580 |
with Patterns.Error e -> raise_loc_generic p.loc e
|
| 581 |
| Location (loc,exn) when loc = noloc -> raise (Location (p.loc, exn))
|
| 582 |
|
| 583 |
|
| 584 |
(* II. Build skeleton *)
|
| 585 |
|
| 586 |
module Fv = IdSet
|
| 587 |
|
| 588 |
type branch = Branch of Typed.branch * branch list
|
| 589 |
|
| 590 |
let cur_branch : branch list ref = ref []
|
| 591 |
|
| 592 |
let exp loc fv e =
|
| 593 |
fv,
|
| 594 |
{ Typed.exp_loc = loc;
|
| 595 |
Typed.exp_typ = Types.empty;
|
| 596 |
Typed.exp_descr = e;
|
| 597 |
}
|
| 598 |
|
| 599 |
|
| 600 |
let rec expr loc = function
|
| 601 |
| LocatedExpr (loc,e) -> expr loc e
|
| 602 |
| Forget (e,t) ->
|
| 603 |
let (fv,e) = expr loc e and t = typ t in
|
| 604 |
exp loc fv (Typed.Forget (e,t))
|
| 605 |
| Var s ->
|
| 606 |
exp loc (Fv.singleton s) (Typed.Var s)
|
| 607 |
| Apply (e1,e2) ->
|
| 608 |
let (fv1,e1) = expr loc e1 and (fv2,e2) = expr loc e2 in
|
| 609 |
exp loc (Fv.cup fv1 fv2) (Typed.Apply (e1,e2))
|
| 610 |
| Abstraction a ->
|
| 611 |
let iface = List.map (fun (t1,t2) -> (typ t1, typ t2))
|
| 612 |
a.fun_iface in
|
| 613 |
let t = List.fold_left
|
| 614 |
(fun accu (t1,t2) -> Types.cap accu (Types.arrow t1 t2))
|
| 615 |
Types.any iface in
|
| 616 |
let iface = List.map
|
| 617 |
(fun (t1,t2) -> (Types.descr t1, Types.descr t2))
|
| 618 |
iface in
|
| 619 |
let (fv0,body) = branches a.fun_body in
|
| 620 |
let fv = match a.fun_name with
|
| 621 |
| None -> fv0
|
| 622 |
| Some f -> Fv.remove f fv0 in
|
| 623 |
let e = Typed.Abstraction
|
| 624 |
{ Typed.fun_name = a.fun_name;
|
| 625 |
Typed.fun_iface = iface;
|
| 626 |
Typed.fun_body = body;
|
| 627 |
Typed.fun_typ = t;
|
| 628 |
Typed.fun_fv = fv
|
| 629 |
} in
|
| 630 |
exp loc fv e
|
| 631 |
| Cst c ->
|
| 632 |
exp loc Fv.empty (Typed.Cst c)
|
| 633 |
| Pair (e1,e2) ->
|
| 634 |
let (fv1,e1) = expr loc e1 and (fv2,e2) = expr loc e2 in
|
| 635 |
exp loc (Fv.cup fv1 fv2) (Typed.Pair (e1,e2))
|
| 636 |
| Xml (e1,e2) ->
|
| 637 |
let (fv1,e1) = expr loc e1 and (fv2,e2) = expr loc e2 in
|
| 638 |
exp loc (Fv.cup fv1 fv2) (Typed.Xml (e1,e2))
|
| 639 |
| Dot (e,l) ->
|
| 640 |
let (fv,e) = expr loc e in
|
| 641 |
exp loc fv (Typed.Dot (e,l))
|
| 642 |
| RemoveField (e,l) ->
|
| 643 |
let (fv,e) = expr loc e in
|
| 644 |
exp loc fv (Typed.RemoveField (e,l))
|
| 645 |
| RecordLitt r ->
|
| 646 |
let fv = ref Fv.empty in
|
| 647 |
let r = LabelMap.map
|
| 648 |
(fun e ->
|
| 649 |
let (fv2,e) = expr loc e
|
| 650 |
in fv := Fv.cup !fv fv2; e)
|
| 651 |
r in
|
| 652 |
exp loc !fv (Typed.RecordLitt r)
|
| 653 |
| Op (op,le) ->
|
| 654 |
let (fvs,ltes) = List.split (List.map (expr loc) le) in
|
| 655 |
let fv = List.fold_left Fv.cup Fv.empty fvs in
|
| 656 |
(try
|
| 657 |
(match (ltes,Typed.find_op op) with
|
| 658 |
| [e], `Unary op -> exp loc fv (Typed.UnaryOp (op, e))
|
| 659 |
| [e1;e2], `Binary op -> exp loc fv (Typed.BinaryOp (op, e1,e2))
|
| 660 |
| _ -> assert false)
|
| 661 |
with Not_found -> assert false)
|
| 662 |
|
| 663 |
| Match (e,b) ->
|
| 664 |
let (fv1,e) = expr loc e
|
| 665 |
and (fv2,b) = branches b in
|
| 666 |
exp loc (Fv.cup fv1 fv2) (Typed.Match (e, b))
|
| 667 |
| Map (e,b) ->
|
| 668 |
let (fv1,e) = expr loc e
|
| 669 |
and (fv2,b) = branches b in
|
| 670 |
exp loc (Fv.cup fv1 fv2) (Typed.Map (e, b))
|
| 671 |
| Transform (e,b) ->
|
| 672 |
let (fv1,e) = expr loc e
|
| 673 |
and (fv2,b) = branches b in
|
| 674 |
exp loc (Fv.cup fv1 fv2) (Typed.Transform (e, b))
|
| 675 |
| Xtrans (e,b) ->
|
| 676 |
let (fv1,e) = expr loc e
|
| 677 |
and (fv2,b) = branches b in
|
| 678 |
exp loc (Fv.cup fv1 fv2) (Typed.Xtrans (e, b))
|
| 679 |
| Validate (e,schema,elt) ->
|
| 680 |
let (fv,e) = expr loc e in
|
| 681 |
exp loc fv (Typed.Validate (e, schema, elt))
|
| 682 |
| Try (e,b) ->
|
| 683 |
let (fv1,e) = expr loc e
|
| 684 |
and (fv2,b) = branches b in
|
| 685 |
exp loc (Fv.cup fv1 fv2) (Typed.Try (e, b))
|
| 686 |
|
| 687 |
|
| 688 |
and branches b =
|
| 689 |
let fv = ref Fv.empty in
|
| 690 |
let accept = ref Types.empty in
|
| 691 |
let branch (p,e) =
|
| 692 |
let cur_br = !cur_branch in
|
| 693 |
cur_branch := [];
|
| 694 |
let (fv2,e) = expr noloc e in
|
| 695 |
let br_loc = merge_loc p.loc e.Typed.exp_loc in
|
| 696 |
let p = pat p in
|
| 697 |
let fv2 = Fv.diff fv2 (Patterns.fv p) in
|
| 698 |
fv := Fv.cup !fv fv2;
|
| 699 |
accept := Types.cup !accept (Types.descr (Patterns.accept p));
|
| 700 |
let br =
|
| 701 |
{
|
| 702 |
Typed.br_loc = br_loc;
|
| 703 |
Typed.br_used = br_loc = noloc;
|
| 704 |
Typed.br_pat = p;
|
| 705 |
Typed.br_body = e } in
|
| 706 |
cur_branch := Branch (br, !cur_branch) :: cur_br;
|
| 707 |
br in
|
| 708 |
let b = List.map branch b in
|
| 709 |
(!fv,
|
| 710 |
{
|
| 711 |
Typed.br_typ = Types.empty;
|
| 712 |
Typed.br_branches = b;
|
| 713 |
Typed.br_accept = !accept;
|
| 714 |
Typed.br_compiled = None;
|
| 715 |
}
|
| 716 |
)
|
| 717 |
|
| 718 |
let expr = expr noloc
|
| 719 |
|
| 720 |
let let_decl p e =
|
| 721 |
let (_,e) = expr e in
|
| 722 |
{ Typed.let_pat = pat p;
|
| 723 |
Typed.let_body = e;
|
| 724 |
Typed.let_compiled = None }
|
| 725 |
|
| 726 |
(* III. Type-checks *)
|
| 727 |
|
| 728 |
type env = Types.descr Env.t
|
| 729 |
|
| 730 |
open Typed
|
| 731 |
|
| 732 |
let require loc t s =
|
| 733 |
if not (Types.subtype t s) then raise_loc loc (Constraint (t, s))
|
| 734 |
|
| 735 |
let check loc t s =
|
| 736 |
require loc t s; t
|
| 737 |
|
| 738 |
let should_have loc constr s =
|
| 739 |
raise_loc loc (ShouldHave (constr,s))
|
| 740 |
|
| 741 |
let flatten loc arg constr precise =
|
| 742 |
let constr' = Sequence.star
|
| 743 |
(Sequence.approx (Types.cap Sequence.any constr)) in
|
| 744 |
let sconstr' = Sequence.star constr' in
|
| 745 |
let exact = Types.subtype constr' constr in
|
| 746 |
if exact then
|
| 747 |
let t = arg sconstr' precise in
|
| 748 |
if precise then Sequence.flatten t else constr
|
| 749 |
else
|
| 750 |
let t = arg sconstr' true in
|
| 751 |
Sequence.flatten t
|
| 752 |
|
| 753 |
let rec type_check env e constr precise =
|
| 754 |
let d = type_check' e.exp_loc env e.exp_descr constr precise in
|
| 755 |
let d = if precise then d else constr in
|
| 756 |
e.exp_typ <- Types.cup e.exp_typ d;
|
| 757 |
d
|
| 758 |
|
| 759 |
and type_check' loc env e constr precise = match e with
|
| 760 |
| Forget (e,t) ->
|
| 761 |
let t = Types.descr t in
|
| 762 |
ignore (type_check env e t false);
|
| 763 |
check loc t constr
|
| 764 |
|
| 765 |
| Abstraction a ->
|
| 766 |
let t =
|
| 767 |
try Types.Arrow.check_strenghten a.fun_typ constr
|
| 768 |
with Not_found ->
|
| 769 |
should_have loc constr
|
| 770 |
"but the interface of the abstraction is not compatible"
|
| 771 |
in
|
| 772 |
let env = match a.fun_name with
|
| 773 |
| None -> env
|
| 774 |
| Some f -> Env.add f a.fun_typ env in
|
| 775 |
List.iter
|
| 776 |
(fun (t1,t2) ->
|
| 777 |
let acc = a.fun_body.br_accept in
|
| 778 |
if not (Types.subtype t1 acc) then
|
| 779 |
raise_loc loc (NonExhaustive (Types.diff t1 acc));
|
| 780 |
ignore (type_check_branches loc env t1 a.fun_body t2 false)
|
| 781 |
) a.fun_iface;
|
| 782 |
t
|
| 783 |
|
| 784 |
| Match (e,b) ->
|
| 785 |
let t = type_check env e b.br_accept true in
|
| 786 |
type_check_branches loc env t b constr precise
|
| 787 |
|
| 788 |
| Try (e,b) ->
|
| 789 |
let te = type_check env e constr precise in
|
| 790 |
let tb = type_check_branches loc env Types.any b constr precise in
|
| 791 |
Types.cup te tb
|
| 792 |
|
| 793 |
| Pair (e1,e2) ->
|
| 794 |
type_check_pair loc env e1 e2 constr precise
|
| 795 |
|
| 796 |
| Xml (e1,e2) ->
|
| 797 |
type_check_pair ~kind:`XML loc env e1 e2 constr precise
|
| 798 |
|
| 799 |
| RecordLitt r ->
|
| 800 |
type_record loc env r constr precise
|
| 801 |
|
| 802 |
| Map (e,b) ->
|
| 803 |
type_map loc env false e b constr precise
|
| 804 |
|
| 805 |
| Transform (e,b) ->
|
| 806 |
flatten loc (type_map loc env true e b) constr precise
|
| 807 |
|
| 808 |
| Apply (e1,e2) ->
|
| 809 |
let t1 = type_check env e1 Types.Arrow.any true in
|
| 810 |
let t1 = Types.Arrow.get t1 in
|
| 811 |
let dom = Types.Arrow.domain t1 in
|
| 812 |
let res =
|
| 813 |
if Types.Arrow.need_arg t1 then
|
| 814 |
let t2 = type_check env e2 dom true in
|
| 815 |
Types.Arrow.apply t1 t2
|
| 816 |
else
|
| 817 |
(ignore (type_check env e2 dom false); Types.Arrow.apply_noarg t1)
|
| 818 |
in
|
| 819 |
check loc res constr
|
| 820 |
|
| 821 |
| UnaryOp (o,e) ->
|
| 822 |
let t = o.un_op_typer loc
|
| 823 |
(type_check env e) constr precise in
|
| 824 |
check loc t constr
|
| 825 |
|
| 826 |
| BinaryOp (o,e1,e2) ->
|
| 827 |
let t = o.bin_op_typer loc
|
| 828 |
(type_check env e1)
|
| 829 |
(type_check env e2) constr precise in
|
| 830 |
check loc t constr
|
| 831 |
|
| 832 |
| Var s ->
|
| 833 |
let t =
|
| 834 |
try Env.find s env
|
| 835 |
with Not_found -> raise_loc loc (UnboundId s) in
|
| 836 |
check loc t constr
|
| 837 |
|
| 838 |
| Cst c ->
|
| 839 |
check loc (Types.constant c) constr
|
| 840 |
|
| 841 |
| Dot (e,l) ->
|
| 842 |
let t = type_check env e Types.Record.any true in
|
| 843 |
let t =
|
| 844 |
try (Types.Record.project t l)
|
| 845 |
with Not_found -> raise_loc loc (WrongLabel(t,l))
|
| 846 |
in
|
| 847 |
check loc t constr
|
| 848 |
|
| 849 |
| RemoveField (e,l) ->
|
| 850 |
let t = type_check env e Types.Record.any true in
|
| 851 |
let t = Types.Record.remove_field t l in
|
| 852 |
check loc t constr
|
| 853 |
|
| 854 |
| Xtrans (e,b) ->
|
| 855 |
let t = type_check env e Sequence.any true in
|
| 856 |
let t =
|
| 857 |
Sequence.map_tree
|
| 858 |
(fun t ->
|
| 859 |
let resid = Types.diff t b.br_accept in
|
| 860 |
let res = type_check_branches loc env t b Sequence.any true in
|
| 861 |
(res,resid)
|
| 862 |
) t in
|
| 863 |
check loc t constr
|
| 864 |
|
| 865 |
| Validate (e, schema_name, elt_name) ->
|
| 866 |
ignore (type_check env e Types.any false);
|
| 867 |
let t = fst (Hashtbl.find !schema_elements (schema_name, elt_name)) in
|
| 868 |
check loc t constr
|
| 869 |
|
| 870 |
and type_check_pair ?(kind=`Normal) loc env e1 e2 constr precise =
|
| 871 |
let rects = Types.Product.normal ~kind constr in
|
| 872 |
if Types.Product.is_empty rects then
|
| 873 |
(match kind with
|
| 874 |
| `Normal -> should_have loc constr "but it is a pair"
|
| 875 |
| `XML -> should_have loc constr "but it is an XML element");
|
| 876 |
let need_s = Types.Product.need_second rects in
|
| 877 |
let t1 = type_check env e1 (Types.Product.pi1 rects) (precise || need_s) in
|
| 878 |
let c2 = Types.Product.constraint_on_2 rects t1 in
|
| 879 |
if Types.is_empty c2 then
|
| 880 |
raise_loc loc (ShouldHave2 (constr,"but the first component has type",t1));
|
| 881 |
let t2 = type_check env e2 c2 precise in
|
| 882 |
|
| 883 |
if precise then
|
| 884 |
match kind with
|
| 885 |
| `Normal -> Types.times (Types.cons t1) (Types.cons t2)
|
| 886 |
| `XML -> Types.xml (Types.cons t1) (Types.cons t2)
|
| 887 |
else
|
| 888 |
constr
|
| 889 |
|
| 890 |
and type_record loc env r constr precise =
|
| 891 |
(* try to get rid of precise = true for values of fields *)
|
| 892 |
(* also: the use equivalent of need_second to optimize... *)
|
| 893 |
if not (Types.Record.has_record constr) then
|
| 894 |
should_have loc constr "but it is a record";
|
| 895 |
let (rconstr,res) =
|
| 896 |
List.fold_left
|
| 897 |
(fun (rconstr,res) (l,e) ->
|
| 898 |
(* could compute (split l e) once... *)
|
| 899 |
let pi = Types.Record.project_opt rconstr l in
|
| 900 |
if Types.is_empty pi then
|
| 901 |
(let l = U.to_string (LabelPool.value l) in
|
| 902 |
should_have loc constr
|
| 903 |
(Printf.sprintf "Field %s is not allowed here." l));
|
| 904 |
let t = type_check env e pi true in
|
| 905 |
let rconstr = Types.Record.condition rconstr l t in
|
| 906 |
let res = (l,Types.cons t) :: res in
|
| 907 |
(rconstr,res)
|
| 908 |
) (constr, []) (LabelMap.get r)
|
| 909 |
in
|
| 910 |
if not (Types.Record.has_empty_record rconstr) then
|
| 911 |
should_have loc constr "More fields should be present";
|
| 912 |
let t =
|
| 913 |
Types.record' (false, LabelMap.from_list (fun _ _ -> assert false) res)
|
| 914 |
in
|
| 915 |
check loc t constr
|
| 916 |
|
| 917 |
|
| 918 |
and type_check_branches loc env targ brs constr precise =
|
| 919 |
if Types.is_empty targ then Types.empty
|
| 920 |
else (
|
| 921 |
brs.br_typ <- Types.cup brs.br_typ targ;
|
| 922 |
branches_aux loc env targ
|
| 923 |
(if precise then Types.empty else constr)
|
| 924 |
constr precise brs.br_branches
|
| 925 |
)
|
| 926 |
|
| 927 |
and branches_aux loc env targ tres constr precise = function
|
| 928 |
| [] -> tres
|
| 929 |
| b :: rem ->
|
| 930 |
let p = b.br_pat in
|
| 931 |
let acc = Types.descr (Patterns.accept p) in
|
| 932 |
|
| 933 |
let targ' = Types.cap targ acc in
|
| 934 |
if Types.is_empty targ'
|
| 935 |
then branches_aux loc env targ tres constr precise rem
|
| 936 |
else
|
| 937 |
( b.br_used <- true;
|
| 938 |
let res = Patterns.filter targ' p in
|
| 939 |
let env' = List.fold_left
|
| 940 |
(fun env (x,t) -> Env.add x (Types.descr t) env)
|
| 941 |
env res in
|
| 942 |
let t = type_check env' b.br_body constr precise in
|
| 943 |
let tres = if precise then Types.cup t tres else tres in
|
| 944 |
let targ'' = Types.diff targ acc in
|
| 945 |
if (Types.non_empty targ'') then
|
| 946 |
branches_aux loc env targ'' tres constr precise rem
|
| 947 |
else
|
| 948 |
tres
|
| 949 |
)
|
| 950 |
|
| 951 |
and type_map loc env def e b constr precise =
|
| 952 |
let acc = if def then Sequence.any else Sequence.star b.br_accept in
|
| 953 |
let t = type_check env e acc true in
|
| 954 |
|
| 955 |
let constr' = Sequence.approx (Types.cap Sequence.any constr) in
|
| 956 |
let exact = Types.subtype (Sequence.star constr') constr in
|
| 957 |
(* Note:
|
| 958 |
- could be more precise by integrating the decomposition
|
| 959 |
of constr inside Sequence.map.
|
| 960 |
*)
|
| 961 |
let res =
|
| 962 |
Sequence.map
|
| 963 |
(fun t ->
|
| 964 |
let res =
|
| 965 |
type_check_branches loc env t b constr' (precise || (not exact)) in
|
| 966 |
if def && not (Types.subtype t b.br_accept)
|
| 967 |
then Types.cup res Sequence.nil_type
|
| 968 |
else res)
|
| 969 |
t in
|
| 970 |
if exact then res else check loc res constr
|
| 971 |
|
| 972 |
and type_let_decl env l =
|
| 973 |
let acc = Types.descr (Patterns.accept l.let_pat) in
|
| 974 |
let t = type_check env l.let_body acc true in
|
| 975 |
let res = Patterns.filter t l.let_pat in
|
| 976 |
List.map (fun (x,t) -> (x, Types.descr t)) res
|
| 977 |
|
| 978 |
and type_rec_funs env l =
|
| 979 |
let types =
|
| 980 |
List.fold_left
|
| 981 |
(fun accu -> function
|
| 982 |
| { exp_descr=Abstraction { fun_typ = t; fun_name = Some f } } ->
|
| 983 |
(f,t) :: accu
|
| 984 |
| _ -> assert false
|
| 985 |
) [] l
|
| 986 |
in
|
| 987 |
let env' = List.fold_left (fun env (x,t) -> Env.add x t env) env types in
|
| 988 |
List.iter (fun e -> ignore (type_check env' e Types.any false)) l;
|
| 989 |
types
|
| 990 |
|
| 991 |
|
| 992 |
let rec unused_branches b =
|
| 993 |
List.iter
|
| 994 |
(fun (Branch (br,s)) ->
|
| 995 |
if not br.br_used
|
| 996 |
then warning br.br_loc "This branch is not used"
|
| 997 |
else unused_branches s
|
| 998 |
)
|
| 999 |
b
|
| 1000 |
|
| 1001 |
let report_unused_branches () =
|
| 1002 |
unused_branches !cur_branch;
|
| 1003 |
cur_branch := []
|
| 1004 |
|
| 1005 |
(* Schema stuff from now on ... *)
|
| 1006 |
|
| 1007 |
let debug = true ;;
|
| 1008 |
|
| 1009 |
(** convertion from XML Schema types (including global elements and
|
| 1010 |
attributes) to CDuce Types.descr *)
|
| 1011 |
module Schema_converter =
|
| 1012 |
struct
|
| 1013 |
|
| 1014 |
open Printf ;;
|
| 1015 |
open Schema_types ;;
|
| 1016 |
|
| 1017 |
(* auxiliary functions *)
|
| 1018 |
|
| 1019 |
(* build a regexp Elem from a Types.descr *)
|
| 1020 |
let mk_re_elt descr = Ast.Elem (Location.mknoloc (Ast.Internal descr)) ;;
|
| 1021 |
|
| 1022 |
(* conversion functions *)
|
| 1023 |
|
| 1024 |
let cd_type_of_simple_type = function
|
| 1025 |
| SBuilt_in name -> Schema_builtin.cd_type_of_builtin name
|
| 1026 |
| SUser_defined (_, _, _, _) -> assert false (* TODO *)
|
| 1027 |
;;
|
| 1028 |
|
| 1029 |
let rec regexp_of_term = function
|
| 1030 |
| All _ -> assert false
|
| 1031 |
| Choice [] -> Ast.Epsilon
|
| 1032 |
| Choice (hd :: tl) ->
|
| 1033 |
List.fold_left
|
| 1034 |
(fun acc particle -> Ast.Alt (acc, regexp_of_particle particle))
|
| 1035 |
(regexp_of_particle hd) tl
|
| 1036 |
| Sequence [] -> Ast.Epsilon
|
| 1037 |
| Sequence (hd :: tl) ->
|
| 1038 |
List.fold_left
|
| 1039 |
(fun acc particle -> Ast.Seq (acc, regexp_of_particle particle))
|
| 1040 |
(regexp_of_particle hd) tl
|
| 1041 |
| Elt decl -> mk_re_elt (cd_type_of_elt_decl !decl)
|
| 1042 |
|
| 1043 |
and regexp_of_content_type = function
|
| 1044 |
| CT_empty -> Ast.Epsilon
|
| 1045 |
| CT_simple st -> mk_re_elt (cd_type_of_simple_type st)
|
| 1046 |
| CT_model (particle, mixed) ->
|
| 1047 |
assert (not mixed); (* TODO mixed support *)
|
| 1048 |
regexp_of_particle particle
|
| 1049 |
|
| 1050 |
and regexp_of_particle =
|
| 1051 |
(* given a regexp re and a (non negative) integer n create a regexp
|
| 1052 |
matching exactly n times re *)
|
| 1053 |
let rec repeat_regexp re = function
|
| 1054 |
| 0 -> Ast.Epsilon
|
| 1055 |
| n when n > 0 -> Ast.Seq (re, repeat_regexp re (n - 1))
|
| 1056 |
| _ -> assert false
|
| 1057 |
in
|
| 1058 |
fun (min, max, term) ->
|
| 1059 |
let term_regexp = regexp_of_term term in
|
| 1060 |
let min_regexp = repeat_regexp term_regexp min in
|
| 1061 |
match max with
|
| 1062 |
| Some max ->
|
| 1063 |
assert (max >= min);
|
| 1064 |
let rec aux acc = function
|
| 1065 |
| 0 -> acc
|
| 1066 |
| n ->
|
| 1067 |
aux
|
| 1068 |
(Ast.Alt (Ast.Epsilon, (Ast.Seq (term_regexp, acc))))
|
| 1069 |
(n - 1)
|
| 1070 |
in
|
| 1071 |
Ast.Seq (min_regexp, aux Ast.Epsilon (max - min))
|
| 1072 |
| None -> Ast.Seq (min_regexp, Ast.Star term_regexp)
|
| 1073 |
|
| 1074 |
(** @return a pair composed by a type for the attributes (a record) and a
|
| 1075 |
type for the content model (a sequence) *)
|
| 1076 |
and cd_type_of_complex_type' = function
|
| 1077 |
| CBuilt_in name -> assert false
|
| 1078 |
| CUser_defined (name, _, _, attr_uses, content) ->
|
| 1079 |
let content_re = regexp_of_content_type content in
|
| 1080 |
let content_ast_node =
|
| 1081 |
Location.mknoloc (Ast.Regexp
|
| 1082 |
(content_re, Location.mknoloc (Ast.Internal Sequence.nil_type)))
|
| 1083 |
in
|
| 1084 |
(cd_type_of_attr_uses attr_uses, (Types.descr (typ content_ast_node)))
|
| 1085 |
|
| 1086 |
(** @return a closed record *)
|
| 1087 |
and cd_type_of_attr_uses attr_uses =
|
| 1088 |
Types.rec_of_list' ~opened:false
|
| 1089 |
(List.fold_left
|
| 1090 |
(fun fields (required, (name, st, _), _) ->
|
| 1091 |
(not required, name, cd_type_of_simple_type !st) :: fields)
|
| 1092 |
[] attr_uses)
|
| 1093 |
|
| 1094 |
and cd_type_of_elt_decl (name, typ, _) =
|
| 1095 |
let atom_type = Types.atom (Atoms.atom (Atoms.mk_ascii name)) in
|
| 1096 |
(match !typ with
|
| 1097 |
| S st ->
|
| 1098 |
Types.xml' atom_type Types.empty_closed_record
|
| 1099 |
(cd_type_of_simple_type st)
|
| 1100 |
| C ct ->
|
| 1101 |
let (attr_type, cont_type) = cd_type_of_complex_type' ct in
|
| 1102 |
Types.xml' atom_type attr_type cont_type)
|
| 1103 |
;;
|
| 1104 |
|
| 1105 |
let cd_type_of_complex_type = function
|
| 1106 |
| CBuilt_in name -> Schema_builtin.cd_type_of_builtin name
|
| 1107 |
| ct ->
|
| 1108 |
let (attr_type, cont_type) = cd_type_of_complex_type' ct in
|
| 1109 |
Types.xml' Types.any attr_type cont_type
|
| 1110 |
;;
|
| 1111 |
|
| 1112 |
let cd_type_of_type_def = function
|
| 1113 |
| S st -> cd_type_of_simple_type st
|
| 1114 |
| C ct -> cd_type_of_complex_type ct
|
| 1115 |
;;
|
| 1116 |
|
| 1117 |
end
|
| 1118 |
;;
|
| 1119 |
|
| 1120 |
let get_schema_validator (schema_name, elt_name) =
|
| 1121 |
snd (Hashtbl.find !schema_elements (schema_name, elt_name))
|
| 1122 |
;;
|
| 1123 |
|
| 1124 |
let register_schema schema_name schema =
|
| 1125 |
if StringSet.mem schema_name !schemas then
|
| 1126 |
failwith ("Redefinition of schema " ^ schema_name)
|
| 1127 |
else begin
|
| 1128 |
schemas := StringSet.add schema_name !schemas;
|
| 1129 |
List.iter (* Schema types -> CDuce types *)
|
| 1130 |
(fun type_def ->
|
| 1131 |
let cd_type = Schema_converter.cd_type_of_type_def type_def in
|
| 1132 |
Hashtbl.add !schema_types
|
| 1133 |
(schema_name, Schema_types.name_of_type_def type_def)
|
| 1134 |
cd_type)
|
| 1135 |
schema.Schema_types.type_defs;
|
| 1136 |
(* Schema attributes -> CDuce types TODO *)
|
| 1137 |
List.iter (* Schema elements -> CDuce types * validators *)
|
| 1138 |
(fun elt_decl ->
|
| 1139 |
let cd_type = Schema_converter.cd_type_of_elt_decl elt_decl in
|
| 1140 |
if debug then
|
| 1141 |
(Types.Print.print Format.std_formatter cd_type;
|
| 1142 |
Format.fprintf Format.std_formatter "\n";
|
| 1143 |
Format.pp_print_flush Format.std_formatter ());
|
| 1144 |
let validator = Schema_validator.validator_of_elt_decl elt_decl in
|
| 1145 |
Hashtbl.add !schema_elements
|
| 1146 |
(schema_name, Schema_types.name_of_elt_decl elt_decl)
|
| 1147 |
(cd_type, validator))
|
| 1148 |
schema.Schema_types.elt_decls
|
| 1149 |
end
|
| 1150 |
;;
|
| 1151 |
|
| 1152 |
(* DEBUGGING ONLY *)
|
| 1153 |
|
| 1154 |
let get_schema_type x = fst (Hashtbl.find !schema_elements x) ;;
|
Parent Directory
| 
Revision Log