Skip to content
Browse files

added small tool to simplify XML api

  • Loading branch information...
1 parent 1ab8609 commit 7714b141708c593ed7e0c641908bed2ea068ebde @Kakadu committed Sep 28, 2011
Showing with 188 additions and 38 deletions.
  1. +10 −10 build.ml
  2. +5 −0 moc/.gitignore
  3. +1 −3 moc/input
  4. +4 −25 xml/superIndex.ml
  5. +1 −0 xml/superIndex.mli
  6. +5 −0 xmltool/4test5
  7. +44 −0 xmltool/Makefile
  8. +8 −0 xmltool/README
  9. +62 −0 xmltool/main.ml
  10. +48 −0 xmltool/simplexmlwriter.ml
View
20 build.ml 100755 → 100644
@@ -1,8 +1,12 @@
-#!/usr/bin/ocaml
print_endline "Configure script for lablqt";;
#load "unix.cma";;
open UnixLabels;;
open Sys;;
+open Printf;;
+
+let cores_count = 3;; (* mkae -j parameter *)
+let api_xml = "../for_test5.xml";;
+(* .. because this file will be accesses from ./xml *)
let touch s =
if not (Sys.file_exists s) then
@@ -27,19 +31,16 @@ if not (file_exists "xml/out") then
symlink ~src:"../test_gen/out" ~dst:"xml/out";;
(* compiling xml *)
-let x = command "make -C xml depend clean all" in
-if x<>0 then failwith "error while compiling xml";;
+wrap_cmd "make -C xml depend clean all" "error while compiling xml";;
(* executing generator *)
chdir "xml";;
-let x = command "./main.opt -xml -file ../aaa.xml" in
-if x<>0 then failwith "error while generating code";;
+wrap_cmd (sprintf "./main.opt -xml -file %s" api_xml) "error while generating code";;
chdir "..";;
print_endline "\ncompiling generated C++ files\n";;
-let x = command "make -j3 -C test_gen/out/cpp" in
-if x<>0 then failwith "error while compiling generated C++ files";;
-
+wrap_cmd (Printf.sprintf "make -j%d -C test_gen/out/cpp" cores_count)
+ "error while compiling generated C++ files";;
print_endline "\ncompiling mocml\n";;
touch "moc/.depend";;
@@ -53,8 +54,7 @@ let add_mocml where =
List.iter add_mocml ["test_gen/test4";"test_gen/test5"];;
print_endline "\ncompiling the lablqt library";;
-let x = command "make -C test_gen clean all" in
-if x<>0 then failwith "error while building library";;
+wrap_cmd "make -C test_gen clean all" "error while building library";;
print_endline "making tests";;
let tests = ["test";"test2";"test3";"test4"] in
View
5 moc/.gitignore
@@ -0,0 +1,5 @@
+UserSlots.cpp
+UserSlots.h
+UserSlots_stubs.ml
+cppmoc.ml
+
View
4 moc/input
@@ -1,4 +1,2 @@
let foo: int -> int -> unit
-let goo: int -> qWidget -> qWidget
-let boo: qWidget -> unit
-
+let goo: qWidget -> qWidget
View
29 xml/superIndex.ml
@@ -178,7 +178,7 @@ let super_filter_meths ~base ~cur =
наследование с базовым (абстрактным) классом *)
(!base_not_impl,!cur_impl,!cur_new)
-let build_superindex root_ns =
+let build_graph root_ns =
let index = ref SuperIndex.empty in
let g = G.create () in
@@ -246,8 +246,10 @@ let build_superindex root_ns =
List.fold_left ~init:false ~f:(fun acc prefix -> acc or (startswith ~prefix name)) prefixes
| _ -> assert false)
);
+ (index,g)
-
+let build_superindex root_ns =
+ let (index,g) = build_graph root_ns in
let h = open_out "./outgraph.dot" in
GraphPrinter.output_graph h g;
close_out h;
@@ -404,27 +406,4 @@ let build_superindex root_ns =
| Class _ -> ()
| Enum _ -> Q.enqueue !ans_queue key
);
-(*
- let get_vertexes_names lst =
- List.map ~f:(fun v -> G.V.label v |> snd) lst |> List.stable_sort ~cmp:String.compare
- in
-
- let roots = ref [] in
- G.iter_vertex (fun v -> if G.pred_e g v |> List.length = 0 then roots := v :: !roots) g;
- let roots_names = get_vertexes_names !roots in
- print_endline "Root vertexes are:";
- List.iter roots_names ~f:(print_endline);
- *)
-(* print_endline "Now printing virtuals";
- SuperIndex.iter !index ~f:(fun ~key ~data -> begin
- match data with
- | Class (c,_) ->
- Printf.printf "class %s extends %s\n" c.c_name (List.to_string (fun x->x) c.c_inherits);
- printf " inner abstr:\n";
- MethSet.iter c.c_meths_innabstr ~f:(fun (m,_) -> Printf.printf "\t%s\n" (string_of_meth m) );
- printf " c_meths_abstr:\n";
- MethSet.iter c.c_meths_abstr ~f:(fun (m,_) -> Printf.printf "\t%s\n" (string_of_meth m) )
- | Enum (ename,lst) -> ()
- end);
-*)
(!index,g, !ans_queue)
View
1 xml/superIndex.mli
@@ -159,4 +159,5 @@ module G :
(* val kill_and_fall : t -> vertex -> unit *)
end
+val build_graph : Parser.namespace -> (index_data SuperIndex.t ref) * G.t
val build_superindex : Parser.namespace -> index_data SuperIndex.t * G.t * SuperIndex.key Core.Core_queue.t
View
5 xmltool/4test5
@@ -0,0 +1,5 @@
+#!/bin/bash
+
+lst="QDialog QMenuBar QMenu QAction QGroupBox QHBoxLayout QGridLayout QLabel QLineEdit QTextEdit QFormLayout QComboBox QLabel QSpinBox QVBoxLayout QPushButton QDialogButtonBox Qt QAbstractSlider QScrollBar QCheckBox"
+
+./main.opt -in ../aaa.xml -out ../for_test5.xml $lst
View
44 xmltool/Makefile
@@ -0,0 +1,44 @@
+ML_OBJS=simplexmlwriter.cmo main.cmo
+ML_OBJS_OPT=simplexmlwriter.cmx main.cmx
+
+PACKAGES=dynlink,str,tyxml,ocamlgraph,sexplib,core,core_extended
+
+OCAMLDEP=ocamlfind ocamldep -package $(PACKAGES)
+OCAMLC=ocamlfind ocamlc -g -package $(PACKAGES)
+OCAMLOPT=ocamlfind ocamlopt -g -thread -package $(PACKAGES)
+INC=-I `ocamlc -where`/camlp4
+CMOS=$(CMOS_LIB) $(ML_OBJS)
+CMXS=$(CMXS_LIB) $(ML_OBJS_OPT)
+
+all: opt
+
+.SUFFIXES: .ml .mli .cmo .cmi .var .cpp .cmx
+
+depend:
+ $(OCAMLDEP) *.ml *.mli > .depend
+
+.ml.cmx:
+ $(OCAMLOPT) -I ../xml -c $<
+
+.ml.cmo:
+ $(OCAMLC) $(INC) -c $<
+
+.mli.cmi:
+ $(OCAMLC) -c $<
+
+opt: $(ML_OBJS_OPT)
+ $(OCAMLOPT) $(INC) ../xml/parser.cmx ../xml/superIndex.cmx \
+ camlp4lib.cmxa xmllexer.cmx simplexmlparser.cmx $(CMXS) -linkpkg -o main.opt
+
+byte: $(ML_OBJS)
+ $(OCAMLC) -I `ocamlc -where`/camlp4 parser.cmo ../xml/superIndex.cmo \
+ camlp4lib.cma xmllexer.cmo simplexmlparser.cmo \
+ $(CMOS) -linkpkg -o main.byte
+
+clean:
+ rm -f *~ *.cm* *.[oa] *.so *tags.[ch] *.annot
+
+main.cmo: simplexmlwriter.cmo
+main.cmx: simplexmlwriter.cmx
+simplexmlwriter.cmo:
+simplexmlwriter.cmx:
View
8 xmltool/README
@@ -0,0 +1,8 @@
+It is very simple tool filter a big xml APIs. I filters classes only if second level of XML (children of `code` node).
+
+Thing which are not so simple.
+1) I we include a class all base class are included too.
+2) TODO: fix current name comparation to lower-case compareation (to avoid user spelling mistakes)
+3) TODO: improve classes names specifiction. Added some decalrations like Qt::Win*
+
+
View
62 xmltool/main.ml
@@ -0,0 +1,62 @@
+open Core
+module List = Core_list
+module Set = Core_set
+open SuperIndex
+open Parser
+open Printf
+
+let names = ref Set.empty
+let xml_name = ref "../aaa.xml";;
+let out_name = ref "out.xml";;
+
+let () = Arg.parse [
+ ("-in", Arg.String (fun s -> xml_name := s), "input xml file");
+ ("-out", Arg.String (fun s -> out_name := s), "output xml file")
+ ]
+ (fun name -> names := Set.add !names name) "haha"
+
+let root = Simplexmlparser.xmlparser_file !xml_name |> List.hd_exn
+module Printer = XML_print.MakeSimple(XML)(struct let emptytags=[] end)
+
+let (_,g) = build_graph (root |> Parser.build)
+
+open Simplexmlparser
+let () =
+ let start_set = ref Set.empty in
+ G.iter_vertex (fun v ->
+ let name = G.vertex_name v in
+ if Set.mem !names name then start_set:= Set.add !start_set v
+ ) g;
+ let ans_vs = ref !start_set in
+ let rec loop set =
+ if Set.is_empty set then () else begin
+ let parents = ref Set.empty in
+ Set.iter set ~f:(G.iter_pred (fun v -> parents := Set.add !parents v ) g);
+ ans_vs:= Set.union !ans_vs !parents;
+ loop !parents
+ end
+ in
+ loop !start_set;
+
+(* Set.iter (fun x -> print_endline (G.vertex_name x)) !ans_vs; *)
+ let names = Set.union (Set.map ~f:G.vertex_name !ans_vs) !names in
+
+ let lst = match root with
+ | Element ("code",_,lst) -> lst
+ | _ -> assert false
+ in
+ let ans_lst = List.filter lst ~f:(fun e -> match e with
+ | Element (_,attr,_) ->
+ let name = List.Assoc.find_exn attr "name" in
+ Set.mem names name
+ | _ -> false
+ ) in
+ let xml = Element ("code",[],ans_lst) in
+ let out_ch = open_out !out_name in
+ printf "Writing out xml....\n";
+ let out s = Printf.fprintf out_ch "%s" s in
+ Simplexmlwriter.print ~out xml;
+ close_out out_ch
+
+
+
View
48 xmltool/simplexmlwriter.ml
@@ -0,0 +1,48 @@
+open Printf
+open Simplexmlparser
+
+module M = Map.Make(struct type t = int let compare = compare end)
+
+exception Bug of string
+let bug s = raise (Bug s)
+
+let bad_pcdata s =
+ try
+ ignore(Str.search_forward (Str.regexp "]]>") s 0 : int);
+ true
+ with
+ Not_found -> false
+
+let string_of_attr (a,b) = Printf.sprintf "%s=\"%s\"" a b
+
+let print ~out ?(tabc=4) root =
+ let prefixes = ref M.empty in
+ let prefix i =
+(* printf "searching prefix %d\n" i; *)
+ if M.mem i !prefixes then ( (* printf "found!\n"; *) M.find i !prefixes )
+ else
+ let s = String.make (tabc*i) ' ' in
+(* printf "created prefix %d\n" i; *)
+ prefixes := M.add i s !prefixes;
+ s
+ in
+
+ let rec visit ~level el = match el with
+ | PCData d when bad_pcdata d -> bug "PCData value contains ]]>"
+ | PCData d -> out (prefix level); out d
+ | Element (name, attr, lst) ->
+ let prefix = prefix level in
+ out (sprintf "%s<%s " prefix name);
+ let attr_str = String.concat " " (List.map string_of_attr attr) in
+ out attr_str;
+ let () = match lst with
+ | [PCData d] -> out (sprintf ">%s</%s>\n" d name)
+ | [] -> out "/>\n"
+ | _ ->
+ out ">\n";
+ List.iter (visit ~level:(level+1)) lst;
+ out (sprintf "%s</%s>\n" prefix name)
+ in
+ ()
+ in
+ visit ~level:0 root

0 comments on commit 7714b14

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