Skip to content
This repository
Browse code

[cleanup] Log: add a debug variable for xml

  • Loading branch information...
commit bc2add44169a3c72874f01a8bb5be3be25767763 1 parent 10aa59f
authored June 22, 2011
1  libbase/_tags
@@ -7,6 +7,7 @@
7 7
 <json_utils.ml> : use_ulex
8 8
 <cactutf.ml>: use_ulex
9 9
 <sgzip.ml> : use_zip
  10
+<xml.ml>: with_mlstate_debug
10 11
 
11 12
 # This warnings are generated by the preprocessor : what a shame !
12 13
 <indexer.ml>: warn_z
1  libbase/debugVariables.ml
@@ -79,6 +79,7 @@ let debug_paxos_consensus = var "debug_paxos_consensus"
79 79
 let debug_paxos_le = var "debug_paxos_le"
80 80
 let debug_paxos_rbr = var "debug_paxos_rbr"
81 81
 let debug_paxos_sched = var "debug_paxos_sched"
  82
+let debug_xml = var "debug_xml"
82 83
 let diffing = var "diffing"
83 84
 let effects_show = var "effects_show"
84 85
 let expl_inst_debug = var "expl_inst_debug"
7  libbase/debugVariables.mli
@@ -482,6 +482,13 @@ val debug_paxos_rbr : debug_var
482 482
 val debug_paxos_consensus : debug_var
483 483
 val debug_paxos_sched : debug_var
484 484
 
  485
+
  486
+(**
  487
+  {b MLSTATE_DEBUG_XML}
  488
+  Enables debug messages for Xml module (libbase)
  489
+*)
  490
+val debug_xml: debug_var
  491
+
485 492
 (**
486 493
    {b MLSTATE_DIFFING}
487 494
    Try to remove as much as possible any diff not due to the input of the compiler,
26  libbase/xml.ml
@@ -16,9 +16,17 @@
16 16
     along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 17
 *)
18 18
 
  19
+#<Debugvar:DEBUG_XML>
  20
+
19 21
 module List = BaseList
20 22
 
21  
-(**)
  23
+(* -- *)
  24
+
  25
+let debug fmt =
  26
+  #<If> Printf.eprintf ("[Xml]"^^fmt)
  27
+  #<Else> Printf.ifprintf stdout fmt
  28
+  #<End>
  29
+
22 30
 
23 31
 (* FIXME: unifier avec Qml *)
24 32
 type value =
@@ -72,7 +80,7 @@ let rewrite l =
72 80
   let rec aux ok stack xml = function
73 81
     | `one ((n, _) as t) :: tl -> aux ok stack xml (`start t :: `stop n :: tl)
74 82
     | `start (n, o) :: tl ->
75  
-        Base.jlog ~level:3 (Printf.sprintf "start: %s" n) ;
  83
+        debug "start: %s" n;
76 84
         let nid = xml.count
77 85
         and node = new_node n o in
78 86
         let stack, is_main = match stack with
@@ -85,28 +93,28 @@ let rewrite l =
85 93
         let xml = if is_main then { xml with main = nid :: xml.main } else xml in
86 94
         aux ok stack { xml with count = succ nid } tl
87 95
     | `stop n :: tl ->
88  
-        Base.jlog ~level:3 (Printf.sprintf "stop: %s" n) ;
  96
+        debug "stop: %s" n;
89 97
         begin match stack with
90 98
         | (nid, node) :: stl ->
91 99
             if node.nname = n then
92 100
               let node = { node with ncontent = List.rev node.ncontent } in
93 101
               aux ok stl { xml with nodes = IntMap.add nid node xml.nodes } tl
94 102
             else (
95  
-              Base.jlog (Printf.sprintf "error in rewrite: closing tag %s which is not last open tag" n) ;
  103
+              debug "error in rewrite: closing tag %s which is not last open tag" n;
96 104
               aux false stack xml tl
97 105
             )
98 106
         | _ ->
99  
-            Base.jlog (Printf.sprintf "error in rewrite: closing tag %s which is not open" n) ;
  107
+            debug "error in rewrite: closing tag %s which is not open" n;
100 108
             aux false stack xml tl
101 109
         end
102 110
     | `text t :: tl ->
103  
-        Base.jlog ~level:3 (Printf.sprintf "text: %s" t) ;
  111
+        debug "text: %s" t;
104 112
         begin match stack with
105 113
         | (nid, node) :: stl ->
106 114
             let node = add_node node (Text t) in
107 115
             aux ok ((nid, node)::stl) xml tl
108 116
         | _ ->
109  
-            Base.jlog (Printf.sprintf "error in rewrite: text '%s' outside of tag (skipped)" t) ;
  117
+            debug "error in rewrite: text '%s' outside of tag (skipped)" t;
110 118
             aux false stack xml tl
111 119
         end
112 120
     | `space :: tl ->
@@ -117,7 +125,7 @@ let rewrite l =
117 125
         else
118 126
           let id = fst (List.hd stack) in
119 127
           let name = (snd (List.hd stack)).nname in
120  
-          Base.jlog (Printf.sprintf "error in rewrite: tag <%d:%s> is never closed" id name) ;
  128
+          debug "error in rewrite: tag <%d:%s> is never closed" id name;
121 129
           aux false stack xml [`stop name]
122 130
   in
123 131
   aux true [] empty_xml l
@@ -182,7 +190,7 @@ let delete_node ?(replace=[]) xml parent nid =
182 190
       { xml with nodes = IntMap.add p { parent_node with ncontent = parent_content } xml.nodes }
183 191
 
184 192
 let insert_node parent (xml, nid_list) (n, o, content) =
185  
-  Base.jlog "insert_node" ;
  193
+  debug "insert_node" ;
186 194
   let nid = xml.count
187 195
   and node = new_node n o in
188 196
   let node =

0 notes on commit bc2add4

Please sign in to comment.
Something went wrong with that request. Please try again.