Use memo/ttl for git cache, uri-encode from std/net/uri, glob-match from std/text/glob
ober
146a975c98d822355abef67bd976c585aa64e1b2
--- a/lib/jerboa-emacs/qt/commands-core2.sls +++ b/lib/jerboa-emacs/qt/commands-core2.sls @@ -12,30 +12,30 @@ cmd-toggle-centered-cursor-mode *qt-tab-width* cmd-tab-to-tab-stop cmd-set-tab-width qt-json-pretty-print cmd-json-format-buffer cmd-json-minify-buffer - cmd-json-pretty-print-region uri-encode uri-decode - cmd-url-encode-region cmd-url-decode-region - qt-reverse-lines-in-string cmd-reverse-lines qt-shuffle - cmd-shuffle-lines cmd-xml-format qt-find-url-at-point - cmd-open-url-at-point cmd-compare-windows cmd-dedent-region - cmd-count-words-line cmd-diff-goto-source - cmd-find-file-by-path cmd-insert-date-iso cmd-org-schedule - cmd-org-deadline cmd-org-insert-src-block - *qt-org-clock-line* *qt-org-clock-heading* - qt-count-lines-before cmd-org-clock-in cmd-org-clock-out - cmd-org-clock-cancel cmd-org-clock-goto) + cmd-json-pretty-print-region cmd-url-encode-region + cmd-url-decode-region qt-reverse-lines-in-string + cmd-reverse-lines qt-shuffle cmd-shuffle-lines + cmd-xml-format qt-find-url-at-point cmd-open-url-at-point + cmd-compare-windows cmd-dedent-region cmd-count-words-line + cmd-diff-goto-source cmd-find-file-by-path + cmd-insert-date-iso cmd-org-schedule cmd-org-deadline + cmd-org-insert-src-block *qt-org-clock-line* + *qt-org-clock-heading* qt-count-lines-before + cmd-org-clock-in cmd-org-clock-out cmd-org-clock-cancel + cmd-org-clock-goto) (import (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex mutex? mutex-name sort sort!) (std sugar) (std sort) (std srfi srfi-13) (std text base64) - (std text json) (jerboa-emacs qt sci-shim) - (jerboa-emacs core) (jerboa-emacs subprocess) - (jerboa-emacs editor) (jerboa-emacs repl) - (jerboa-emacs eshell) (jerboa-emacs shell) - (jerboa-emacs terminal) (jerboa-emacs qt buffer) - (jerboa-emacs qt window) (jerboa-emacs persist) - (jerboa-emacs qt echo) (jerboa-emacs qt highlight) - (jerboa-emacs qt modeline) + (std text json) (only (std net uri) uri-encode uri-decode) + (jerboa-emacs qt sci-shim) (jerboa-emacs core) + (jerboa-emacs subprocess) (jerboa-emacs editor) + (jerboa-emacs repl) (jerboa-emacs eshell) + (jerboa-emacs shell) (jerboa-emacs terminal) + (jerboa-emacs qt buffer) (jerboa-emacs qt window) + (jerboa-emacs persist) (jerboa-emacs qt echo) + (jerboa-emacs qt highlight) (jerboa-emacs qt modeline) (only (jerboa-emacs editor-core) paredit-delimiter? @@ -322,54 +322,6 @@ (echo-message! (app-state-echo app) "JSON formatted")))))))) - (def (uri-encode str) - (let ([out (open-output-string)]) - (string-for-each - (lambda (ch) - (let ([code (char->integer ch)]) - (if (or (and (>= code 65) (<= code 90)) - (and (>= code 97) (<= code 122)) - (and (>= code 48) (<= code 57)) - (char=? ch #\-) - (char=? ch #\_) - (char=? ch #\.) - (char=? ch #\~)) - (write-char ch out) - (begin - (write-char #\% out) - (let ([hi (arithmetic-shift code -4)] - [lo (bitwise-and code 15)]) - (write-char (string-ref "0123456789ABCDEF" hi) out) - (write-char - (string-ref "0123456789ABCDEF" lo) - out)))))) - str) - (get-output-string out))) - (def (uri-decode str) - (let ([len (string-length str)] [out (open-output-string)]) - (let loop ([i 0]) - (if (>= i len) - (get-output-string out) - (let ([ch (string-ref str i)]) - (cond - [(char=? ch #\%) - (if (>= (+ i 2) len) - (begin (write-char ch out) (loop (+ i 1))) - (let* ([h (string-ref str (+ i 1))] - [l (string-ref str (+ i 2))] - [hex (string h l)] - [code (string->number hex 16)]) - (if code - (begin - (write-char (integer->char code) out) - (loop (+ i 3))) - (begin - (write-char ch out) - (loop (+ i 1))))))] - [(char=? ch #\+) - (write-char #\space out) - (loop (+ i 1))] - [else (write-char ch out) (loop (+ i 1))])))))) (def (cmd-url-encode-region app) "URL-encode the selected region." (let* ([ed (current-qt-editor app)] --- a/lib/jerboa-emacs/qt/modeline.sls +++ b/lib/jerboa-emacs/qt/modeline.sls @@ -10,47 +10,29 @@ (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex mutex? mutex-name) - (std sugar) (jerboa-emacs qt sci-shim) (jerboa-emacs core) + (std sugar) (only (std misc memo) memo/ttl) + (jerboa-emacs qt sci-shim) (jerboa-emacs core) (jerboa-emacs qt window) (jerboa core) (jerboa runtime)) - (def *git-branch-cache* (make-hash-table)) - (def *git-branch-cache-time* (make-hash-table)) - (def *git-cache-ttl* 5.0) + (def git-branch-for-dir + (memo/ttl + 5.0 + (lambda (dir) + (with-catch + (lambda (e) #f) + (lambda () + (let* ([proc (open-process + (list 'path: "/usr/bin/git" 'arguments: + (list "rev-parse" "--abbrev-ref" "HEAD") + 'directory: dir 'stdin-redirection: #f + 'stdout-redirection: #t + 'stderr-redirection: #t))] + [result (read-line proc)]) + (close-port proc) + (if (string? result) result #f))))))) (def (git-branch-for-file file-path) (if (not file-path) #f - (let ([dir (path-directory file-path)]) - (let ([cached-time (hash-get *git-branch-cache-time* dir)]) - (if (and cached-time - (< (- (time->seconds (current-time)) cached-time) - *git-cache-ttl*)) - (hash-get *git-branch-cache* dir) - (let ([branch (with-catch - (lambda (e) #f) - (lambda () - (let* ([proc (open-process - (list 'path: "/usr/bin/git" - 'arguments: - (list - "rev-parse" - "--abbrev-ref" - "HEAD") - 'directory: dir - 'stdin-redirection: - #f - 'stdout-redirection: - #t - 'stderr-redirection: - #t))] - [result (read-line proc)]) - (process-status proc) - (close-port proc) - (if (string? result) result #f))))]) - (hash-put! *git-branch-cache* dir branch) - (hash-put! - *git-branch-cache-time* - dir - (time->seconds (current-time))) - branch)))))) + (git-branch-for-dir (path-directory file-path)))) (def (mode-name-for-buffer buf) (let ([lang (buffer-lexer-lang buf)]) (case lang --- a/src/jerboa-emacs/editor-extra-final.ss +++ b/src/jerboa-emacs/editor-extra-final.ss @@ -10,6 +10,7 @@ :std/misc/process :std/misc/ports :std/srfi/19 + (only-in :std/text/glob glob-match?) ./pregexp-compat :chez-scintilla/constants :chez-scintilla/scintilla @@ -438,17 +439,8 @@ (reverse result))) (def (editorconfig-glob-match? pattern filename) - "Simple glob matching for editorconfig patterns." - (let ((basename (path-strip-directory filename)) - (ext (path-extension filename))) - (cond - ((string=? pattern "*") #t) - ((string-prefix? "*." pattern) - ;; Match by extension: *.py matches .py files - (let ((pat-ext (substring pattern 1 (string-length pattern)))) - (string-suffix? pat-ext basename))) - ((string-prefix? "[" pattern) #t) ;; Simplified: match all bracket patterns - (else (string=? pattern basename))))) + "Glob matching for editorconfig patterns." + (glob-match? pattern (path-strip-directory filename))) (def (find-editorconfig filepath) "Search up from filepath for .editorconfig files, return merged settings." --- a/src/jerboa-emacs/editor-extra-web.ss +++ b/src/jerboa-emacs/editor-extra-web.ss @@ -10,6 +10,7 @@ :std/misc/process :std/misc/shuffle :std/text/json + (only-in :std/net/uri uri-encode uri-decode) :chez-scintilla/constants :chez-scintilla/scintilla :chez-scintilla/tui @@ -516,60 +517,10 @@ ;;; URL encode/decode ;;;============================================================================ -(def (url-encode str) - "Percent-encode a string for URLs." - (let ((out (open-output-string))) - (let loop ((i 0)) - (when (< i (string-length str)) - (let ((ch (string-ref str i))) - (cond - ((or (char-alphabetic? ch) (char-numeric? ch) - (memv ch '(#\- #\_ #\. #\~))) - (write-char ch out)) - ((char=? ch #\space) - (write-char #\+ out)) - (else - (let ((b (char->integer ch))) - (display "%" out) - (when (< b 16) (write-char #\0 out)) - (display (number->string b 16) out))))) - (loop (+ i 1)))) - (get-output-string out))) - -(def (hex-digit-value ch) - "Convert hex digit char to integer value." - (cond - ((and (char>=? ch #\0) (char<=? ch #\9)) - (- (char->integer ch) (char->integer #\0))) - ((and (char>=? ch #\a) (char<=? ch #\f)) - (+ 10 (- (char->integer ch) (char->integer #\a)))) - ((and (char>=? ch #\A) (char<=? ch #\F)) - (+ 10 (- (char->integer ch) (char->integer #\A)))) - (else #f))) - -(def (url-decode str) - "Decode a percent-encoded URL string." - (let ((out (open-output-string)) - (len (string-length str))) - (let loop ((i 0)) - (when (< i len) - (let ((ch (string-ref str i))) - (cond - ((and (char=? ch #\%) (< (+ i 2) len)) - (let ((h1 (hex-digit-value (string-ref str (+ i 1)))) - (h2 (hex-digit-value (string-ref str (+ i 2))))) - (if (and h1 h2) - (begin - (write-char (integer->char (+ (* h1 16) h2)) out) - (loop (+ i 3))) - (begin (write-char ch out) (loop (+ i 1)))))) - ((char=? ch #\+) - (write-char #\space out) - (loop (+ i 1))) - (else - (write-char ch out) - (loop (+ i 1))))))) - (get-output-string out))) +;; url-encode / url-decode are now provided by (std net uri) as uri-encode / uri-decode. +;; Keep aliases for compatibility with existing call sites. +(def url-encode uri-encode) +(def url-decode uri-decode) (def (cmd-url-encode-region app) "URL-encode the selected region." --- a/src/jerboa-emacs/modeline.ss +++ b/src/jerboa-emacs/modeline.ss @@ -7,6 +7,7 @@ (export modeline-draw!) (import :std/sugar + (only-in :std/misc/memo memo/ttl) :chez-scintilla/constants :chez-scintilla/scintilla :chez-scintilla/tui @@ -37,34 +38,27 @@ ;;; Git branch detection (cached) ;;;============================================================================ -(def *git-branch-cache* (make-hash-table)) -(def *git-branch-cache-time* (make-hash-table)) -(def *git-cache-ttl* 5.0) +(def git-branch-for-dir + (memo/ttl 5.0 + (lambda (dir) + (with-catch + (lambda (e) #f) + (lambda () + (let-values (((in-port out-port err-port pid) + (open-process-ports + (string-append "cd " dir " && git rev-parse --abbrev-ref HEAD 2>/dev/null") + (buffer-mode block) + (native-transcoder)))) + (close-port out-port) + (close-port err-port) + (let ((result (read-line in-port))) + (close-port in-port) + (if (string? result) result #f)))))))) (def (git-branch-for-file file-path) "Get current git branch for a file's directory, with caching." (if (not file-path) #f - (let ((dir (path-directory file-path))) - (let ((cached-time (hash-get *git-branch-cache-time* dir))) - (if (and cached-time - (< (- (time->seconds (current-time)) cached-time) *git-cache-ttl*)) - (hash-get *git-branch-cache* dir) - (let ((branch (with-catch - (lambda (e) #f) - (lambda () - (let-values (((in-port out-port err-port pid) - (open-process-ports - (string-append "cd " dir " && git rev-parse --abbrev-ref HEAD 2>/dev/null") - (buffer-mode block) - (native-transcoder)))) - (close-port out-port) - (close-port err-port) - (let ((result (read-line in-port))) - (close-port in-port) - (if (string? result) result #f))))))) - (hash-put! *git-branch-cache* dir branch) - (hash-put! *git-branch-cache-time* dir (time->seconds (current-time))) - branch)))))) + (git-branch-for-dir (path-directory file-path)))) ;;;============================================================================ ;;; Mode name detection --- a/src/jerboa-emacs/qt/commands-core2.ss +++ b/src/jerboa-emacs/qt/commands-core2.ss @@ -9,6 +9,7 @@ :std/srfi/13 :std/text/base64 :std/text/json + (only-in :std/net/uri uri-encode uri-decode) :jerboa-emacs/qt/sci-shim :jerboa-emacs/core :jerboa-emacs/subprocess @@ -317,49 +318,7 @@ ;;; URL encode / decode ;;;============================================================================ -;; Simple URI percent-encoding (RFC 3986 unreserved chars pass through) -(def (uri-encode str) - (let ((out (open-output-string))) - (string-for-each - (lambda (ch) - (let ((code (char->integer ch))) - (if (or (and (>= code 65) (<= code 90)) ;; A-Z - (and (>= code 97) (<= code 122)) ;; a-z - (and (>= code 48) (<= code 57)) ;; 0-9 - (char=? ch #\-) (char=? ch #\_) - (char=? ch #\.) (char=? ch #\~)) - (write-char ch out) - (begin - (write-char #\% out) - (let ((hi (arithmetic-shift code -4)) - (lo (bitwise-and code #xf))) - (write-char (string-ref "0123456789ABCDEF" hi) out) - (write-char (string-ref "0123456789ABCDEF" lo) out)))))) - str) - (get-output-string out))) - -(def (uri-decode str) - (let ((len (string-length str)) - (out (open-output-string))) - (let loop ((i 0)) - (if (>= i len) - (get-output-string out) - (let ((ch (string-ref str i))) - (cond - ((char=? ch #\%) - (if (>= (+ i 2) len) - (begin (write-char ch out) (loop (+ i 1))) - (let* ((h (string-ref str (+ i 1))) - (l (string-ref str (+ i 2))) - (hex (string h l)) - (code (string->number hex 16))) - (if code - (begin (write-char (integer->char code) out) (loop (+ i 3))) - (begin (write-char ch out) (loop (+ i 1))))))) - ((char=? ch #\+) - (write-char #\space out) (loop (+ i 1))) - (else - (write-char ch out) (loop (+ i 1))))))))) +;; uri-encode / uri-decode now provided by (std net uri) import above. (def (cmd-url-encode-region app) "URL-encode the selected region." --- a/src/jerboa-emacs/qt/modeline.ss +++ b/src/jerboa-emacs/qt/modeline.ss @@ -9,38 +9,32 @@ *modeline-narrow-provider*) (import :std/sugar + (only-in :std/misc/memo memo/ttl) :jerboa-emacs/qt/sci-shim :jerboa-emacs/core :jerboa-emacs/qt/window) -(def *git-branch-cache* (make-hash-table)) -(def *git-branch-cache-time* (make-hash-table)) -(def *git-cache-ttl* 5.0) +(def git-branch-for-dir + (memo/ttl 5.0 + (lambda (dir) + (with-catch + (lambda (e) #f) + (lambda () + (let* ((proc (open-process + (list path: "/usr/bin/git" + arguments: ["rev-parse" "--abbrev-ref" "HEAD"] + directory: dir + stdin-redirection: #f + stdout-redirection: #t + stderr-redirection: #t))) + (result (read-line proc))) + ;; Omit process-status (Qt SIGCHLD race) + (close-port proc) + (if (string? result) result #f))))))) (def (git-branch-for-file file-path) (if (not file-path) #f - (let ((dir (path-directory file-path))) - (let ((cached-time (hash-get *git-branch-cache-time* dir))) - (if (and cached-time - (< (- (time->seconds (current-time)) cached-time) *git-cache-ttl*)) - (hash-get *git-branch-cache* dir) - (let ((branch (with-catch - (lambda (e) #f) - (lambda () - (let* ((proc (open-process - (list path: "/usr/bin/git" - arguments: ["rev-parse" "--abbrev-ref" "HEAD"] - directory: dir - stdin-redirection: #f - stdout-redirection: #t - stderr-redirection: #t))) - (result (read-line proc))) - (process-status proc) - (close-port proc) - (if (string? result) result #f)))))) - (hash-put! *git-branch-cache* dir branch) - (hash-put! *git-branch-cache-time* dir (time->seconds (current-time))) - branch)))))) + (git-branch-for-dir (path-directory file-path)))) (def (mode-name-for-buffer buf) (let ((lang (buffer-lexer-lang buf)))