commit a035deb09d7d8b50240183700a6d0709e6a11c7e
parent 4b189d1fa7bd2174592cf2174b9a810be932eccb
Author: Daniel Barlow <dan@telent.net>
Date: Mon, 4 Aug 2025 23:20:11 +0100
textile: use lpeg for the code handling inline markup
this means we can handle (@code@) correctly, and also opens the way to
support __, ** etc if we find we've actually written any textile that
needs it
Diffstat:
| M | default.nix | | | 1 | + |
| M | textile.fnl | | | 167 | +++++++++++++++++++++++++++++++++++++++++-------------------------------------- |
2 files changed, 87 insertions(+), 81 deletions(-)
diff --git a/default.nix b/default.nix
@@ -30,6 +30,7 @@ let
readline
http
lcmark
+ lpeg
]);
pname = "cripslock";
in stdenv.mkDerivation {
diff --git a/textile.fnl b/textile.fnl
@@ -1,5 +1,9 @@
(import-macros { : define-tests : expect : expect= } :assert)
+(local lpeg (require :lpeg))
+(local loc (lpeg.locale))
+(local { : view } (require :fennel))
+
(local { : to-html } (require :html))
(local { : prepend } (require :lib))
@@ -69,78 +73,83 @@
;; @code@
;; %(classname)span%
+(fn merging-concat [tbl e]
+ (let [last (# tbl)
+ string? (fn [x] (= (type x) :string))]
+ (if (and (string? (. tbl last)) (string? e))
+ (tset tbl last (.. (. tbl last) e))
+ (table.insert tbl e))
+ tbl))
+
+(fn merge-strings [tbl]
+ (accumulate [o []
+ _ v (ipairs tbl)]
+ (merging-concat o v)))
+
+(define-tests :merge-strings
+ (expect= (merge-strings []) [])
+ (expect= (merge-strings ["a"]) ["a"])
+ (expect= (merge-strings ["a" "b" "j"]) ["abj"])
+ (expect= (merge-strings ["a" 7 "j"]) ["a" 7 "j"])
+ (expect= (merge-strings ["a" "b" 7 ",j"]) ["ab" 7 ",j"]))
+
+
+(fn trace [x]
+ (print :TRACE (view x))
+ x)
+
+(var inline-parser nil)
+(set
+ inline-parser
+ (let [{ : P : V : C : B : Cp : Ct : S} lpeg
+ special (S "_*\"@-")
+ except (fn [x] (^ (- (P 1) x) 1))
+ recurse #(merge-strings (inline-parser:match $1))]
+ (P {
+ 1 :elements
+ :elements (Ct (^ (V :element) 0))
+ :element (+
+ (/ (^ (except special) 1) #$1)
+ (V :strong)
+ (V :code)
+ (V :emph)
+ (V :link)
+ (V :del)
+ (C special))
+
+ :emph (* (P "_")
+ (/ (except (P "_")) #(prepend :em (recurse $1)))
+ (P "_"))
+
+ :strong (* (P "*")
+ (/ (except (P "*")) #(prepend :strong (recurse $1)))
+ (P "*"))
+
+ :del (* (B loc.space)
+ (P "-")
+ (/ (* (- (P 1) (S " -")) (except (P "-")))
+ #(prepend :del (recurse $1)))
+ (P "-"))
+
+ :code (* (B (S " ("))
+ (P "@")
+ (/ (except (P "@")) #[:code $1])
+ (P "@"))
+
+ :link (/ (* (P "\"") (C (except "\"")) (P "\":")
+ (C (except loc.space)))
+ #(prepend [:a {:href $2}] (recurse $1)))
+ })))
+
+(fn inline-markup [x] (merge-strings (inline-parser:match x)))
-;; walk the string from left to right. on encountering
-;; any recognised opening token for inline markup, find the
-;; matching closing token, and recursively walk the bit in the
-;; middle. Note that markup may be nested
-
-(fn scan-tok [endtok tag]
- (fn [f str]
- (let [(s e) (string.find str endtok 3 true)]
- (if s
- (values
- (doto (f (string.sub str 2 (- s 1)))
- (table.insert 1 tag))
- (string.sub str (+ e 1)))
- (values str "")
- ))))
-
-(local inline-tokens {
- "_" (scan-tok "_" :em)
- "*" (scan-tok "*" :strong)
- "@" (let [s (scan-tok "@" :code)]
- (fn [_ str] (s (fn [x] [x]) str)))
-
- "\"" (fn [f str]
- (let [(title url unparsed)
- (string.match str "^\"([^\"]-)\":(%g+)%f[%G](.*)$")]
- (if title
- (values
- (doto (f title)
- (table.insert 1 [:a {:href url} ]))
- unparsed)
- (values "\"" (string.sub str 2))
- )))
- ;; this one must be last
- "-" (scan-tok "-" :del)
- })
-
-(local inline-token-pattern
- (.. "%f[%g](["
- (accumulate [chrs ""
- c _ (pairs inline-tokens)]
- (.. "%" (string.sub c 1 1) chrs))
- "])%g"))
-
-(fn inline-markup [str]
- (if (or (not str) (= str ""))
- nil
- (case (string.find str inline-token-pattern)
- (start _end tok)
- (let [end (+ start -1 (# tok))
- (during after)
- ((. inline-tokens tok) inline-markup (string.sub str end))
- marked-after (or (inline-markup after) [])]
- (if (> start 1)
- (list-append
- [
- (string.sub str 1 (- start 1))
- during
- ]
- marked-after
- )
- (list-append
- [
- during
- ]
- marked-after
- )))
- _ [str])))
(define-tests :inline-markup
+ (expect= (inline-markup "") [])
+
(expect= (inline-markup "foo") ["foo"])
(expect= (inline-markup "foo _emph_") ["foo " [:em "emph"] ])
+ (expect= (inline-markup "foo -struck-") ["foo " [:del "struck"] ])
(expect= (inline-markup "foo @1+2+3@") ["foo " [:code "1+2+3"] ])
;; markup in code blocks is ignored
(expect= (inline-markup "foo @1+_2_+3@") ["foo " [:code "1+_2_+3"] ])
@@ -152,7 +161,7 @@
(expect= (inline-markup "foo @ example.com") ["foo @ example.com" ])
(expect= (inline-markup "say \"hello\" to my friend")
- ["say " "\"" "hello\" to my friend"])
+ ["say \"hello\" to my friend"])
(expect= (inline-markup "foo *strong*") ["foo " [:strong "strong"]])
@@ -178,9 +187,7 @@ image and rely on the \"kernel mtdsplit
code\":https://ww.telent.net/2018/4/16/flash_ah_ah to find the root
filesystem. ")
["when doing
-a "
- "\""
- "development\" build, now we make a single agglomerated firmware
+a \"development\" build, now we make a single agglomerated firmware
image and rely on the "
[["a" {:href "https://ww.telent.net/2018/4/16/flash_ah_ah"}]
"kernel mtdsplit
@@ -190,16 +197,14 @@ filesystem. "])
(expect= (inline-markup "use the --help option to be lied to")
- ["use the " "--help option to be lied to"])
-
- (comment
- ;; this one doesn't work and I can't see an wasy way to fix that
- (expect= (inline-markup
- "(@vmlinux@ is not actually required on the target, it's a leftover))")
- ["( "
- ["code" "vmlinux"]
- " is not actually required on the target, it's a leftover))"]
- ))
+ ["use the --help option to be lied to"])
+
+ (expect= (inline-markup
+ "(@vmlinux@ is not actually required on the target, it's a leftover))")
+ ["("
+ ["code" "vmlinux"]
+ " is not actually required on the target, it's a leftover))"]
+ )
)
