typer.ml 44.8 KB
Newer Older
1
open Cduce_loc
2
3
open Ast
open Ident
4

5
6
7
8
9
10
let (=) (x:int) y = x = y
let (<=) (x:int) y = x <= y
let (<) (x:int) y = x < y
let (>=) (x:int) y = x >= y
let (>) (x:int) y = x > y

11
let warning loc msg =
12
  let v = Cduce_loc.get_viewport () in
13
  let ppf = if Html.is_html v then Html.ppf v else Format.err_formatter in
14
15
  Cduce_loc.print_loc ppf (loc,`Full);
  Cduce_loc.html_hilight (loc,`Full);
16
  Format.fprintf ppf "Warning: %s@." msg
17

18
19
20
21
22
23
exception NonExhaustive of Types.descr
exception Constraint of Types.descr * Types.descr
exception ShouldHave of Types.descr * string
exception ShouldHave2 of Types.descr * string * Types.descr
exception WrongLabel of Types.descr * label
exception UnboundId of id * bool
24
exception UnboundExtId of Compunit.t * id
25
exception Error of string
26
27
exception Warning of string * Types.t

28
29
30
31
let raise_loc loc exn = raise (Location (loc,`Full,exn))
let raise_loc_str loc ofs exn = raise (Location (loc,`Char ofs,exn))
let error loc msg = raise_loc loc (Error msg)

32
33
34
35
36
37
type schema = {
  sch_uri: string;
  sch_ns: Ns.Uri.t;
  sch_comps: (Types.t * Schema_validator.t) Ident.Env.t;
}

38
type item =
39
40
41
42
43
44
45
46
47
48
49
  (* These are really exported by CDuce units: *)
| Type of (Types.t * Var.t array)
| Val of Types.t
| ECDuce of Compunit.t
| ESchema of schema
| ENamespace of Ns.Uri.t
  (* These are only used internally: *)
| EVal of Compunit.t * id * Types.t
| EOCaml of string
| EOCamlComponent of string
| ESchemaComponent of (Types.t * Schema_validator.t)
50

51
type t = {
52
  ids : item Env.t;
53
  delta : Var.Set.t;
54
  ns: Ns.table;
55
  keep_ns: bool
56
}
57

58
let pp_env ppf env =
Pietro Abate's avatar
Pietro Abate committed
59
60
  let pp_item ppf (s,t) = match t with
    |Val t -> Format.fprintf ppf "val %s : %a" s Types.Print.pp_type t
Pietro Abate's avatar
Pietro Abate committed
61
62
    |Type (t,[||]) -> Format.fprintf ppf "type %s = %a" s Types.Print.pp_noname t
    |Type (t,al) ->
63
64
65
      Format.fprintf ppf "type %s(%a) = %a" s
        (Utils.pp_list ~delim:("","") Var.pp) (Array.to_list al)
        Types.Print.pp_noname t
66
67
    |_ -> ()
  in
68
  let t = [
Pietro Abate's avatar
Pietro Abate committed
69
70
71
72
73
74
    "Empty";"Any";"Int";"Char";"Byte";"Atom";
    "Pair";"Arrow";"Record";
    "String";"Latin1";
    "Bool";"Float";"AnyXml";
    "Namespaces";"Caml_int" ]
  in
75
  let ids =
Pietro Abate's avatar
Pietro Abate committed
76
77
    Env.filter (fun n _ ->
      not(List.mem (Id.to_string n) t)
78
    ) env.ids
Pietro Abate's avatar
Pietro Abate committed
79
  in
Pietro Abate's avatar
Pietro Abate committed
80
  Format.printf "{ids=%a;delta=%a}"
81
82
    (Ident.pp_env pp_item) ids
    Var.Set.pp env.delta
83
84
;;

85
86
(* Namespaces *)

87
let set_ns_table_for_printer env =
88
89
90
91
92
93
94
95
96
97
  Ns.InternalPrinter.set_table env.ns

let get_ns_table tenv = tenv.ns

let type_keep_ns env k =
  { env with keep_ns = k }

let protect_error_ns loc f x =
  try f x
  with Ns.UnknownPrefix ns ->
98
    raise_loc_generic loc
99
      ("Undefined namespace prefix " ^ (U.to_string ns))
100

101
let qname env loc t =
102
  protect_error_ns loc (Ns.map_tag env.ns) t
103

104
105
106
107
let ident env loc t =
  protect_error_ns loc (Ns.map_attr env.ns) t

let parse_atom env loc t = Atoms.V.mk (qname env loc t)
108

109
110
111
112
113
114
115
116
117
118
let parse_ns env loc ns =
  protect_error_ns loc (Ns.map_prefix env.ns) ns

let parse_label env loc t =
  Label.mk (protect_error_ns loc (Ns.map_attr env.ns) t)

let parse_record env loc f r =
  let r = List.map (fun (l,x) -> (parse_label env loc l, f x)) r in
  LabelMap.from_list (fun _ _ -> raise_loc_generic loc "Duplicated record field") r

119
120
let load_schema = ref (fun _ _ -> assert false)
let from_comp_unit = ref (fun _ -> assert false)
121
let load_comp_unit = ref (fun _ -> assert false)
122
123
let has_ocaml_unit = ref (fun _ -> false)
let has_static_external = ref (fun _ -> assert false)
124

125
126
127
128
129
let type_schema env loc name uri =
  let x = ident env loc name in
  let (ns,sch) = !load_schema (U.to_string name) uri in
  let sch = { sch_uri = uri; sch_comps = sch; sch_ns = ns } in
  { env with ids = Env.add x (ESchema sch) env.ids }
130

131
let empty_env = {
Pietro Abate's avatar
Pietro Abate committed
132
  ids = Env.empty; (* map from expression variables to items *)
133
  delta = Var.Set.empty; (* set of bounded type variables *)
134
135
  ns = Ns.def_table;
  keep_ns = false
136
137
}

138
139
let enter_id x i env =
  { env with ids = Env.add x i env.ids }
140

141
142
let type_using env loc x cu =
  try
143
144
145
146
147
    let cu = !load_comp_unit cu in
    enter_id (ident env loc x) (ECDuce cu) env
  with Not_found ->
    error loc ("Cannot find external unit " ^ (U.to_string cu))

Pietro Abate's avatar
Pietro Abate committed
148
let enter_type id t env = enter_id id (Type (t,[||])) env
149
let enter_types l env =
150
  { env with ids =
Pietro Abate's avatar
Pietro Abate committed
151
152
153
154
      List.fold_left (fun accu (id,t,al) ->
        Env.add id (Type (t,al)) accu
      ) env.ids l
  }
155

156
157
158
159
160
161
let find_id env0 env loc head x =
  let id = ident env0 loc x in
  try Env.find id env.ids
  with Not_found when head ->
    try ECDuce (!load_comp_unit x)
    with Not_found ->
Pietro Abate's avatar
Pietro Abate committed
162
      error loc "Cannot resolve this identifier"
163
164
165

let find_id_comp env0 env loc x =
  if ((match (U.get_str x).[0] with 'A'..'Z' -> true | _ -> false)
166
      && !has_ocaml_unit x)
167
168
169
  then EOCaml (U.get_str x)
  else find_id env0 env loc true x

170

171
let enter_value id t env =
172
  { env with ids = Env.add id (Val t) env.ids }
173

174
let enter_values l env =
175
  { env with ids =
176
      List.fold_left (fun accu (id,t) -> Env.add id (Val t) accu) env.ids l;
177
178
  }

179
let enter_values_dummy l env =
180
  { env with ids =
181
      List.fold_left (fun accu id -> Env.add id (Val Types.empty) accu) env.ids l }
182

183
184
let value_name_ok id env =
  try match Env.find id env.ids with
185
186
  | Val _ | EVal _ -> true
  | _ -> false
187
188
  with Not_found -> true

189
190
let iter_values env f =
  Env.iter (fun x ->
191
192
    function Val t -> f x t;
    | _ -> ()) env.ids
193

194
let register_types cu env =
Pietro Abate's avatar
Pietro Abate committed
195
  Env.iter (fun x -> function
196
197
  | Type (t,_) -> Types.Print.register_global (cu,(Ident.value x),[||]) t
  | _ -> ()
Pietro Abate's avatar
Pietro Abate committed
198
  ) env.ids
199

200
201
202
203
204
205
206
207
208
let rec const env loc = function
  | LocatedExpr (loc,e) -> const env loc e
  | Pair (x,y) -> Types.Pair (const env loc x, const env loc y)
  | Xml (x,y) -> Types.Xml (const env loc x, const env loc y)
  | RecordLitt x -> Types.Record (parse_record env loc (const env loc) x)
  | String (i,j,s,c) -> Types.String (i,j,s,const env loc c)
  | Atom t -> Types.Atom (parse_atom env loc t)
  | Integer i -> Types.Integer i
  | Char c -> Types.Char c
209
  | Const c -> c
210
211
212
  | _ -> raise_loc_generic loc "This should be a scalar or structured constant"

(* I. Transform the abstract syntax of types and patterns into
213
   the internal form *)
214

215
216
let find_schema_component sch name =
  try ESchemaComponent (Env.find name sch.sch_comps)
217
  with Not_found ->
218
    raise (Error (Printf.sprintf "No component named '%s' found in schema '%s'"
219
220
221
222
		    (Ns.QName.to_string name) sch.sch_uri))

let navig loc env0 (env,comp) id =
  match comp with
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
  | ECDuce cu ->
    let env = !from_comp_unit cu in
    let c =
      try find_id env0 env loc false id
      with Not_found -> error loc "Unbound identifier"
    in
    let c = match c with
      | Val t -> EVal (cu,ident env0 loc id,t)
      | c -> c
    in
    env,c
  | EOCaml cu ->
    let s = cu ^ "." ^ (U.get_str id) in
    (match (U.get_str id).[0] with
    | 'A'..'Z' -> env,EOCaml s
    | _ -> env,EOCamlComponent s)
  | ESchema sch ->
    env,find_schema_component sch (ident env0 loc id)
  | Type _ -> error loc "Types don't have components"
  | Val _ | EVal _ -> error loc "Values don't have components"
  | ENamespace _ -> error loc "Namespaces don't have components"
  | EOCamlComponent _ -> error loc "Caml values don't have components"
  | ESchemaComponent _ -> error loc "Schema components don't have components"
246
(*
247
  | _ -> error loc "Invalid dot access"
248
*)
249

250
251
let rec find_global env loc ids =
  match ids with
252
253
254
255
  | id::rest ->
    let comp = find_id env env loc true id in
    snd (List.fold_left (navig loc env) (env,comp) rest)
  | _ -> assert false
256

257
258
259
let eval_ns env loc = function
  | `Uri ns -> ns
  | `Path ids ->
260
261
262
263
    match find_global env loc ids with
    | ENamespace ns -> ns
    | ESchema sch -> sch.sch_ns
    | _ -> error loc "This path does not refer to a namespace or schema"
264
265
266
267

let type_ns env loc p ns =
  (* TODO: check that p has no prefix *)
  let ns = eval_ns env loc ns in
268
  { env with
269
270
    ns = Ns.add_prefix p ns env.ns;
    ids = Env.add (Ns.empty,p) (ENamespace ns) env.ids }
271

272
273
let find_global_type env loc ids =
  match find_global env loc ids with
274
275
276
  | Type (t,pargs) -> (t,pargs)
  | ESchemaComponent (t,_) -> (t,[||]) (* XXX *)
  | _ -> error loc "This path does not refer to a type"
277
278
279

let find_global_schema_component env loc ids =
  match find_global env loc ids with
280
281
  | ESchemaComponent c -> c
  | _ -> error loc "This path does not refer to a schema component"
282

283
284
let find_local_type env loc id =
  match Env.find id env.ids with
285
286
  | Type (t,pargs) -> (t,pargs)
  | _ -> raise Not_found
287
288

let find_value id env =
289
  match Env.find id env.ids with
290
291
  | Val t | EVal (_,_,t) -> t
  | _ -> raise Not_found
292

293
294
let do_open env cu =
  let env_cu = !from_comp_unit cu in
295
  let ids =
296
297
    Env.fold
      (fun n d ids ->
298
299
300
301
	let d = match d with
	  | Val t -> EVal (cu,n,t)
	  | d -> d in
	Env.add n d ids)
302
303
      env_cu.ids
      env.ids in
304
  { env with
305
306
    ids = ids;
    ns = Ns.merge_tables env.ns env_cu.ns }
307

308
309
310

let type_open env loc ids =
  match find_global env loc ids with
311
312
  | ECDuce cu -> do_open env cu
  | _ -> error loc "This path does not refer to a CDuce unit"
313

314
module IType = struct
315
  open Typepat
316

317
  (* From AST to the intermediate representation *)
318
319
320

  type penv = {
    penv_tenv : t;
321
    penv_derec : (node * U.t list) Env.t;
322
    penv_var : (string, Var.var) Hashtbl.t;
323
324
  }

325
  let penv tenv = { penv_tenv = tenv; penv_derec = Env.empty ; penv_var = Hashtbl.create 17 }
326

327
328
  let all_delayed = ref []

329
330
  let clean_on_err () = all_delayed := []

331
332
333
334
335
336
  let delayed loc =
    let s = mk_delayed () in
    all_delayed := (loc,s) :: !all_delayed;
    s

  let check_one_delayed (loc,p) =
337
    if not (check_wf p) then error loc "Ill-formed recursion"
338

339
340
  let check_delayed () =
    let l = !all_delayed in
341
    all_delayed := [];
342
    List.iter check_one_delayed l
343

344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388

  let seq_to_list e =
    let rec loop e acc =
      match e with
      | Seq(e1, e2) -> loop e1 (loop e2 acc)
      | _ -> e :: acc
    in
    loop e []

  let list_to_seq l =
    let rec loop l acc =
    match l with
      [] -> acc
    | ((Elem { descr = PatVar(_, []); _} ) as var) ::
      ((Arg _) as arg) :: rest -> loop rest (re_seq acc (re_seq var arg))
    | (Arg r) :: rest | r :: rest -> loop rest (re_seq acc r)
    in
    loop l Epsilon

  let rec clean_re e =
    match e with
    | Seq(_,_) -> let l = seq_to_list e in
      let l =
        List.map (function Arg e -> Arg (clean_re e) | e -> clean_re e) l
      in
      list_to_seq l
    | Alt(e1, e2) -> Alt (clean_re e1, clean_re e2)
    | Star e0 -> Star (clean_re e0)
    | WeakStar e0 -> WeakStar (clean_re e0)
    | SeqCapture (i, e0) -> SeqCapture (i, clean_re e0)
    | Arg e0 -> clean_re e0
    | _ -> e

  let rec print_re fmt e =
    match e with
    Epsilon -> Format.fprintf fmt "Epsilon"
    | Elem _ -> Format.fprintf fmt "Elem"
    | Guard _ -> Format.fprintf fmt "Guard"
    | Seq (e1, e2) -> Format.fprintf fmt "Seq(%a, %a)" print_re e1 print_re e2
    | Alt (e1, e2) -> Format.fprintf fmt "Alt(%a, %a)" print_re e1 print_re e2
    | Star (e0) -> Format.fprintf fmt "Star(%a)" print_re e0
    | WeakStar (e0) -> Format.fprintf fmt "WeakStar(%a)" print_re e0
    | SeqCapture (_, e0) -> Format.fprintf fmt "SeqCapture(_, %a)" print_re e0
    | Arg (e0) -> Format.fprintf fmt "Arg(%a)" print_re e0

Pietro Abate's avatar
Pietro Abate committed
389
  (* Ast -> symbolic type *)
390
  let rec derecurs env p =
Pietro Abate's avatar
Pietro Abate committed
391
    match p.descr with
392
    | PatVar ids -> derecurs_var env p.loc ids
393
    | Recurs (p,b) -> derecurs (fst (derecurs_def env b)) p
394
    | Internal t -> mk_type t
395
    | NsT ns ->
396
      mk_type (Types.atom (Atoms.any_in_ns (parse_ns env.penv_tenv p.loc ns)))
397
398
399
400
401
402
403
    | Or (p1,p2) -> mk_or (derecurs env p1) (derecurs env p2)
    | And (p1,p2) -> mk_and (derecurs env p1) (derecurs env p2)
    | Diff (p1,p2) -> mk_diff (derecurs env p1) (derecurs env p2)
    | Prod (p1,p2) -> mk_prod (derecurs env p1) (derecurs env p2)
    | XmlT (p1,p2) -> mk_xml (derecurs env p1) (derecurs env p2)
    | Arrow (p1,p2) -> mk_arrow (derecurs env p1) (derecurs env p2)
    | Optional p -> mk_optional (derecurs env p)
404
    | Record (o,r) ->
405
406
407
408
      let aux = function
	| (p,Some e) -> (derecurs env p, Some (derecurs env e))
	| (p,None) -> derecurs env p, None in
      mk_record o (parse_record env.penv_tenv p.loc aux r)
409
    | Constant (x,c) ->
410
      mk_constant (ident env.penv_tenv p.loc x) (const env.penv_tenv p.loc c)
411
    | Cst c -> mk_type (Types.constant (const env.penv_tenv p.loc c))
412
    | Regexp r -> rexp (derecurs_regexp env (clean_re r))
413
414
    | Concat (p1,p2) ->  mk_concat (derecurs env p1) (derecurs env p2)
    | Merge (p1,p2) -> mk_merge (derecurs env p1) (derecurs env p2)
415
    | Group p -> derecurs env p
416

417
  and derecurs_regexp env = function
418
    | Epsilon -> mk_epsilon
419
420
    | Elem p -> mk_elem (derecurs env p)
    | Guard p -> mk_guard (derecurs env p)
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
    | Seq (p1,p2) -> (* we need to disambiguate between sequence concatenation in regexp
                       and type instantiation *)
      begin
        match p1, p2 with
        Elem { loc; descr = PatVar ((id :: rest as ids), []) }, Arg (Elem t2) ->
          let nargs =
            try
              if rest == [] then (* local identifier *)
                let id = ident env.penv_tenv loc id in
                try List.length (snd (Env.find id env.penv_derec))
                with Not_found ->
                  Array.length (snd (find_local_type env.penv_tenv loc id))
              else
                Array.length (snd (find_global_type env.penv_tenv loc ids))
            with Not_found -> 0
          in
          if nargs != 0 then (* instantiation *)
            mk_elem (derecurs env { loc; descr = PatVar(ids, prod_to_list t2) })
          else
            mk_seq (derecurs_regexp env p1) (derecurs_regexp env p2)
        | _ ->
          mk_seq (derecurs_regexp env p1) (derecurs_regexp env p2)
      end
444
445
446
    | Alt (p1,p2) -> mk_alt (derecurs_regexp env p1) (derecurs_regexp env p2)
    | Star p -> mk_star (derecurs_regexp env p)
    | WeakStar p -> mk_weakstar (derecurs_regexp env p)
Pietro Abate's avatar
Pietro Abate committed
447
    | SeqCapture ((loc,x),p) -> mk_seqcapt (ident env.penv_tenv loc x) (derecurs_regexp env p)
448
    | Arg r -> derecurs_regexp env r
449

450
451
  and derecurs_var env loc ids =
    match ids with
452
453
454
    | ([v],a) ->
      let v = ident env.penv_tenv loc v in
      begin
455
        try fst (Env.find v env.penv_derec)
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
	with Not_found ->
	  try
            let (t,pargs) = find_local_type env.penv_tenv loc v in
            let palen = Array.length pargs in
            if palen <> List.length a then
              raise_loc_generic loc
                (Printf.sprintf "Parametric type %s is not fully instanciated" (Ident.to_string v));
            let a = Array.of_list a in
            let l = ref [] in
            for i=0 to (Array.length pargs) - 1 do
              try
                let err s = Error s in
                let tai = typ ~err (derecurs env a.(i)) in
                l := (pargs.(i), tai )::!l
              with
              |Error s -> raise_loc_generic loc s
              |_ -> assert false
            done;
            mk_type (Types.Positive.substitute_list t !l)
	  with Not_found ->
            if List.length a >= 1 then
              raise_loc_generic loc
478
                (Printf.sprintf "Parametric type %s does not exists" (Ident.to_string v))
479
480
481
482
483
            else
              mk_capture v
      end
    | (ids,_) ->
      mk_type (fst(find_global_type env.penv_tenv loc ids))
484

485
  and derecurs_def env b =
486
    let seen = ref IdSet.empty in
487
    let b =
488
      List.map (fun ((loc,v),args,p) ->
489
490
491
492
493
494
	let v = ident env.penv_tenv loc v in
	if IdSet.mem !seen v then
	  raise_loc_generic loc
	    ("Multiple definitions for the type identifer " ^
		(Ident.to_string v));
	seen := IdSet.add v !seen;
495
	(v,args,p,delayed loc)
496
      ) b
Pietro Abate's avatar
Pietro Abate committed
497
    in
498
499
500
501
    let n = List.fold_left
        (fun env (v,a,p,s) -> Env.add v (s,a) env)
        env.penv_derec b
    in
502
    let env = { env with penv_derec = n } in
503
    List.iter (fun (v,_, p,s) -> link s (derecurs env p)) b;
504
505
    (env, b)

506
507
  let derec penv p =
    let d = derecurs penv p in
508
    elim_concats ();
509
    check_delayed ();
510
    internalize d;
511
    d
512

513
  (* API *)
514

515
516
  let check_no_fv loc n =
    match peek_fv n with
517
518
519
520
    | None -> ()
    | Some x ->
      raise_loc_generic loc
	("Capture variable not allowed: " ^ (Ident.to_string x))
521

522
  let type_defs env b =
523
    let _,b' = derecurs_def (penv env) b in
524
525
526
527
528
    elim_concats ();
    check_delayed ();
    let aux loc d =
      internalize d;
      check_no_fv loc d;
529
      try typ d
530
      with Patterns.Error s -> raise_loc_generic loc s
531
    in
532
    let b =
533
      List.map2 (fun ((loc,v),pl,p) (v',_,_, d) ->
534
535
536

        let t_rhs = aux loc d in
        if (loc <> noloc) && (Types.is_empty t_rhs) then
537
538
          warning loc
            ("This definition yields an empty type for " ^ (U.to_string v));
539
540
541
542
543
544
545
546
547

        let vars_rhs = Types.all_vars t_rhs in
        let vars_mapping = (* create a sequence 'a -> 'a_0 for all variables *)
          List.map (fun v -> let vv =  Var.mk (Ident.U.to_string v) in vv, Var.fresh vv) pl
        in
        let vars_lhs =
          List.fold_left (fun acc (v, _) -> Var.Set.add v acc) Var.Set.empty vars_mapping
        in
        if not (Var.Set.subset vars_rhs vars_lhs) then
548
          error loc
549
550
551
552
553
554
555
            (Printf.sprintf "Definition of type %s contains unbound type variables"
               (U.to_string v));

        let t_rhs =
          Types.Positive.substitute_list t_rhs
            (List.map (fun (v,vt) -> v, Types.var vt) vars_mapping)
        in
Pietro Abate's avatar
Pietro Abate committed
556
        let al =
557
          let a = Array.make (List.length pl) (Var.mk "dummy") in
558
          List.iteri (fun i (_,v) -> a.(i) <- v) vars_mapping;
Pietro Abate's avatar
Pietro Abate committed
559
          a
560
        in
561
        (v',t_rhs,al)
562
      ) (List.rev b) (List.rev b')
Pietro Abate's avatar
Pietro Abate committed
563
    in
564
565
566
    List.iter (fun (v,t,al) ->
      Types.Print.register_global ("",v,Array.map Types.var al) t
    ) b;
567
    enter_types b env
568

569
570
571
572
  let type_defs env b =
    try type_defs env b
    with exn -> clean_on_err (); raise exn

573
  let typ env t =
574
    try
575
      let d = derec (penv env) t in
576
577
578
579
      check_no_fv t.loc d;
      try typ_node d
      with Patterns.Error s -> raise_loc_generic t.loc s
    with exn -> clean_on_err (); raise exn
580

581
  let pat env t =
582
583
584
585
586
    try
      let d = derec (penv env) t in
      try pat_node d
      with Patterns.Error s -> raise_loc_generic t.loc s
    with exn -> clean_on_err (); raise exn
587

588
end
589
590
591
592
593
594

let typ = IType.typ
let pat = IType.pat
let type_defs = IType.type_defs

let dump_types ppf env =
595
  Env.iter (fun v ->
596
597
598
    function
  (Type _) -> Format.fprintf ppf " %a" Ident.print v
    | _ -> ()) env.ids
599
600
601
602
603
604

let dump_ns ppf env =
  Ns.dump_table ppf env.ns



605

606
607
(* II. Build skeleton *)

608

609
type type_fun = Types.t -> bool -> Types.t
610

611
module Fv = IdSet
612

613
614
615
type branch = Branch of Typed.branch * branch list

let cur_branch : branch list ref = ref []
616

617
let exp' loc e =
Pietro Abate's avatar
Pietro Abate committed
618
619
620
621
  { Typed.exp_loc = loc;
    Typed.exp_typ = Types.empty;
    Typed.exp_descr = e
  }
622
623
624
625
626

let exp loc fv e = fv, exp' loc e

let exp_nil = exp' noloc (Typed.Cst Sequence.nil_cst)

627
let pat_true =
628
629
630
631
  let n = Patterns.make Fv.empty in
  Patterns.define n (Patterns.constr Builtin_defs.true_type);
  n

632
let pat_false =
633
634
635
636
  let n = Patterns.make Fv.empty in
  Patterns.define n (Patterns.constr Builtin_defs.false_type);
  n

637
let ops = Hashtbl.create 13
638
639
let register_op op arity f = Hashtbl.add ops op (arity,f)
let typ_op op = snd (Hashtbl.find ops op)
640

641
642
let fun_name env a =
  match a.fun_name with
643
644
  | None -> None
  | Some (loc,s) -> Some (ident env loc s)
645

646
647
let count_arg_name = ref 0
let fresh_arg_name () =
648
649
  incr count_arg_name;
  "__abstr_arg" ^ (string_of_int !count_arg_name)
650

651
let is_op env s =
652
653
  if (Env.mem s env.ids) then None
  else
654
655
    let (ns,s) = s in
    if Ns.Uri.equal ns Ns.empty then
656
      let s = U.get_str s in
657
      try
658
659
660
661
	let o = Hashtbl.find ops s in
	Some (s, fst o)
      with Not_found -> None
    else None
662

663
664
let rec expr env loc = function
  | LocatedExpr (loc,e) -> expr env loc e
665
  | Forget (e,t) ->
666
667
    let (fv,e) = expr env loc e and t = typ env t in
    exp loc fv (Typed.Forget (e,t))
668
  | Check (e,t) ->
669
670
    let (fv,e) = expr env loc e and t = typ env t in
    exp loc fv (Typed.Check (ref Types.empty,e,t))
671
  | Var s -> var env loc s
672
  | Apply (e1,e2) ->
673
674
675
676
677
678
679
    let (fv1,e1) = expr env loc e1 and (fv2,e2) = expr env loc e2 in
    let fv = Fv.cup fv1 fv2 in
    (match e1.Typed.exp_descr with
    | Typed.Op (op,arity,args) when arity > 0 ->
      exp loc fv (Typed.Op (op,arity - 1,args @ [e2]))
    | _ ->
      exp loc fv (Typed.Apply (e1,e2)))
680
  | Abstraction a -> abstraction env loc a
681
  | (Integer _ | Char _ | Atom _ | Const _ ) as c ->
682
    exp loc Fv.empty (Typed.Cst (const env loc c))
683
  | Pair (e1,e2) ->
684
685
    let (fv1,e1) = expr env loc e1 and (fv2,e2) = expr env loc e2 in
    exp loc (Fv.cup fv1 fv2) (Typed.Pair (e1,e2))
686
  | Xml (e1,e2) ->
687
688
689
    let (fv1,e1) = expr env loc e1 and (fv2,e2) = expr env loc e2 in
    let n = if env.keep_ns then Some env.ns else None in
    exp loc (Fv.cup fv1 fv2) (Typed.Xml (e1,e2,n))
690
  | Dot _ as e ->
691
    dot loc env e []
692
  | TyArgs (Dot _ as e, args) ->
693
    dot loc env e args
694
  | TyArgs _ ->
695
    error loc "Only OCaml external can have type arguments"
696
  | RemoveField (e,l) ->
697
698
    let (fv,e) = expr env loc e in
    exp loc fv (Typed.RemoveField (e,parse_label env loc l))
699
  | RecordLitt r ->
700
701
702
703
704
705
706
    let fv = ref Fv.empty in
    let r = parse_record env loc
      (fun e ->
	let (fv2,e) = expr env loc e
	in fv := Fv.cup !fv fv2; e)
      r in
    exp loc !fv (Typed.RecordLitt r)
707
  | String (i,j,s,e) ->
708
709
    let (fv,e) = expr env loc e in
    exp loc fv (Typed.String (i,j,s,e))
710
  | Match (e,b) ->
711
712
713
    let (fv1,e) = expr env loc e
    and (fv2,b) = branches env b in
    exp loc (Fv.cup fv1 fv2) (Typed.Match (e, b))
714
  | Map (e,b) ->
715
716
717
    let (fv1,e) = expr env loc e
    and (fv2,b) = branches env b in
    exp loc (Fv.cup fv1 fv2) (Typed.Map (e, b))
718
  | Transform (e,b) ->
719
720
721
    let (fv1,e) = expr env loc e
    and (fv2,b) = branches env b in
    exp loc (Fv.cup fv1 fv2) (Typed.Transform (e, b))
722
  | Xtrans (e,b) ->
723
724
725
    let (fv1,e) = expr env loc e
    and (fv2,b) = branches env b in
    exp loc (Fv.cup fv1 fv2) (Typed.Xtrans (e, b))
726
  | Validate (e,ids) ->
727
728
729
    let (fv,e) = expr env loc e in
    let (t,v) = find_global_schema_component env loc ids  in
    exp loc fv (Typed.Validate (e, t, v))
730
  | SelectFW (e,from,where) ->
731
    select_from_where env loc e from where
732
  | Try (e,b) ->
733
734
735
    let (fv1,e) = expr env loc e
    and (fv2,b) = branches env b in
    exp loc (Fv.cup fv1 fv2) (Typed.Try (e, b))
736
  | NamespaceIn (pr,ns,e) ->
737
738
    let env = type_ns env loc pr ns in
    expr env loc e
739
  | KeepNsIn (k,e) ->
740
    expr (type_keep_ns env k) loc e
741
  | Ref (e,t) ->
742
743
    let (fv,e) = expr env loc e and t = typ env t in
    exp loc fv (Typed.Ref (e,t))
744
745
746
747
748
749
750

and if_then_else loc cond yes no =
  let b = {
    Typed.br_typ = Types.empty;
    Typed.br_branches = [
      { Typed.br_loc = yes.Typed.exp_loc;
	Typed.br_used = false;
751
	Typed.br_ghost = false;
752
	Typed.br_vars_empty = Fv.empty;
753
	Typed.br_vars_poly = IdMap.empty;
754
755
756
757
	Typed.br_pat = pat_true;
	Typed.br_body = yes };
      { Typed.br_loc = no.Typed.exp_loc;
	Typed.br_used = false;
758
	Typed.br_ghost = false;
759
	Typed.br_vars_empty = Fv.empty;
760
	Typed.br_vars_poly = IdMap.empty;
761
762
763
764
765
	Typed.br_pat = pat_false;
	Typed.br_body = no } ];
    Typed.br_accept = Builtin_defs.bool;
  } in
  exp' loc (Typed.Match (cond,b))
766
767


768
and dot loc env0 e args =
769
  let dot_access loc (fv,e) l =
770
771
772
773
774
775
776
777
    exp loc fv (Typed.Dot (e,parse_label env0 loc l)) in

  let no_args () =
    if args <> [] then
      error loc "Only OCaml externals can have type arguments" in
  let rec aux loc = function
    | LocatedExpr (loc,e) -> aux loc e
    | Dot (e,id) ->
778
779
780
      (match aux loc e with
      | `Val e -> `Val (dot_access loc e id)
      | `Comp c -> `Comp (navig loc env0 c id))
781
    | Var id ->
782
783
784
      (match find_id_comp env0 env0 loc id with
      | Val _ -> `Val (var env0 loc id)
      | c -> `Comp (env0,c))
785
786
787
    | e -> `Val (expr env0 loc e)
  in
  match aux loc e with
788
789
790
791
792
  | `Val e -> no_args (); e
  | `Comp (_,EVal (cu,id,t)) ->
    no_args (); exp loc Fv.empty (Typed.ExtVar (cu,id,t))
  | `Comp (_,EOCamlComponent s) -> extern loc env0 s args
  | _ -> error loc "This dot notation does not refer to a value"
793
794

and extern loc env s args =
795
796
  let args = List.map (typ env) args in
  try
797
798
799
800
801
802
    let (i,t) =
      if !has_static_external s then
	(`Builtin s, Externals.typ s args)
      else
	let (i,t) = Externals.resolve s args in
	(`Ext i, t) in
803
804
    exp loc Fv.empty (Typed.External (t,i))
  with exn -> raise_loc loc exn
805

806
and var env loc s =
807
808
  let id = ident env loc s in
  match is_op env id with
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
  | Some (s,arity) ->
    let e = match s with
      | "print_xml" | "print_xml_utf8" ->
	Typed.NsTable (env.ns,Typed.Op (s, arity, []))
      | "load_xml" when env.keep_ns ->
	Typed.Op ("!load_xml",arity,[])
      | _ -> Typed.Op (s, arity, [])
    in
    exp loc Fv.empty e
  | None ->
    try match Env.find id env.ids with
    | Val _ -> exp loc (Fv.singleton id) (Typed.Var id)
    | EVal (cu,id,t) -> exp loc Fv.empty (Typed.ExtVar (cu,id,t))
    | _ ->  error loc "This identifier does not refer to a value"
    with Not_found -> error loc "Unbound identifier"
824

825
and abstraction env loc a =
826
827
  let iface =
    List.map
828
829
      (fun (t1,t2) -> (typ env t1, typ env t2)) a.fun_iface
  in
830
831
832
  let t =
    List.fold_left
      (fun accu (t1,t2) -> Types.cap accu (Types.arrow t1 t2))
833
      Types.any iface in
834
835
836
  let iface =
    List.map
      (fun (t1,t2) -> (Types.descr t1, Types.descr t2))
837
      iface in
838
  let fun_name = fun_name env a in
839
840
  let env' =
    match fun_name with
841
842
    | None -> env
    | Some f -> enter_values_dummy [ f ] env
843
844
  in
  let (fv0,body) = branches env' a.fun_body in
845
  let fv = match fun_name with
846
847
    | None -> fv0
    | Some f -> Fv.remove f fv0 in
848
  let e = Typed.Abstraction
849
850
851
852
853
854
    { Typed.fun_name = fun_name;
      Typed.fun_iface = iface;
      Typed.fun_body = body;
      Typed.fun_typ = t;
      Typed.fun_fv = fv
    } in
855
  exp loc fv e
856
857

and branches env b =
858
859
  let fv = ref Fv.empty in
  let accept = ref Types.empty in
860
  let branch (p,e) =
861
862
    let cur_br = !cur_branch in
    cur_branch := [];
863
864
865
866
867
    let ploc = p.loc in
    let p = pat env p in
    let fvp = Patterns.fv p in
    let (fv2,e) = expr (enter_values_dummy fvp env) noloc e in
    let br_loc = merge_loc ploc e.Typed.exp_loc in
868
    (match Fv.pick (Fv.diff fvp fv2) with
869
870
871
872
873
874
    | None -> ()
    | Some x ->
      let x = Ident.to_string x in
      warning br_loc
	("The capture variable " ^ x ^
	    " is declared in the pattern but not used in the body of this branch." ^
Pietro Abate's avatar
Pietro Abate committed
875
            " It might be a misspelled or undeclared type or name (if it isn't, use _ instead)."));
876
877
    let fv2 = Fv.diff fv2 fvp in
    fv := Fv.cup !fv fv2;
878
879
880
881
    let p_accept = Types.descr (Patterns.accept p) in
    if not (Var.Set.is_empty (Types.all_vars p_accept)) then
      error br_loc "Type variables cannot occur in patterns";
    accept := Types.cup !accept p_accept;
882
    let ghost = br_loc == noloc in
883
884
    let br =
      {
885
	Typed.br_loc = br_loc;
886
887
	Typed.br_used = ghost;
	Typed.br_ghost = ghost;
888
	Typed.br_vars_empty = fvp;
889
	Typed.br_vars_poly = IdMap.empty;
890
	Typed.br_pat = p;
891
892
893
894
	Typed.br_body = e } in
    cur_branch := Branch (br, !cur_branch) :: cur_br;
    br in
  let b = List.map branch b in
895
896
897
898
  (!fv,
   {
     Typed.br_typ = Types.empty;
     Typed.br_branches = b;
899
     Typed.br_accept = !accept;
900
   }
901
  )
902

903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
and select_from_where env loc e from where =
  let env = ref env in
  let all_fv = ref Fv.empty in
  let bound_fv = ref Fv.empty in
  let clause (p,e) =
    let ploc = p.loc in
    let p = pat !env p in
    let fvp = Patterns.fv p in
    let (fv2,e) = expr !env noloc e in
    env := enter_values_dummy fvp !env;
    all_fv := Fv.cup (Fv.diff fv2 !bound_fv) !all_fv;
    bound_fv := Fv.cup fvp !bound_fv;
    (ploc,p,fvp,e) in
  let from = List.map clause from in
  let where = List.map (expr !env noloc) where in

919
  let put_cond rest (fv,cond) =
920
921
    all_fv := Fv.cup (Fv.diff fv !bound_fv) !all_fv;
    if_then_else loc cond rest exp_nil in
922
  let aux (ploc,p,fvp,e) (where,rest) =
923
924
925
926
927
    (* Put here the conditions that depends on variables in fvp *)
    let (above,here) = List.partition (fun (v,_) -> Fv.disjoint v fvp) where in
    (* if cond then ... else [] *)
    let rest = List.fold_left put_cond rest here in
    (* transform e with p -> ... *)
928
    let br = { Typed.br_loc = ploc;
929
930
931
932
933
934
	       Typed.br_used = false;
	       Typed.br_ghost = false;
	       Typed.br_vars_empty = fvp;
               Typed.br_vars_poly = IdMap.empty;
	       Typed.br_pat = p;
	       Typed.br_body = rest } in
935
936
937
938
    cur_branch := [ Branch (br, !cur_branch) ];
    let b = {
      Typed.br_typ = Types.empty;
      Typed.br_branches = [ br ];
939
940
941
942
943
      Typed.br_accept = Types.descr (Patterns.