[r2003-06-30 14:11:14 by cvscast] Namespaces in record fields

Original author: cvscast
Date: 2003-06-30 14:11:14+00:00

parser/ast.ml

@@ -49,7 +49,7 @@ and pexpr =
   | Cst of pconst
   | Pair of pexpr * pexpr
   | Xml of pexpr * pexpr
-  | RecordLitt of pexpr label_map
+  | RecordLitt of (label * pexpr) list
   | String of U.uindex * U.uindex * U.t * pexpr
       
   (* Data destructors *)
@@ -67,6 +67,8 @@ and pexpr =
   (* Other *)
   | NamespaceIn of U.t * Ns.t * pexpr
 
+and label = U.t
+
 and abstr = { 
   fun_name : id option; 
   fun_iface : (ppat * ppat) list;
@@ -93,7 +95,7 @@ and ppat' =
   | XmlT of ppat * ppat
   | Arrow of ppat * ppat
   | Optional of ppat
-  | Record of bool * ppat label_map
+  | Record of bool * (label * ppat) list
   | Capture of id
   | Constant of id * pconst
   | Regexp of regexp * ppat

parser/parser.ml

@@ -21,19 +21,8 @@ let parse_ident = U.mk_latin1
 
 let id_dummy = ident (U.mk "$$$")
 
-(*
-let split_qname s =
-  try
-    let i = String.index s ':' in
-    let ns = String.sub s 0 i in
-    let s = String.sub s (i + 1) (String.length s - i - 1) in
-    (parse_ident ns, parse_ident s)
-  with Not_found -> 
-    (U.mk "", parse_ident s)
-*)
-
 (* TODO: NS *)
-let label s = LabelPool.mk (Ns.empty, parse_ident s)
+let label = parse_ident
 let ident s = ident (parse_ident s)
 
 let prog    = Grammar.Entry.create gram "prog"
@@ -72,8 +61,6 @@ let seq_of_string s =
   in
   aux (Encodings.Utf8.start_index s) (Encodings.Utf8.end_index s)
 
-let make_record loc r =
-  LabelMap.from_list (fun _ _ -> error loc "Duplicated record field") r
 
 let parse_char loc s =
   match seq_of_string s with
@@ -286,7 +273,7 @@ EXTEND
 	a = expr_attrib_spec; ">"; c = expr ->
 (*	  let t = Pair (cst_nil, t) in *)
 	  exp loc (Xml (t, Pair (a,c)))
-    | "{"; r = [ expr_record_spec | -> exp loc (RecordLitt LabelMap.empty) ]; "}" -> r
+    | "{"; r = [ expr_record_spec | -> exp loc (RecordLitt []) ]; "}" -> r
     | s = STRING2 ->
 	let s = U.mk s in
 	exp loc (String (U.start_index s, U.end_index s, s, cst_nil))
@@ -500,7 +487,7 @@ EXTEND
 		    let x = if o then mk loc (Optional x) else x in
 		    (label l, x)
                 ] SEP ";" ->
-	  make_record loc r
+	  r
       ] ];
   
   char:
@@ -529,13 +516,13 @@ EXTEND
 	      [ l = [LIDENT | UIDENT | keyword ]; "="; x = expr -> 
 		  (label l,x) ] 
 	      SEP ";" ->
-	  exp loc (RecordLitt (make_record loc r))
+	  exp loc (RecordLitt r)
       ] ];
   
   expr_attrib_spec:
     [ [ r = expr_record_spec -> r ]
     | [ e = expr LEVEL "no_appl" -> e 
-      | -> exp loc (RecordLitt (LabelMap.empty)) 
+      | -> exp loc (RecordLitt []) 
       ] 
     ];
 END

typing/typer.ml

@@ -190,33 +190,32 @@ let mk_slot loc =
   incr counter; 
   { ploop = false; ploc = loc; pid = !counter; pdescr = None }
 
-(*
-let ns_from_prefix env loc ns =
-  try TypeEnv.find ns env.tenv_nspref
-  with Not_found -> 
-    raise_loc_generic loc 
-      ("Undefined namespace prefix " ^ (U.to_string ns))
-*)
-  
-let parse_atom env loc t =
-  try 
-    let (ns,l) = Ns.map_tag env.tenv_nspref t in
-    Atoms.mk ns l
+let protect_error_ns loc f x =
+  try f x
   with Ns.UnknownPrefix ns ->
     raise_loc_generic loc 
     ("Undefined namespace prefix " ^ (U.to_string ns))
 
-let parse_ns env loc ns =
-  try Ns.map_prefix env.tenv_nspref ns
-  with Ns.UnknownPrefix ns ->
-    raise_loc_generic loc 
-    ("Undefined namespace prefix " ^ (U.to_string ns))
+  
+let parse_atom env loc t =
+  let (ns,l) = protect_error_ns loc (Ns.map_tag env.tenv_nspref) t in
+  Atoms.mk ns l
  
+let parse_ns env loc ns =
+  protect_error_ns loc (Ns.map_prefix env.tenv_nspref) ns
 
 let const env loc = function
   | Const_internal c -> c
   | Const_atom t -> Types.Atom (parse_atom env loc t)
 
+let parse_label env loc t =
+  let (ns,l) = protect_error_ns loc (Ns.map_attr env.tenv_nspref) t in
+  LabelPool.mk (ns,l)
+
+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
+
 let rec derecurs env p = match p.descr with
   | PatVar v ->
       (try PAlias (TypeEnv.find v env.tenv_names)
@@ -263,7 +262,7 @@ let rec derecurs env p = match p.descr with
   | XmlT (p1,p2) -> PXml (derecurs env p1, derecurs env p2)
   | Arrow (p1,p2) -> PArrow (derecurs env p1, derecurs env p2)
   | Optional p -> POptional (derecurs env p)
-  | Record (o,r) -> PRecord (o, LabelMap.map (derecurs env) r)
+  | Record (o,r) -> PRecord (o, parse_record env p.loc (derecurs env) r)
   | Capture x -> PCapture x
   | Constant (x,c) -> PConstant (x,const env p.loc c)
   | Regexp (r,q) -> 
@@ -687,13 +686,13 @@ let rec expr glb loc = function
       exp loc (Fv.cup fv1 fv2) (Typed.Xml (e1,e2))
   | Dot (e,l) ->
       let (fv,e) = expr glb loc e in
-      exp loc fv (Typed.Dot (e,l))
+      exp loc fv (Typed.Dot (e,parse_label glb loc l))
   | RemoveField (e,l) ->
       let (fv,e) = expr glb loc e in
-      exp loc fv (Typed.RemoveField (e,l))
+      exp loc fv (Typed.RemoveField (e,parse_label glb loc l))
   | RecordLitt r -> 
       let fv = ref Fv.empty in
-      let r = LabelMap.map 
+      let r = parse_record glb loc
 		(fun e -> 
 		   let (fv2,e) = expr glb loc e 
 		   in fv := Fv.cup !fv fv2; e)