[r2005-03-06 18:26:47 by afrisch] Concatenation in types

Original author: afrisch
Date: 2005-03-06 18:26:47+00:00

CHANGES

@@ -26,6 +26,7 @@ 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
 
 - Tools:
    * A new tool cduce_mktop produces customized CDuce toplevels with embedded 

parser/ast.ml

@@ -112,6 +112,7 @@ and ppat' =
   | Record of bool * (label * (ppat * ppat option)) list
   | Constant of U.t * pexpr
   | Regexp of regexp
+  | Concat of ppat * ppat
 
 and regexp =
   | Epsilon

parser/parser.ml

@@ -553,7 +553,8 @@ EXTEND
         b = LIST1 [ (la,a) = located_ident; "="; y = pat -> 
 		      (la,a,y) ] SEP "and"
             -> mk loc (Recurs (x,b)) ]
-    | RIGHTA [ x = pat; "->"; y = pat -> mk loc (Arrow (x,y)) ]
+    | RIGHTA [ x = pat; "->"; y = pat -> mk loc (Arrow (x,y))
+             | x = pat; "@"; y = pat -> mk loc (Concat (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

@@ -281,6 +281,7 @@ module IType = struct
     | IRecord of bool * (node * node option) label_map
     | ICapture of id
     | IConstant of id * Types.const
+    | IConcat of node * node
 
   let rec node_temp = { 
     desc = ILink node_temp;
@@ -309,6 +310,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
 
   let hash0 = hash (fun n -> 1)
   let hash1 = hash hash0
@@ -524,6 +526,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
   and compute_typ_field = function
     | (s, None) -> typ_node s
     | (s, Some _) -> 
@@ -583,7 +586,7 @@ module IType = struct
     | IConstant (x,c) -> Patterns.constant x c
     | IArrow _ ->
 	raise (Patterns.Error "Arrows are not allowed in patterns")
-    | IType _ | ILink _ -> assert false
+    | IType _ | ILink _ | IConcat _ -> assert false
       
   and pat_node n =
     let n = repr n in
@@ -606,6 +609,8 @@ module IType = struct
 
   let penv tenv = { penv_tenv = tenv; penv_derec = Env.empty }
 
+  let concats = ref []
+
   let mk d = { node_temp with desc = d }
   let mk_delayed () = { node_temp with desc = ILink node_temp }
   let itype t = mk (IType (t, Types.hash t))
@@ -760,17 +765,11 @@ module IType = struct
     let l = !all_delayed in
     all_delayed := []; 
     List.iter check_one_delayed l
+
     
   let rec derecurs env p = match p.descr with
     | PatVar (cu,v) -> derecurs_var env p.loc cu v
-(*
-    | SchemaVar (kind, schema_name, component_name) ->
-
-	let name = qname env.penv_tenv  p.loc component_name in
-	itype (find_schema_descr env.penv_tenv kind schema_name name)
-*)
-
-    | Recurs (p,b) -> derecurs (derecurs_def env b) p
+    | Recurs (p,b) -> derecurs (fst (derecurs_def env b)) p
     | Internal t -> itype t
     | NsT ns -> 
 	itype (Types.atom (Atoms.any_in_ns (parse_ns env.penv_tenv p.loc ns)))
@@ -792,6 +791,10 @@ module IType = struct
     | Regexp r ->
 	let r,_ = derecurs_regexp IdSet.empty false IdSet.empty true env r in
 	rexp r
+    | Concat (p1,p2) -> 
+	let n = mk (IConcat (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
@@ -869,10 +872,74 @@ module IType = struct
       List.fold_left (fun env (v,p,s) -> Env.add v s env) env.penv_derec b in
     let env = { env with penv_derec = n } in
     List.iter (fun (v,p,s) -> s.desc <- ILink (derecurs env p)) b;
-    env
+    (env, b)
+
+  module H = Hashtbl.Make(Types)
+
+  let rec elim_concat n =
+    match n.desc with
+      | IConcat (a,b) ->
+	  if (n.sid > 0) then 	
+	    raise (Patterns.Error "Ill-formed concatenation loop");
+	  n.sid <- 1;
+	  n.desc <- ILink (elim_conc a b)
+      | _ -> ()
+  and elim_conc n q =
+    let mem = ref [] in
+    let rec aux n =
+      try List.assq n !mem
+      with Not_found ->
+	let r = mk_delayed () in
+	mem := (n,r) :: !mem;
+	let rec aux2 n =
+	  let m = 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
+	in
+	r.desc <- ILink (aux2 n);
+	r
+    in
+    aux n
+  and elim_concat_type t q =
+    if not (Types.subtype t Sequence.any) then
+      raise (Patterns.Error "Left argument of concatenation is not a sequence type");
+    (* TODO: check t <= [ Any* ] *)
+    let mem = H.create 17 in
+    let rec aux t =
+      try H.find mem t 
+      with Not_found ->
+	let n = mk_delayed () in
+	H.add mem t n;
+	let d = 
+	  List.fold_left
+	    (fun accu (t1,t2) -> ior accu (mk (ITimes (itype t1, aux t2))))
+	    (if Types.Atom.has_atom t Sequence.nil_atom then q else iempty)
+	    (Types.Product.get t) in
+	n.desc <- d.desc;
+	n
+    in
+    aux t
+    
+   
+    
+  let elim_concats () =
+    try
+      List.iter elim_concat !concats;
+      List.iter (fun n -> n.sid <- 0) !concats;
+      concats := []
+    with exn ->
+      List.iter (fun n -> n.sid <- 0) !concats;
+      concats := [];
+      raise exn
 
   let derec penv p =
     let d = derecurs penv p in
+    elim_concats ();
     check_delayed ();
     internalize d;
     d
@@ -882,22 +949,24 @@ module IType = struct
 
   module Ids = Set.Make(Id)
   let type_defs env b =
-    let penv = derecurs_def (penv env) b in
-    let aux t =
-      let d = derec penv t in
-      check_no_fv t.loc d;
+    let _,b' = derecurs_def (penv env) b in
+    elim_concats ();
+    check_delayed ();
+    let aux loc d =
+      internalize d;
+      check_no_fv loc d;
       try typ d
-      with Patterns.Error s -> raise_loc_generic t.loc s
+      with Patterns.Error s -> raise_loc_generic loc s
     in
     let b = 
-      List.map 
-	(fun (loc,v,p) ->
-	   let t = aux p in
+      List.map2 
+	(fun (loc,v,p) (v',_,d) ->
+	   let t = aux loc d in
 	   if (loc <> noloc) && (Types.is_empty t) then
 	     warning loc 
 	       ("This definition yields an empty type for " ^ (U.to_string v));
 	   let v = ident env loc v in
-	   (v,t)) b in
+	   (v',t)) b b' in
     List.iter (fun (v,t) -> Types.Print.register_global 
 		 (Types.CompUnit.get_current ()) (Id.value v) t) b;
     b