diff --git a/src/reqtraceDocHtml.ml b/src/reqtraceDocHtml.ml
index 2ffd310..1e4f3b0 100644
--- a/src/reqtraceDocHtml.ml
+++ b/src/reqtraceDocHtml.ml
@@ -18,6 +18,12 @@
open Ezxmlm
open ReqtraceTypes.RFC
+let strings_of_importance = function
+ | Must -> "must", "MUST, SHALL"
+ | Should -> "should", "SHOULD, RECOMMENDED"
+ | May -> "may", "MAY, OPTIONAL"
+ | Not -> "other", "OTHER"
+
let ns = ""
let attr name value = ((ns, name), value)
@@ -30,6 +36,13 @@ let of_line (line:linesub) =
(* TODO: start/end/num *)
make_tag "span" ([attr "class" "line"], [`Data line.text])
+let fold_clauses f a rfc =
+ List.fold_left (fun acc s ->
+ List.fold_left (fun acc p ->
+ List.fold_left f acc p.clauses)
+ acc s.paras)
+ a rfc.sections
+
let body_of_doc doc ref_hash src_base =
let of_ref target =
make_tag "div" ([attr "class" "ref"], [
@@ -38,15 +51,19 @@ let body_of_doc doc ref_hash src_base =
])
in
- let open ReqtraceTypes.Refs in
- let of_reqref { loc={Location.loc_start={Lexing.pos_fname=path; Lexing.pos_lnum=linenum}}; reftype; } =
- let reftype_str = match reftype with
+ let string_of_reftype reftype path =
+ let open ReqtraceTypes.Refs in
+ match reftype with
| Impl -> "impl"
| Test -> "test"
| Unknown -> match Stringext.find_from path "test" with
| None -> "impl"
| Some i -> "test"
- in
+ in
+
+ let open ReqtraceTypes.Refs in
+ let of_reqref { loc={Location.loc_start={Lexing.pos_fname=path; Lexing.pos_lnum=linenum}}; reftype; } =
+ let reftype_str = string_of_reftype reftype path in
let text = Printf.sprintf "%s:%d" path linenum in
make_tag "div" (
[attr "class" ("coderef " ^ reftype_str);],
@@ -99,22 +116,79 @@ let body_of_doc doc ref_hash src_base =
opt_attr "id" section.id [],
[`Data section.name]
) in
- let anchor = make_tag "a" ([
- attr "name" (match section.id with None -> section.name | Some id -> id)
- ], []) in
let paras = if section.name = "Table of Contents" then
List.map of_toc_paragraph section.paras
else
List.map of_paragraph section.paras
in
(* TODO: in *)
- make_tag "div" ([attr "class" "section"], heading :: anchor :: paras)
+ make_tag "div" ([attr "class" "section"], heading :: paras)
+ in
+
+ let clause_table doc importance =
+ let imp_id, imp_heading = strings_of_importance importance in
+ let headers = ["Clause"; "Notes"; "Impl"; "Test"; "TODO"] in
+ let row_of_clause clause id =
+ let code_refs = Hashtbl.find_all ref_hash id in
+ let has_notes, has_todo = List.fold_left (
+ fun (has_notes, has_todo) child ->
+ match child with
+ | Note note -> (true, has_todo || note.todo)
+ | Ref ref -> (true, has_todo)
+ | CodeRef _ -> (has_notes, has_todo)
+ ) (false, false) clause.notes
+ in
+ let has_impl, has_test =
+ List.fold_left (
+ fun (has_impl, has_test) { loc={Location.loc_start={Lexing.pos_fname=path; Lexing.pos_lnum=linenum}}; reftype; } ->
+ let reftype_str = string_of_reftype reftype path in
+ (has_impl || reftype_str = "impl", has_test || reftype_str = "test")
+ ) (false, false) code_refs
+ in
+ make_tag "tr" ([], [
+ make_tag "td" ([], [
+ make_tag "a" ([attr "href" ("#" ^ id)], [`Data id])
+ ]);
+ make_tag "td" ([], [`Data (if has_notes then "Yes" else "")]);
+ make_tag "td" ([], [`Data (if has_impl then "Yes" else "")]);
+ make_tag "td" ([], [`Data (if has_test then "Yes" else "")]);
+ make_tag "td" ([], [`Data (if has_todo then "Yes" else "")]);
+ ])
+ in
+ let rows_rev = fold_clauses (fun l clause ->
+ if clause.importance = importance then
+ match clause.id with
+ | None -> l
+ | Some id -> (row_of_clause clause id) :: l
+ else
+ l
+ ) [] doc
+ in
+ make_tag "div" (
+ [
+ attr "class" "index";
+ attr "id" ("clauses_" ^ imp_id)
+ ],
+ [
+ make_tag "h2" ([], [`Data imp_heading]);
+ make_tag "table" (
+ [attr "class" "index"],
+ [
+ make_tag "thead" ([], List.map (fun h -> make_tag "th" ([], [`Data h])) headers);
+ make_tag "tbody" ([], List.rev rows_rev);
+ ])
+ ])
in
let clause_index doc =
make_tag "div" (
[attr "id" "index_of_clauses"],
- [])
+ [
+ make_tag "h1" ([], [`Data "Index of Clauses"]);
+ clause_table doc Must;
+ clause_table doc Should;
+ clause_table doc May;
+ ])
in
let p_links = make_tag "p" ([], [
diff --git a/src/reqtraceDocXml.ml b/src/reqtraceDocXml.ml
index 39f37b8..5cf26f9 100644
--- a/src/reqtraceDocXml.ml
+++ b/src/reqtraceDocXml.ml
@@ -84,6 +84,13 @@ let rec of_xml path xml =
| `Data _ | `Dtd _ -> read_notes notes
| `El_end -> notes
in
+ let importance_of_attr = function
+ | Some "must" -> Must
+ | Some "should" -> Should
+ | Some "may" -> May
+ | Some _ -> Not
+ | None -> Not
+ in
(* Returns a clause record, with line substrings and notes in reverse order *)
let rec read_clause (clause:clause) =
match Xmlm.input xml with
@@ -110,7 +117,8 @@ let rec of_xml path xml =
read_paragraph { paragraph with lines = line :: paragraph.lines }
| `El_start ((ns,"clause"),attrs) when ns = xmlns ->
let id = optional_attr attrs "id" in
- let clause_rev = read_clause { id; lines=[]; notes=[] } in
+ let importance = importance_of_attr (optional_attr attrs "importance") in
+ let clause_rev = read_clause { id; lines=[]; notes=[]; importance; } in
let clause = { clause_rev with lines = List.rev clause_rev.lines; notes = List.rev clause_rev.notes; } in
read_paragraph { paragraph with clauses = clause :: paragraph.clauses }
| `El_start _ -> fail_xml "expected or in "
diff --git a/src/reqtraceTypes.ml b/src/reqtraceTypes.ml
index c013228..71bd8c9 100644
--- a/src/reqtraceTypes.ml
+++ b/src/reqtraceTypes.ml
@@ -34,10 +34,13 @@ module RFC = struct
| Ref of string
| CodeRef of string
+ type importance = Must | Should | May | Not
+
type clause = {
id: elemid option;
lines: linesub list;
notes: notes_child list;
+ importance: importance;
}
type paragraph = {