- experimental support for cdata sections

runtime/print_xml.ml

@@ -66,9 +66,13 @@ let false_literal = U.mk "false"
 
   (* @raise exn_print_xml in case of failure. Rationale: schema printing is
    * the last attempt to print a value, others have already failed *)
-let rec schema_value ?(recurs=true) ~wds v = match v with
-  | Abstract ("float",f) ->
-      wds (U.mk (string_of_float (Obj.magic f : float)))
+let rec schema_value ?(recurs=true) ~wds ~wcs v = match v with
+  | Abstract ("float",o) ->
+      wds (U.mk (string_of_float (Obj.magic o : float)))
+  | Abstract ("cdata",o) ->
+      wcs (U.mk "<![CDATA[");
+      wcs (U.mk (U.get_str (Obj.magic o : U.t)));
+      wcs (U.mk "]]>")
   | Record _ as v ->
       (try
         wds (Schema_builtin.string_of_time_type (Value.get_fields v))
@@ -76,18 +80,18 @@ let rec schema_value ?(recurs=true) ~wds v = match v with
   | Integer i -> wds (U.mk (Intervals.V.to_string i))
   | v when Value.equal v Value.vtrue -> wds true_literal
   | v when Value.equal v Value.vfalse -> wds false_literal
-  | Pair _ as v when recurs -> schema_values ~wds v
+  | Pair _ as v when recurs -> schema_values ~wds ~wcs v
   | String_utf8 _ | String_latin1 _ as v -> wds (fst (get_string_utf8 v))
   | _ -> raise exn_print_xml
 
-and schema_values ~wds v =
+and schema_values ~wds ~wcs v =
   match v with
   | Pair (hd, Atom a) when a = Sequence.nil_atom ->
-      schema_value ~recurs:false ~wds hd
+      schema_value ~recurs:false ~wds ~wcs hd
   | Pair (hd, tl) ->
-      schema_value ~recurs:false ~wds hd;
+      schema_value ~recurs:false ~wds ~wcs hd;
       wds blank;
-      schema_values ~wds tl
+      schema_values ~wds ~wcs tl
   | _ -> raise exn_print_xml
 
 let to_buf ~utf8 buffer ns_table v = 
@@ -97,6 +101,7 @@ let to_buf ~utf8 buffer ns_table v =
 
   let wms = write_markup_string ~to_enc buffer
   and wds s = write_data_string ~to_enc buffer (U.get_str s)
+  and wcs s = buffer (U.get_str s) in
   in
   let write_att (n,v) =
     wms (" " ^ (Ns.Printer.attr printer (Label.value n)) ^ "=\""); wds v; wms "\"" in
@@ -160,7 +165,7 @@ let to_buf ~utf8 buffer ns_table v =
                          end else begin
                            let buf = Buffer.create 20 in
                            let wds s = Buffer.add_string buf (U.get_str s) in
-                           schema_value ~wds v;
+                           schema_value ~wds ~wcs:wds v;
                            (Label.from_int n, U.mk (Buffer.contents buf))
                          end
 		      ) attrs in
@@ -177,7 +182,7 @@ let to_buf ~utf8 buffer ns_table v =
     match q with
       | Pair ((Xml _ | XmlNs _) as x, q) -> print_elt [] x; print_content q
       | Atom a when a = Sequence.nil_atom -> ()
-      | v -> schema_value ~wds v
+      | v -> schema_value ~wds ~wcs v
   in
   document_start ();
   print_elt (Ns.Printer.prefixes printer) v

runtime/value.ml

@@ -284,6 +284,11 @@ let rec print ppf v =
 	Format.fprintf ppf "<concat:%a;%a>" print x print y
     | Abstract ("float",o) ->
 	Format.fprintf ppf "%f" (Obj.magic o : float)
+    | Abstract ("cdata",o) ->
+        let s = Utf8.get_str (Obj.magic o : Utf8.t) in
+        Format.fprintf ppf "'%s'" s
+        (* Format.fprintf ppf "%s" (Utf8.get_str (Obj.magic o :
+            * Encodings.Utf8.t)) *)
     | Abstract (s,_) ->
 	Format.fprintf ppf "<abstract=%s>" s
     | Absent -> 	
@@ -417,8 +422,12 @@ let rec compare x y =
 	  raise (CDuceExn (string_latin1 "comparing functional values"))
       | Abstract (s1,v1), Abstract (s2,v2) ->
 	  let c = Types.Abstract.T.compare s1 s2 in if c <> 0 then c 
-	  else Pervasives.compare (Obj.magic v1 : float) (Obj.magic v2 : float)
-	    (* raise (CDuceExn (string_latin1 "comparing abstract values")) *)
+	  else begin
+              match s1 with
+              |"float" -> Pervasives.compare (Obj.magic v1 : float) (Obj.magic v2 : float)
+              |"cdata" -> Pervasives.compare (Obj.magic v1 : Encodings.Utf8.t) (Obj.magic v2 : Encodings.Utf8.t)
+              |_ -> raise (CDuceExn (string_latin1 "comparing abstract values"))
+          end
       | Absent,_ | _,Absent ->
 	  Format.fprintf Format.std_formatter
 	    "ERR: Compare %a %a@." print x print y;
@@ -713,6 +722,9 @@ let print_utf8 v =
 let float n =
   Abstract ("float", Obj.repr n)
 
+let cdata n =
+  Abstract ("cdata", Obj.repr n)
+
 let cduce2ocaml_option f v =
   match normalize v with
     | Pair (x,y) -> Some (f x)

runtime/value.mli

@@ -83,6 +83,7 @@ val flatten : t -> t
 val append : t -> t -> t
 
 val float: float -> t
+val cdata: string -> t
 
 val get_string_latin1 : t -> string
 val get_string_utf8 : t -> U.t * t

types/builtin.ml

@@ -116,6 +116,12 @@ let exn_namespaces = lazy (
       Value.string_latin1 "namespaces"))
 )
 
+let exn_cdata_of = lazy (
+  Value.CDuceExn (
+    Value.Pair (
+      Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
+      Value.string_latin1 "cdata_of"))
+)
 
 let eval_load_file ~utf8 e =
   Cduce_loc.protect_op "load_file";
@@ -439,3 +445,11 @@ register_fun "float_of" string float
      let (s,_) = Value.get_string_utf8 v in
      try Value.float (float_of_string (U.get_str s))
      with Failure _ -> raise (Lazy.force exn_float_of));;
+
+(* cdata *)
+
+register_fun "cdata_of" string string
+  (fun v ->
+     let (s,_) = Value.get_string_utf8 v in
+     try Value.cdata (U.get_str s)
+     with Failure _ -> raise (Lazy.force exn_cdata_of));;