open Nonstd
module Legacy_string = String
module String = Sosa.Native_string
let dbg fmt = Printf.(ksprintf (eprintf "# %s\n")) fmt
module Meta_result = struct
type ('a, 'b) t = {
result: 'a;
more_things_todo: 'b list;
}
let return ?(more_things_todo=[]) result = {result; more_things_todo}
let bind m ~f =
let next = f m.result in
{ next with more_things_todo = next.more_things_todo @ m.more_things_todo}
let (>>=) m f = bind m ~f
end
module File_kind = struct
let check_and_remove_extension filename ~ext =
if Filename.check_suffix filename ext
then Some (Filename.chop_suffix filename ext)
else None
let identify_file filename =
begin match check_and_remove_extension filename ~ext:".md" with
| Some sub -> `Markdown sub
| None ->
begin match check_and_remove_extension filename ~ext:".ml" with
| Some sub -> `Ocaml_implementation sub
| None ->
begin match check_and_remove_extension filename ~ext:".mli" with
| Some sub -> `Ocaml_interface sub
| None -> `Other
end
end
end
end
module Markdown = struct
type 'a configuration = 'a constraint 'a = <
catch_module_paths: (string * Re.re * string) list;
..
>
let code_url code =
String.map code ~f:(function
| 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' as c -> c
| other -> '_')
^ ".html"
let looks_like_module_path ~configuration code =
List.exists configuration#catch_module_paths
~f:(fun (_, re, _) -> Re.execp re code)
let url_of_module_path ~configuration code =
let is_value v =
match v.[0] with
| None -> false
| Some c when Char.lowercase c = c -> true
| Some c -> false in
let rec loop acc =
function
| [] -> ""
| ["t"] -> acc ^ "html#TYPEt"
| [one] when is_value one -> acc ^ "html#VAL" ^ one
| [one] -> acc ^ one ^ ".html"
| modul :: more -> loop (acc ^ modul ^ ".") more
in
let prefix =
List.find_map configuration#catch_module_paths ~f:(fun (_, re, pr) ->
if Re.execp re code then Some pr else None)
|> Option.value ~default:"" in
loop ("api/" ^ prefix) (String.split code ~on:(`Character '.'))
let preprocess ~configuration content =
let highligh : Omd_representation.extension =
object
method parser_extension t read_tokens =
let open Omd_representation in
let highlight_style =
"color: red; background-color: yellow; font-weight: bold" in
function
| Exclamation :: Word w :: Exclamation :: more ->
let in_red = sprintf "<span style=%S>%s</span>" highlight_style w in
Some (Raw in_red :: t, read_tokens, more)
| m ->
None
method to_string = "highlight"
end
in
let more_stuff_to_do = ref [] in
let rec transform_links (t: Omd.element) : Omd.element =
let open Omd in
match t with
| Paragraph t -> Paragraph (List.map ~f:transform_links t)
| Emph t -> Emph (List.map ~f:transform_links t)
| Bold t -> Bold (List.map ~f:transform_links t)
| Ul tl -> Ul (List.map ~f:(List.map ~f:transform_links) tl)
| Ol tl -> Ol (List.map ~f:(List.map ~f:transform_links) tl)
| Ulp tl -> Ulp (List.map ~f:(List.map ~f:transform_links) tl)
| Olp tl -> Olp (List.map ~f:(List.map ~f:transform_links) tl)
| H1 t -> H1 (List.map ~f:transform_links t)
| H2 t -> H2 (List.map ~f:transform_links t)
| H3 t -> H3 (List.map ~f:transform_links t)
| H4 t -> H4 (List.map ~f:transform_links t)
| H5 t -> H5 (List.map ~f:transform_links t)
| H6 t -> H6 (List.map ~f:transform_links t)
| Blockquote t -> Blockquote (List.map ~f:transform_links t)
| Text _
| Br
| Hr
| Img_ref _
| Html _
| Html_block _
| Html_comment _
| NL
| X _
| Raw _ | Raw_block _
| Img _ as e -> e
| Code (lang, code) when
String.sub code ~index:(String.length code - 6) ~length:6
= Some "--help" ->
more_stuff_to_do := `Create_man_page code :: !more_stuff_to_do;
Url (code_url code, [Code (lang, code)], code)
| Code (lang, code) when looks_like_module_path ~configuration code ->
Url (url_of_module_path ~configuration code, [Code (lang, code)], code)
| Code (lang, code) -> Code (lang, code)
| Code_block (lang, code) as code_block ->
begin try
let (_ : Higlo.lexer) = Higlo.get_lexer lang in
Raw (
"<pre>"
^ (Higlo.to_xml ~lang code |> Xtmpl_xml.to_string)
^ "</pre>")
with _ -> code_block
end
| Url (href, t, title)
when String.sub href 0 7 = Some "http://"
|| String.sub href 0 8 = Some "https://"
|| String.sub href 0 6 = Some "ftp://"
-> Url (href, t, title)
| Url (href, t, title) ->
begin match File_kind.identify_file href with
| `Markdown m ->
Url (sprintf "./%s.html" (Filename.basename m),
List.map ~f:transform_links t, title)
| `Ocaml_interface m ->
let modname = Filename.basename m |> Legacy_string.capitalize in
Url (sprintf "api/%s.html" modname,
List.map ~f:transform_links t, title)
| `Ocaml_implementation m ->
Url (sprintf "%s.html" (Filename.basename m),
List.map ~f:transform_links t, title)
| `Other ->
Url (href, List.map ~f:transform_links t, title)
end
| Ref (ref_container, name, string, _) as e -> e
in
let make_paragraphs =
let module E = Omd_parser.Default_env(struct end) in
let module Parser = Omd_parser.Make(E) in
Parser.make_paragraphs in
Meta_result.return ~more_things_todo:!more_stuff_to_do (
Omd_parser.default_parse
~extensions:[highligh] (Omd_lexer.lex content)
|> make_paragraphs
|> List.map ~f:transform_links)
let to_html ~(configuration:_ configuration) content =
Meta_result.(
preprocess ~configuration content
>>= fun p ->
return Omd.(to_html p)
)
let to_toc ~configuration content =
Meta_result.(
preprocess ~configuration content
>>= fun p ->
return Omd.(to_html (toc ~start:[0] p))
)
let to_html_and_toc ~configuration content =
Meta_result.(
preprocess ~configuration content
>>= fun p ->
return Omd.(to_html p, to_html (toc ~start:[1] p))
)
end
module Ocaml = struct
open Meta_result
let to_html ~configuration code =
let remove_comments s =
String.sub_exn s ~index:3 ~length:(String.length s - 6)
in
let open Higlo in
let parsed = parse ~lang:"ocaml" code in
let flush_tokens revtoklist =
if List.for_all revtoklist
~f:(function Text t when String.strip t = "" -> true | _ -> false)
then ""
else
let html =
Xtmpl_xml.to_string
(List.rev_map ~f:Higlo.token_to_xml revtoklist) in
"<pre>" ^ html ^ "</pre>"
in
let rec loop acc_tokens acc_html acc_toc tokens =
match tokens with
| [] ->
(List.rev acc_toc |> String.concat ~sep:"\n"
|> Markdown.to_toc ~configuration)
>>= fun toc ->
return (List.rev (flush_tokens acc_tokens :: acc_html)
|> String.concat ~sep:"\n", toc)
| one :: more ->
begin match one with
| Bcomment com
| Lcomment com when String.sub com ~index:0 ~length:3 = Some "(*M" ->
let html_code = flush_tokens acc_tokens in
let comment_content = remove_comments com in
Markdown.to_html ~configuration comment_content
>>= fun html_comment ->
loop [] (html_comment :: html_code :: acc_html)
(comment_content :: acc_toc) more
| tok ->
loop (tok :: acc_tokens) acc_html acc_toc more
end
in
loop [] [] [] parsed
end
module Template = struct
let make_page ~title ~stylesheets ~toc ~menu content =
let link css =
sprintf "<link rel=\"stylesheet\" href=%S type=\"text/css\">" css in
Meta_result.return (
" <!DOCTYPE html> <html> <head>"
^ String.concat ~sep:"\n" (List.map stylesheets ~f:link)
^ "<meta charset=\"utf-8\">"
^ sprintf "<title>%s</title>" title
^ "</head>"
^ "<body><div class=\"container\">"
^ sprintf "<h1>%s</h1>" title
^ "<div class=\"row\">\n<div class=\"col-md-3\">\n<h2>Contents</h2>"
^ toc
^ "<h2>Menu</h2>"
^ menu
^ "</div><div class=\"col-md-9\">"
^ content
^ "</div></div></div></body><html>")
end
module Utilities = struct
let (//) = Filename.concat
let env s =
try Some (Sys.getenv s) with _ -> None
let failwithf fmt = ksprintf failwith fmt
let succeed s =
match Sys.command s with
| 0 -> ()
| other -> failwithf "Command %S did not succeed: %d" s other
let succeedf fmt= ksprintf succeed fmt
let all_files dir =
Sys.readdir dir |> Array.to_list
|> List.filter_map ~f:(fun d ->
let p = dir // d in
if Sys.is_directory p then None else Some p)
let read_file f =
let i = open_in f in
let buf = Buffer.create 42 in
let rec loop () =
try Buffer.add_channel buf i 1; loop () with _ -> () in
loop ();
close_in i;
Buffer.contents buf
let write_file f ~content =
let o = open_out f in
output_string o content;
close_out o
let parse_list_of_substitutions s =
let subs = String.split ~on:(`Character ',') s in
List.filter_map subs ~f:(fun sub ->
match String.split ~on:(`Character ':') (String.strip sub) with
| [one; two] -> Some (one, two)
| other -> None
)
end
open Utilities
let say fmt = Printf.(ksprintf (printf "%s\n")) fmt
let default_stylesheets = [
"https://cdn.rawgit.com/hammerlab/ketrew/2d1c430cca52caa71e363a765ff8775a6ae14ba9/src/doc/code_style.css";
"http://cdn.jsdelivr.net/bootstrap/3.1.1/css/bootstrap.min.css";
"http://cdn.jsdelivr.net/bootstrap/3.1.1/css/bootstrap-theme.min.css";
]
let configuration =
object (self)
method output_directory =
env "OUTPUT_DIR" |> Option.value ~default:"_doc"
method input_files =
env "INPUT" |> Option.value ~default:""
|> String.split ~on:(`Character ',')
|> List.map ~f:(fun path ->
try
if Sys.is_directory path
then all_files path
else [path]
with _ -> [])
|> List.concat
method index_file =
env "INDEX" |> Option.value ~default:"README.md"
method stylesheets =
env "CSS" |> Option.map ~f:(String.split ~on:(`Character ','))
|> Option.value ~default:default_stylesheets
method api_doc_directory =
env "API"
method title_prefix =
env "TITLE_PREFIX" |> Option.value ~default:""
method title_substitutions =
env "TITLE_SUBSTITUTIONS"
|> Option.value_map ~default:[] ~f:parse_list_of_substitutions
method title ?(with_prefix=true) t =
let tt =
List.find_map self#title_substitutions ~f:(function
| (a, b) when
a = t || (try Filename.chop_extension a = t with _ -> false) ->
Some b
| _ -> None)
|> function
| Some b -> b
| None ->
String.map t ~f:(function '_' -> ' ' | c -> c)
in
sprintf "%s%s" (if with_prefix then self#title_prefix else "") tt
method command_substitutions =
env "COMMAND_SUBSTITUTIONS"
|> Option.value_map ~default:[] ~f:parse_list_of_substitutions
method catch_module_paths =
env "CATCH_MODULE_PATHS"
|> Option.value_map ~default:[] ~f:parse_list_of_substitutions
|> List.filter_map ~f:(fun (pattern, prefix) ->
try Some (pattern, Re_posix.compile_pat pattern, prefix)
with _ -> None)
method add_to_menu =
env "ADD_TO_MENU"
|> Option.value ~default:""
method display =
let list_of_paths l =
(List.map l ~f:(sprintf " - %S") |> String.concat ~sep:"\n") in
let variable_note var =
say " (%S is %s)" var
(match env var with None -> "empty" | Some s -> sprintf "%S" s) in
say "Output directory: %s" self#output_directory;
variable_note "OUTPUT_DIR";
say "Input files:\n%s"
(list_of_paths self#input_files);
variable_note "INPUT";
say "Style sheets:\n%s" (list_of_paths self#stylesheets);
variable_note "CSS";
begin match self#api_doc_directory with
| Some s -> say "Getting API docs from: %S" s
| None -> say "No getting API docs (*Warning*)"
end;
variable_note "API";
say "Title prefix: %S" self#title_prefix;
variable_note "TITLE_PREFIX";
say "Command substitutions:";
List.iter self#command_substitutions (fun (a, b) -> say " - %s → %s" a b);
variable_note "COMMAND_SUBSTITUTIONS";
say "Index file: %s" self#index_file;
variable_note "INDEX";
say "Catch module paths:";
List.iter self#catch_module_paths (fun (a,_, b) ->
say " - %S → Prefix: %s" a b);
variable_note "CATCH_MODULE_PATHS";
say "Add to the menu: %S" self#add_to_menu;
variable_note "ADD_TO_MENU";
()
end
let main () =
let open Meta_result in
succeedf "mkdir -p %s" configuration#output_directory;
begin match configuration#api_doc_directory with
| Some s -> succeedf "rsync -a %s/ %s/api" s configuration#output_directory
| None -> say "Warning, no API docs"
end;
let menu_md =
sprintf "- [Home](index.html)\n"
:: (List.map configuration#input_files ~f:(fun path ->
match File_kind.identify_file path with
| `Markdown m
| `Ocaml_implementation m ->
let base = Filename.basename m in
let title = configuration#title ~with_prefix:false base in
sprintf "- [%s](%s.html)\n" title base
| other -> ""))
@ [
(match configuration#api_doc_directory with
| Some _ -> sprintf "- [API Documentation](./api/index.html)\n"
| None -> "");
configuration#add_to_menu; ]
|> String.concat ~sep:""
in
let first_pass_result : (unit, _) t =
Markdown.to_html ~configuration menu_md
>>= fun menu ->
Markdown.to_html_and_toc ~configuration (read_file configuration#index_file)
>>= fun (content, toc) ->
let title = configuration#title "Home" in
Template.make_page ~menu ~title ~stylesheets:configuration#stylesheets ~toc content
>>= fun markdown_index ->
write_file (configuration#output_directory // "index.html") ~content:markdown_index;
List.fold ~init:(return ()) configuration#input_files ~f:begin fun prev path ->
prev >>= fun () ->
match File_kind.identify_file path with
| `Markdown m ->
let base = Filename.basename m in
let title = configuration#title base in
Markdown.to_html_and_toc ~configuration (read_file path)
>>= fun (content, toc) ->
Template.make_page ~menu ~title ~stylesheets:configuration#stylesheets ~toc content
>>= fun content ->
write_file (configuration#output_directory // sprintf "%s.html" base) ~content;
return ()
| `Ocaml_implementation impl ->
let base = Filename.basename impl in
let title = configuration#title base in
Ocaml.to_html ~configuration (read_file path)
>>= fun (content, toc) ->
Template.make_page ~title ~menu ~stylesheets:configuration#stylesheets ~toc content
>>= fun content ->
write_file (configuration#output_directory // sprintf "%s.html" base) ~content;
return ()
| m ->
succeedf "cp %s %s/" (Filename.quote path) configuration#output_directory;
return ()
end
in
List.dedup first_pass_result.more_things_todo |> List.iter ~f:begin function
| `Create_man_page cmd ->
let actual_cmd =
let stripped = String.strip cmd in
List.find_map configuration#command_substitutions ~f:(fun (left, right) ->
match String.(sub stripped ~index:0 ~length:(length left)) with
| Some prefix when prefix = left ->
Some (right
^ String.(sub_exn stripped ~index:(length left)
~length:(length stripped - length left)))
| _ -> None) |> Option.value ~default:stripped
in
let output_file = configuration#output_directory // Markdown.code_url cmd in
begin try
let bash_cmd =
sprintf "set -o pipefail ; %s=groff | groff -Thtml -mandoc > %s"
actual_cmd output_file in
succeedf "bash -c %s" (Filename.quote bash_cmd)
with
| e ->
ignore (
succeedf "(echo '```' ; %s ; echo '```') > %s" actual_cmd output_file;
Markdown.to_html_and_toc ~configuration (read_file output_file)
>>= fun (content, toc) ->
Markdown.to_html ~configuration menu_md
>>= fun menu ->
Template.make_page ~menu ~title:cmd ~stylesheets:configuration#stylesheets ~toc:"" content
>>= fun content ->
write_file (output_file) ~content;
return ()
);
end;
end;
()
let () =
match Array.to_list Sys.argv with
| [ _ ] | [] -> main ()
| exec :: "--help" :: _
| exec :: "-h" :: _ ->
say "Usage: [ENV_VAR=...] %s" exec;
say "Current configuration:";
configuration#display
| exec :: other ->
say "Wrong command line";
exit 1