[r2004-12-25 20:39:15 by afrisch] Default values for record fields

Original author: afrisch
Date: 2004-12-25 20:39:15+00:00

parser/ast.ml

@@ -106,7 +106,7 @@ and ppat' =
   | XmlT of ppat * ppat
   | Arrow of ppat * ppat
   | Optional of ppat
-  | Record of bool * (label * ppat) list
+  | Record of bool * (label * (ppat * ppat option)) list
   | Constant of id * pexpr
   | Regexp of regexp * ppat
       (* regular expression, continuation: [ re ; cont ], e.g: [ re ; nil ] *)

parser/parser.ml

@@ -506,8 +506,9 @@ EXTEND
       | "{|"; r = record_spec; "|}" -> mk loc (Record (false,r))
       | "ref"; p = pat ->
 	  let get_fun = mk loc (Arrow (pat_nil, p)) 
-	  and set_fun = mk loc (Arrow (p, pat_nil)) in
-	  let fields = [ label "get", get_fun; label "set", set_fun ] in
+	  and set_fun = mk loc (Arrow (p, pat_nil))in
+	  let fields = 
+	    [ label "get", (get_fun, None); label "set", (set_fun, None) ] in
 	  mk loc (Record (false, fields))
       | IDENT "_" -> mk loc (Internal Types.any)
       | "("; a = IDENT; ":="; c = expr; ")" -> 
@@ -562,12 +563,14 @@ EXTEND
     
   ];
 
+  or_else : [ [ OPT [ "else"; y = pat -> y ]  ] ];
+
   record_spec:
     [ [ r = LIST0 [ l = [IDENT | keyword ]; "=";
                   o = [ "?" -> true | -> false]; 
-                  x = pat -> 
+                  x = pat;  y = or_else ->
 		    let x = if o then mk loc (Optional x) else x in
-		    (label l, x)
+		    (label l, (x,y))
                 ] SEP ";" ->
 	  r
       ] ];
@@ -581,9 +584,9 @@ EXTEND
   attrib_spec:
     [ [ r = LIST0 [ l = [IDENT | keyword ]; "=";
                   o = [ "?" -> true | -> false]; 
-                  x = pat; OPT ";" -> 
+		  x = pat; y = or_else; OPT ";" -> 
 		    let x = if o then mk loc (Optional x) else x in
-		    (label l, x)
+		    (label l, (x, y))
                 ] ->
 	  mk loc (Record (true,r)) 
       | "("; t = pat; ")" -> t 

query/query.ml

@@ -111,10 +111,14 @@ let rec var_of_ppat x =
 	     |XmlT(p1,p2) -> var_of_ppat p1 @ var_of_ppat p2
 	     |Arrow(p1,p2) -> var_of_ppat p1 @ var_of_ppat p2
 	     |Optional(p1) -> var_of_ppat p1
-             |Record(b,lm) -> let rec listing l=(match l with 
-			     [] -> []
-			     |(s,ppat)::r -> var_of_ppat(ppat) @ listing r
-			     )in listing (lm)	      
+             |Record(b,lm) -> 
+		let rec aux accu (_,(ppat,e)) = 
+		  let accu = var_of_ppat ppat @ accu in
+		  match e with
+		    | None -> accu
+		    | Some ppat -> var_of_ppat ppat @ accu
+		in 
+		List.fold_left aux [] lm
 	     |Constant(i,t) -> [i]
 	     |Regexp(rg,p) -> var_of_rg rg @ var_of_ppat p
 	     

query/query_parse.ml

@@ -55,7 +55,8 @@ EXTEND
       a = [IDENT|keyword]-> (* projection sur 1 attribut *)
         let tag = mk loc (Internal(Types.atom Atoms.any)) in
         let any = mk loc (Internal(Types.any)) in
-        let att = mk loc (Record(true,[(label a,mk loc (PatVar(U.mk "$$$")))]))in
+        let att = mk loc (Record(true,[(label a,
+					(mk loc (PatVar(U.mk "$$$")),None))]))in
         (*let ct= mk loc (Regexp(Elem any , any)) in *)
         let p = mk loc(XmlT (tag,multi_prod loc[att;any])) in
         let t =(p, Pair(Var (Id.value id_dummy),cst_nil)) 

typing/typer.ml

@@ -285,7 +285,7 @@ type derecurs_slot = {
   | PXml of derecurs * derecurs
   | PArrow of derecurs * derecurs
   | POptional of derecurs
-  | PRecord of bool * derecurs label_map
+  | PRecord of bool * (derecurs * derecurs option) label_map
   | PCapture of id
   | PConstant of id * Types.const
   | PRegexp of derecurs_regexp * derecurs
@@ -311,7 +311,7 @@ type descr =
   | IXml of slot * slot
   | IArrow of slot * slot
   | IOptional of descr
-  | IRecord of bool * slot label_map
+  | IRecord of bool * (slot * descr option) label_map
   | ICapture of id
   | IConstant of id * Types.const
 and slot = {
@@ -361,13 +361,16 @@ let rec hash_derecurs = function
   | POptional p -> 
       8 + 17 * (hash_derecurs p)
   | PRecord (o,r) -> 
-      (if o then 9 else 10) + 17 * (LabelMap.hash hash_derecurs r)
+      (if o then 9 else 10) + 17 * (LabelMap.hash hash_derecurs_field r)
   | PCapture x -> 
       11 + 17 * (Id.hash x)
   | PConstant (x,c) -> 
       12 + 17 * (Id.hash x) + 257 * (Types.Const.hash c)
   | PRegexp (p,q) -> 
       13 + 17 * (hash_derecurs_regexp p) + 257 * (hash_derecurs q)
+and hash_derecurs_field = function
+  | (p, Some e) -> 1 + 17 * hash_derecurs p + 257 * hash_derecurs e
+  | (p, None) -> 2 + 17 * hash_derecurs p
 and hash_derecurs_regexp = function
   | PEpsilon -> 
       1
@@ -399,7 +402,7 @@ let rec equal_derecurs p1 p2 = (p1 == p2) || match p1,p2 with
   | POptional p1, POptional p2 -> 
       equal_derecurs p1 p2
   | PRecord (o1,r1), PRecord (o2,r2) -> 
-      (o1 == o2) && (LabelMap.equal equal_derecurs r1 r2)
+      (o1 == o2) && (LabelMap.equal equal_derecurs_field r1 r2)
   | PCapture x1, PCapture x2 -> 
       Id.equal x1 x2
   | PConstant (x1,c1), PConstant (x2,c2) -> 
@@ -407,6 +410,10 @@ let rec equal_derecurs p1 p2 = (p1 == p2) || match p1,p2 with
   | PRegexp (p1,q1), PRegexp (p2,q2) -> 
       (equal_derecurs_regexp p1 p2) && (equal_derecurs q1 q2)
   | _ -> false
+and equal_derecurs_field r1 r2 = match (r1,r2) with
+  | (p1,None),(p2,None) -> equal_derecurs p1 p2
+  | (p1, Some e1), (p2, Some e2) -> equal_derecurs p1 p2 && equal_derecurs e1 e2
+  | _ -> false
 and equal_derecurs_regexp r1 r2 = match r1,r2 with
   | PEpsilon, PEpsilon -> 
       true
@@ -453,9 +460,12 @@ let rec hash_descr = function
   | ITimes (s1,s2) -> 5 + 17 * (hash_slot s1) + 257 * (hash_slot s2)
   | IXml (s1,s2) -> 6 + 17 * (hash_slot s1) + 257 * (hash_slot s2)
   | IArrow (s1,s2) -> 7 + 17 * (hash_slot s1) + 257 * (hash_slot s2)
-  | IRecord (o,r) -> (if o then 8 else 9) + 17 * (LabelMap.hash hash_slot r)
+  | IRecord (o,r) -> (if o then 8 else 9) + 17 * (LabelMap.hash hash_descr_field r)
   | ICapture x -> 10 + 17 * (Id.hash x)
   | IConstant (x,y) -> 11 + 17 * (Id.hash x) + 257 * (Types.Const.hash y)
+and hash_descr_field = function
+  | (d, Some e) -> 1 + 17 * hash_slot d + 257 * hash_descr e
+  | (d, None) -> 2 + 17 * hash_slot d
 and hash_slot s =
   if s.gen1 = !gen then 13 * s.rank1
   else (
@@ -475,11 +485,15 @@ let rec equal_descr d1 d2 =
   | IXml (x1,y1), IXml (x2,y2) 
   | IArrow (x1,y1), IArrow (x2,y2) -> (equal_slot x1 x2) && (equal_slot y1 y2)
   | IRecord (o1,r1), IRecord (o2,r2) -> 
-      (o1 = o2) && (LabelMap.equal equal_slot r1 r2)
+      (o1 = o2) && (LabelMap.equal equal_descr_field r1 r2)
   | ICapture x1, ICapture x2 -> Id.equal x1 x2
   | IConstant (x1,y1), IConstant (x2,y2) -> 
       (Id.equal x1 x2) && (Types.Const.equal y1 y2)
   | _ -> false
+and equal_descr_field d1 d2 = match (d1,d2) with
+  | (d1,None),(d2,None) -> equal_slot d1 d2
+  | (d1, Some e1), (d2, Some e2) -> equal_slot d1 d2 && equal_descr e1 e2
+  | _ -> false
 and equal_slot s1 s2 =
   ((s1.gen1 = !gen) && (s2.gen2 = !gen) && (s1.rank1 = s2.rank2))
   ||
@@ -584,7 +598,11 @@ 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, parse_record env.penv_tenv p.loc (derecurs env) r)
+  | Record (o,r) -> 
+      let aux = function
+	| (p,Some e) -> (derecurs env p, Some (derecurs env e))
+	| (p,None) -> derecurs env p, None in
+      PRecord (o, parse_record env.penv_tenv p.loc aux r)
   | Constant (x,c) -> PConstant (x,const env.penv_tenv p.loc c)
   | Cst c -> PType (Types.constant (const env.penv_tenv p.loc c))
   | Regexp (r,q) -> 
@@ -657,8 +675,12 @@ and fv_descr = function
   | IXml (s1,s2)  
   | IArrow (s1,s2) -> IdSet.cup (fv_slot s1) (fv_slot s2)
   | IRecord (o,r) -> 
-      List.fold_left IdSet.cup IdSet.empty (LabelMap.map_to_list fv_slot r)
+      List.fold_left IdSet.cup IdSet.empty (LabelMap.map_to_list fv_field r)
   | ICapture x | IConstant (x,_) -> IdSet.singleton x
+and fv_field = function
+  | (d,Some e) -> IdSet.cup (fv_slot d) (fv_descr e)
+  | (d,None) -> fv_slot d
+
 
 let compute_fv s =
   match s.fv with
@@ -703,11 +725,15 @@ and real_compile = function
   | PXml (t1,t2) -> IXml (compile_slot t1, compile_slot t2)
   | PArrow (t1,t2) -> IArrow (compile_slot t1, compile_slot t2)
   | POptional t -> IOptional (compile t)
-  | PRecord (o,r) ->  IRecord (o, LabelMap.map compile_slot r)
+  | PRecord (o,r) ->  IRecord (o, LabelMap.map compile_field r)
   | PConstant (x,v) -> IConstant (x,v)
   | PCapture x -> ICapture x
   | PRegexp (r,q) -> compile (remove_regexp r q)
 
+and compile_field = function
+  | (p, Some e) -> (compile_slot p, Some (compile e))
+  | (p, None) -> (compile_slot p, None)
+
 and compile_slot p =
   try DerecursTable.find compile_slot_hash p
   with Not_found ->
@@ -743,9 +769,14 @@ let rec typ = function
   | IXml (s1,s2) -> Types.xml (typ_node s1) (typ_node s2)
   | IArrow (s1,s2) -> Types.arrow (typ_node s1) (typ_node s2)
   | IOptional s -> Types.Record.or_absent (typ s)
-  | IRecord (o,r) -> Types.record' (o, LabelMap.map typ_node r)
+  | IRecord (o,r) ->  Types.record' (o, LabelMap.map typ_field r)
   | IDummy | ICapture _ | IConstant (_,_) -> assert false
       
+and typ_field = function
+  | (s, None) -> typ_node s
+  | (s, Some _) -> 
+      raise (Patterns.Error "Or-else clauses are not allowed in types")
+
 and typ_node s : Types.Node.t =
   try SlotTable.find typ_nodes s
   with Not_found ->
@@ -774,11 +805,20 @@ and pat_aux = function
       raise (Patterns.Error "Optional fields are not allowed in record patterns")
   | IRecord (o,r) ->
       let pats = ref [] in
-      let aux l s = 
-	if IdSet.is_empty (fv_slot s) then typ_node s
-	else
-	  ( pats := Patterns.record l (pat_node s) :: !pats;
-	    Types.any_node )
+      let aux l = function
+	| (s,None) ->
+	    if IdSet.is_empty (fv_slot s) then typ_node s
+	    else
+	      ( pats := Patterns.record l (pat_node s) :: !pats;
+		Types.any_node )
+	| (s,Some e) ->
+	    if IdSet.is_empty (fv_slot s) then
+	      raise (Patterns.Error "Or-else clauses are not allowed in types")
+	    else
+	      ( pats := Patterns.cup 
+		  (Patterns.record l (pat_node s))
+		  (pat e) :: !pats;
+		Types.Record.any_or_absent_node )
       in
       let constr = Types.record' (o,LabelMap.mapi aux r) in
       List.fold_left Patterns.cap (Patterns.constr constr) !pats
@@ -1612,7 +1652,7 @@ module Schema_converter =
               | _ -> cd_type_of_simple_type ~schema at.attr_decl.attr_typdef
             in
             let r = if at.attr_required then r else POptional r in
-            (LabelPool.mk (Ns.empty, at.attr_decl.attr_name), r))
+            (LabelPool.mk (Ns.empty, at.attr_decl.attr_name), (r,None)))
           attr_uses in
       PRecord (false, LabelMap.from_list_disj fields)
 
@@ -1620,7 +1660,7 @@ module Schema_converter =
       let r = cd_type_of_simple_type ~schema att.attr_typdef in
       PRecord (false,
         LabelMap.from_list_disj
-          [(LabelPool.mk (schema.targetNamespace, att.attr_name), r)])
+          [(LabelPool.mk (schema.targetNamespace, att.attr_name), (r,None))])
 
     and cd_type_of_elt_decl ~schema elt =
       let atom_type =