[r2005-03-06 19:02:15 by afrisch] Record concatenation in types

Original author: afrisch
Date: 2005-03-06 19:02:15+00:00

CHANGES

@@ -26,7 +26,8 @@ Since 0.2.2
       - the ";" between fields is optional even for records 
         (used to be optional only for attributes)
    * Keywords are now allowed as type names
-   * Concatenatiom @ allowed in types
+   * Concatenation @ allowed in types
+   * Record concatenation + allowed in types
 
 - Tools:
    * A new tool cduce_mktop produces customized CDuce toplevels with embedded 

parser/ast.ml

@@ -113,6 +113,7 @@ and ppat' =
   | Constant of U.t * pexpr
   | Regexp of regexp
   | Concat of ppat * ppat
+  | Merge of ppat * ppat
 
 and regexp =
   | Epsilon

parser/parser.ml

@@ -554,7 +554,8 @@ EXTEND
 		      (la,a,y) ] SEP "and"
             -> mk loc (Recurs (x,b)) ]
     | RIGHTA [ x = pat; "->"; y = pat -> mk loc (Arrow (x,y))
-             | x = pat; "@"; y = pat -> mk loc (Concat (x,y)) ]
+             | x = pat; "@"; y = pat -> mk loc (Concat (x,y))
+             | x = pat; "+"; y = pat -> mk loc (Merge (x,y)) ]
     | "no_arrow" [ x = pat; "|"; y = pat -> mk loc (Or (x,y)) ] 
     | "simple" [ x = pat; "&"; y = pat -> mk loc (And (x,y)) 
 	       | x = pat; "\\"; y = pat -> mk loc (Diff (x,y)) ]

typing/typer.ml

@@ -282,6 +282,7 @@ module IType = struct
     | ICapture of id
     | IConstant of id * Types.const
     | IConcat of node * node
+    | IMerge of node * node
 
   let rec node_temp = { 
     desc = ILink node_temp;
@@ -310,7 +311,7 @@ module IType = struct
 	257*(LabelMap.hash (hash_field f) r)
     | ICapture x -> 10 + 17 * (Id.hash x)
     | IConstant (x,c) -> 11 + 17 * (Id.hash x) + 257*(Types.Const.hash c)
-    | IConcat (p1,p2) -> assert false
+    | IConcat _ | IMerge _ -> assert false
 
   let hash0 = hash (fun n -> 1)
   let hash1 = hash hash0
@@ -526,7 +527,7 @@ module IType = struct
     | IRecord (o,r) ->  Types.record' (o, LabelMap.map compute_typ_field r)
     | ILink _ -> assert false
     | ICapture _ | IConstant (_,_) -> assert false
-    | IConcat _ -> assert false
+    | IConcat _ | IMerge _ -> assert false
   and compute_typ_field = function
     | (s, None) -> typ_node s
     | (s, Some _) -> 
@@ -586,7 +587,7 @@ module IType = struct
     | IConstant (x,c) -> Patterns.constant x c
     | IArrow _ ->
 	raise (Patterns.Error "Arrows are not allowed in patterns")
-    | IType _ | ILink _ | IConcat _ -> assert false
+    | IType _ | ILink _ | IConcat _ | IMerge _ -> assert false
       
   and pat_node n =
     let n = repr n in
@@ -795,6 +796,10 @@ module IType = struct
 	let n = mk (IConcat (derecurs env p1, derecurs env p2)) in
 	concats := n :: !concats;
 	n
+    | Merge (p1,p2) -> 
+	let n = mk (IMerge (derecurs env p1, derecurs env p2)) in
+	concats := n :: !concats;
+	n
 	  
   and derecurs_regexp vars b rvars f env = function
       (* - vars: seq variables to be propagated top-down and added
@@ -879,11 +884,62 @@ module IType = struct
   let rec elim_concat n =
     match n.desc with
       | IConcat (a,b) ->
-	  if (n.sid > 0) then 	
-	    raise (Patterns.Error "Ill-formed concatenation loop");
+	  if (n.sid > 0) 
+	  then 	raise (Patterns.Error "Ill-formed concatenation loop");
 	  n.sid <- 1;
 	  n.desc <- ILink (elim_conc a b)
+      | IMerge (a,b) ->
+	  if (n.sid > 0) 
+	  then 	raise (Patterns.Error "Ill-formed concatenation loop");
+	  n.sid <- 1;
+	  n.desc <- ILink (elim_merge a b)
       | _ -> ()
+  and elim_merge a b =
+    let get_rec t =
+      let t = Types.Record.get t in
+      List.map (fun (l,o,_) ->
+		  o, 
+		  LabelMap.map 
+		    (fun (opt,x) ->
+		       let x = itype x in 
+		       (if opt then mk (IOptional x) else x),
+		       None)
+		    l) t in
+    let merge (o1,l1) (o2,l2) =
+      mk (IRecord (o1||o2, LabelMap.merge (fun _ x -> x) l1 l2)) in
+    (* Problem: repr can loop with ill-formed recursion.
+       type t = s + t where s = s | s;; *)
+    match (repr a).desc, (repr b).desc with
+      | IType (t1,_), IType (t2,_) -> 
+	  if not (Types.subtype t1 Types.Record.any) then
+	    raise 
+	      (Patterns.Error 
+		 "Left argument of record concatenation is not a record type");
+	  if not (Types.subtype t2 Types.Record.any) then
+	    raise 
+	      (Patterns.Error 
+		 "Right argument of record concatenation is not a record type");
+	  itype (Types.Record.merge t1 t2)
+      | IOr (a1,a2), _ -> ior (elim_merge a1 b) (elim_merge a2 b)
+      | _, IOr (b1,b2) -> ior (elim_merge a b1) (elim_merge a b2)
+      | IRecord (o1,l1), IRecord (o2,l2) -> merge (o1,l1) (o2,l2)
+      | IType (t1,_), IRecord (o2,l2) ->
+	  if not (Types.subtype t1 Types.Record.any) then
+	    raise 
+	      (Patterns.Error 
+		 "Left argument of record concatenation is not a record type");
+	  List.fold_left (fun accu (o1,l1) -> 
+			    ior accu (merge (o1,l1) (o2,l2)))
+	    iempty (get_rec t1)
+      | IRecord (o1,l1), IType (t2,_) ->
+	  if not (Types.subtype t2 Types.Record.any) then
+	    raise 
+	      (Patterns.Error 
+		 "Right argument of record concatenation is not a record type");
+	  List.fold_left (fun accu (o2,l2) -> 
+			    ior accu (merge (o1,l1) (o2,l2)))
+	    iempty (get_rec t2)
+      | _ -> raise (Patterns.Error "Cannot compute record concatenation")
   and elim_conc n q =
     let mem = ref [] in
     let rec aux n =
@@ -892,14 +948,13 @@ module IType = struct
 	let r = mk_delayed () in
 	mem := (n,r) :: !mem;
 	let rec aux2 n =
-	  let m = match n.desc with
+	  match n.desc with
 	    | ILink n' -> aux2 n'
 	    | IOr (a,b) -> ior (aux a) (aux b)
 	    | ITimes (a,b) -> mk (ITimes (a, aux b))
 	    | IConcat (a,b) -> elim_concat n; aux2 n
 	    | IType (t,_) -> elim_concat_type t q
-	    | _ -> assert false in
-	  m
+	    | _ -> raise (Patterns.Error "Cannot compute concatenation")
 	in
 	r.desc <- ILink (aux2 n);
 	r