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 = {