X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fuwobo%2Fuwobo_engine.ml;h=d7a1c4995025e6aa11ca4c3a1a2921374ed6f067;hb=03dee221bd1f2c9a6e7f74d9abf88be14aac7763;hp=aad4f971b8d8032bc712a447e8ea145f801837b7;hpb=47b0c2c1b421b62302b1957954912b4c0dfba9fa;p=helm.git

diff --git a/helm/uwobo/uwobo_engine.ml b/helm/uwobo/uwobo_engine.ml
index aad4f971b..d7a1c4995 100644
--- a/helm/uwobo/uwobo_engine.ml
+++ b/helm/uwobo/uwobo_engine.ml
@@ -88,11 +88,153 @@ let get_property name (document: Gdome.document) =
         Some (element#getAttribute domName)#to_string
       else
         None
+;;
+
+let namespaceURI = Some (Gdome.domString Uwobo_common.uwobo_namespace) ;;
+
+  (** output type wrt adding of debugging/error messages *)
+type outputType =
+  | XmlOutput of Gdome.node
+  | TextPlainOutput of Gdome.text
+  | NoOutput
+;;
+
+exception Found of int ;;
+
+  (** add debugging and/or error messages to a Gdome document. Handle three
+  distinct cases: (1) output contains an XML tree, (2) output contains only one
+  text node, (3) output contains no data.
+  If output contains an XML tree then users wishes are preserved and messages
+  are either not included or included as comments or included as XML ndoes.
+  If output contains only a text node comments are either not included or
+  included at the beginning of the textual output.
+  If output contains no data (i.e. DOM superroot node with no element or text
+  children) messages are embedded as XML comments or not embedded at all *)
+let add_msgs ~errormode ~debugmode ~msgs (doc: Gdome.document) =
+  let getOutputType (doc: Gdome.document) =
+    let children = doc#get_childNodes in
+    let len = children#get_length in
+    let rec find_element i =
+      if i > len then
+        raise Not_found
+      else
+        (match children#item i with
+        | Some node when node#get_nodeType = GdomeNodeTypeT.ELEMENT_NODE ->
+            XmlOutput node
+        | _ -> find_element (i + 1))
+    in
+    let rec find_text i =
+      if i > len then
+        raise Not_found
+      else
+        (match children#item i with
+        | Some node when node#get_nodeType = GdomeNodeTypeT.TEXT_NODE ->
+            TextPlainOutput (new Gdome.text_of_node node)
+        | _ -> find_element (i + 1))
+    in
+    if len = 0 then
+      NoOutput
+    else
+      (try find_element 0 with Not_found ->
+        (try find_text 0 with Not_found -> NoOutput))
+  in
+  match getOutputType (doc :> Gdome.document) with
+  | XmlOutput node ->
+    let add_generic_msg mode build tagname =
+      (match mode with
+      | LibXsltMsgIgnore -> (fun msg -> ())
+      | LibXsltMsgComment ->
+          (fun msg ->
+(*                 let contents = string_of_xslt_msg (build msg) ^ "<br />" in *)
+            let contents = string_of_xslt_msg (build msg) in
+            ignore (node#insertBefore
+              ~newChild:(doc#createComment
+                (Gdome.domString contents) :> Gdome.node)
+              ~refChild:node#get_firstChild))
+      | LibXsltMsgEmbed ->
+          (fun msg ->
+(*                 let contents = string_of_xslt_msg (build msg) ^ "<br />" in *)
+            let contents = string_of_xslt_msg (build msg) in
+            let element =
+              doc#createElementNS
+                ~namespaceURI ~qualifiedName:(Gdome.domString tagname)
+            in
+            ignore (element#appendChild
+              (doc#createTextNode
+                ~data:(Gdome.domString contents) :> Gdome.node));
+            ignore (node#insertBefore
+              ~newChild:(element :> Gdome.node)
+              ~refChild:node#get_firstChild)))
+    in
+    let add_error_msg =
+      add_generic_msg
+        errormode (fun msg -> LibXsltErrorMsg msg) "uwobo:error"
+    in
+    let add_debug_msg =
+      add_generic_msg
+        debugmode (fun msg -> LibXsltDebugMsg msg) "uwobo:debug"
+    in
+    List.iter
+      (function
+        | LibXsltErrorMsg msg -> add_error_msg msg
+        | LibXsltDebugMsg msg -> add_debug_msg msg)
+      (List.rev msgs) (* because each msg is added as 1st children *)
+| TextPlainOutput text ->
+    let add_generic_msg mode build =
+      (match mode with
+      | LibXsltMsgIgnore -> (fun _ -> ())
+      | LibXsltMsgComment | LibXsltMsgEmbed ->
+          (fun msg ->
+            text#insertData ~offset:0
+              ~arg:(Gdome.domString
+                (string_of_xslt_msg (build msg) ^ "\n"))))
+    in
+    let add_error_msg =
+      add_generic_msg errormode (fun msg -> LibXsltErrorMsg msg)
+    in
+    let add_debug_msg =
+      add_generic_msg debugmode (fun msg -> LibXsltDebugMsg msg)
+    in
+    List.iter
+      (function
+        | LibXsltErrorMsg msg -> add_error_msg msg
+        | LibXsltDebugMsg msg -> add_debug_msg msg)
+      (List.rev msgs) (* because each msg is added as 1st children *)
+| NoOutput ->
+    let add_generic_msg mode build =
+      (match mode with
+      | LibXsltMsgIgnore -> (fun _ -> ())
+      | LibXsltMsgComment | LibXsltMsgEmbed ->
+          (fun msg ->
+            let comment_node =
+              (* use comments anyway because text nodes aren't allowed in DOM as
+              superroot children *)
+              doc#createComment
+                (Gdome.domString (string_of_xslt_msg (build msg)))
+            in
+            ignore (doc#insertBefore ~newChild:(comment_node :> Gdome.node)
+              ~refChild:doc#get_firstChild)))
+    in
+    let add_error_msg =
+      add_generic_msg errormode (fun msg -> LibXsltErrorMsg msg)
+    in
+    let add_debug_msg =
+      add_generic_msg debugmode (fun msg -> LibXsltDebugMsg msg)
+    in
+    List.iter
+      (function
+        | LibXsltErrorMsg msg -> add_error_msg msg
+        | LibXsltDebugMsg msg -> add_debug_msg msg)
+      (List.rev msgs) (* because each msg is added as 1st children *)
+;;
 
 let apply
   ~(logger: Uwobo_logger.sysLogger)
   ~(styles: Uwobo_styles.styles)
-  ~keys ~params ~props ~input
+  ~keys ~params ~props
+  ~(veillogger: Uwobo_common.libXsltLogger)
+  ?(errormode = LibXsltMsgIgnore) ?(debugmode = LibXsltMsgIgnore)
+  input
   =
     (* "p_" prefix means "processed" *)
   let (p_stylesheets, last_stylesheet) = styles#get keys in
@@ -125,6 +267,15 @@ let apply
       input
       p_stylesheets
   in
+    (* add error and debugging messages to result document *)
+  add_msgs ~errormode ~debugmode ~msgs:veillogger#msgs result;
+(*
+  (* DEBUGGING *)
+  add_msgs
+    ~errormode:LibXsltMsgEmbed ~debugmode:LibXsltMsgEmbed
+    ~msgs:[LibXsltErrorMsg "error1"; LibXsltDebugMsg "debug1"]
+    result;
+*)
   let last_stylesheet = (* used to retrieve serialization options *)
     try
       apply_properties logger last_stylesheet props