Commit 06487a9f authored by Stephane Glondu's avatar Stephane Glondu

Pretty-printing of machine-readable ledger

parent 1ecf35f6
......@@ -39,7 +39,7 @@ let extract_text cell =
aux c##nextSibling
in
let inner_cell = (Js.Opt.get (xs##item (0)) (fun _ -> assert false)) in
inner_cell, aux inner_cell##firstChild
inner_cell, String.trim (aux inner_cell##firstChild)
let extract_float s =
let buf = Buffer.create 100 in
......@@ -72,9 +72,16 @@ let ( ++ ) f g x = g (f x)
let classify_row row =
if is_class_row "total" row then
`Total row
else if is_class_row "summable" row then (
else if is_class_row "ledger-header" row then (
match extract_rev_cells row with
| _ :: xs ->
let headers = List.rev_map (extract_text ++ snd) xs in
`Headers headers
| _ -> `None
) else if is_class_row "summable" row then (
match extract_rev_cells row with
| cell :: xs ->
let wtf = snd (extract_text cell) in
let atoms = List.map (extract_text ++ snd ++ extract_float) xs in
let atoms = Array.of_list (List.rev atoms) in
let sum = Array.fold_left ( +. ) 0. atoms in
......@@ -84,27 +91,28 @@ let classify_row row =
in
Dom.appendChild cell
(document##createTextNode (Js.string check_text));
`Summable atoms
| _ -> assert false
`Summable (wtf, atoms)
| _ -> `None
) else `None
let parse_rows (xs : Dom_html.element Dom.nodeList Js.t) =
let n = xs##length in
let rec aux (total, accu) i =
let rec aux (total, accu, headers) i =
if i < n then
let x = Js.Opt.get (xs##item (i)) (fun () -> assert false) in
let arg =
begin match classify_row x with
| `Total x -> Some x, accu
| `Summable xs -> total, xs::accu
| `None -> total, accu
| `Total x -> Some x, accu, headers
| `Summable xs -> total, xs::accu, headers
| `Headers xs -> total, accu, Some xs
| `None -> total, accu, headers
end
in
aux arg (i+1)
else
(total, accu)
(total, accu, headers)
in
aux (None, []) 0
aux (None, [], None) 0
let count lines =
let n = List.fold_left max 0 (List.map Array.length lines) in
......@@ -157,7 +165,7 @@ let get_parent_table row =
| _ -> Js.Opt.case (node##parentNode) (fun () -> node) loop
in loop node
let append_source_link table =
let source_link () =
let p = document##createElement (Js.string "p") in
let element = document##createElement (Js.string "a") in
element##setAttribute (
......@@ -167,12 +175,49 @@ let append_source_link table =
let text = document##createTextNode (Js.string "Source code") in
Dom.appendChild element text;
Dom.appendChild p element;
Dom.appendChild table p
p
let block_header = "-----BEGIN LEDGER-----"
let block_footer = "-----END LEDGER-----"
let format_ledger txs =
let buf = Buffer.create 256 in
Buffer.add_string buf block_header;
Buffer.add_string buf "\n";
List.iter (fun (wtf, line) ->
Buffer.add_string buf wtf;
Buffer.add_string buf " |";
List.iter (fun (k, v) ->
Printf.bprintf buf " %s(%s)" k (format_float v)
) line;
Buffer.add_string buf "\n";
) txs;
Buffer.add_string buf block_footer;
Buffer.add_string buf "\n";
Buffer.contents buf
let ledger_box txs =
let pre = document##createElement (Js.string "pre") in
pre##innerHTML <- Js.string (format_ledger txs);
pre
let start () =
let ps = document##getElementsByTagName (Js.string "tr") in
let total, lines = parse_rows ps in
let sums = count lines in
let total, lines, headers = parse_rows ps in
let txs =
match headers with
| Some hs ->
let assoc = List.map (fun (wtf, cells) ->
let full_dict = List.combine hs (Array.to_list cells) in
wtf, List.filter (fun (k, v) ->
v < (-. epsilon) || v > epsilon
) full_dict
) lines in
Some assoc
| None -> None
in
let nums = List.map snd lines in
let sums = count nums in
let normalize = normalize
(Array.fold_left min max_float sums)
(Array.fold_left max min_float sums)
......@@ -193,7 +238,11 @@ let start () =
let ys = row##getElementsByTagName (Js.string "td") in
let set i x = Js.Opt.iter (ys##item (i)) (fill_total x) in
Array.iteri set sums;
append_source_link (get_parent_table row);
let table = get_parent_table row in
Dom.appendChild table (source_link ());
(match txs with
| Some txs -> Dom.appendChild table (ledger_box txs)
| None -> ());
);
Lwt.return ()
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment