Implement Tier 2: backend-agnostic modules (9 files, 81 tests passing)
ober
2ec34b91e1a7533b543a59cf40c9c02b08b4465e
new file mode 100644 --- /dev/null +++ b/lib/jerboa-emacs/async.sls @@ -0,0 +1,329 @@ +#!chezscheme +;;; async.sls — Async infrastructure for jemacs SMP +;;; +;;; Ported from gerbil-emacs/async.ss +;;; Provides a unified UI action queue, async process runners, +;;; async file I/O, and a periodic task scheduler. +;;; UPGRADE: Uses jerboa native threads (no Gambit SMP pinning needed — +;;; Chez uses native OS threads, so any thread can make UI calls if synchronized). + +(library (jerboa-emacs async) + (export + ;; UI action queue + ui-queue-push! + ui-queue-drain! + + ;; Async command runner + async-process! + async-process-stream! + + ;; Async file I/O + async-read-file! + async-write-file! + + ;; Async eval (background thunk → UI callback) + async-eval! + + ;; Periodic task scheduler + schedule-periodic! + master-timer-tick! + current-time-ms + + ;; Background services + file-index + start-file-indexer! + stop-file-indexer! + file-index-lookup + git-status-cache + start-git-watcher! + stop-git-watcher! + flycheck-trigger + flycheck-trigger! + start-flycheck-watcher! + stop-flycheck-watcher!) + (import (except (chezscheme) + make-hash-table hash-table? iota 1+ 1- sort sort! atom?) + (jerboa core) + (jerboa runtime) + (std sugar) + (std srfi srfi-13) + (only (std misc string) string-split) + (std misc channel) + (std misc atom) + (std misc process) + (only (jerboa prelude) path-strip-directory) + (only (std misc thread) thread-sleep!) + (jerboa-emacs core)) + + ;;;============================================================================ + ;;; UI Action Queue + ;;;============================================================================ + + (def *ui-queue* (make-channel 4096)) + + (def (ui-queue-push! thunk) + (with-catch + (lambda (e) (void)) + (lambda () (channel-put *ui-queue* thunk)))) + + (def (ui-queue-drain!) + (let loop ((n 0)) + (when (< n 64) + (let-values (((action ok) (channel-try-get *ui-queue*))) + (when ok + (with-catch + (lambda (e) (jemacs-log! (string-append "UI queue error: " (format "~a" e)))) + (lambda () (action))) + (loop (+ n 1))))))) + + ;;;============================================================================ + ;;; Periodic Task Scheduler + ;;;============================================================================ + + (def *scheduled-tasks* '()) + + (def (current-time-ms) + (let ((t (current-time))) + (+ (* (time-second t) 1000) + (quotient (time-nanosecond t) 1000000)))) + + (def (schedule-periodic! name interval-ms thunk) + (set! *scheduled-tasks* + (cons (list name interval-ms 0 thunk) *scheduled-tasks*))) + + (def (master-timer-tick!) + (ui-queue-drain!) + (let ((now (current-time-ms))) + (set! *scheduled-tasks* + (map (lambda (task) + (let ((name (car task)) + (interval (cadr task)) + (last (caddr task)) + (thunk (cadddr task))) + (if (>= (- now last) interval) + (begin + (with-catch + (lambda (e) + (jemacs-log! (string-append "Timer error in " + (if (string? name) name (symbol->string name)) + ": " (format "~a" e)))) + thunk) + (list name interval now thunk)) + task))) + *scheduled-tasks*)))) + + ;;;============================================================================ + ;;; Async Process Runner + ;;;============================================================================ + + (def (async-process! cmd callback . rest) + (let ((on-error (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) #f)) + (stdin-text (if (and (pair? rest) (pair? (cdr rest)) (pair? (cddr rest)) (pair? (cdddr rest))) + (cadddr rest) #f))) + (fork-thread + (lambda () + (with-catch + (lambda (e) + (ui-queue-push! + (lambda () + (if on-error (on-error e) + (jemacs-log! (string-append "async-process error: " (format "~a" e))))))) + (lambda () + (let ((result (run-process (list "/bin/sh" "-c" cmd)))) + (ui-queue-push! (lambda () (callback result)))))))))) + + (def (async-process-stream! cmd on-line . rest) + (let ((on-done (if (pair? rest) (car rest) #f)) + (on-error (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) #f))) + (fork-thread + (lambda () + (with-catch + (lambda (e) + (ui-queue-push! + (lambda () + (if on-error (on-error e) + (jemacs-log! (string-append "async-process-stream error: " (format "~a" e))))))) + (lambda () + (let ((pp (open-process (list "/bin/sh" "-c" cmd)))) + (let ((stdout (process-port-rec-stdout-port pp))) + (let loop () + (let ((line (get-line stdout))) + (if (eof-object? line) + (begin + (close-port stdout) + (when on-done + (ui-queue-push! on-done))) + (begin + (ui-queue-push! (lambda () (on-line line))) + (loop))))))))))))) + + ;;;============================================================================ + ;;; Async File I/O + ;;;============================================================================ + + (def (async-read-file! path callback) + (fork-thread + (lambda () + (let ((content (with-catch (lambda (e) #f) + (lambda () + (call-with-input-file path + (lambda (port) (get-string-all port))))))) + (ui-queue-push! (lambda () (callback content))))))) + + (def (async-write-file! path content callback) + (fork-thread + (lambda () + (let ((ok (with-catch (lambda (e) #f) + (lambda () + (call-with-output-file path + (lambda (port) (display content port))) + #t)))) + (ui-queue-push! (lambda () (callback ok))))))) + + ;;;============================================================================ + ;;; Async Eval + ;;;============================================================================ + + (def (async-eval! thunk callback) + (fork-thread + (lambda () + (let ((result (with-catch + (lambda (e) (cons 'error e)) + thunk))) + (ui-queue-push! (lambda () (callback result))))))) + + ;;;============================================================================ + ;;; Background Services + ;;;============================================================================ + + ;;; File Indexer — builds file index for fast find-file completion + + (def *file-index* (atom (make-hash-table))) + (def (file-index) *file-index*) + (def *file-indexer-thread* #f) + + (def (build-file-index root-dir) + (let ((index (make-hash-table))) + (with-catch + (lambda (e) index) + (lambda () + (let walk ((dir root-dir)) + (for-each + (lambda (entry) + (let ((path (string-append dir "/" entry))) + (with-catch + (lambda (e) #f) + (lambda () + (if (file-directory? path) + (unless (and (> (string-length entry) 0) + (char=? (string-ref entry 0) #\.)) + (walk path)) + (let* ((name (path-strip-directory path)) + (existing (or (hash-get index name) '()))) + (hash-put! index name (cons path existing)))))))) + (directory-list dir))) + index)))) + + (def (start-file-indexer! root-dir) + (stop-file-indexer!) + (set! *file-indexer-thread* + (fork-thread + (lambda () + (let loop () + (let ((index (build-file-index root-dir))) + (atom-reset! *file-index* index)) + (thread-sleep! 30) + (loop)))))) + + (def (stop-file-indexer!) + (when *file-indexer-thread* + ;; No clean way to interrupt — just abandon + (set! *file-indexer-thread* #f))) + + (def (file-index-lookup name) + (or (hash-get (atom-deref *file-index*) name) '())) + + ;;; Git Status Watcher — polls git status for modeline + + (def *git-status-cache* (atom (make-hash-table))) + (def (git-status-cache) *git-status-cache*) + (def *git-watcher-thread* #f) + + (def (start-git-watcher! dir . rest) + (let ((on-update (if (pair? rest) (car rest) #f))) + (stop-git-watcher!) + (set! *git-watcher-thread* + (fork-thread + (lambda () + (let loop () + (with-catch + (lambda (e) #f) + (lambda () + (let* ((output (run-process (list "git" "status" "--porcelain" "-b") + 'directory: dir)) + (lines (string-split output #\newline)) + (status (make-hash-table)) + (modified 0) (staged 0) (untracked 0)) + (for-each + (lambda (line) + (when (>= (string-length line) 3) + (let ((xy (substring line 0 2))) + (cond + ((string-prefix? "##" xy) + (hash-put! status 'branch + (substring line 3 (string-length line)))) + ((string-contains xy "?") + (set! untracked (+ untracked 1))) + ((or (string-contains xy "M") + (string-contains xy "D")) + (set! modified (+ modified 1))) + ((or (string-contains xy "A") + (string-contains xy "R")) + (set! staged (+ staged 1))))))) + lines) + (hash-put! status 'modified modified) + (hash-put! status 'staged staged) + (hash-put! status 'untracked untracked) + (atom-reset! *git-status-cache* status) + (when on-update + (ui-queue-push! (lambda () (on-update status))))))) + (thread-sleep! 5) + (loop))))))) + + (def (stop-git-watcher!) + (when *git-watcher-thread* + (set! *git-watcher-thread* #f))) + + ;;; Flycheck Watcher — runs linter on save via channel trigger + + (def *flycheck-trigger* (make-channel 64)) + (def (flycheck-trigger) *flycheck-trigger*) + (def *flycheck-watcher-thread* #f) + + (def (flycheck-trigger! path) + (with-catch + (lambda (e) (void)) + (lambda () (channel-put *flycheck-trigger* path)))) + + (def (start-flycheck-watcher! lint-fn on-result) + (stop-flycheck-watcher!) + (set! *flycheck-watcher-thread* + (fork-thread + (lambda () + (let loop () + (let ((path (channel-get *flycheck-trigger*))) + (when (string? path) + (with-catch + (lambda (e) + (jemacs-log! (string-append "flycheck error: " (format "~a" e)))) + (lambda () + (let ((errors (lint-fn path))) + (ui-queue-push! + (lambda () (on-result path errors)))))))) + (loop)))))) + + (def (stop-flycheck-watcher!) + (when *flycheck-watcher-thread* + (set! *flycheck-watcher-thread* #f))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa-emacs/chat.sls @@ -0,0 +1,112 @@ +#!chezscheme +;;; chat.sls — AI Chat mode: interact with Claude CLI from a buffer +;;; +;;; Ported from gerbil-emacs/chat.ss +;;; Spawns `claude -p` in print mode for each prompt and streams +;;; the response into the chat buffer. + +(library (jerboa-emacs chat) + (export chat-buffer? + chat-state-map + chat-state? chat-state-process chat-state-process-set! + chat-state-prompt-pos chat-state-prompt-pos-set! + chat-state-busy? chat-state-busy?-set! + chat-state-continue? chat-state-continue?-set! + chat-state-cwd + make-chat-state + chat-start! + chat-send! + chat-read-available + chat-stop! + chat-busy?) + (import (except (chezscheme) + make-hash-table hash-table? iota 1+ 1- sort sort!) + (jerboa core) + (jerboa runtime) + (std sugar) + (std srfi srfi-13) + (std misc process) + (jerboa-emacs core)) + + ;;;============================================================================ + ;;; Chat state + ;;;============================================================================ + + (def (chat-buffer? buf) + (eq? (buffer-lexer-lang buf) 'chat)) + + (def *chat-state* (make-hash-table-eq)) + (def (chat-state-map) *chat-state*) + + (defstruct chat-state (process prompt-pos busy? continue? cwd)) + + ;;;============================================================================ + ;;; Chat operations + ;;;============================================================================ + + (def (chat-start! cwd) + (make-chat-state #f 0 #f #f (or cwd (current-directory)))) + + (def (chat-busy? cs) + (chat-state-busy? cs)) + + (def (chat-send! cs input) + (when (and (not (chat-state-busy? cs)) + (> (string-length (string-trim input)) 0)) + (let* ((args (if (chat-state-continue? cs) + (list "claude" "-p" "--continue" "--output-format" "text" + "--no-session-persistence" input) + (list "claude" "-p" "--output-format" "text" + "--no-session-persistence" input))) + (pp (open-process args))) + ;; Close stdin immediately — claude -p reads prompt from args + (let ((stdin (process-port-rec-stdin-port pp))) + (when stdin (close-port stdin))) + (chat-state-process-set! cs pp) + (chat-state-busy?-set! cs #t) + (chat-state-continue?-set! cs #t)))) + + (def (chat-read-available cs) + (let ((pp (chat-state-process cs))) + (if (and pp (chat-state-busy? cs)) + (let ((stdout (process-port-rec-stdout-port pp))) + (if (input-port-ready? stdout) + (let ((out (open-output-string))) + (let loop () + (when (input-port-ready? stdout) + (let ((ch (read-char stdout))) + (if (eof-object? ch) + ;; Process finished + (begin + (with-catch void (lambda () (close-port stdout))) + (chat-state-process-set! cs #f) + (chat-state-busy?-set! cs #f)) + (begin + (write-char ch out) + (loop)))))) + (let ((s (get-output-string out))) + (if (and (string=? s "") (not (chat-state-busy? cs))) + 'done + (if (string=? s "") + #f + (if (chat-state-busy? cs) + s + (cons s 'done)))))) + #f)) + #f))) + + (def (chat-stop! cs) + (let ((pp (chat-state-process cs))) + (when pp + (with-catch void + (lambda () + (let ((stdin (process-port-rec-stdin-port pp))) + (when stdin (close-port stdin))))) + (with-catch void + (lambda () + (let ((stdout (process-port-rec-stdout-port pp))) + (when stdout (close-port stdout))))) + (chat-state-process-set! cs #f) + (chat-state-busy?-set! cs #f)))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa-emacs/debug-repl.sls @@ -0,0 +1,180 @@ +#!chezscheme +;;; debug-repl.sls — TCP REPL server for debugging a running jemacs instance. +;;; +;;; Ported from gerbil-emacs/debug-repl.ss +;;; Connect with: nc 127.0.0.1 <port> +;;; Simplified: no Gambit-specific thread introspection (##thread-state, +;;; ##display-continuation-backtrace, etc.) + +(library (jerboa-emacs debug-repl) + (export start-debug-repl! stop-debug-repl! debug-repl-port) + (import (except (chezscheme) + make-hash-table hash-table? iota 1+ 1- sort sort!) + (jerboa core) + (jerboa runtime) + (std sugar) + (std srfi srfi-13) + (std net tcp) + (jerboa-emacs core)) + + ;;;============================================================================ + ;;; State + ;;;============================================================================ + + (def *debug-repl-server* #f) + (def *debug-repl-actual-port* #f) + (def *debug-repl-port-file* + (string-append (or (getenv "HOME") ".") "/.jemacs-repl-port")) + + ;;;============================================================================ + ;;; Port file + ;;;============================================================================ + + (def (write-repl-port-file! port-num) + (call-with-output-file *debug-repl-port-file* + (lambda (p) + (put-string p "PORT=") (display port-num p) (newline p) + (put-string p "PID=") (display (get-process-id) p) (newline p)))) + + (def (delete-repl-port-file!) + (when (file-exists? *debug-repl-port-file*) + (with-catch void + (lambda () (delete-file *debug-repl-port-file*))))) + + ;;;============================================================================ + ;;; Comma command helpers + ;;;============================================================================ + + (def (cmd-list-buffers port) + (for-each + (lambda (buf) + (let ((name (buffer-name buf)) + (path (buffer-file-path buf)) + (mod (buffer-modified buf))) + (put-string port + (string-append + " " name + (if mod " [modified]" "") + (if path (string-append " " path) " (no file)") + "\n")))) + (buffer-list))) + + (def (cmd-show-state port) + (let ((bufs (buffer-list))) + (put-string port + (string-append + " buffers: " (number->string (length bufs)) " buffer(s)\n" + " kill-ring: (not accessible without app)\n")))) + + (def (cmd-force-gc port) + (collect (collect-maximum-generation)) + (put-string port " GC done.\n")) + + (def help-text + " ,help This help message + ,buffers List all open buffers + ,state Show key state summary + ,gc Force GC + ,quit Close this REPL connection + <expr> Evaluate arbitrary Scheme expression +") + + ;;;============================================================================ + ;;; Client handler + ;;;============================================================================ + + (def (debug-repl-handle-client! in out token) + ;; Token auth + (when token + (let ((line (with-catch (lambda (e) #f) (lambda () (get-line in))))) + (unless (and (string? line) (string=? (string-trim-both line) token)) + (put-string out "Access denied.\n") + (flush-output-port out) + (close-port in) + (close-port out) + (error 'debug-repl "access denied")))) + ;; Banner + (put-string out "jemacs debug REPL — type ,help for commands\n") + (flush-output-port out) + (let loop () + (put-string out "jemacs-dbg> ") + (flush-output-port out) + (let ((line (with-catch (lambda (e) #f) (lambda () (get-line in))))) + (when (and line (not (eof-object? line))) + (let ((cmd (string-trim-both line))) + (cond + ((string=? cmd "") (loop)) + ((string=? cmd ",quit") + (put-string out "Connection closed.\n") + (flush-output-port out)) + ((string=? cmd ",help") + (put-string out help-text) + (flush-output-port out) + (loop)) + ((string=? cmd ",buffers") + (cmd-list-buffers out) + (flush-output-port out) + (loop)) + ((string=? cmd ",state") + (cmd-show-state out) + (flush-output-port out) + (loop)) + ((string=? cmd ",gc") + (cmd-force-gc out) + (flush-output-port out) + (loop)) + (else + ;; Evaluate as Scheme expression + (with-catch + (lambda (e) + (put-string out "ERROR: ") + (put-string out (format "~a" e)) + (newline out)) + (lambda () + (let ((result (eval (read (open-input-string cmd))))) + (write result out) + (newline out)))) + (flush-output-port out) + (loop)))))))) + + ;;;============================================================================ + ;;; Public API + ;;;============================================================================ + + (def (start-debug-repl! port-num . rest) + (let ((token (if (pair? rest) (car rest) #f))) + (let* ((srv (tcp-listen "127.0.0.1" port-num)) + (actual-port (tcp-server-port srv))) + (set! *debug-repl-server* srv) + (write-repl-port-file! actual-port) + (set! *debug-repl-actual-port* actual-port) + (fork-thread + (lambda () + (let loop () + (let-values (((in out) + (with-catch + (lambda (e) (values #f #f)) + (lambda () (tcp-accept srv))))) + (when (and in out) + (fork-thread + (lambda () + (with-catch + (lambda (e) (void)) + (lambda () + (debug-repl-handle-client! in out token) + (with-catch void (lambda () (close-port in))) + (with-catch void (lambda () (close-port out))))))) + (loop)))))) + actual-port))) + + (def (stop-debug-repl!) + (when *debug-repl-server* + (with-catch void (lambda () (tcp-close *debug-repl-server*))) + (set! *debug-repl-server* #f) + (set! *debug-repl-actual-port* #f)) + (delete-repl-port-file!)) + + (def (debug-repl-port) + *debug-repl-actual-port*) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa-emacs/helm.sls @@ -0,0 +1,421 @@ +#!chezscheme +;;; helm.sls — Helm core framework for jemacs +;;; +;;; Ported from gerbil-emacs/helm.ss +;;; Backend-agnostic: data model, multi-match engine, filtering, +;;; session management, action dispatch. No TUI or Qt imports. + +(library (jerboa-emacs helm) + (export + ;; Data structures + helm-source? helm-source-name helm-source-candidates helm-source-actions + helm-source-persistent-action helm-source-display-fn helm-source-real-fn + helm-source-fuzzy? helm-source-volatile? helm-source-candidate-limit + helm-source-keymap helm-source-follow? + make-helm-source + + helm-session? helm-session-sources helm-session-pattern + helm-session-candidates helm-session-candidates-set! + helm-session-selected helm-session-selected-set! + helm-session-marked helm-session-marked-set! + helm-session-buffer-name helm-session-scroll-offset + helm-session-scroll-offset-set! helm-session-follow? + helm-session-follow?-set! helm-session-alive? + helm-session-alive?-set! + make-helm-session + + helm-candidate? helm-candidate-display helm-candidate-real + helm-candidate-source + make-helm-candidate + + ;; Matching + helm-multi-match + helm-multi-match? + + ;; Filtering + helm-filter-source + helm-filter-all + + ;; Session management + helm-sessions + helm-last-session + helm-session-store! + helm-session-resume + + ;; Action dispatch + helm-default-action + helm-run-action + + ;; Candidate construction + make-helm-candidates + + ;; Session construction + make-new-session + make-simple-source + + ;; Match highlighting + helm-match-positions + + ;; Pattern access (for volatile sources like grep) + helm-current-pattern + + ;; Configuration + helm-candidate-limit + helm-follow-delay) + (import (except (chezscheme) + make-hash-table hash-table? iota 1+ 1-) + (jerboa core) + (jerboa runtime) + (std sugar) + (std srfi srfi-13) + (only (std misc string) string-split)) + + ;;;============================================================================ + ;;; Configuration + ;;;============================================================================ + + (def *helm-candidate-limit* 100) + (def *helm-follow-delay* 0.1) + + (def (helm-candidate-limit) *helm-candidate-limit*) + (def (helm-follow-delay) *helm-follow-delay*) + + ;; Dynamic parameter: set to current pattern during helm-filter-source + (def *helm-current-pattern* (make-parameter "")) + (def (helm-current-pattern) *helm-current-pattern*) + + ;;;============================================================================ + ;;; Data structures + ;;;============================================================================ + + (defstruct helm-source + (name candidates actions persistent-action display-fn real-fn + fuzzy? volatile? candidate-limit keymap follow?)) + + (defstruct helm-session + (sources pattern candidates selected marked buffer-name + scroll-offset follow? alive?)) + + (defstruct helm-candidate + (display real source)) + + ;; filter-map: map + filter #f results + (def (filter-map f lst) + (let loop ((l lst) (acc '())) + (if (null? l) (reverse acc) + (let ((v (f (car l)))) + (if v (loop (cdr l) (cons v acc)) + (loop (cdr l) acc)))))) + + ;;;============================================================================ + ;;; Multi-match engine + ;;;============================================================================ + + (defstruct match-token (text negate? prefix?)) + + ;; Fuzzy match: characters of query appear in order in candidate + (def (fuzzy-match? query candidate) + (let ((qlen (string-length query)) + (clen (string-length candidate))) + (let loop ((qi 0) (ci 0)) + (cond + ((>= qi qlen) #t) + ((>= ci clen) #f) + ((char-ci=? (string-ref query qi) (string-ref candidate ci)) + (loop (+ qi 1) (+ ci 1))) + (else (loop qi (+ ci 1))))))) + + ;; Fuzzy score: higher = better match, -1 = no match + (def (fuzzy-score query candidate) + (let ((qlen (string-length query)) + (clen (string-length candidate))) + (let loop ((qi 0) (ci 0) (score 0) (consecutive 0)) + (cond + ((>= qi qlen) (+ score qlen)) ; matched all chars + ((>= ci clen) -1) ; ran out of candidate + ((char-ci=? (string-ref query qi) (string-ref candidate ci)) + (loop (+ qi 1) (+ ci 1) + (+ score 1 consecutive + (if (= ci qi) 3 0)) ; bonus for same position + (+ consecutive 1))) + (else (loop qi (+ ci 1) score 0)))))) + + (def (parse-match-tokens pattern) + (let ((words (filter (lambda (w) (> (string-length w) 0)) + (string-split pattern #\space)))) + (map (lambda (word) + (cond + ((and (> (string-length word) 1) + (char=? (string-ref word 0) #\!)) + (make-match-token (substring word 1 (string-length word)) #t #f)) + ((and (> (string-length word) 1) + (char=? (string-ref word 0) #\^)) + (make-match-token (substring word 1 (string-length word)) #f #t)) + (else + (make-match-token word #f #f)))) + words))) + + (def (token-matches? token candidate-str use-fuzzy?) + (let* ((text (match-token-text token)) + (target-lower (string-downcase candidate-str)) + (text-lower (string-downcase text)) + (matches + (cond + ((match-token-prefix? token) + (string-prefix? text-lower target-lower)) + (use-fuzzy? + (fuzzy-match? text candidate-str)) + (else + (string-contains target-lower text-lower))))) + (if (match-token-negate? token) + (not matches) + (and matches #t)))) + + (def (helm-multi-match? pattern candidate-str . rest) + (let ((use-fuzzy? (if (pair? rest) (car rest) #f))) + (let ((tokens (parse-match-tokens pattern))) + (if (null? tokens) + #t + (let loop ((toks tokens)) + (cond + ((null? toks) #t) + ((not (token-matches? (car toks) candidate-str use-fuzzy?)) #f) + (else (loop (cdr toks))))))))) + + (def (helm-multi-match pattern candidate-str . rest) + (let ((use-fuzzy? (if (pair? rest) (car rest) #f))) + (let ((tokens (parse-match-tokens pattern))) + (if (null? tokens) + 0 + (let loop ((toks tokens) (total-score 0)) + (cond + ((null? toks) total-score) + (else + (let ((tok (car toks))) + (if (match-token-negate? tok) + (let* ((text (match-token-text tok)) + (target-lower (string-downcase candidate-str)) + (text-lower (string-downcase text)) + (matches (if use-fuzzy? + (fuzzy-match? text candidate-str) + (string-contains target-lower text-lower)))) + (if matches -1 + (loop (cdr toks) total-score))) + (let ((score (if (match-token-prefix? tok) + (let* ((text-lower (string-downcase (match-token-text tok))) + (target-lower (string-downcase candidate-str))) + (if (string-prefix? text-lower target-lower) + (+ 5 (string-length (match-token-text tok))) + -1)) + (if use-fuzzy? + (fuzzy-score (match-token-text tok) candidate-str) + (let* ((text-lower (string-downcase (match-token-text tok))) + (target-lower (string-downcase candidate-str))) + (if (string-contains target-lower text-lower) + (+ 3 (string-length (match-token-text tok)) + (if (string-prefix? text-lower target-lower) 5 0)) + -1)))))) + (if (< score 0) -1 + (loop (cdr toks) (+ total-score score))))))))))))) + + ;;;============================================================================ + ;;; Filtering + ;;;============================================================================ + + (def (helm-take lst n) + (let loop ((l lst) (i 0) (acc '())) + (if (or (null? l) (>= i n)) + (reverse acc) + (loop (cdr l) (+ i 1) (cons (car l) acc))))) + + (def (helm-filter-source source pattern) + (let* ((raw-candidates (parameterize ((*helm-current-pattern* pattern)) + (let ((c (helm-source-candidates source))) + (if (procedure? c) (c) c)))) + (display-fn (helm-source-display-fn source)) + (real-fn (helm-source-real-fn source)) + (use-fuzzy? (helm-source-fuzzy? source)) + (limit (or (helm-source-candidate-limit source) *helm-candidate-limit*))) + (let* ((scored + (filter-map + (lambda (raw) + (let* ((display-str (if display-fn (display-fn raw) raw)) + (real-val (if real-fn (real-fn raw) raw)) + (score (if (string=? pattern "") + 0 + (helm-multi-match pattern display-str use-fuzzy?)))) + (and (>= score 0) + (cons score (make-helm-candidate display-str real-val source))))) + raw-candidates)) + (sorted (if (string=? pattern "") + scored + (list-sort (lambda (a b) (> (car a) (car b))) scored))) + (limited (if (> (length sorted) limit) + (helm-take sorted limit) + sorted))) + (map cdr limited)))) + + (def (helm-filter-all session) + (let ((pattern (helm-session-pattern session)) + (sources (helm-session-sources session))) + (let ((all-candidates + (apply append + (map (lambda (src) + (helm-filter-source src pattern)) + sources)))) + (list->vector all-candidates)))) + + ;;;============================================================================ + ;;; Candidate construction helpers + ;;;============================================================================ + + (def (make-helm-candidates strings source) + (map (lambda (s) + (make-helm-candidate s s source)) + strings)) + + ;;;============================================================================ + ;;; Session management + ;;;============================================================================ + + (def *helm-sessions* '()) + (def *helm-last-session* #f) + (def *helm-max-sessions* 10) + + (def (helm-sessions) *helm-sessions*) + (def (helm-last-session) *helm-last-session*) + + (def (helm-session-store! session) + (let ((name (helm-session-buffer-name session))) + (set! *helm-last-session* session) + (set! *helm-sessions* + (cons (cons name session) + (filter (lambda (pair) (not (string=? (car pair) name))) + *helm-sessions*))) + (when (> (length *helm-sessions*) *helm-max-sessions*) + (set! *helm-sessions* (helm-take *helm-sessions* *helm-max-sessions*))))) + + (def (helm-session-resume . rest) + (let ((name (if (pair? rest) (car rest) #f))) + (if name + (let ((found (assoc name *helm-sessions*))) + (and found (cdr found))) + *helm-last-session*))) + + ;;;============================================================================ + ;;; Action dispatch + ;;;============================================================================ + + (def (helm-default-action source) + (let ((actions (helm-source-actions source))) + (and (pair? actions) (cdar actions)))) + + (def (helm-run-action action candidates) + (for-each + (lambda (cand) + (action (helm-candidate-real cand))) + candidates)) + + ;;;============================================================================ + ;;; Source constructors (convenience) + ;;;============================================================================ + + (def (make-simple-source name candidates-thunk action . rest) + (let ((fuzzy? (if (pair? rest) (car rest) #t)) + (persistent-action (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) #f)) + (display-fn (if (and (pair? rest) (pair? (cdr rest)) (pair? (cddr rest))) (caddr rest) #f)) + (real-fn (if (and (pair? rest) (pair? (cdr rest)) (pair? (cddr rest)) (pair? (cdddr rest))) (cadddr rest) #f)) + (volatile? #f) + (follow? #f)) + (make-helm-source + name + candidates-thunk + (list (cons "Default" action)) + persistent-action + display-fn + real-fn + fuzzy? + volatile? + *helm-candidate-limit* + #f + follow?))) + + ;;;============================================================================ + ;;; New session creation + ;;;============================================================================ + + (def (make-new-session sources . rest) + (let ((buffer-name (if (pair? rest) (car rest) "*helm*")) + (initial-input (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) ""))) + (let ((session (make-helm-session + sources + initial-input + (vector) + 0 + '() + buffer-name + 0 + #f + #t))) + ;; Initial filter + (helm-session-candidates-set! session (helm-filter-all session)) + session))) + + ;;;============================================================================ + ;;; Match highlighting + ;;;============================================================================ + + (def (fuzzy-match-positions pattern target) + (let ((plen (string-length pattern)) + (tlen (string-length target)))