package frama-c

  1. Overview
  2. Docs
package frama-c
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file server_doc.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
(**************************************************************************)
(*                                                                        *)
(*  This file is part of Frama-C.                                         *)
(*                                                                        *)
(*  Copyright (C) 2007-2024                                               *)
(*    CEA (Commissariat à l'énergie atomique et aux énergies              *)
(*         alternatives)                                                  *)
(*                                                                        *)
(*  you can redistribute it and/or modify it under the terms of the GNU   *)
(*  Lesser General Public License as published by the Free Software       *)
(*  Foundation, version 2.1.                                              *)
(*                                                                        *)
(*  It is distributed in the hope that it will be useful,                 *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU Lesser General Public License for more details.                   *)
(*                                                                        *)
(*  See the GNU Lesser General Public License version 2.1                 *)
(*  for more details (enclosed in the file licenses/LGPLv2.1).            *)
(*                                                                        *)
(**************************************************************************)

(* -------------------------------------------------------------------------- *)
(* --- Server Documentation                                               --- *)
(* -------------------------------------------------------------------------- *)

open Package
type json = Yojson.Basic.t
module Md = Markdown
module Senv = Server_parameters
module Pages = Map.Make(String)

type chapter = [ `Protocol | `Kernel | `Plugin of string ]

(* Section contents can be generated statically or dynamically.
   Typically, general kernel dictionary entries can be extended by plugins.
   The general case is to have a function that builds the (final) content
   on demand. *)
type section = (unit -> Markdown.elements)

type page = {
  path : string ;
  rootdir : string ; (* path to document root *)
  chapter : chapter ;
  title : string ;
  order : int ;
  descr : Markdown.elements ;
  readme: Filepath.Normalized.t option ;
  mutable sections : section list ;
}

let order = ref 0
let pages : page Pages.t ref = ref Pages.empty
let plugins : string list ref = ref []
let entries : (string * Markdown.href) list ref = ref []
let path page = page.path
let href page name : Markdown.href = Section( page.path , name )

(* -------------------------------------------------------------------------- *)
(* --- Page Collection                                                    --- *)
(* -------------------------------------------------------------------------- *)

let chapter pg = pg.chapter

let path_for chapter filename =
  match chapter with
  | `Protocol -> "." , filename
  | `Kernel -> ".." , Printf.sprintf "kernel/%s" filename
  | `Plugin name -> "../.." , Printf.sprintf "plugins/%s/%s" name filename

let path_for_readme ~plugin filename =
  let dirname = match plugin with Kernel -> "server" | Plugin p -> p in
  Filepath.Normalized.concats
    (Filepath.Normalized.of_string ".")
    ["src";"plugins";dirname;"doc";filename]

let page chapter ~title ?(descr=[]) ?(plugin=Kernel) ~readme ~filename () =
  let rootdir , path = path_for chapter filename in
  try
    let other = Pages.find path !pages in
    Senv.failure "Duplicate page '%s' path@." path ; other
  with Not_found ->
    let order = incr order ; !order in
    let readme = Option.map (path_for_readme ~plugin) readme in
    let page = {
      order ; rootdir ; path ;
      chapter ; title ; descr ; readme ;
      sections=[] ;
    } in
    begin match chapter with
      | `Kernel | `Protocol -> ()
      | `Plugin p -> plugins := p :: !plugins
    end ;
    pages := Pages.add path page !pages ; page

let static () = []

let publish ~page ?name ?(index=[]) ~title
    ?(contents=[])
    ?(generated=static)
    () =
  let id = match name with Some id -> id | None -> title in
  let href = Md.Section( page.path , id ) in
  let section () = Markdown.section ?name ~title (contents @ generated ()) in
  List.iter (fun entry -> entries := (entry , href) :: !entries) index ;
  page.sections <- section :: page.sections ; href

let protocol ~title ~readme:filename =
  ignore (page `Protocol ~title ~readme:(Some filename) ~filename ())

let () = protocol ~title:"Architecture" ~readme:"server.md"

(* -------------------------------------------------------------------------- *)
(* --- Package Publication                                                --- *)
(* -------------------------------------------------------------------------- *)

let href_of_ident names id =
  let chapter = match id.plugin with
    | Kernel -> `Kernel | Plugin p -> `Plugin p in
  let filename =
    if id.package = [] then "index.md" else
      String.concat "_" id.package ^ ".md" in
  let page = snd @@ path_for chapter filename in
  let text = try IdMap.find id names with Not_found -> id.name in
  Md.link ~text:(Md.code text) ~page ~name:id.name ()

let page_of_package pkg =
  let chapter = match pkg.p_plugin with
    | Kernel -> `Kernel | Plugin p -> `Plugin p in
  let filename =
    if pkg.p_package = [] then "index.md" else
      String.concat "_" pkg.p_package ^ ".md" in
  try
    let _,path = path_for chapter filename in
    Pages.find path !pages
  with Not_found ->
    page chapter
      ~title:pkg.p_title
      ~descr:(Markdown.par pkg.p_descr)
      ~plugin:pkg.p_plugin
      ~readme:pkg.p_readme
      ~filename ()

let kind_of_decl = function
  | D_signal -> "SIGNAL"
  | D_value _ | D_state _ -> "STATE"
  | D_array _ -> "ARRAY"
  | D_type _ | D_record _ | D_enum _ -> "DATA"
  | D_request { rq_kind=`GET } -> "GET"
  | D_request { rq_kind=`SET } -> "SET"
  | D_request { rq_kind=`EXEC } -> "EXEC"
  | D_decoder _ | D_order _ | D_default _ -> assert false

let pp_for ?decl names =
  let self =
    match decl with
    | Some d ->
      let name = d.d_ident.name in
      Md.link ~text:(Md.code name) ~name ()
    | None ->
      Md.code "self"
  in Package.{ self ; ident = href_of_ident names }

let md_param ~kind pp prm =
  Md.emph kind @ Md.code "::=" @ match prm with
  | P_value jt -> Package.md_jtype pp jt
  | P_named _ -> Md.code "{" @ Md.emph (kind ^ "…") @ Md.code "}"

let md_named ~kind pp = function
  | P_value _ -> []
  | P_named prms ->
    let title = String.capitalize_ascii kind in
    Md.table (Package.md_fields ~title pp prms)

let md_signals signals =
  if signals = [] then []
  else
    Md.quote (Md.emph "signals") @
    Md.block Md.(list (List.map (fun x -> text (code x)) signals))

let descr_of_decl names decl =
  match decl.d_kind with
  | D_decoder _ | D_order _ | D_default _ -> assert false
  | D_signal -> []
  | D_state _ -> [] (* TBC *)
  | D_value _ -> [] (* TBC *)
  | D_array _ -> [] (* TBC *)
  | D_type data ->
    let pp = pp_for ~decl names in
    Md.quote (pp.self @ Md.code "::=" @ Package.md_jtype pp data)
  | D_record fields ->
    let pp = pp_for ~decl names in
    Md.quote (pp.self @ Md.code "::= {" @ Md.emph "fields…" @ Md.code "}") @
    Md.table (Package.md_fields pp fields)
  | D_enum tags ->
    let pp = pp_for ~decl names in
    Md.quote (pp.self @ Md.code "::=" @ Md.emph "tags…") @
    Md.table (Package.md_tags tags)
  | D_request rq ->
    let pp = pp_for names in
    Md.quote (md_param ~kind:"input" pp rq.rq_input) @
    Md.quote (md_param ~kind:"output" pp rq.rq_output) @
    md_named ~kind:"input" pp rq.rq_input @
    md_named ~kind:"output" pp rq.rq_output @
    md_signals rq.rq_signals

let declaration page names decl =
  match decl.d_kind with
  | D_decoder _ | D_order _ | D_default _ -> ()
  | _ ->
    let name = decl.d_ident.name in
    let fullname = name_of_ident decl.d_ident in
    let kind = kind_of_decl decl.d_kind in
    let title = Printf.sprintf "%s (`%s`)" fullname kind in
    let index = [ title ] in
    let contents = Markdown.par decl.d_descr in
    let generated () = descr_of_decl names decl in
    let href = publish ~page ~name ~title ~index ~contents ~generated () in
    ignore href

let package pkg =
  begin
    let page = page_of_package pkg in
    let names = Package.resolve pkg in
    List.iter (declaration page names) pkg.p_content ;
  end

(* -------------------------------------------------------------------------- *)
(* --- Tables of Content                                                  --- *)
(* -------------------------------------------------------------------------- *)

let title_of_chapter = function
  | `Protocol -> "Protocols"
  | `Kernel -> "Kernel"
  | `Plugin name -> "Plugin " ^ String.capitalize_ascii name

let pages_of_chapter c =
  let w = ref [] in
  Pages.iter
    (fun _ p -> if p.chapter = c then w := p :: !w) !pages ;
  List.sort (fun p q -> p.order - q.order) !w

let table_of_page p =
  Md.text (Md.link ~text:(Md.plain p.title) ~page:p.path ())

let table_of_chapter c =
  [Md.H2 (Markdown.plain (title_of_chapter c), None);
   Md.Block (Md.list (List.map table_of_page (pages_of_chapter c)))]

let table_of_contents () =
  table_of_chapter `Protocol @
  table_of_chapter `Kernel @
  List.concat
    (List.map
       (fun p -> table_of_chapter (`Plugin p))
       (List.sort_uniq String.compare !plugins))

module Cmap = Map.Make
    (struct
      type t = string list
      let compare = Stdlib.compare
    end)

let index_entry (title,href) =
  Md.text @@ Markdown.href ~text:(Md.plain title) href

let index () =
  let category name =
    match List.rev (String.split_on_char '.' name) with
    | [] -> []
    | _::rpath -> List.rev rpath in
  let cmap =
    List.fold_left
      (fun cs entry ->
         let c = category (fst entry) in
         let es = try Cmap.find c cs with Not_found -> [] in
         Cmap.add c (entry :: es) cs)
      Cmap.empty !entries in
  let by_name (a,_) (b,_) = String.compare a b in
  let categories = Cmap.fold
      (fun c es ces -> ( c , List.sort by_name es ) :: ces)
      cmap [] in
  begin
    List.fold_left
      (fun elements (c,es) ->
         let entries =
           Md.Block (Md.list @@ List.map index_entry es) :: elements in
         if c = [] then entries
         else
           let cname = String.concat "." c in
           let title = Printf.sprintf "Index of `%s`" cname in
           Md.H3(Md.plain title,None) :: entries
      ) [] categories
  end

let link ~toc ~title ~href : json =
  let link = [ "title" , `String title ; "href" , `String href ] in
  `Assoc (if not toc then link else ( "toc" , `Bool true ) ::  link)

let link_page page : json list =
  List.fold_right
    (fun p links ->
       if p.chapter = page.chapter then
         let toc = (p.path = page.path) in
         let href = Filename.basename p.path in
         link ~toc ~title:p.title ~href :: links
       else links
    ) (pages_of_chapter page.chapter) []

let maindata : json =
  `Assoc [
    "document", `String "Frama-C Server" ;
    "title",`String "Presentation" ;
    "root", `String "." ;
  ]

let metadata page : json =
  `Assoc [
    "document", `String "Frama-C Server" ;
    "chapter", `String (title_of_chapter page.chapter) ;
    "title", `String page.title ;
    "root", `String page.rootdir ;
    "link",`List (link_page page) ;
  ]

(* -------------------------------------------------------------------------- *)
(* --- Dump Documentation                                                 --- *)
(* -------------------------------------------------------------------------- *)

let pp_one_page ~root ~page ~title body =
  let full_path = Filepath.Normalized.concat root page in
  ignore (Extlib.mkdir ~parents:true (Filepath.dirname full_path) 0o755);
  try
    let chan = open_out (full_path:>string) in
    let fmt = Format.formatter_of_out_channel chan in
    let title = Md.plain title in
    Markdown.(pp_pandoc ~page fmt (pandoc ~title body))
  with Sys_error e ->
    Senv.fatal "Could not open file %a for writing: %s"
      Filepath.Normalized.pretty full_path e

(* Build section contents in reverse order *)
let build d s = List.fold_left (fun d s -> s() :: d) d s

let dump ~root ?(meta=true) () =
  begin
    Pages.iter
      (fun path page ->
         Senv.feedback "[doc] Page: '%s'" path ;
         let title = page.title in
         let intro = match page.readme with
           | None -> Markdown.section ~title page.descr
           | Some file ->
             if Filepath.exists file
             then Markdown.rawfile (file :> string) @ page.descr
             else (
               Senv.warning "Can not find %a file"
                 Filepath.Normalized.pretty file ;
               Markdown.section ~title page.descr)
         in
         let body = Markdown.subsections page.descr (build [] page.sections) in
         pp_one_page ~root ~page:path ~title (intro @ body) ;
         if meta then
           let path = Filepath.Normalized.concat root (path ^ ".json") in
           Yojson.Basic.to_file (path:>string) (metadata page) ;
      ) !pages ;
    Senv.feedback "[doc] Page: 'readme.md'" ;
    if meta then
      let path = Filepath.Normalized.concat root "readme.md.json" in
      Yojson.Basic.to_file (path:>string) maindata ;
      let body =
        [ Md.H1 (Md.plain "Presentation", None);
          Md.Block (Md.text (Md.format "Version %s" Fc_config.version))]
        @
        table_of_contents ()
        @
        [Md.H2 (Md.plain "Index", None)]
        @
        index ()
      in
      let title = "Presentation" in
      pp_one_page ~root ~page:"readme.md" ~title body
  end

let () =
  Boot.Main.extend begin
    fun () ->
      if not (Senv.Doc.is_empty ()) then
        let root = Senv.Doc.get () in
        if Filepath.is_dir root then
          begin
            Senv.feedback "[doc] Root: '%a'" Filepath.Normalized.pretty root ;
            Package.iter package ;
            dump ~root () ;
          end
        else
          Senv.error "[doc] File '%a' is not a directory"
            Filepath.Normalized.pretty root
  end

(* -------------------------------------------------------------------------- *)
OCaml

Innovation. Community. Security.

GitHub Discord Twitter Peertube RSS
About
Changelog Releases Industrial Users Academic Users Why OCaml
Ecosystem
Packages Community Events OCaml Planet Jobs
Resources
Install OCaml Get Started Platform Tools Language Manual Standard Library API Books Exercises Papers OCaml Playground Logo
Policies
Carbon Footprint Governance Privacy Code of Conduct