Skip to content

Commit 52f7f66

Browse files
ivgivg
authored
improves the Primus Lisp documentation generator (#1393)
The new generator will produce documenation for all available packages, not only for the `user` package as it was before. In addition, it will print the location and the source code for each definition, if it is available. The generated documentation is huge (over 300 pages) but it is still possible to generate documentation for a single package, using the `--package` option of the `primus-lisp-documentation` command. The `bapdoc` generator is also updated to produce documentation for both dynamic and static interpeters.
1 parent 6af0e78 commit 52f7f66

8 files changed

+136
-29
lines changed

‎lib/bap_primus/bap_primus.mli

+14-1
Original file line numberDiff line numberDiff line change
@@ -3672,9 +3672,22 @@ text ::= ?any atom that is not recognized as a <word>?
36723672

36733673
module Category : Element
36743674
module Name = Knowledge.Name
3675-
module Descr : Element
3675+
module Descr : sig
3676+
include Element
36763677

3678+
(** [has_source desc] if the source code is available.
3679+
@since 2.5.0 *)
3680+
val has_source : t -> bool
36773681

3682+
(** prints the location if [has_source], otherwise does nothing.
3683+
@since 2.5.0 *)
3684+
val pp_location : Format.formatter -> t -> unit
3685+
3686+
3687+
(** prints source code if it is available, otherwise does nothing.
3688+
@since 2.5.0 *)
3689+
val pp_source : Format.formatter -> t -> unit
3690+
end
36783691

36793692
(** Documentation index.
36803693

‎lib/bap_primus/bap_primus_info.mli

+1
Original file line numberDiff line numberDiff line change
@@ -9,3 +9,4 @@ val name : t -> Knowledge.Name.t
99
val desc : t -> string
1010
val long : t -> string
1111
val pp : Format.formatter -> t -> unit
12+
val normalize_text : string -> string

‎lib/bap_primus/bap_primus_lisp.ml

+50-14
Original file line numberDiff line numberDiff line change
@@ -12,8 +12,10 @@ module Lisp = struct
1212
module Attributes = Bap_primus_lisp_attributes
1313
module Def = Bap_primus_lisp_def
1414
module Var = Bap_primus_lisp_var
15+
module Loc = Bap_primus_lisp_loc
1516
module Resolve = Bap_primus_lisp_resolve
1617
module State = Bap_primus_state
18+
module Source = Bap_primus_lisp_source
1719
module Check = Bap_primus_lisp_type.Check
1820
module Context = Bap_primus_lisp_context
1921
module Program = Bap_primus_lisp_program
@@ -841,32 +843,66 @@ module Doc = struct
841843

842844
module Category = String
843845
module Name = Knowledge.Name
844-
module Descr = String
846+
module Descr = struct
847+
type t = {
848+
desc : string;
849+
code : string option;
850+
loc : Lisp.Loc.t option;
851+
}
852+
853+
let normalize_location : loc -> loc = fun loc -> {
854+
loc with file = Filename.basename loc.file;
855+
}
856+
857+
let create prog def =
858+
let src = Lisp.Program.sources prog in
859+
let desc = Info.normalize_text (Lisp.Def.docs def) in
860+
let loc = Lisp.Source.loc src def.id in
861+
if Lisp.Source.has_loc src def.id then {
862+
desc;
863+
code = Some (Format.asprintf "%a" (Lisp.Source.pp src) loc);
864+
loc = Some (normalize_location loc);
865+
} else {desc; code = None; loc = None}
866+
867+
let merge_desc x y = match x,y with
868+
| "", y -> y
869+
| x, "" -> x
870+
| x,y when String.equal x y -> x
871+
| x,y -> sprintf "%s\nOR\n%s" x y
872+
873+
let merge x y = {
874+
desc = merge_desc x.desc y.desc;
875+
code = Option.first_some x.code y.code;
876+
loc = Option.first_some x.loc y.loc;
877+
}
878+
879+
let has_source {code} = Option.is_some code
880+
881+
let pp_location ppf {loc} = match loc with
882+
| None -> ()
883+
| Some loc -> Lisp.Loc.pp ppf loc
845884

846-
type index = (string * (Name.t * string) list) list
885+
let pp_source ppf {code} = match code with
886+
| None -> ()
887+
| Some code -> Format.fprintf ppf "%s" code
888+
889+
let pp ppf {desc} = Format.fprintf ppf "%s" desc
890+
end
891+
892+
type index = (string * (Name.t * Descr.t) list) list
847893

848894
let normalize xs =
849-
Map.of_alist_reduce (module Name) xs ~f:(fun x y -> match x,y with
850-
| "", y -> y
851-
| x, "" -> x
852-
| x,y when String.equal x y -> x
853-
| x,y -> sprintf "%s\nOR\n%s" x y) |>
895+
Map.of_alist_reduce (module Name) xs ~f:Descr.merge |>
854896
Map.to_alist
855897

856898
let describe prog item =
857899
Lisp.Program.fold prog item ~init:[] ~f:(fun ~package def defs ->
858900
let name = Name.create ~package (Lisp.Def.name def) in
859-
let info = Info.create ~desc:(Lisp.Def.docs def) name in
860-
(name,Info.desc info) :: defs) |> normalize
861-
862-
let describe_packages prog =
863-
Lisp.Program.packages prog |>
864-
List.map ~f:(fun (n,d) -> KB.Name.create n, d)
901+
(name,Descr.create prog def) :: defs) |> normalize
865902

866903
let remove_empty = List.filter ~f:(function (_,[]) -> false | _ -> true)
867904

868905
let create_index p = remove_empty@@Lisp.Program.Items.[
869-
"Packages", describe_packages p;
870906
"Macros", describe p macro;
871907
"Substitutions", describe p subst;
872908
"Constants", describe p const;

‎lib/bap_primus/bap_primus_lisp.mli

+6-1
Original file line numberDiff line numberDiff line change
@@ -23,7 +23,12 @@ module Doc : sig
2323

2424
module Category : Element
2525
module Name = KB.Name
26-
module Descr : Element
26+
module Descr : sig
27+
include Element
28+
val has_source : t -> bool
29+
val pp_location : formatter -> t -> unit
30+
val pp_source : formatter -> t -> unit
31+
end
2732
type index = (Category.t * (Name.t * Descr.t) list) list
2833

2934
module Make(Machine : Machine) : sig

‎plugins/primus_lisp/primus_lisp_documentation.ml

+56-5
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,8 @@ open Bap_primus.Std
99
open Primus.Analysis.Syntax
1010
open Format
1111

12+
module Doc = Primus.Lisp.Doc
13+
1214
type error = Conflict of KB.Conflict.t
1315
| Wrong_target of string
1416
| Wrong_system of string
@@ -18,14 +20,63 @@ type Extension.Error.t += Failed of error
1820

1921
let fail prob = Error (Failed prob)
2022

21-
let print package index =
23+
let build_library index =
24+
let (%:) k v = Map.singleton (module String) k v in
25+
let init = Map.empty (module String) in
26+
List.fold index ~init ~f:(fun library (cat,elts) ->
27+
let cat = Format.asprintf "%a" Doc.Category.pp cat in
28+
List.fold ~init:library elts ~f:(fun library (name,desc) ->
29+
let package = KB.Name.package name
30+
and name = KB.Name.unqualified name in
31+
Map.update library package ~f:(function
32+
| None -> cat %: (name %: desc)
33+
| Some cats ->
34+
Map.update cats cat ~f:(function
35+
| None -> (name %: desc)
36+
| Some elts ->
37+
Map.set elts name desc))))
38+
39+
let pp_source ppf desc =
40+
Format.fprintf ppf "\
41+
#+BEGIN_SRC lisp
42+
;; %a
43+
%a
44+
#+END_SRC\n"
45+
Doc.Descr.pp_location desc Doc.Descr.pp_source desc
46+
47+
48+
let pp_descr ppf desc =
49+
let pp = if Doc.Descr.has_source desc
50+
then pp_source else Doc.Descr.pp in
51+
Format.fprintf ppf "%a@\n" pp desc
52+
53+
54+
let print_library index =
55+
let library = build_library index in
56+
printf "* Packages@\n";
57+
Map.iter_keys library ~f:(fun package ->
58+
printf " * [[Package ~%s~][%s]]@\n"
59+
package package);
60+
Map.iteri library ~f:(fun ~key:package ~data:cats ->
61+
printf "* Package ~%s~@\n" package;
62+
Map.iteri cats ~f:(fun ~key:category ~data:elts ->
63+
printf "** %s@\n" category;
64+
Map.iteri elts ~f:(fun ~key:name ~data:desc ->
65+
printf "*** ~%s~@\n%a" name pp_descr desc)))
66+
67+
let print_package package index =
2268
List.iter index ~f:(fun (cat,elts) ->
23-
printf "* %a@\n" Primus.Lisp.Doc.Category.pp cat;
69+
printf "* %a@\n" Doc.Category.pp cat;
2470
List.iter elts ~f:(fun (name,desc) ->
2571
if String.equal (KB.Name.package name) package
2672
then printf "** ~%s~@\n%a@\n"
2773
(KB.Name.unqualified name)
28-
Primus.Lisp.Doc.Descr.pp desc))
74+
pp_descr desc))
75+
76+
let print = function
77+
| None -> print_library
78+
| Some p -> print_package p
79+
2980

3081
let string_of_problem = function
3182
| Wrong_target s ->
@@ -45,7 +96,7 @@ let print_dynamic package target system =
4596
let proj = Project.empty target in
4697
let state = Toplevel.current () in
4798
let init =
48-
let open Primus.Lisp.Doc.Make(Primus.Analysis) in
99+
let open Doc.Make(Primus.Analysis) in
49100
generate_index >>| print package in
50101
match Primus.System.run system proj state ~init with
51102
| Ok (Normal,_,_)
@@ -75,7 +126,7 @@ let semantics = Extension.Command.flag "semantics"
75126
~doc:"Print the documentation for Primus Lisp semantics lifter"
76127

77128
let package = Extension.Command.parameter
78-
Extension.Type.(string =? "user") "package"
129+
Extension.Type.(some string) "package"
79130
~doc:"Print the documentation for the specified package."
80131

81132
let spec = Extension.Command.(args $package $semantics $target $system)

‎plugins/primus_lisp/primus_lisp_documentation.mli

+1-1
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,3 @@
11
open Bap_primus.Std
22

3-
val print : string -> Primus.Lisp.Doc.index -> unit
3+
val print : string option -> Primus.Lisp.Doc.index -> unit

‎plugins/primus_lisp/primus_lisp_main.ml

+1-1
Original file line numberDiff line numberDiff line change
@@ -44,7 +44,7 @@ module Documentation = struct
4444
let module Main = Primus.Machine.Main(Machine) in
4545
let print =
4646
Doc.generate_index >>|
47-
Primus_lisp_documentation.print "user" in
47+
Primus_lisp_documentation.print None in
4848
match Main.run proj print with
4949
| Normal, _ -> ()
5050
| Exn e, _ ->

‎tools/bapdoc.ml

+7-6
Original file line numberDiff line numberDiff line change
@@ -240,14 +240,14 @@ let install_handwritten_manpages () =
240240
(* by default, title is the buffer/file name with no extension,
241241
that's why we need override it with an empty title *)
242242
let html_of_org file =
243-
run "echo \"#+TITLE:\n\" >> %s" file;
243+
run "echo \"#+TITLE: Primus Lisp Documentation\n\" >> %s" file;
244244
run "emacs %s --batch --eval '(org-html-export-to-html)'" file;
245245
Sys.remove file
246246

247-
let install_lisp_documentation () =
248-
let file = "lisp/index.org" in
249-
mkdir "lisp";
250-
run "bap /bin/true --primus-lisp-documentation > %s" file;
247+
let install_lisp_documentation ?(option="") target =
248+
let file = Filename.concat target "index.org" in
249+
mkdir target;
250+
run "bap primus-lisp-documentation %s > %s" option file;
251251
html_of_org file
252252

253253
let install_primus_api () =
@@ -276,6 +276,7 @@ let () =
276276
check ();
277277
generate_manual ();
278278
install_handwritten_manpages ();
279-
install_lisp_documentation ();
279+
install_lisp_documentation "lisp";
280+
install_lisp_documentation ~option:"--semantics" "semantics";
280281
install_primus_api ();
281282
generate ()

0 commit comments

Comments
 (0)