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