Permalink
Browse files

[cleanup] Log: add a debug variable for xml

  • Loading branch information...
1 parent 10aa59f commit bc2add44169a3c72874f01a8bb5be3be25767763 Raja committed Jun 22, 2011
Showing with 26 additions and 9 deletions.
  1. +1 −0 libbase/_tags
  2. +1 −0 libbase/debugVariables.ml
  3. +7 −0 libbase/debugVariables.mli
  4. +17 −9 libbase/xml.ml
View
1 libbase/_tags
@@ -7,6 +7,7 @@
<json_utils.ml> : use_ulex
<cactutf.ml>: use_ulex
<sgzip.ml> : use_zip
+<xml.ml>: with_mlstate_debug
# This warnings are generated by the preprocessor : what a shame !
<indexer.ml>: warn_z
View
1 libbase/debugVariables.ml
@@ -79,6 +79,7 @@ let debug_paxos_consensus = var "debug_paxos_consensus"
let debug_paxos_le = var "debug_paxos_le"
let debug_paxos_rbr = var "debug_paxos_rbr"
let debug_paxos_sched = var "debug_paxos_sched"
+let debug_xml = var "debug_xml"
let diffing = var "diffing"
let effects_show = var "effects_show"
let expl_inst_debug = var "expl_inst_debug"
View
7 libbase/debugVariables.mli
@@ -482,6 +482,13 @@ val debug_paxos_rbr : debug_var
val debug_paxos_consensus : debug_var
val debug_paxos_sched : debug_var
+
+(**
+ {b MLSTATE_DEBUG_XML}
+ Enables debug messages for Xml module (libbase)
+*)
+val debug_xml: debug_var
+
(**
{b MLSTATE_DIFFING}
Try to remove as much as possible any diff not due to the input of the compiler,
View
26 libbase/xml.ml
@@ -16,9 +16,17 @@
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
+#<Debugvar:DEBUG_XML>
+
module List = BaseList
-(**)
+(* -- *)
+
+let debug fmt =
+ #<If> Printf.eprintf ("[Xml]"^^fmt)
+ #<Else> Printf.ifprintf stdout fmt
+ #<End>
+
(* FIXME: unifier avec Qml *)
type value =
@@ -72,7 +80,7 @@ let rewrite l =
let rec aux ok stack xml = function
| `one ((n, _) as t) :: tl -> aux ok stack xml (`start t :: `stop n :: tl)
| `start (n, o) :: tl ->
- Base.jlog ~level:3 (Printf.sprintf "start: %s" n) ;
+ debug "start: %s" n;
let nid = xml.count
and node = new_node n o in
let stack, is_main = match stack with
@@ -85,28 +93,28 @@ let rewrite l =
let xml = if is_main then { xml with main = nid :: xml.main } else xml in
aux ok stack { xml with count = succ nid } tl
| `stop n :: tl ->
- Base.jlog ~level:3 (Printf.sprintf "stop: %s" n) ;
+ debug "stop: %s" n;
begin match stack with
| (nid, node) :: stl ->
if node.nname = n then
let node = { node with ncontent = List.rev node.ncontent } in
aux ok stl { xml with nodes = IntMap.add nid node xml.nodes } tl
else (
- Base.jlog (Printf.sprintf "error in rewrite: closing tag %s which is not last open tag" n) ;
+ debug "error in rewrite: closing tag %s which is not last open tag" n;
aux false stack xml tl
)
| _ ->
- Base.jlog (Printf.sprintf "error in rewrite: closing tag %s which is not open" n) ;
+ debug "error in rewrite: closing tag %s which is not open" n;
aux false stack xml tl
end
| `text t :: tl ->
- Base.jlog ~level:3 (Printf.sprintf "text: %s" t) ;
+ debug "text: %s" t;
begin match stack with
| (nid, node) :: stl ->
let node = add_node node (Text t) in
aux ok ((nid, node)::stl) xml tl
| _ ->
- Base.jlog (Printf.sprintf "error in rewrite: text '%s' outside of tag (skipped)" t) ;
+ debug "error in rewrite: text '%s' outside of tag (skipped)" t;
aux false stack xml tl
end
| `space :: tl ->
@@ -117,7 +125,7 @@ let rewrite l =
else
let id = fst (List.hd stack) in
let name = (snd (List.hd stack)).nname in
- Base.jlog (Printf.sprintf "error in rewrite: tag <%d:%s> is never closed" id name) ;
+ debug "error in rewrite: tag <%d:%s> is never closed" id name;
aux false stack xml [`stop name]
in
aux true [] empty_xml l
@@ -182,7 +190,7 @@ let delete_node ?(replace=[]) xml parent nid =
{ xml with nodes = IntMap.add p { parent_node with ncontent = parent_content } xml.nodes }
let insert_node parent (xml, nid_list) (n, o, content) =
- Base.jlog "insert_node" ;
+ debug "insert_node" ;
let nid = xml.count
and node = new_node n o in
let node =

0 comments on commit bc2add4

Please sign in to comment.