improves the Primus Lisp documentation generator (BinaryAnalysisPlatf…

…orm#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.
thestr4ng3r · Jan 7, 2022 · 52f7f66 · 52f7f66
1 parent 6af0e78
commit 52f7f66
Show file tree

Hide file tree

Showing 8 changed files with 136 additions and 29 deletions.
diff --git a/lib/bap_primus/bap_primus.mli b/lib/bap_primus/bap_primus.mli
@@ -3672,9 +3672,22 @@ text ::= ?any atom that is not recognized as a <word>?
 
         module Category : Element
         module Name     = Knowledge.Name
-        module Descr    : Element
+        module Descr    : sig
+          include Element
 
+          (** [has_source desc] if the source code is available.
+              @since 2.5.0 *)
+          val has_source : t -> bool
 
+          (** prints the location if [has_source], otherwise does nothing.
+              @since 2.5.0  *)
+          val pp_location : Format.formatter -> t -> unit
+
+
+          (** prints source code if it is available, otherwise does nothing.
+              @since 2.5.0 *)
+          val pp_source : Format.formatter -> t -> unit
+        end
 
         (** Documentation index.
 

diff --git a/lib/bap_primus/bap_primus_info.mli b/lib/bap_primus/bap_primus_info.mli
@@ -9,3 +9,4 @@ val name : t -> Knowledge.Name.t
 val desc : t -> string
 val long : t -> string
 val pp : Format.formatter -> t -> unit
+val normalize_text : string -> string
diff --git a/lib/bap_primus/bap_primus_lisp.ml b/lib/bap_primus/bap_primus_lisp.ml
@@ -12,8 +12,10 @@ module Lisp = struct
   module Attributes = Bap_primus_lisp_attributes
   module Def = Bap_primus_lisp_def
   module Var = Bap_primus_lisp_var
+  module Loc = Bap_primus_lisp_loc
   module Resolve = Bap_primus_lisp_resolve
   module State = Bap_primus_state
+  module Source = Bap_primus_lisp_source
   module Check = Bap_primus_lisp_type.Check
   module Context = Bap_primus_lisp_context
   module Program = Bap_primus_lisp_program
@@ -841,32 +843,66 @@ module Doc = struct
 
   module Category = String
   module Name = Knowledge.Name
-  module Descr = String
+  module Descr = struct
+    type t = {
+      desc : string;
+      code : string option;
+      loc : Lisp.Loc.t option;
+    }
+
+    let normalize_location : loc -> loc = fun loc -> {
+        loc with file = Filename.basename loc.file;
+      }
+
+    let create prog def =
+      let src = Lisp.Program.sources prog in
+      let desc = Info.normalize_text (Lisp.Def.docs def) in
+      let loc = Lisp.Source.loc src def.id in
+      if Lisp.Source.has_loc src def.id then {
+        desc;
+        code = Some (Format.asprintf "%a" (Lisp.Source.pp src) loc);
+        loc = Some (normalize_location loc);
+      } else {desc; code = None; loc = None}
+
+    let merge_desc x y = match x,y with
+      | "", y -> y
+      | x, "" -> x
+      | x,y when String.equal x y -> x
+      | x,y -> sprintf "%s\nOR\n%s" x y
+
+    let merge x y = {
+      desc = merge_desc x.desc y.desc;
+      code = Option.first_some x.code y.code;
+      loc = Option.first_some x.loc y.loc;
+    }
+
+    let has_source {code} = Option.is_some code
+
+    let pp_location ppf {loc} = match loc with
+      | None -> ()
+      | Some loc -> Lisp.Loc.pp ppf loc
 
-  type index = (string * (Name.t * string) list) list
+    let pp_source ppf {code} = match code with
+      | None -> ()
+      | Some code -> Format.fprintf ppf "%s" code
+
+    let pp ppf {desc} = Format.fprintf ppf "%s" desc
+  end
+
+  type index = (string * (Name.t * Descr.t) list) list
 
   let normalize xs =
-    Map.of_alist_reduce (module Name) xs ~f:(fun x y -> match x,y with
-        | "", y -> y
-        | x, "" -> x
-        | x,y when String.equal x y -> x
-        | x,y -> sprintf "%s\nOR\n%s" x y) |>
+    Map.of_alist_reduce (module Name) xs ~f:Descr.merge |>
     Map.to_alist
 
   let describe prog item =
     Lisp.Program.fold prog item ~init:[] ~f:(fun ~package def defs ->
         let name = Name.create ~package (Lisp.Def.name def) in
-        let info = Info.create ~desc:(Lisp.Def.docs def) name in
-        (name,Info.desc info) :: defs) |> normalize
-
-  let describe_packages prog =
-    Lisp.Program.packages prog |>
-    List.map ~f:(fun (n,d) -> KB.Name.create n, d)
+        (name,Descr.create prog def) :: defs) |> normalize
 
   let remove_empty = List.filter ~f:(function (_,[]) -> false | _ -> true)
 
   let create_index p = remove_empty@@Lisp.Program.Items.[
-      "Packages", describe_packages p;
       "Macros", describe p macro;
       "Substitutions", describe p subst;
       "Constants", describe p const;

diff --git a/lib/bap_primus/bap_primus_lisp.mli b/lib/bap_primus/bap_primus_lisp.mli
@@ -23,7 +23,12 @@ module Doc : sig
 
   module Category : Element
   module Name     = KB.Name
-  module Descr    : Element
+  module Descr    : sig
+    include Element
+    val has_source : t -> bool
+    val pp_location : formatter -> t -> unit
+    val pp_source : formatter -> t -> unit
+  end
   type index = (Category.t * (Name.t * Descr.t) list) list
 
   module Make(Machine : Machine) : sig

diff --git a/plugins/primus_lisp/primus_lisp_documentation.ml b/plugins/primus_lisp/primus_lisp_documentation.ml
@@ -9,6 +9,8 @@ open Bap_primus.Std
 open Primus.Analysis.Syntax
 open Format
 
+module Doc = Primus.Lisp.Doc
+
 type error = Conflict of KB.Conflict.t
            | Wrong_target of string
            | Wrong_system of string
@@ -18,14 +20,63 @@ type Extension.Error.t += Failed of error
 
 let fail prob = Error (Failed prob)
 
-let print package index =
+let build_library index =
+  let (%:) k v = Map.singleton (module String) k v in
+  let init = Map.empty (module String) in
+  List.fold index ~init ~f:(fun library (cat,elts) ->
+      let cat = Format.asprintf "%a" Doc.Category.pp cat in
+      List.fold ~init:library elts ~f:(fun library (name,desc) ->
+          let package = KB.Name.package name
+          and name = KB.Name.unqualified name in
+          Map.update library package ~f:(function
+              | None -> cat %: (name %: desc)
+              | Some cats ->
+                Map.update cats cat ~f:(function
+                    | None -> (name %: desc)
+                    | Some elts ->
+                      Map.set elts name desc))))
+
+let pp_source ppf desc =
+  Format.fprintf ppf "\
+#+BEGIN_SRC lisp
+;; %a
+%a
+#+END_SRC\n"
+    Doc.Descr.pp_location desc Doc.Descr.pp_source desc
+
+
+let pp_descr ppf desc =
+  let pp = if Doc.Descr.has_source desc
+    then pp_source else Doc.Descr.pp in
+  Format.fprintf ppf "%a@\n" pp desc
+
+
+let print_library index =
+  let library = build_library index in
+  printf "* Packages@\n";
+  Map.iter_keys library ~f:(fun package ->
+      printf " * [[Package ~%s~][%s]]@\n"
+        package package);
+  Map.iteri library ~f:(fun ~key:package ~data:cats ->
+      printf "* Package ~%s~@\n" package;
+      Map.iteri cats ~f:(fun ~key:category ~data:elts ->
+          printf "** %s@\n" category;
+          Map.iteri elts ~f:(fun ~key:name ~data:desc ->
+              printf "*** ~%s~@\n%a" name pp_descr desc)))
+
+let print_package package index =
   List.iter index ~f:(fun (cat,elts) ->
-      printf "* %a@\n" Primus.Lisp.Doc.Category.pp cat;
+      printf "* %a@\n" Doc.Category.pp cat;
       List.iter elts ~f:(fun (name,desc) ->
           if String.equal (KB.Name.package name) package
           then printf "** ~%s~@\n%a@\n"
               (KB.Name.unqualified name)
-              Primus.Lisp.Doc.Descr.pp desc))
+              pp_descr desc))
+
+let print = function
+  | None -> print_library
+  | Some p -> print_package p
+
 
 let string_of_problem = function
   | Wrong_target s ->
@@ -45,7 +96,7 @@ let print_dynamic package target system =
   let proj = Project.empty target in
   let state = Toplevel.current () in
   let init =
-    let open Primus.Lisp.Doc.Make(Primus.Analysis) in
+    let open Doc.Make(Primus.Analysis) in
     generate_index >>| print package in
   match Primus.System.run system proj state ~init with
   | Ok (Normal,_,_)
@@ -75,7 +126,7 @@ let semantics = Extension.Command.flag "semantics"
     ~doc:"Print the documentation for Primus Lisp semantics lifter"
 
 let package = Extension.Command.parameter
-    Extension.Type.(string =? "user") "package"
+    Extension.Type.(some string) "package"
     ~doc:"Print the documentation for the specified package."
 
 let spec = Extension.Command.(args $package $semantics $target $system)

diff --git a/plugins/primus_lisp/primus_lisp_documentation.mli b/plugins/primus_lisp/primus_lisp_documentation.mli
@@ -1,3 +1,3 @@
 open Bap_primus.Std
 
-val print : string -> Primus.Lisp.Doc.index -> unit
+val print : string option -> Primus.Lisp.Doc.index -> unit
diff --git a/plugins/primus_lisp/primus_lisp_main.ml b/plugins/primus_lisp/primus_lisp_main.ml
@@ -44,7 +44,7 @@ module Documentation = struct
     let module Main = Primus.Machine.Main(Machine) in
     let print =
       Doc.generate_index >>|
-      Primus_lisp_documentation.print "user" in
+      Primus_lisp_documentation.print None in
     match Main.run proj print with
     | Normal, _ -> ()
     | Exn e, _ ->

diff --git a/tools/bapdoc.ml b/tools/bapdoc.ml
@@ -240,14 +240,14 @@ let install_handwritten_manpages () =
 (* by default, title is the buffer/file name with no extension,
    that's why we need override it with an empty title *)
 let html_of_org file =
-  run "echo \"#+TITLE:\n\" >> %s" file;
+  run "echo \"#+TITLE: Primus Lisp Documentation\n\" >> %s" file;
   run "emacs %s --batch --eval '(org-html-export-to-html)'" file;
   Sys.remove file
 
-let install_lisp_documentation () =
-  let file = "lisp/index.org" in
-  mkdir "lisp";
-  run "bap /bin/true --primus-lisp-documentation > %s" file;
+let install_lisp_documentation ?(option="") target =
+  let file = Filename.concat target "index.org" in
+  mkdir target;
+  run "bap primus-lisp-documentation %s > %s" option file;
   html_of_org file
 
 let install_primus_api () =
@@ -276,6 +276,7 @@ let () =
   check ();
   generate_manual ();
   install_handwritten_manpages ();
-  install_lisp_documentation ();
+  install_lisp_documentation "lisp";
+  install_lisp_documentation ~option:"--semantics" "semantics";
   install_primus_api ();
   generate ()