# [ส] tui.janet
# ~ lexi hale <lexi@hale.su>
# ๐ฏ AGPLv3
# ? quick and extremely dirty rawterm interface
(use /alg)
# FIXME use ffi to directly munge termios where feasible
(defn raw [fd]
(os/execute ["stty" "raw" "-echo" "opost"] :p))
(defn unraw [fd]
(os/execute ["stty" "-raw" "echo"] :p))
(defmacro use-raw [fd]
~(upscope
(,raw ,fd)
(,defer ,unraw ,fd)))
(defmacro with-raw [fd & x]
~(do (,raw ,fd)
,;x
(,unraw ,fd)))
(def- capq-resp (peg/compile ~{
:lst (* '(+ (some (range "09"))
(constant "0"))
(? (* ";" :lst)))
:resp "\e[?"
:seq (* :resp (group :lst))
:tc (* :seq "c")
:pg (* :resp (number (any (range "09"))) "u")
:main (* (+ :pg (constant false))
:tc)
}))
(def- pg-flags {0x01 :E # disambig events
0x02 :e # report evt types
0x04 :k # keycode alts
0x08 :K # all keys as alts
0x16 :t}) # text
(defn release [env]
(defn send [& x] (ev/write (env :fd) (string ;x)))
(when (string/check-set (env :caps) :p)
(send "\e[<1u"))
(unraw (env :fd))
(:close (env :fd)))
(defn- read-until [pred fd]
(def buf @"")
(label matched
(forever
# (ev/write fd (string/format "buf: %j\r\n" buf))
(ev/read fd 1 buf)
(spit "dbgkeys" buf)
(def p (pred buf))
(when p (return matched p)))))
(defn- text-key [c & args]
(struct :text c
:key ((string/ascii-lower c) 0)
:case (c 0)
:base (c 0)
:how :press
;args))
(def- event-code-ptn (peg/compile ~{
:csi "\e["
:ss3 "\e\x4f"
:cs3 (+ :csi :ss3)
:key-basic (cmt (* :csi :keycode :keyev "~" )
,(fn [kc ks kb mods how]
(def basis
(case kc
2 :ins
3 :del
5 :pgup
6 :pgdn
7 :home
8 :end
(cond (<= 11 kc 24) (keyword :f (- kc 11))
:else :unknown)))
{:key basis
:mods mods
:how how}))
:key-magic (cmt (* :csi "1" :keyev '(+ (range "AF") "H" "P" "Q" "S"))
,(fn [mods how cue]
{:mods mods
:how how
:key (case cue
"A" :up "C" :rt
"B" :dn "D" :lf
"H" :home "F" :end
"E" :kp-begin )}))
:legacy-ctl (cmt '(range "\x01\x07" "\x0b\x0c" "\x0e\x1a")
,(fn [ccode]
(def code (+ 0x60 (ccode 0)))
(def lc (string/format "%c" code))
{ :text lc
:key code
:case code
:base code
:how :press
:mods :c }))
:key (+ (* "\x0D" (constant {:key :enter :how :press}))
(* (+ "\x7F" "\x08") (constant {:key :bksp :how :press}))
(* "\x09" (constant ,(text-key "\t" :key :tab)))
(* "\x00" (constant ,(text-key " " :key :sp :mods :c)))
:legacy-ctl
(* :cs3 "A" (constant {:key :up :how :press}))
(* :cs3 "B" (constant {:key :dn :how :press}))
(* :cs3 "C" (constant {:key :rt :how :press}))
(* :cs3 "D" (constant {:key :lf :how :press}))
(* :cs3 "E" (constant {:key :kp-begin :how :press}))
(+ (* :csi :keyspec "u")
(* "\e" (cmt :legacy-ctl
,(fn [c] (struct/with-proto c
:mods (keyword (get c :mods :) :a)))))
(* "\e" (not "[") (cmt '1 ,|(text-key $ :mods :a)))
(* (not "\e") (cmt '1 ,|(text-key $)))))
:ctl (cmt :num0 ,(fn [c]
(defn b [n k]
(if (not= 0 (band (- c 1) n)) k :))
(keyword (b 0x01 :s) (b 0x10 :H)
(b 0x02 :a) (b 0x20 :m)
(b 0x04 :c) (b 0x40 :C)
(b 0x08 :S) (b 0x80 :N))))
:keyev (+ (* ";" :ctl
(+ (* ":1" (constant :press))
(* ":2" (constant :repeat))
(* ":3" (constant :release))
(constant :press)))
(* ";" (constant :) (constant :press))
(* (constant :) (constant :press)))
:text (+ (cmt (group (some (* ";" :num0)))
,(fn [chars] #FIXME
(string ;(map |(string/format "%c" $) chars))))
(constant false))
:keycode (+ (* :num0 ":" :num0 ":" :num0)
(* :num0 ":" :num0 (constant false))
(* :num0 (constant false) (constant false)))
:keyspec (cmt (* :keycode :keyev :text)
,(fn keyspec-translate [kc ks kb mods how t]
(def basis
(case kc
9 {:key :tab }
13 {:key :enter }
127 {:key :bksp }
57358 {:key :lock-caps }
57360 {:key :lock-num }
57414 {:key :kp-enter }
57413 {:key :kp-plus :text "+"}
57412 {:key :kp-minus :text "-"}
57411 {:key :kp-mul :text "*"}
57410 {:key :kp-div :text "/"}
43 {:key :add :text "+"}
8722 {:key :sub :text "โ"}
215 {:key :mul :text "ร" }
243 {:key :div :text "รท" }
57441 {:key :shift-l} 57447 {:key :shift-r}
57443 {:key :alt-l} 57449 {:key :alt-r}
57444 {:key :super-l} 57450 {:key :super-r}
57445 {:key :hyper-l} 57451 {:key :hyper-r}
57442 {:key :ctl-l} 57448 {:key :ctl-r}
57453 {:key :lvl3}
57454 {:key :lvl5}
(cond (<= 57376 kc 57398) {:key (keyword :f (- kc 57363))}
:else {:key kc
:text (or t (string/format "%c" (or ks kc)))})))
{:text (get basis :text nil)
:key (get basis :key nil)
:case (or ks kc)
:base (or kb kc)
:mods mods
:how how}))
:main (* (+ :key-basic :key-magic :key) -1)
:num (some (range "09"))
:num0 (+ (number :num)
(constant 0))
}))
(def- color-cmd
(do (def env (os/environ))
(def ct (env "COLORTERM"))
(def term (env "TERM"))
(defn mode-char [mode]
(case mode :fg "3" :bg "4"
:fg-br "9" :bg-br "10"
(error "bad mode")))
(cond (or (= ct "truecolor")
(= term "xterm")) # modern xterm supports tc
(fn colorize-tc [mode rgb]
(as-> rgb v
(map |(math/floor (* 255 (clamp $))) v)
(string/join (map string v) ";")
(string "\e[" (mode-char mode) "8;2;" v "m")))
(or (string/has-suffix? "256color" term)
(not (nil? ct)))
(fn colorize-256 [mode rgb]
(def code (math/floor
(cond (= 0 ;rgb) 0
(= ;rgb) (lerp (rgb 0) 232 255)
:else (+ 16 ;(vect * [36 6 1]
(map clamp rgb))))))
(string "\e[" (mode-char mode) "8;5;" code "m"))
:else
(fn colorize-8 [mode rgb] "")))) #FIXME
(defn- vbar [tty f & grad]
(def c [ " " "โ" "โ" "โ" "โ" "โ
" "โ" "โ" "โ" ])
# (def fg (vect |(lerp f ;$&) bright dim))
(def fg (vlut f grad))
(def bg (vect |(lerp .5 ;$&) fg [0 0 0]))
(def idx (math/floor (* (max 0 (min 1 f))
(dec (length c)))))
(:color tty fg bg (c idx)))
(def- <env> {:close release
:write |(ev/write ($ :fd) $1)
:read |(ev/read ($ :fd) $1)
:color (fn tui:color [me fg bg str]
(as-> str cmd
(if fg (string (color-cmd :fg fg) cmd) cmd)
(if bg (string (color-cmd :bg bg) cmd) cmd)
(if (or fg bg) (string cmd "\e[m"))))
:vbar vbar
:await (fn tui:await [me]
# (print "awaiting")
(def [evt] (read-until |(peg/match event-code-ptn $) (me :fd)))
evt)})
# (def- chord-pat (peg/compile ~{
# :wd (some (* (not "-") wd))
# }))
(defn- subset [a b]
(var matches true)
(loop [[k v] :pairs a :while matches]
(when (not= v (get b k nil))
(set matches false)))
matches)
(defn chord [& fm]
(def ksym (last fm))
(def mods (keyword ;(slice fm 0 -2)))
(merge {:mods mods
:how :press}
(cond
(keyword? ksym) {:key ksym}
(string? ksym)
{#:text ksym
:key (in (string/ascii-lower ksym) 0)
:case (in ksym 0)})))
(defn event<chord? [evt & fm]
(subset evt (chord ;fm)))
(defn init [fd]
(raw fd)
(defn send [& x] (ev/write fd (string ;x)))
(defn recv [n &opt buf] (string (ev/read fd n buf)))
(var caps :)
(send "\e[?u\e[c") # query caps
(def lists (label done
(def buf @"")
(forever
(recv 1 buf)
(def m (peg/match capq-resp buf))
(when m
(return done m)))))
(defn set-caps! [which tbl]
(each e which
(when (has-key? tbl e)
(set caps (keyword caps (tbl e))))))
(set-caps! (lists 1) {
"4" :6 # sixel
})
(when (lists 0)
(set caps (keyword caps :p))
(each [c f] (pairs pg-flags)
(when (not= 0 (band c (lists 0)))
(set caps (keyword caps f)))))
(when (string/check-set caps :p)
(def fmap (invert pg-flags))
(def f (bor (lists 0) (fmap :k) (fmap :e) (fmap :K)))
(send "\e[>" (string (inc f) "u")))
(struct/with-proto <env>
:fd fd
:caps caps))