add styling support

2 files changed, 312 insertions, 0 deletions

diff --git a/doc/txt/txt.css b/doc/txt/txt.css
new file mode 100644
index 0000000..a012223
--- /dev/null
+++ b/doc/txt/txt.css
@@ -0,0 +1,4 @@
+h3 {
+	border-bottom: 1px solid #aaa;
+	background-color: #eee;
+}
diff --git a/doc/txt/txt.ml b/doc/txt/txt.ml
new file mode 100644
index 0000000..a753cc3
--- /dev/null
+++ b/doc/txt/txt.ml
@@ -0,0 +1,308 @@
+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<l && isspace s.[!i]
+      do incr i done;
+    while !j>=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 f ls =
+    match top lines with
+    | Some (n, i, l)
+      when i >= idnt
+        || dedent l (i+1) = "" ->
+      pop lines;
+      f (dedent l idnt :: ls)
+    | _ ->
+      let ls =
+        if List.hd ls = ""
+          then List.tl ls
+          else ls in
+      List.rev ls |>
+      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;
+          l
+        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 "&lt;"
+    | '>' -> printf "&gt;"
+    | '&' -> printf "&amp;"
+    | c   -> printf "%c" c in
+  let escape = String.iter pchar in
+  let plink l =
+    try
+      let (_, n) = Hashtbl.find titles l in
+      printf "<a href=\"#%d\">%s</a>" n l
+    with Not_found ->
+      warn "warning: unresolved link '%s'\n" l;
+      printf "<a href=\"#\">%s</a>" l in
+  let pcode s =
+    printf "<code>";
+    escape s;
+    printf "</code>"; in
+  let pp = {pchar; plink; pcode} in
+  let rec plist =
+    List.iter begin fun d ->
+      match d with
+      | Par p :: d ->
+        printf "<li>";
+        print pp p;
+        printf "\n";
+        dochtml titles d;
+      | d ->
+        printf "<li>";
+        dochtml titles d;
+    end in
+  let itemhtml = function
+    | Title (0, n, t) ->
+      printf "<h3><a id='%d'>" n;
+      escape t;
+      printf "</a></h3>\n";
+    | Title (_, n, t) ->
+      printf "<h4><a id='%d'>" n;
+      escape t;
+      printf "</a></h4>\n";
+    | Olist l ->
+      printf "<ol>\n";
+      plist l;
+      printf "</ol>\n";
+    | Ulist l ->
+      printf "<ul>\n";
+      plist l;
+      printf "</ul>\n";
+    | Verb (_, v) ->
+      printf "<pre>\n";
+      escape v;
+      printf "\n</pre>\n";
+    | Par p ->
+      printf "<p>\n";
+      print pp p;
+      printf "\n</p>\n"; in
+  List.iter itemhtml d
+
+let _ =
+  let lines = getlines [] 1 in
+  let titles = gettitles lines in
+  getdoc (ref lines) 0 [] |> dochtml titles