;; 公开文档：从一个 Fossil 仓库的某个分支读取 Markdown。
;; 根目录下的 .md 归入 General。每一层文件夹都是分类，名称用 " / " 连接。
;; 文章标题优先用文件开头的一级标题，否则用文件名。README 与 index 排在分类最前。
(defmodule lamina_docs
(export all))
(defun cache-key () 'lamina_docs_cache)
(defun general-label () "General")
;;---- 设置 ----
(defun saved-repo-id ()
(lamina_site_mgr:get 'docs_repo_id ""))
(defun saved-branch ()
(let ((branch (string:trim (lamina_site_mgr:get 'docs_branch ""))))
(if (=:= "" branch) "trunk" branch)))
(defun list-repos ()
(case (catch (lamina_db:q
"SELECT r.id, r.name, COALESCE(r.display_name,''), COALESCE(o.name,''), r.fossil_path, COALESCE(r.description,'') FROM repositories r LEFT JOIN organizations o ON r.organization_id=o.id ORDER BY COALESCE(o.name,''), r.name;"))
(rows (lists:map #'repo-row/1 rows))
(_ '())))
(defun repo-row (row)
(maps:from_list
(list (tuple 'id (to-int (lists:nth 1 row)))
(tuple 'name (to-str (lists:nth 2 row)))
(tuple 'display_name (to-str (lists:nth 3 row)))
(tuple 'org (to-str (lists:nth 4 row)))
(tuple 'path (to-str (lists:nth 5 row)))
(tuple 'description (to-str (lists:nth 6 row))))))
(defun repo-label (repo)
(let ((name (let ((display (maps:get 'display_name repo "")))
(if (=:= "" display) (maps:get 'name repo "") display)))
(org (maps:get 'org repo "")))
(if (=:= "" org) name (lists:flatten (list org " / " name)))))
(defun find-repo (repo-id)
(let ((id (to-int repo-id)))
(lists:search (lambda (repo) (=:= id (maps:get 'id repo))) (list-repos))))
(defun save (repo-id branch)
(let ((branch1 (string:trim (to-str branch))))
(case (find-repo repo-id)
('false `#(error "Select a repository."))
(`#(value ,_repo)
(cond
((lamina_library:claims-repo? repo-id) `#(error "That repository is already in the Library."))
((not (valid-branch? branch1)) `#(error "Enter a branch name."))
('true
(case (lamina_site_mgr:set 'docs_repo_id (to-str (to-int repo-id)))
('ok
(case (lamina_site_mgr:set 'docs_branch branch1)
('ok (progn (clear-cache) 'ok))
(`#(error ,reason) `#(error ,reason))
(_ `#(error "Could not save the branch."))))
(`#(error ,reason) `#(error ,reason))
(_ `#(error "Could not save the repository.")))))))))
(defun valid-branch? (name)
(and (> (length name) 0)
(< (length name) 200)
(not (lists:prefix "-" name))
(not (lists:member ".." (string:split name "/" 'all)))
(lists:all #'branch-char?/1 name)))
(defun branch-char? (char)
(or (and (>= char 128) (=< char 1114111))
(and (>= char 48) (=< char 57))
(and (>= char 65) (=< char 90))
(and (>= char 97) (=< char 122))
(lists:member char (list 45 46 47 95))))
(defun branches (repo-path)
(case (lamina_fossil:run (list "branch" "list" "-R" repo-path))
(`#(ok ,output) (parse-branches output))
(_ '())))
(defun parse-branches (output)
(lists:filtermap
(lambda (line)
(let ((name (string:trim (string:trim line 'leading "*"))))
(if (=:= "" name) 'false `#(true ,name))))
(split-lines output)))
(defun clear-cache ()
(catch (persistent_term:erase (cache-key)))
'ok)
;; 后台摘要：文章数和分类数只看文件路径，不展开正文。
(defun doc-counts (files)
(let ((articles (lists:filter #'markdown-file?/1 files)))
(maps:from_list
(list (tuple 'articles (length articles))
(tuple 'categories (length (lists:usort (lists:map #'dirname/1 articles))))))))
(defun file-size (path)
(case (file:read_file_info path)
(`#(ok ,info) (element 2 info))
(_ 0)))
(defun timeline-count (repo-path)
(case (lamina_fossil:run
(list "sql" "-R" repo-path "SELECT count(*) FROM event WHERE type='ci';"))
(`#(ok ,output) (parse-count output))
(_ 0)))
(defun parse-count (output)
(parse-count-chars (decode-text output) 0 'false))
(defun parse-count-chars (chars acc seen)
(case chars
('() (if seen acc 0))
(`(,char . ,rest)
(if (and (>= char 48) (=< char 57))
(parse-count-chars rest (+ (* acc 10) (- char 48)) 'true)
(if seen
acc
(parse-count-chars rest 0 'false))))))
(defun format-bytes (bytes)
(cond
((< bytes 1024)
(lists:flatten (io_lib:format "~p B" (list bytes))))
((< bytes 1048576)
(lists:flatten (io_lib:format "~.1f KB" (list (/ bytes 1024.0)))))
('true
(lists:flatten (io_lib:format "~.1f MB" (list (/ bytes 1048576.0)))))))
;;---- 读取仓库 ----
(defun source ()
(let ((id (saved-repo-id)))
(if (=:= "" id)
'none
(case (find-repo id)
('false `#(error "The selected repository no longer exists."))
(`#(value ,repo) `#(ok ,(maps:get 'path repo) ,(saved-branch)))))))
(defun serve (request-path)
(case (source)
('none 'unconfigured)
(`#(error ,message) `#(error ,message))
(`#(ok ,repo-path ,branch)
(serve repo-path branch "/docs" request-path))))
(defun serve (repo-path branch prefix request-path)
(case (cached-tree repo-path branch prefix)
(`#(ok ,tree) (resolve tree repo-path branch (clean-request request-path)))
(`#(error ,message) `#(error ,message))))
(defun cached-tree (repo-path branch)
(cached-tree repo-path branch "/docs"))
(defun cached-tree (repo-path branch prefix)
(let ((stamp (repo-stamp repo-path))
(key (tuple repo-path branch prefix))
(cache (cache-map)))
(case (maps:find key cache)
(`#(ok #(,stamp ,tree)) `#(ok ,tree))
(_
(case (load-tree repo-path branch prefix)
(`#(ok ,tree)
(persistent_term:put (cache-key) (maps:put key (tuple stamp tree) cache))
`#(ok ,tree))
(error error))))))
(defun cache-map ()
(let ((found (persistent_term:get (cache-key) #M())))
(if (is_map found) found #M())))
(defun repo-stamp (path)
(case (file:read_file_info path)
(`#(ok ,info) (tuple (element 2 info) (element 6 info)))
(_ 'missing)))
(defun load-tree (repo-path branch)
(load-tree repo-path branch "/docs"))
(defun load-tree (repo-path branch prefix)
(case (list-files repo-path branch)
(`#(ok ,files)
`#(ok ,(maps:from_list
(list (tuple 'files files)
(tuple 'categories (categories repo-path branch files prefix))))))
(error error)))
(defun list-files (repo-path branch)
(case (lamina_fossil:run (list "ls" "-r" branch "-R" repo-path))
(`#(ok ,output)
`#(ok ,(lists:filtermap #'keep-file/1 (split-lines (decode-text output)))))
(`#(error ,reason) `#(error ,(lamina_fossil:error-message reason)))))
(defun keep-file (line)
(case (clean-path line)
('error 'false)
(path (if (hidden-path? path) 'false `#(true ,path)))))
(defun categories (repo-path branch files)
(categories repo-path branch files "/docs"))
(defun categories (repo-path branch files prefix)
(let ((articles (lists:filtermap
(lambda (path)
(if (markdown-file? path)
(case (read-article repo-path branch path prefix)
(`#(ok ,article) `#(true ,article))
(_ 'false))
'false))
files)))
(sort-categories
(maps:fold
(lambda (dir group acc)
(cons group acc))
'()
(lists:foldl #'add-article/2 #M() articles)))))
(defun read-article (repo-path branch path)
(read-article repo-path branch path "/docs"))
(defun read-article (repo-path branch path prefix)
(case (cat repo-path branch path)
(`#(ok ,body0)
(let* ((body (decode-text body0))
((tuple title rest) (split-title (filename path) body))
(dir (dirname path)))
`#(ok ,(maps:from_list
(list (tuple 'path path)
(tuple 'dir dir)
(tuple 'label (category-label dir))
(tuple 'filename (filename path))
(tuple 'title title)
(tuple 'body rest)
(tuple 'prefix prefix)
(tuple 'url (article-url prefix path)))))))
(_ 'error)))
(defun add-article (article groups)
(let ((dir (maps:get 'dir article)))
(maps:update_with
dir
(lambda (group)
(maps:put 'articles (cons article (maps:get 'articles group)) group))
(maps:from_list
(list (tuple 'dir dir)
(tuple 'label (maps:get 'label article))
(tuple 'articles (list article))))
groups)))
(defun sort-categories (categories)
(let ((sorted (lists:map
(lambda (group)
(maps:put 'articles (sort-articles (maps:get 'articles group)) group))
categories)))
(lists:sort
(lambda (a b) (< (category-key a) (category-key b)))
sorted)))
(defun sort-articles (articles)
(lists:sort
(lambda (a b) (< (article-key a) (article-key b)))
articles))
(defun category-key (group)
(if (=:= "" (maps:get 'dir group))
(list 0 "")
(list 1 (string:lowercase (maps:get 'label group)))))
(defun article-key (article)
(let ((name (string:lowercase (maps:get 'filename article))))
(cond
((readme-name? name) (list 0 name))
((index-name? name) (list 1 name))
('true (list 2 name)))))
(defun readme-name? (name)
(or (=:= name "readme.md") (=:= name "readme.markdown")))
(defun index-name? (name)
(or (=:= name "index.md") (=:= name "index.markdown")))
(defun cat (repo-path branch filename)
(lamina_fossil:run (list "cat" filename "-r" branch "-R" repo-path)))
(defun resolve (tree repo-path branch request)
(if (=:= 'error request)
`#(not-found ,tree)
(let ((categories (maps:get 'categories tree '()))
(files (maps:get 'files tree '())))
(cond
((and (=:= "" request) (=:= '() (all-articles categories)))
`#(empty ,tree))
((=:= "" request)
`#(article ,tree ,(first-article categories)))
((lists:member request files)
(if (markdown-file? request)
(case (find-article categories request)
('none `#(not-found ,tree))
(article `#(article ,tree ,article)))
(serve-file repo-path branch request)))
('true
(case (find-article categories request)
('none `#(not-found ,tree))
(article `#(article ,tree ,article))))))))
(defun serve-file (repo-path branch filename)
(case (cat repo-path branch filename)
(`#(ok ,bytes) `#(file ,(mime filename) ,(list_to_binary bytes)))
(`#(error ,reason) `#(error ,(lamina_fossil:error-message reason)))))
(defun find-article (categories request)
(find-article-in (all-articles categories) request))
(defun find-article-in (articles request)
(case articles
('() 'none)
(`(,article . ,rest)
(if (or (=:= request (maps:get 'path article))
(=:= request (drop-ext (maps:get 'path article))))
article
(find-article-in rest request)))))
(defun all-articles (categories)
(lists:flatmap (lambda (group) (maps:get 'articles group '())) categories))
(defun first-article (categories)
(hd (all-articles categories)))
;;---- 目录（纯函数，测试用） ----
(defun catalog (paths)
(sort-categories
(maps:fold
(lambda (_dir group acc) (cons group acc))
'()
(lists:foldl
(lambda (path groups)
(case (article-from-path path)
('none groups)
(article (add-article article groups))))
#M()
paths))))
(defun article-from-path (path)
(case (clean-path path)
('error 'none)
(clean
(if (or (hidden-path? clean) (not (markdown-file? clean)))
'none
(let ((dir (dirname clean)))
(maps:from_list
(list (tuple 'path clean)
(tuple 'dir dir)
(tuple 'label (category-label dir))
(tuple 'filename (filename clean))
(tuple 'title (filename-title (filename clean)))
(tuple 'body "")
(tuple 'url (article-url clean)))))))))
(defun split-title (filename body)
(case (take-h1 body)
(`#(ok ,title ,rest) (tuple (string:trim title) rest))
(_ (tuple (filename-title filename) body))))
(defun take-h1 (text)
(case (drop-blank (split-lines text))
(`(,line . ,rest)
(case (h1-text line)
('none 'none)
(title `#(ok ,title ,(join-lines rest)))))
(_ 'none)))
(defun h1-text (line)
(if (lists:prefix "# " (string:trim line 'leading))
(string:trim (lists:nthtail 2 (string:trim line 'leading)))
'none))
(defun filename-title (filename)
(lists:map
(lambda (char) (if (or (=:= char 45) (=:= char 95)) 32 char))
(drop-ext filename)))
;;---- 路径 ----
(defun clean-path (path)
(let ((trimmed (string:trim (string:trim (to-str path) 'both "\r"))))
(case (collapse (string:split trimmed "/" 'all) '())
('error 'error)
(`#(ok ,()) 'error)
(`#(ok ,segs) (string:join segs "/")))))
(defun clean-request (path)
(let ((trimmed (string:trim (to-str path) 'both "/")))
(if (=:= "" trimmed)
""
(clean-path trimmed))))
(defun collapse (segs acc)
(case segs
('() `#(ok ,(lists:reverse acc)))
(`("" . ,rest) (collapse rest acc))
(`("." . ,rest) (collapse rest acc))
(`(".." . ,rest)
(case acc
('() 'error)
(`(,_ . ,more) (collapse rest more))))
(`(,seg . ,rest)
(if (or (hidden-seg? seg) (lists:member 0 seg))
'error
(collapse rest (cons seg acc))))))
(defun hidden-path? (path)
(lists:any #'hidden-seg?/1 (string:split path "/" 'all)))
(defun hidden-seg? (seg)
(lists:prefix "." seg))
(defun dirname (path)
(case (lists:droplast (string:split path "/" 'all))
('() "")
(dirs (string:join dirs "/"))))
(defun filename (path)
(lists:last (string:split path "/" 'all)))
(defun category-label (dir)
(if (=:= "" dir)
(general-label)
(string:join (string:split dir "/" 'all) " / ")))
(defun markdown-file? (path)
(let ((lower (string:lowercase (filename path))))
(or (lists:suffix ".md" lower) (lists:suffix ".markdown" lower))))
(defun drop-ext (path)
(let ((lower (string:lowercase path)))
(cond
((lists:suffix ".markdown" lower) (lists:sublist path 1 (- (length path) 9)))
((lists:suffix ".md" lower) (lists:sublist path 1 (- (length path) 3)))
('true path))))
(defun article-url (path)
(article-url "/docs" path))
(defun article-url (prefix path)
(lists:flatten (list (trim-prefix prefix) "/" (encode-path (drop-ext path)))))
(defun file-url (path)
(file-url "/docs" path))
(defun file-url (prefix path)
(lists:flatten (list (trim-prefix prefix) "/" (encode-path path))))
(defun trim-prefix (prefix)
(let ((text (to-str prefix)))
(if (and (> (length text) 0) (=:= (lists:last text) 47))
(lists:sublist text 1 (- (length text) 1))
text)))
(defun decode-url-path (path)
(string:join
(lists:map #'decode-url-segment/1 (string:split (to-str path) "/" 'all))
"/"))
(defun decode-url-segment (segment)
(if (not (lists:member 37 segment))
segment
(case (percent-bytes segment '())
('error segment)
(bytes
(case (unicode:characters_to_list (list_to_binary bytes))
(`#(error ,_ ,_) segment)
(`#(incomplete ,_ ,_) segment)
(chars chars))))))
(defun percent-bytes (chars acc)
(case chars
(`(37 ,high ,low . ,rest)
(case (hex-byte high low)
('error 'error)
(byte (percent-bytes rest (cons byte acc)))))
(`(,char . ,rest)
(percent-bytes rest (cons char acc)))
('() (lists:reverse acc))))
(defun hex-byte (high low)
(case (tuple (hex-value high) (hex-value low))
(`#(,h ,l) (when (and (is_integer h) (is_integer l)))
(+ (* h 16) l))
(_ 'error)))
(defun hex-value (char)
(cond
((and (>= char 48) (=< char 57)) (- char 48))
((and (>= char 65) (=< char 70)) (+ 10 (- char 65)))
((and (>= char 97) (=< char 102)) (+ 10 (- char 97)))
('true 'error)))
(defun encode-path (path)
(string:join (lists:map #'encode-segment/1 (string:split path "/" 'all)) "/"))
(defun encode-segment (segment)
(lists:flatten
(lists:map #'encode-byte/1
(binary_to_list (unicode:characters_to_binary (to-str segment))))))
(defun decode-text (output)
(let ((bin (cond
((is_binary output) output)
((is_list output) (catch (list_to_binary output)))
('true #""))))
(case bin
(`#(EXIT ,_) (to-str output))
(_
(case (unicode:characters_to_list bin)
(`#(error ,_ ,_) (to-str output))
(`#(incomplete ,_ ,_) (to-str output))
(chars chars))))))
(defun encode-byte (char)
(if (unreserved? char)
(list char)
(let ((hex "0123456789ABCDEF"))
(list 37 (lists:nth (+ 1 (div char 16)) hex)
(lists:nth (+ 1 (rem char 16)) hex)))))
(defun unreserved? (char)
(or (and (>= char 48) (=< char 57))
(and (>= char 65) (=< char 90))
(and (>= char 97) (=< char 122))
(lists:member char (list 45 46 95 126))))
(defun mime (path)
(let ((lower (string:lowercase path)))
(cond
((lists:suffix ".png" lower) "image/png")
((or (lists:suffix ".jpg" lower) (lists:suffix ".jpeg" lower)) "image/jpeg")
((lists:suffix ".gif" lower) "image/gif")
((lists:suffix ".webp" lower) "image/webp")
((lists:suffix ".svg" lower) "image/svg+xml")
((lists:suffix ".pdf" lower) "application/pdf")
((lists:suffix ".txt" lower) "text/plain; charset=utf-8")
((lists:suffix ".css" lower) "text/css; charset=utf-8")
('true "application/octet-stream"))))
;;---- Markdown ----
(defun render-markdown (text dir)
(lists:flatten (render-blocks (split-lines (to-str text)) (normalize-dir dir) '())))
(defun render-blocks (lines dir acc)
(case (drop-blank lines)
('() (lists:reverse acc))
(`(,line . ,rest)
(cond
((fence-open? line)
(let ((marker (fence-marker line)))
(let (((tuple body more) (take-fence rest marker)))
(render-blocks more dir (cons (code-html (fence-lang line marker) body) acc)))))
((not (=:= 'false (heading-level line)))
(render-blocks rest dir (cons (heading-html line dir) acc)))
((hr? line)
(render-blocks rest dir (cons "<hr>" acc)))
((quote-line? line)
(let (((tuple chunk more) (take-while #'quote-line?/1 (cons line rest))))
(render-blocks more dir (cons (quote-html chunk dir) acc))))
((table-start? line rest)
(let (((tuple chunk more) (take-table (cons line rest))))
(render-blocks more dir (cons (table-html chunk dir) acc))))
((not (=:= 'false (list-info line)))
(let (((tuple html more) (list-html (cons line rest) dir)))
(render-blocks more dir (cons html acc))))
('true
(let (((tuple chunk more) (take-paragraph (cons line rest))))
(render-blocks more dir (cons (paragraph-html chunk dir) acc))))))))
(defun fence-open? (line)
(let ((marker (fence-marker line)))
(>= (length marker) 3)))
(defun fence-marker (line)
(let ((trimmed (string:trim line)))
(take-same trimmed (if (lists:prefix "~" trimmed) 126 96) '())))
(defun take-same (chars char acc)
(case chars
(`(,c . ,rest) (when (=:= c char))
(take-same rest char (cons c acc)))
(_ (lists:reverse acc))))
(defun fence-lang (line marker)
(let ((trimmed (string:trim line)))
(string:trim (lists:nthtail (length marker) trimmed))))
(defun take-fence (lines marker)
(take-fence lines marker '()))
(defun take-fence (lines marker acc)
(case lines
('() (tuple (lists:reverse acc) '()))
(`(,line . ,rest)
(if (closing-fence? line marker)
(tuple (lists:reverse acc) rest)
(take-fence rest marker (cons line acc))))))
(defun closing-fence? (line marker)
(let ((trimmed (string:trim line)))
(and (lists:prefix marker trimmed)
(=:= "" (string:trim (lists:nthtail (length marker) trimmed))))))
(defun code-html (lang lines)
(let ((class (safe-lang lang)))
(list "<pre><code"
(if (=:= "" class) "" (list " class=\"language-" class "\""))
">" (escape (string:join lines "\n")) "</code></pre>")))
(defun safe-lang (lang)
(if (lists:all #'lang-char?/1 lang) lang ""))
(defun lang-char? (char)
(or (and (>= char 48) (=< char 57))
(and (>= char 65) (=< char 90))
(and (>= char 97) (=< char 122))
(lists:member char (list 43 45 95))))
(defun heading-level (line)
(heading-level (string:trim line 'leading) 0))
(defun heading-level (chars level)
(case chars
(`(35 . ,rest) (when (< level 6))
(heading-level rest (+ level 1)))
(`(32 . ,_rest) (when (> level 0))
level)
(_ 'false)))
(defun heading-html (line dir)
(let ((level (heading-level line))
(text (heading-text line)))
(list "<h" (integer_to_list level) ">" (render-inlines text dir) "</h" (integer_to_list level) ">")))
(defun heading-text (line)
(string:trim (drop-hashes (string:trim line 'leading))))
(defun drop-hashes (chars)
(case chars
(`(35 . ,rest) (drop-hashes rest))
(`(32 . ,rest) rest)
(_ chars)))
(defun hr? (line)
(let ((trimmed (string:trim line)))
(if (< (length trimmed) 3)
'false
(if (lists:all (lambda (char) (=:= char (hd trimmed))) trimmed)
(lists:member (hd trimmed) (list 42 45 95))
'false))))
(defun quote-line? (line)
(lists:prefix ">" (string:trim line 'leading)))
(defun quote-html (lines dir)
(list "<blockquote>" (render-markdown (join-lines (lists:map #'strip-quote/1 lines)) dir) "</blockquote>"))
(defun strip-quote (line)
(let ((rest (lists:nthtail 1 (string:trim line 'leading))))
(if (lists:prefix " " rest) (lists:nthtail 1 rest) rest)))
(defun table-start? (line rest)
(case rest
(`(,next . ,_)
(and (lists:member 124 line) (separator-row? next)))
(_ 'false)))
(defun separator-row? (line)
(let ((cells (table-cells line)))
(and (> (length cells) 0)
(lists:all #'separator-cell?/1 cells))))
(defun separator-cell? (cell)
(let ((trimmed (string:trim cell 'both ":")))
(and (>= (length trimmed) 3)
(lists:all (lambda (char) (=:= char 45)) trimmed))))
(defun take-table (lines)
(case lines
(`(,header ,_sep . ,rest)
(let (((tuple body more) (take-while #'table-row?/1 rest)))
(tuple (cons header body) more)))
(_ (tuple '() lines))))
(defun table-row? (line)
(and (/= "" (string:trim line)) (lists:member 124 line)))
(defun table-html (lines dir)
(case lines
(`(,header . ,body)
(list "<table><thead><tr>" (row-html "th" header dir) "</tr></thead><tbody>"
(lists:map (lambda (line) (list "<tr>" (row-html "td" line dir) "</tr>")) body)
"</tbody></table>"))
(_ "")))
(defun row-html (tag line dir)
(lists:map
(lambda (cell)
(list "<" tag ">" (render-inlines (string:trim cell) dir) "</" tag ">"))
(table-cells line)))
(defun table-cells (line)
(let ((cells (string:split line "|" 'all)))
(let ((trimmed (lists:map (lambda (cell) (string:trim cell)) cells)))
(drop-edge (drop-edge-last trimmed)))))
(defun drop-edge (cells)
(case cells
(`("" . ,rest) rest)
(_ cells)))
(defun drop-edge-last (cells)
(lists:reverse (drop-edge (lists:reverse cells))))
(defun list-info (line)
(let (((tuple indent rest) (split-indent line)))
(cond
((or (lists:prefix "- " rest) (lists:prefix "* " rest) (lists:prefix "+ " rest))
(tuple indent "ul" (lists:nthtail 2 rest)))
('true
(case (ol-text rest)
('none 'false)
(text (tuple indent "ol" text)))))))
(defun ol-text (chars)
(ol-text chars 0 chars))
(defun ol-text (chars count original)
(case chars
(`(,c . ,rest) (when (and (>= c 48) (=< c 57) (< count 6)))
(ol-text rest (+ count 1) original))
(`(46 32 . ,rest) (when (> count 0))
rest)
(_ 'none)))
(defun split-indent (line)
(split-indent line 0))
(defun split-indent (chars indent)
(case chars
(`(32 . ,rest) (split-indent rest (+ indent 1)))
(_ (tuple indent chars))))
(defun list-html (lines dir)
(let (((tuple indent kind _text) (list-info (hd lines))))
(let (((tuple items more) (take-items lines indent '())))
(tuple (render-items items kind dir) more))))
(defun take-items (lines indent acc)
(case lines
(`(,line . ,rest)
(case (list-info line)
((tuple ind kind text) (when (>= ind indent))
(if (> ind indent)
(case acc
('() (tuple (lists:reverse acc) lines))
(`(,item . ,older)
(let (((tuple nested more) (take-items lines ind '())))
(take-items more indent (cons (tuple (element 1 item) (element 2 item) nested) older)))))
(take-items rest indent (cons (tuple kind text '()) acc))))
(_ (tuple (lists:reverse acc) lines))))
(_ (tuple (lists:reverse acc) lines))))
(defun render-items (items kind dir)
(list "<" kind ">"
(lists:map
(lambda (item)
(let (((tuple _ text nested) item))
(list "<li>" (render-inlines text dir)
(if (=:= '() nested) "" (render-items nested (element 1 (hd nested)) dir))
"</li>")))
items)
"</" kind ">"))
(defun take-paragraph (lines)
(take-paragraph lines '()))
(defun take-paragraph (lines acc)
(case lines
('() (tuple (lists:reverse acc) '()))
(`(,line . ,rest)
(if (or (=:= "" (string:trim line)) (block-line? line rest))
(tuple (lists:reverse acc) lines)
(take-paragraph rest (cons line acc))))))
(defun block-line? (line rest)
(or (fence-open? line)
(not (=:= 'false (heading-level line)))
(hr? line)
(quote-line? line)
(not (=:= 'false (list-info line)))
(table-start? line rest)))
(defun paragraph-html (lines dir)
(list "<p>" (render-inlines (string:join lines " ") dir) "</p>"))
(defun render-inlines (text dir)
(lists:flatten (render-chars (to-str text) (normalize-dir dir) 10 '())))
(defun render-chars (chars dir prev acc)
(case chars
('() (lists:reverse acc))
(`(96 . ,_)
(let (((tuple count rest) (count-char chars 96 0)))
(case (find-ticks rest count '())
('error
(render-chars rest dir 96 (cons (lists:duplicate count 96) acc)))
(`#(ok ,code ,more)
(render-chars more dir 96 (cons (list "<code>" (escape code) "</code>") acc))))))
(`(33 91 . ,rest)
(case (read-link rest)
(`#(ok ,alt ,url ,more)
(render-chars more dir 41 (cons (img-tag alt url dir) acc)))
(_ (render-chars rest dir 91 (cons (escape-text "![") acc)))))
(`(91 . ,rest)
(case (read-link rest)
(`#(ok ,label ,url ,more)
(render-chars more dir 41 (cons (link-tag label url dir) acc)))
(_ (render-chars rest dir 91 (cons (escape-char 91) acc)))))
(`(42 42 . ,rest)
(case (read-until rest "**" '())
(`#(ok ,inner ,more)
(render-chars more dir 42 (cons (list "<strong>" (render-inlines inner dir) "</strong>") acc)))
(_ (render-chars rest dir 42 (cons "**" acc)))))
(`(42 . ,rest)
(case (read-until rest "*" '())
(`#(ok ,inner ,more)
(if (=:= "" inner)
(render-chars rest dir 42 (cons "*" acc))
(render-chars more dir 42 (cons (list "<em>" (render-inlines inner dir) "</em>") acc))))
(_ (render-chars rest dir 42 (cons "*" acc)))))
(`(95 95 . ,rest)
(if (boundary? prev)
(case (read-until rest "__" '())
(`#(ok ,inner ,more)
(render-chars more dir 95 (cons (list "<strong>" (render-inlines inner dir) "</strong>") acc)))
(_ (render-chars (cons 95 rest) dir prev acc)))
(render-chars (cons 95 rest) dir prev acc)))
(`(95 . ,rest)
(if (and (boundary? prev) (not (boundary? (peek rest))))
(case (read-until rest "_" '())
(`#(ok ,inner ,more)
(if (or (=:= "" inner) (not (boundary? (peek more))))
(render-chars rest dir 95 (cons "_" acc))
(render-chars more dir 95 (cons (list "<em>" (render-inlines inner dir) "</em>") acc))))
(_ (render-chars rest dir 95 (cons "_" acc))))
(render-chars rest dir 95 (cons "_" acc))))
(`(,char . ,rest)
(render-chars rest dir char (cons (escape-char char) acc)))))
(defun count-char (chars char count)
(case chars
(`(,c . ,rest) (when (=:= c char))
(count-char rest char (+ count 1)))
(_ (tuple count chars))))
(defun find-ticks (chars count acc)
(cond
((lists:prefix (lists:duplicate count 96) chars)
`#(ok ,(lists:reverse acc) ,(lists:nthtail count chars)))
('true
(case chars
('() 'error)
(`(,char . ,rest) (find-ticks rest count (cons char acc)))))))
(defun read-link (chars)
(case (read-until chars "](" '())
(`#(ok ,label ,after)
(case (read-until after ")" '())
(`#(ok ,url ,more) `#(ok ,label ,url ,more))
(_ 'error)))
(_ 'error)))
(defun read-until (chars marker acc)
(if (lists:prefix marker chars)
`#(ok ,(lists:reverse acc) ,(lists:nthtail (length marker) chars))
(case chars
('() 'error)
(`(,char . ,rest) (read-until rest marker (cons char acc))))))
(defun link-tag (label url dir)
(list "<a href=\"" (escape (rewrite-url url dir)) "\">" (render-inlines label dir) "</a>"))
(defun img-tag (alt url dir)
(list "<img src=\"" (escape (rewrite-url url dir)) "\" alt=\"" (escape alt) "\">"))
(defun normalize-dir (dir)
(case dir
(`#(,prefix ,path) (tuple (trim-prefix prefix) (to-str path)))
(path (tuple "/docs" (to-str path)))))
(defun rewrite-url (url dir0)
(let (((tuple prefix folder) (normalize-dir dir0))
(trimmed (string:trim url)))
(cond
((=:= "" trimmed) "#")
((lists:prefix "#" trimmed) trimmed)
((or (lists:prefix "https://" trimmed)
(lists:prefix "http://" trimmed)
(lists:prefix "mailto:" trimmed)
(lists:prefix "//" trimmed))
trimmed)
((lists:prefix "/" trimmed) trimmed)
((lists:prefix "javascript:" (string:lowercase trimmed)) "#")
('true
(case (resolve-relative folder trimmed)
('error "#")
(`#(ok ,path ,hash)
(lists:flatten
(list (if (markdown-file? path)
(article-url prefix path)
(file-url prefix path))
hash))))))))
(defun resolve-relative (dir url)
(let (((tuple path hash) (split-hash (strip-query url)))
(base (if (=:= "" dir) '() (string:split dir "/" 'all))))
(case (collapse (lists:append base (string:split path "/" 'all)) '())
('error 'error)
(`#(ok ,()) 'error)
(`#(ok ,segs) `#(ok ,(string:join segs "/") ,hash)))))
(defun split-hash (url)
(case (string:split url "#" 'leading)
(`(,path ,hash) (tuple path (lists:flatten (list "#" hash))))
(`(,path) (tuple path ""))
(_ (tuple url ""))))
(defun strip-query (url)
(hd (string:split url "?" 'leading)))
(defun boundary? (char)
(not (or (and (>= char 48) (=< char 57))
(and (>= char 65) (=< char 90))
(and (>= char 97) (=< char 122)))))
(defun peek (chars)
(case chars
('() 10)
(`(,char . ,_) char)))
(defun take-while (pred lines)
(take-while pred lines '()))
(defun take-while (pred lines acc)
(case lines
(`(,line . ,rest)
(if (funcall pred line)
(take-while pred rest (cons line acc))
(tuple (lists:reverse acc) lines)))
(_ (tuple (lists:reverse acc) lines))))
(defun drop-blank (lines)
(case lines
(`(,line . ,rest)
(if (=:= "" (string:trim line))
(drop-blank rest)
lines))
(_ lines)))
(defun split-lines (text)
(lists:map
(lambda (line) (string:trim line 'trailing "\r"))
(string:split (to-str text) "\n" 'all)))
(defun join-lines (lines)
(string:join lines "\n"))
(defun escape-text (text)
(escape text))
(defun escape-char (char)
(case char
(38 "&")
(60 "<")
(62 ">")
(34 """)
(39 "'")
(_ (list char))))
(defun escape (value)
(lists:flatten (lists:map #'escape-char/1 (to-str value))))
;; 模板和数据库文本是 UTF-8 字节，文章标题是 Unicode 码点。两边会落在同一个列表里。
;; 连续的 0–255 按 UTF-8 原样输出，大于 255 的码点再单独编码，避免页脚符号被二次编码。
(defun encode-html (body)
(iolist_to_binary (encode-chunks (lists:flatten body) '() '())))
(defun encode-chunks (items bytes acc)
(case items
('() (lists:reverse (cons (flush-bytes bytes) acc)))
(`(,item . ,rest)
(cond
((is_binary item)
(encode-chunks rest '() (cons item (cons (flush-bytes bytes) acc))))
((and (is_integer item) (> item 255))
(encode-chunks rest '()
(cons (unicode:characters_to_binary (list item))
(cons (flush-bytes bytes) acc))))
((is_integer item)
(encode-chunks rest (cons item bytes) acc))
('true
(encode-chunks rest bytes acc))))))
(defun flush-bytes (rev-bytes)
(if (=:= '() rev-bytes)
#""
(let ((bytes (lists:reverse rev-bytes)))
(let ((bin (list_to_binary bytes)))
(case (unicode:characters_to_binary bin)
(`#(error ,_ ,_) (unicode:characters_to_binary bytes))
(`#(incomplete ,_ ,_) (unicode:characters_to_binary bytes))
(ok ok))))))
(defun to-str (value)
(cond
((is_binary value) (binary_to_list value))
((is_list value) value)
((or (=:= 'undefined value) (=:= 'null value)) "")
('true (lists:flatten (io_lib:format "~p" (list value))))))
(defun to-int (value)
(case (catch
(cond
((is_integer value) value)
((is_binary value) (binary_to_integer value))
((is_list value) (list_to_integer (string:trim value)))
('true 0)))
(`#(EXIT ,_) 0)
(n n)))