let dent = 4 type doc = item list and item = | Verb of string * string | Par of string | Ulist of doc list | Olist of doc list | Title of int * int * string let (|>) x f = f x let isspace = String.contains " \n\t" module String = struct include String let suff s n = let l = String.length s in if n >= l then "" else String.sub s n (l-n) let haspref p s = let lp = String.length p in String.length s >= lp && p = String.sub s 0 lp let trim s = let l = String.length s in let i = ref 0 and j = ref (l-1) in while !i=0 && isspace s.[!j] do decr j done; if !j = -1 then s else sub s !i (!j- !i+1) end let warn = Printf.eprintf let getdent s = let rec f n = if n >= String.length s then 0 else if s.[n] = ' ' then f (n+1) else if s.[n] = '\t' then f (n+8) else n/dent in f 0 let dedent s i = let rec f i j = if i <= 0 then (-i, j) else if j >= String.length s then (0, j) else if s.[j] = ' ' then f (i-1) (j+1) else if s.[j] = '\t' then f (i-8) (j+1) else (0, j) in let (p, j) = f (i*dent) 0 in String.make p ' ' ^ String.suff s j let rec getlines acc n = match try Some (read_line ()) with End_of_file -> None with | Some s -> getlines ((n, getdent s, s) :: acc) (n+1) | None -> List.rev acc let matchs skip fin s = let rec f n = if n >= String.length s then 0 else if s.[n] = fin then (n+1) else if String.contains skip s.[n] then f (n+1) else 0 in f 0 let endnum = matchs " 0123456789" '.' let endbul = matchs " " '*' let skipnum s = String.suff s (endnum s) let skipbul s = String.suff s (endbul s) let gettitles lines = let titles = Hashtbl.create 100 in let insert lvl n t = let t = String.trim (skipnum (String.suff t 2)) in if Hashtbl.mem titles t then warn "line %d: title has multiple definitions\n" n; Hashtbl.add titles t (lvl, n) in lines |> List.iter begin fun (n, lvl, t) -> if lvl <> 0 then () else if String.haspref "- " t then insert 0 n t else if String.haspref "~ " t then insert 1 n t else () end; titles let top lines = match !lines with | [] -> None | l :: _ -> Some l let pop lines = lines := List.tl !lines let push lines l = lines := l :: !lines let isolist l = endnum l <> 0 let isulist l = endbul l <> 0 let getverb lines idnt = let rec skip = function | s :: l when String.trim s = "" -> skip l | l -> l in let rec f ls = match top lines with | Some (n, i, l) when i >= idnt || String.trim l = "" -> pop lines; f (dedent l idnt :: ls) | _ -> skip ls |> List.rev |> String.concat "\n" in f [] let getpar lines idnt = let rec f ls = match top lines with | Some (n, i, l) when i = idnt && l <> "" && not (isolist l) && not (isulist l) -> pop lines; f (l :: ls) | _ -> List.rev ls |> String.concat "\n" in f [] let mergedoc = let rec aggreg f = function | (i :: is) as is'-> begin match f i with | Some l -> let l', is = aggreg f is in List.append l l', is | None -> [], is' end | is -> [], is in let ul = function Ulist l -> Some l | _ -> None in let ol = function Olist l -> Some l | _ -> None in let rec f d = match d with | Ulist _ :: _ -> let l, d = aggreg ul d in Ulist l :: f d | Olist _ :: _ -> let l, d = aggreg ol d in Olist l :: f d | i :: d -> i :: f d | [] -> [] in f let rec getdoc lines si acc = match top lines with | Some (n, i, l) -> if i = si && isolist l then begin (* Olist item *) pop lines; push lines (n, i+1, skipnum l); let li = getdoc lines (si+1) [] in getdoc lines si (Olist [li] :: acc); end else if i = si && isulist l then begin (* Ulist item *) pop lines; push lines (n, i+1, skipbul l); let li = getdoc lines (si+1) [] in getdoc lines si (Ulist [li] :: acc); end else if i > si then begin (* Verb item *) let ty = let l = dedent l i in if l.[0] <> '`' then "" else begin pop lines; String.suff l 1 end in let verb = getverb lines (si+1) in getdoc lines si (Verb (ty, verb) :: acc); end else if si = 0 && String.haspref "~ " l || si = 0 && String.haspref "- " l then begin (* Titles *) pop lines; let lvl = if l.[0] = '-' then 0 else 1 in let tit = String.suff l 2 in getdoc lines si (Title (lvl, n, tit) :: acc); end else if String.haspref "---" l || String.haspref "~~~" l || l = "" then begin (* Decorations *) pop lines; getdoc lines si acc; end else if i = si then begin (* Par item *) let par = getpar lines si in getdoc lines si (Par par :: acc); end else List.rev acc |> mergedoc | None -> List.rev acc |> mergedoc type printer = { pchar: char -> unit ; plink: string -> unit ; pcode: string -> unit } let print pp s = let l = String.length s in let rec getlink j spc = if j >= l || s.[j] = '>' then j+1, "" else if isspace s.[j] then getlink (j+1) true else let j', t = getlink (j+1) false in if spc then j', Printf.sprintf " %c%s" s.[j] t else j', Printf.sprintf "%c%s" s.[j] t in let getlink j = let j', s = getlink j false in j', String.trim s in let rec getdlim j d = if j >= l || s.[j] = d then j+1, "" else let j', t = getdlim (j+1) d in j', Printf.sprintf "%c%s" s.[j] t in let rec f i = if i >= l then () else match s.[i] with | '<' when i < l-1 && s.[i+1] = '@' -> let i, t = getlink (i+2) in pp.plink t; f i | '`' -> let i, t = getdlim (i+1) '`' in pp.pcode t; f i | c -> pp.pchar c; f (i+1) in f 0 let rec dochtml titles d = let open Printf in let pchar = function | '<' -> printf "<" | '>' -> printf ">" | '&' -> printf "&" | c -> printf "%c" c in let escape = String.iter pchar in let plink l = try let (_, n) = Hashtbl.find titles l in printf "%s" n l with Not_found -> warn "warning: unresolved link '%s'\n" l; printf "%s" l in let pcode s = printf ""; escape s; printf ""; in let pp = {pchar; plink; pcode} in let rec plist = List.iter begin fun d -> match d with | Par p :: d -> printf "
  • "; print pp p; printf "\n"; dochtml titles d; | d -> printf "
  • "; dochtml titles d; end in let itemhtml = function | Title (0, n, t) -> printf "

    " n; escape t; printf "

    \n"; | Title (_, n, t) -> printf "

    " n; escape t; printf "

    \n"; | Olist l -> printf "
      \n"; plist l; printf "
    \n"; | Ulist l -> printf "\n"; | Verb (cls, v) -> if cls <> "" then printf "
    " cls
          else printf "
    \n";
          escape v;
          printf "\n
    \n"; | Par p -> printf "

    \n"; print pp p; printf "\n

    \n"; in List.iter itemhtml d let _ = let lines = getlines [] 1 in let titles = gettitles lines in getdoc (ref lines) 0 [] |> dochtml titles