Implement Tier 4: TUI infrastructure modules (7 files, 95 tests passing)
ober
696dd1e6a3f6d544fd3a890018e23eae1fb27994
--- a/Makefile +++ b/Makefile @@ -3,11 +3,11 @@ LIBDIRS = --libdirs lib:$(HOME)/mine/jerboa/lib:$(HOME)/mine/chez-pcre2:$(HOME)/ export LD_LIBRARY_PATH := $(HOME)/mine/chez-pcre2:$(HOME)/mine/chez-scintilla:$(LD_LIBRARY_PATH) export CHEZ_SCINTILLA_LIB := $(HOME)/mine/chez-scintilla -.PHONY: all test-tier0 test-tier2 test-tier3 test clean +.PHONY: all test-tier0 test-tier2 test-tier3 test-tier4 test clean all: test -test: test-tier0 test-tier2 test-tier3 +test: test-tier0 test-tier2 test-tier3 test-tier4 test-tier0: $(SCHEME) $(LIBDIRS) --script tests/test-tier0.ss @@ -18,5 +18,8 @@ test-tier2: test-tier3: $(SCHEME) $(LIBDIRS) --script tests/test-tier3.ss +test-tier4: + $(SCHEME) $(LIBDIRS) --program tests/test-tier4.ss + clean: find lib -name '*.so' -delete 2>/dev/null; true new file mode 100644 --- /dev/null +++ b/lib/jerboa-emacs/buffer.sls @@ -0,0 +1,41 @@ +#!chezscheme +(library (jerboa-emacs buffer) + (export + buffer-create! + buffer-create-from-editor! + buffer-kill! + buffer-attach!) + (import (except (chezscheme) + make-hash-table hash-table? iota 1+ 1- sort sort!) + (jerboa core) + (jerboa runtime) + (jerboa-emacs core) + (chez-scintilla constants) + (chez-scintilla scintilla)) + + (define buffer-create! + (case-lambda + ((name editor) + (buffer-create! name editor #f)) + ((name editor file-path) + (let* ((doc (send-message editor SCI_CREATEDOCUMENT 0 0)) + (buf (make-buffer name file-path doc #f #f #f #f))) + (buffer-list-add! buf) + buf)))) + + (define (buffer-create-from-editor! name editor) + (let ((doc (send-message editor SCI_GETDOCPOINTER))) + (send-message editor SCI_ADDREFDOCUMENT 0 doc) + (let ((buf (make-buffer name #f doc #f #f #f #f))) + (buffer-list-add! buf) + buf))) + + (define (buffer-kill! editor buf) + (send-message editor SCI_RELEASEDOCUMENT 0 (buffer-doc-pointer buf)) + (buffer-list-remove! buf)) + + (define (buffer-attach! editor buf) + (send-message editor SCI_SETDOCPOINTER 0 (buffer-doc-pointer buf)) + (run-hooks! 'post-buffer-attach-hook editor buf)) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa-emacs/echo.sls @@ -0,0 +1,427 @@ +#!chezscheme +;;; echo.sls — TUI echo area / minibuffer for jemacs +;;; +;;; Ported from gerbil-emacs/echo.ss +;;; The echo area occupies the last terminal row. +;;; It displays messages and handles simple line input for prompts. +;;; +;;; Echo state and message functions are in core.sls. + +(library (jerboa-emacs echo) + (export + echo-draw! + echo-read-string + echo-read-string-with-completion + echo-read-file-with-completion + minibuffer-history + minibuffer-history-set! + minibuffer-history-add! + test-echo-responses + test-echo-responses-set!) + (import (except (chezscheme) + make-hash-table hash-table? iota 1+ 1- sort sort!) + (jerboa core) + (jerboa runtime) + (jerboa-emacs core) + (chez-scintilla tui) + (only (std srfi srfi-13) string-suffix?)) + + ;;;========================================================================== + ;;; Mutable state with accessor/mutator pattern (R6RS export limitation) + ;;;========================================================================== + + ;; Test-only: queue of canned responses for app-read-string mock. + ;; Set to a list of strings before calling commands that prompt for input. + ;; Each app-read-string call dequeues one response. + (define *test-echo-responses* '()) + (define (test-echo-responses) *test-echo-responses*) + (define (test-echo-responses-set! v) (set! *test-echo-responses* v)) + + ;; Global minibuffer history (most recent first) + (define *minibuffer-history* '()) + (define (minibuffer-history) *minibuffer-history*) + (define (minibuffer-history-set! v) (set! *minibuffer-history* v)) + + (define *max-history-size* 100) + + ;;;========================================================================== + ;;; Minibuffer history + ;;;========================================================================== + + (define (minibuffer-history-add! input) + ;; Add an input string to the minibuffer history. + ;; Avoids duplicates at the front and limits size. + (when (and (string? input) (> (string-length input) 0)) + ;; Remove duplicate if it's already at the front + (when (and (pair? *minibuffer-history*) + (string=? (car *minibuffer-history*) input)) + (set! *minibuffer-history* (cdr *minibuffer-history*))) + ;; Add to front + (set! *minibuffer-history* (cons input *minibuffer-history*)) + ;; Trim to max size + (when (> (length *minibuffer-history*) *max-history-size*) + (set! *minibuffer-history* + (let loop ((lst *minibuffer-history*) (n 0) (acc '())) + (if (or (null? lst) (>= n *max-history-size*)) + (reverse acc) + (loop (cdr lst) (+ n 1) (cons (car lst) acc)))))))) + + ;;;========================================================================== + ;;; Face helpers for TUI echo area + ;;;========================================================================== + + (define (face-to-rgb-int face-name attr) + ;; Convert a face's fg or bg attribute to RGB integer for tui-print!. + ;; attr should be 'fg or 'bg. Returns 24-bit RGB integer like #xd8d8d8. + (let ((f (face-get face-name))) + (if f + (let ((color-str (if (eq? attr 'fg) (face-fg f) (face-bg f)))) + (if color-str + (let-values (((r g b) (parse-hex-color color-str))) + (+ (bitwise-arithmetic-shift-left r 16) (bitwise-arithmetic-shift-left g 8) b)) + ;; Default: light gray for fg, dark gray for bg + (if (eq? attr 'fg) #xd8d8d8 #x181818))) + ;; Face not found: use defaults + (if (eq? attr 'fg) #xd8d8d8 #x181818)))) + + ;;;========================================================================== + ;;; Draw the echo area (TUI-specific) + ;;;========================================================================== + + (define (echo-draw! echo row width) + ;; Draw the echo area at the given row. + ;; Clear the row using default face background + (let ((bg (face-to-rgb-int 'default 'bg)) + (fg (face-to-rgb-int 'default 'fg))) + (tui-print! 0 row fg bg (make-string width #\space))) + ;; Draw message if any + (let ((msg (echo-state-message echo))) + (when msg + (let* ((face-name (if (echo-state-error? echo) 'error 'default)) + (fg (face-to-rgb-int face-name 'fg)) + (bg (face-to-rgb-int 'default 'bg)) + (display-msg (if (> (string-length msg) width) + (substring msg 0 width) + msg))) + (tui-print! 0 row fg bg display-msg))))) + + ;;;========================================================================== + ;;; Read a string from the user in the echo area (TUI-specific) + ;;; Runs a blocking sub-event-loop. + ;;; Returns the input string, or #f if cancelled (C-g). + ;;;========================================================================== + + (define (echo-read-string echo prompt row width) + (echo-clear! echo) + (let loop ((input "") (hist-idx -1) (saved-input "")) + ;; Draw prompt + input with history indicator + (let* ((hist-suffix (if (>= hist-idx 0) + (string-append " [" (number->string (+ hist-idx 1)) + "/" (number->string (length *minibuffer-history*)) "]") + "")) + (display-str (string-append prompt input)) + (cursor-pos (string-length display-str)) + (display-len (string-length display-str))) + (tui-print! 0 row #xd8d8d8 #x181818 (make-string width #\space)) + (tui-print! 0 row #xd8d8d8 #x181818 + (if (> display-len width) + (substring display-str 0 width) + display-str)) + ;; Show history indicator in dim color + (when (and (>= hist-idx 0) (< cursor-pos width)) + (let ((avail (- width cursor-pos))) + (tui-print! cursor-pos row #x888888 #x181818 + (if (> (string-length hist-suffix) avail) + (substring hist-suffix 0 avail) + hist-suffix)))) + (tui-set-cursor! (min display-len (- width 1)) row) + (tui-present!)) + ;; Wait for key + (let ((ev (tui-poll-event))) + (cond + ((not ev) (loop input hist-idx saved-input)) + ((not (tui-event-key? ev)) (loop input hist-idx saved-input)) + (else + (let* ((key (tui-event-key ev)) + (ch (tui-event-ch ev)) + (mod (tui-event-mod ev)) + (alt? (not (zero? (bitwise-and mod TB_MOD_ALT))))) + (cond + ;; C-g (0x07) -> cancel + ((= key #x07) + (echo-message! echo "Quit") + #f) + ;; Enter (0x0D) -> accept and add to history + ((= key #x0D) + (minibuffer-history-add! input) + input) + ;; M-p -> previous history entry + ((and alt? (= ch (char->integer #\p))) + (let ((hist-len (length *minibuffer-history*))) + (if (> hist-len 0) + (let* ((new-idx (min (+ hist-idx 1) (- hist-len 1))) + ;; Save current input when first entering history + (saved (if (= hist-idx -1) input saved-input)) + (entry (list-ref *minibuffer-history* new-idx))) + (loop entry new-idx saved)) + (loop input hist-idx saved-input)))) + ;; M-n -> next history entry (or back to saved input) + ((and alt? (= ch (char->integer #\n))) + (cond + ((> hist-idx 0) + (let ((entry (list-ref *minibuffer-history* (- hist-idx 1)))) + (loop entry (- hist-idx 1) saved-input))) + ((= hist-idx 0) + ;; Return to saved (pre-history) input + (loop saved-input -1 saved-input)) + (else + (loop input hist-idx saved-input)))) + ;; Backspace (0x08 or 0x7F) -> delete last char + ((or (= key #x08) (= key #x7F)) + (if (> (string-length input) 0) + (loop (substring input 0 (- (string-length input) 1)) -1 "") + (loop input hist-idx saved-input))) + ;; Printable char -> append (exits history browsing) + ((> ch 31) + (loop (string-append input (string (integer->char ch))) -1 "")) + ;; Ignore other keys + (else (loop input hist-idx saved-input))))))))) + + ;;;========================================================================== + ;;; Read a string with tab-completion (TUI-specific) + ;;; completions: sorted list of strings to complete against + ;;; Uses fuzzy matching (characters in order, scored by quality). + ;;; Returns the input string, or #f if cancelled (C-g). + ;;;========================================================================== + + (define (echo-read-string-with-completion echo prompt completions row width) + (echo-clear! echo) + ;; search-pat: when cycling via Tab, holds the original search text + ;; so the match list stays stable across Tab presses. + (let loop ((input "") (match-idx 0) (search-pat #f)) + ;; Use search-pattern for matching during cycling, otherwise use input + (let* ((pattern (or search-pat input)) + (matches (if (string=? pattern "") + completions + (fuzzy-filter-sort pattern completions))) + (match-count (length matches)) + (suffix (cond + ((string=? input "") "") + ((> match-count 0) + (string-append " [" (number->string (min (+ match-idx 1) match-count)) + "/" (number->string match-count) "]")) + (else " [No match]"))) + (cursor-pos (+ (string-length prompt) (string-length input)))) + ;; Draw prompt + input + (tui-print! 0 row #xd8d8d8 #x181818 (make-string width #\space)) + (tui-print! 0 row #xd8d8d8 #x181818 + (if (> cursor-pos width) + (substring (string-append prompt input) 0 width) + (string-append prompt input))) + ;; Show suffix in a dimmer color + (when (< cursor-pos width) + (let ((avail (- width cursor-pos))) + (tui-print! cursor-pos row #x888888 #x181818 + (if (> (string-length suffix) avail) + (substring suffix 0 avail) + suffix)))) + (tui-set-cursor! (min cursor-pos (- width 1)) row) + (tui-present!)) + ;; Wait for key + (let ((ev (tui-poll-event))) + (cond + ((not ev) (loop input match-idx search-pat)) + ((not (tui-event-key? ev)) (loop input match-idx search-pat)) + (else + (let* ((key (tui-event-key ev)) + (ch (tui-event-ch ev)) + ;; Recompute matches for key handling + (pattern (or search-pat input)) + (matches (if (string=? pattern "") + completions + (fuzzy-filter-sort pattern completions))) + (match-count (length matches))) + (cond + ;; C-g -> cancel + ((= key #x07) + (echo-message! echo "Quit") + #f) + ;; Enter -> accept + ((= key #x0D) input) + ;; Tab -> cycle to next fuzzy completion + ((= key #x09) + (if (> match-count 0) + (let* ((idx (modulo match-idx match-count)) + (completed (list-ref matches idx))) + ;; Save search-pattern on first Tab press + (loop completed (+ idx 1) (or search-pat input))) + (loop input 0 search-pat))) + ;; Backspace -> delete last char, reset cycling + ((or (= key #x08) (= key #x7F)) + (if (> (string-length input) 0) + (loop (substring input 0 (- (string-length input) 1)) 0 #f) + (loop input 0 search-pat))) + ;; Printable char -> append, reset cycling + ((> ch 31) + (loop (string-append input (string (integer->char ch))) 0 #f)) + ;; Ignore other keys + (else (loop input match-idx search-pat))))))))) + + ;;;========================================================================== + ;;; Read a file path with directory-aware fuzzy completion (TUI-specific) + ;;; Supports ~ expansion, directory traversal, and Tab cycling. + ;;; Returns the file path string, or #f if cancelled (C-g). + ;;;========================================================================== + + ;; Helper: expand tilde at start of path + (define (expand-tilde path) + (if (and (> (string-length path) 0) + (char=? (string-ref path 0) #\~)) + (let ((home (or (getenv "HOME") "/"))) + (if (= (string-length path) 1) + (string-append home "/") + (if (char=? (string-ref path 1) #\/) + (string-append home (substring path 1 (string-length path))) + path))) + path)) + + ;; Helper: find last slash position (or #f) + (define (last-slash-pos str) + (let loop ((i (- (string-length str) 1))) + (cond ((< i 0) #f) + ((char=? (string-ref str i) #\/) i) + (else (loop (- i 1)))))) + + ;; Helper: list directory files safely, sorted + (define (list-dir dir) + (guard (e (#t '())) + (list-sort string<? (directory-list dir)))) + + ;; Helper: parse input into (values dir partial display-prefix) + (define (parse-input text) + (let* ((text (if (string=? text "~") "~/" text)) + (expanded (expand-tilde text)) + (slash (last-slash-pos expanded))) + (if slash + (let* ((dir (substring expanded 0 (+ slash 1))) + (partial (substring expanded (+ slash 1) (string-length expanded))) + (orig-slash (last-slash-pos text)) + (display-prefix (if orig-slash + (substring text 0 (+ orig-slash 1)) + ""))) + (values dir partial display-prefix)) + (values (current-directory) expanded "")))) + + (define echo-read-file-with-completion + (case-lambda + ((echo prompt row width) + (echo-read-file-with-completion echo prompt row width "")) + ((echo prompt row width initial-input) + (echo-clear! echo) + (let loop ((input initial-input) (match-idx 0) (search-pat #f) + (hist-idx -1) (saved-input "")) + ;; Compute matches for display + (let-values (((dir partial display-prefix) (parse-input (or search-pat input)))) + (let* ((files (list-dir dir)) + (matches (if (string=? partial "") + files + (fuzzy-filter-sort partial files))) + (match-count (length matches)) + (suffix (cond + ((string=? input "") "") + ((> match-count 0) + (string-append " [" (number->string (min (+ match-idx 1) match-count)) + "/" (number->string match-count) "]")) + (else " [No match]"))) + (cursor-pos (+ (string-length prompt) (string-length input)))) + ;; Draw prompt + input + (tui-print! 0 row #xd8d8d8 #x181818 (make-string width #\space)) + (tui-print! 0 row #xd8d8d8 #x181818 + (if (> cursor-pos width) + (substring (string-append prompt input) 0 width) + (string-append prompt input))) + (when (< cursor-pos width) + (let ((avail (- width cursor-pos))) + (tui-print! cursor-pos row #x888888 #x181818 + (if (> (string-length suffix) avail) + (substring suffix 0 avail) + suffix)))) + (tui-set-cursor! (min cursor-pos (- width 1)) row) + (tui-present!))) + ;; Wait for key + (let ((ev (tui-poll-event))) + (cond + ((not ev) (loop input match-idx search-pat hist-idx saved-input)) + ((not (tui-event-key? ev)) (loop input match-idx search-pat hist-idx saved-input)) + (else + (let* ((key (tui-event-key ev)) + (ch (tui-event-ch ev)) + (mod (tui-event-mod ev)) + (alt? (not (zero? (bitwise-and mod TB_MOD_ALT))))) + ;; Recompute matches for key handling + (let-values (((dir partial display-prefix) (parse-input (or search-pat input)))) + (let* ((files (list-dir dir)) + (matches (if (string=? partial "") + files + (fuzzy-filter-sort partial files))) + (match-count (length matches))) + (cond + ;; C-g -> cancel + ((= key #x07) + (echo-message! echo "Quit") + #f) + ;; Enter -> accept, add to history + ((= key #x0D) + (minibuffer-history-add! input) + input) + ;; Tab -> fuzzy complete/cycle + ((= key #x09) + (if (> match-count 0) + (let* ((idx (modulo match-idx match-count)) + (match-name (list-ref matches idx)) + (full-path (string-append display-prefix match-name)) + ;; Check if match is a directory for auto-append / + (expanded-full (expand-tilde full-path)) + (is-dir? (guard (e (#t #f)) + (and (file-exists? expanded-full) + (file-directory? expanded-full))))) + (if is-dir? + ;; Directory: append / and reset search for next Tab + (let ((dir-path (if (string-suffix? "/" full-path) + full-path + (string-append full-path "/")))) + (loop dir-path 0 #f -1 "")) + ;; File: save search-pattern for cycling + (loop full-path (+ idx 1) (or search-pat input) -1 ""))) + (loop input 0 search-pat hist-idx saved-input))) + ;; M-p -> previous history + ((and alt? (= ch (char->integer #\p))) + (let ((hist-len (length *minibuffer-history*))) + (if (> hist-len 0) + (let* ((new-idx (min (+ hist-idx 1) (- hist-len 1))) + (saved (if (= hist-idx -1) input saved-input)) + (entry (list-ref *minibuffer-history* new-idx))) + (loop entry 0 #f new-idx saved)) + (loop input match-idx search-pat hist-idx saved-input)))) + ;; M-n -> next history + ((and alt? (= ch (char->integer #\n))) + (cond + ((> hist-idx 0) + (loop (list-ref *minibuffer-history* (- hist-idx 1)) + 0 #f (- hist-idx 1) saved-input)) + ((= hist-idx 0) + (loop saved-input 0 #f -1 saved-input)) + (else + (loop input match-idx search-pat hist-idx saved-input)))) + ;; Backspace -> delete last char, reset cycling + ((or (= key #x08) (= key #x7F)) + (if (> (string-length input) 0) + (loop (substring input 0 (- (string-length input) 1)) 0 #f -1 "") + (loop input match-idx search-pat hist-idx saved-input))) + ;; Printable char -> reset cycling + ((> ch 31) + (loop (string-append input (string (integer->char ch))) 0 #f -1 "")) + ;; Ignore other keys + (else (loop input match-idx search-pat hist-idx saved-input))))))))))))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa-emacs/highlight.sls @@ -0,0 +1,1133 @@ +#!chezscheme +;;; -*- Chez Scheme -*- +;;; Syntax highlighting for jerboa-emacs +;;; +;;; Shared keyword lists and Scintilla lexer setup for Gerbil Scheme. +;;; Colors based on gerbil-mode.el face definitions. +;;; Ported from gerbil-emacs/highlight.ss to R6RS Chez Scheme. + +(library (jerboa-emacs highlight) + (export setup-gerbil-highlighting! + setup-highlighting-for-file! + detect-file-language + detect-language-from-shebang + gerbil-file-extension? + register-custom-highlighter! + *custom-highlighters* + setup-diff-highlighting!) + + (import (except (chezscheme) + make-hash-table hash-table? iota 1+ 1- sort sort! + path-extension) + (jerboa core) + (jerboa runtime) + (jerboa-emacs core) + (chez-scintilla constants) + (chez-scintilla scintilla) + (chez-scintilla lexer) + (chez-scintilla style) + (only (std srfi srfi-13) string-join string-index string-contains) + (only (jerboa prelude) path-extension path-strip-directory)) + + ;;;========================================================================== + ;;; Scintilla Lisp lexer style IDs (from SciLexer.h) + ;;;========================================================================== + + (define SCE_LISP_DEFAULT 0) + (define SCE_LISP_COMMENT 1) + (define SCE_LISP_NUMBER 2) + (define SCE_LISP_KEYWORD 3) + (define SCE_LISP_KEYWORD_KW 4) + (define SCE_LISP_SYMBOL 5) + (define SCE_LISP_STRING 6) + (define SCE_LISP_STRINGEOL 8) + (define SCE_LISP_IDENTIFIER 9) + (define SCE_LISP_OPERATOR 10) + (define SCE_LISP_SPECIAL 11) + (define SCE_LISP_MULTI_COMMENT 12) + + ;;;========================================================================== + ;;; Gerbil keyword lists (from gerbil-mode.el) + ;;;========================================================================== + + ;; Keyword set 0: Definition forms, control flow, special forms + (define *gerbil-keywords* + (string-join + '(;; Definition forms + "def" "defvalues" "defalias" "defsyntax" "defrule" "defrules" + "defstruct" "defclass" "defmethod" "defgeneric" "deftype" + "defmessage" "definline" "defconst" "defcall-actor" "defproto" + "deferror-class" "defapi" "deftyped" + ;; Control flow + "if" "when" "unless" "cond" "case" "case-lambda" + "match" "match*" "with" "with*" + "begin" "begin0" "begin-syntax" "begin-annotation" + "begin-foreign" "begin-ffi" + ;; Binding forms + "let" "let*" "letrec" "letrec*" "let-values" "letrec-values" + "let-syntax" "letrec-syntax" "let-hash" "let/cc" "let/esc" + "rec" "alet" "alet*" "awhen" + ;; Lambda + "lambda" "lambda%" + ;; Module + "import" "export" "declare" "include" "module" "extern" + "require" "provide" "cond-expand" + ;; Assignment + "set!" "apply" "eval" + ;; Logic + "and" "or" "not" + ;; Error handling + "try" "catch" "finally" "error" "raise" + "unwind-protect" "with-destroy" "guard" + ;; Syntax + "syntax-case" "ast-case" "ast-rules" "core-syntax-case" + "core-ast-case" "core-match" "identifier-rules" + "with-syntax" "with-syntax*" "with-ast" "with-ast*" + "syntax-parameterize" + ;; Iteration + "for" "for*" "for/collect" "for/fold" "while" "until" + "for-each" "map" "foldl" "foldr" + ;; Concurrency + "spawn" "spawn*" "spawn/name" "spawn/group" + "sync" "wait" + ;; Quoting + "quote" "quasiquote" "unquote" "unquote-splicing" + "quote-syntax" "syntax" "quasisyntax" + "unsyntax" "unsyntax-splicing" "syntax/loc" + ;; Misc + "parameterize" "parameterize*" "using" "chain" "is" + "call/cc" "call/values" "values" "cut" + ;; Interface + "interface" "with-interface" "with-struct" "with-class" + "with-methods" "with-class-methods" + ;; Testing + "test-suite" "test-case" "check" "run-tests!" + "check-eq?" "check-equal?" "check-not-equal?" + "check-output" "check-predicate" "check-exception") + " ")) + + ;; Keyword set 1: Built-in functions and types (highlighted differently) + (define *gerbil-builtins* + (string-join + '(;; Common functions + "cons" "car" "cdr" "caar" "cadr" "cdar" "cddr" + "list" "list?" "null?" "pair?" "append" "reverse" "length" + "assoc" "assq" "assv" "member" "memq" "memv" + "vector" "vector-ref" "vector-set!" "vector-length" + "make-vector" "vector->list" "list->vector" + "string" "string-ref" "string-length" "string-append" + "substring" "string->list" "list->string" + "string=?" "string<?" "string>?" + "number?" "string?" "symbol?" "boolean?" "char?" + "integer?" "real?" "zero?" "positive?" "negative?" + "eq?" "eqv?" "equal?" + "+" "-" "*" "/" "=" "<" ">" "<=" ">=" + "min" "max" "abs" "modulo" "remainder" "quotient" + "display" "write" "newline" "read" "read-line" + "open-input-file" "open-output-file" "close-port" + "call-with-input-file" "call-with-output-file" + "with-input-from-file" "with-output-to-file" + "with-input-from-string" "with-output-to-string" + "current-input-port" "current-output-port" + "port?" "input-port?" "output-port?" + "eof-object?" "char-ready?" + ;; Hash tables + "make-hash-table" "hash-table?" "hash-get" "hash-put!" + "hash-remove!" "hash-ref" "hash-key?" "hash-keys" + "hash-values" "hash-for-each" "hash-map" "hash-copy" + ;; Type predicates + "void?" "procedure?" "hash-table?" + "fixnum?" "flonum?" "exact?" "inexact?" + ;; Conversion + "number->string" "string->number" + "symbol->string" "string->symbol" + "char->integer" "integer->char" + "exact->inexact" "inexact->exact" + ;; Boolean + "not" "boolean?" + ;; I/O + "file-exists?" "delete-file" "rename-file" + "directory-files" "create-directory" + "current-directory" "path-expand" "path-directory" + "path-strip-directory" "path-extension" + ;; Gerbil specifics + "make-hash-table-eq" "hash-eq" "hash-eqv" + "string-empty?" "string-contains" + "filter" "sort" "iota" "range" + "void" "raise-type-error") + " ")) + + ;;;========================================================================== + ;;; Syntax highlighting (face-aware, theme-independent) + ;;;========================================================================== + + (define (setup-gerbil-highlighting! ed) + ;; Set the Lisp lexer (same as Scheme) + (editor-set-lexer-language ed "lisp") + + ;; Set keyword lists + (editor-set-keywords ed 0 *gerbil-keywords*) + (editor-set-keywords ed 1 *gerbil-builtins*) + + ;; Default style: from 'default face + (let-values (((fg-r fg-g fg-b) (face-fg-rgb 'default)) + ((bg-r bg-g bg-b) (face-bg-rgb 'default))) + (editor-style-set-foreground ed SCE_LISP_DEFAULT (rgb->scintilla fg-r fg-g fg-b)) + (editor-style-set-background ed SCE_LISP_DEFAULT (rgb->scintilla bg-r bg-g bg-b))) + + ;; Comments: from font-lock-comment-face + (let-values (((fg-r fg-g fg-b) (face-fg-rgb 'font-lock-comment-face)) + ((bg-r bg-g bg-b) (face-bg-rgb 'default))) + (editor-style-set-foreground ed SCE_LISP_COMMENT (rgb->scintilla fg-r fg-g fg-b)) + (editor-style-set-background ed SCE_LISP_COMMENT (rgb->scintilla bg-r bg-g bg-b)) + (when (face-has-italic? 'font-lock-comment-face) + (editor-style-set-italic ed SCE_LISP_COMMENT #t))) + + ;; Multi-line comments: from font-lock-comment-face + (let-values (((fg-r fg-g fg-b) (face-fg-rgb 'font-lock-comment-face)) + ((bg-r bg-g bg-b) (face-bg-rgb 'default))) + (editor-style-set-foreground ed SCE_LISP_MULTI_COMMENT (rgb->scintilla fg-r fg-g fg-b)) + (editor-style-set-background ed SCE_LISP_MULTI_COMMENT (rgb->scintilla bg-r bg-g bg-b)) + (when (face-has-italic? 'font-lock-comment-face) + (editor-style-set-italic ed SCE_LISP_MULTI_COMMENT #t))) + + ;; Numbers: from font-lock-number-face + (let-values (((fg-r fg-g fg-b) (face-fg-rgb 'font-lock-number-face)) + ((bg-r bg-g bg-b) (face-bg-rgb 'default))) + (editor-style-set-foreground ed SCE_LISP_NUMBER (rgb->scintilla fg-r fg-g fg-b)) + (editor-style-set-background ed SCE_LISP_NUMBER (rgb->scintilla bg-r bg-g bg-b))) + + ;; Keywords (set 0): from font-lock-keyword-face + (let-values (((fg-r fg-g fg-b) (face-fg-rgb 'font-lock-keyword-face)) + ((bg-r bg-g bg-b) (face-bg-rgb 'default))) + (editor-style-set-foreground ed SCE_LISP_KEYWORD (rgb->scintilla fg-r fg-g fg-b)) + (editor-style-set-background ed SCE_LISP_KEYWORD (rgb->scintilla bg-r bg-g bg-b)) + (when (face-has-bold? 'font-lock-keyword-face) + (editor-style-set-bold ed SCE_LISP_KEYWORD #t))) + + ;; Keywords KW (set 1): from font-lock-builtin-face + (let-values (((fg-r fg-g fg-b) (face-fg-rgb 'font-lock-builtin-face)) + ((bg-r bg-g bg-b) (face-bg-rgb 'default))) + (editor-style-set-foreground ed SCE_LISP_KEYWORD_KW (rgb->scintilla fg-r fg-g fg-b)) + (editor-style-set-background ed SCE_LISP_KEYWORD_KW (rgb->scintilla bg-r bg-g bg-b))) + + ;; Symbols (quoted): from font-lock-string-face (green) + (let-values (((fg-r fg-g fg-b) (face-fg-rgb 'font-lock-string-face)) + ((bg-r bg-g bg-b) (face-bg-rgb 'default))) + (editor-style-set-foreground ed SCE_LISP_SYMBOL (rgb->scintilla fg-r fg-g fg-b)) + (editor-style-set-background ed SCE_LISP_SYMBOL (rgb->scintilla bg-r bg-g bg-b))) + + ;; Strings: from font-lock-string-face + (let-values (((fg-r fg-g fg-b) (face-fg-rgb 'font-lock-string-face)) + ((bg-r bg-g bg-b) (face-bg-rgb 'default))) + (editor-style-set-foreground ed SCE_LISP_STRING (rgb->scintilla fg-r fg-g fg-b)) + (editor-style-set-background ed SCE_LISP_STRING (rgb->scintilla bg-r bg-g bg-b))) + + ;; String EOL (unterminated string): from 'error face with red background + (let-values (((fg-r fg-g fg-b) (face-fg-rgb 'error))) + (editor-style-set-foreground ed SCE_LISP_STRINGEOL (rgb->scintilla fg-r fg-g fg-b)) + (editor-style-set-background ed SCE_LISP_STRINGEOL (rgb->scintilla #x28 #x18 #x18)) + (editor-style-set-eol-filled ed SCE_LISP_STRINGEOL #t)) + + ;; Identifiers: from 'default face + (let-values (((fg-r fg-g fg-b) (face-fg-rgb 'default)) + ((bg-r bg-g bg-b) (face-bg-rgb 'default))) + (editor-style-set-foreground ed SCE_LISP_IDENTIFIER (rgb->scintilla fg-r fg-g fg-b)) + (editor-style-set-background ed SCE_LISP_IDENTIFIER (rgb->scintilla bg-r bg-g bg-b))) + + ;; Operators (parens, brackets): from font-lock-operator-face + (let-values (((fg-r fg-g fg-b) (face-fg-rgb 'font-lock-operator-face)) + ((bg-r bg-g bg-b) (face-bg-rgb 'default))) + (editor-style-set-foreground ed SCE_LISP_OPERATOR (rgb->scintilla fg-r fg-g fg-b)) + (editor-style-set-background ed SCE_LISP_OPERATOR (rgb->scintilla bg-r bg-g bg-b))) + + ;; Special (#t, #f, #\char, etc.): from font-lock-builtin-face + (let-values (((fg-r fg-g fg-b) (face-fg-rgb 'font-lock-builtin-face)) + ((bg-r bg-g bg-b) (face-bg-rgb 'default))) + (editor-style-set-foreground ed SCE_LISP_SPECIAL (rgb->scintilla fg-r fg-g fg-b)) + (editor-style-set-background ed SCE_LISP_SPECIAL (rgb->scintilla bg-r bg-g bg-b))) + + ;; Trigger initial colorization + (editor-colourise ed 0 -1)) + + ;;;========================================================================== + ;;; C/C++ lexer style IDs (from SciLexer.h -- SCLEX_CPP) + ;;;========================================================================== + + (define SCE_C_DEFAULT 0) + (define SCE_C_COMMENT 1) + (define SCE_C_COMMENTLINE 2) + (define SCE_C_COMMENTDOC 3) + (define SCE_C_NUMBER 4) + (define SCE_C_WORD 5) ;; keyword set 0 + (define SCE_C_STRING 6) + (define SCE_C_CHARACTER 7) + (define SCE_C_PREPROCESSOR 9) + (define SCE_C_OPERATOR 10) + (define SCE_C_IDENTIFIER 11) + (define SCE_C_STRINGEOL 12) + (define SCE_C_WORD2 16) ;; keyword set 1 (types) + (define SCE_C_COMMENTDOCKEYWORD 17) + (define SCE_C_COMMENTDOCKEYWORDERROR 18) + + (define *c-keywords* + (string-join + '("if" "else" "for" "while" "do" "switch" "case" "default" + "break" "continue" "return" "goto" "struct" "union" "enum" + "typedef" "sizeof" "static" "const" "volatile" "extern" + "inline" "register" "auto" "signed" "unsigned" + "class" "public" "private" "protected" "virtual" "override" + "template" "typename" "namespace" "using" "new" "delete" + "throw" "try" "catch" "noexcept" "constexpr" "nullptr" + "true" "false" "this" "operator" "explicit" "friend" + "mutable" "final" "abstract" "static_cast" "dynamic_cast" + "const_cast" "reinterpret_cast" "decltype" "concept" + "requires" "co_await" "co_yield" "co_return") + " ")) + + (define *c-types* + (string-join + '("int" "char" "float" "double" "void" "long" "short" + "bool" "size_t" "ssize_t" "ptrdiff_t" "wchar_t" + "int8_t" "int16_t" "int32_t" "int64_t" + "uint8_t" "uint16_t" "uint32_t" "uint64_t" + "intptr_t" "uintptr_t" + "FILE" "NULL" "EOF" "stdin" "stdout" "stderr") + " ")) + + (define (setup-c-highlighting! ed) + (editor-set-lexer-language ed "cpp") + + ;; Keywords + (editor-set-keywords ed 0 *c-keywords*) + (editor-set-keywords ed 1 *c-types*) + + ;; Default: light gray on dark + (editor-style-set-foreground ed SCE_C_DEFAULT (rgb->scintilla #xd8 #xd8 #xd8)) + (editor-style-set-background ed SCE_C_DEFAULT (rgb->scintilla #x18 #x18 #x18)) + + ;; Comments: gray, italic + (editor-style-set-foreground ed SCE_C_COMMENT (rgb->scintilla #x99 #x99 #x99)) + (editor-style-set-background ed SCE_C_COMMENT (rgb->scintilla #x18 #x18 #x18)) + (editor-style-set-italic ed SCE_C_COMMENT #t) + (editor-style-set-foreground ed SCE_C_COMMENTLINE (rgb->scintilla #x99 #x99 #x99)) + (editor-style-set-background ed SCE_C_COMMENTLINE (rgb->scintilla #x18 #x18 #x18)) + (editor-style-set-italic ed SCE_C_COMMENTLINE #t) + (editor-style-set-foreground ed SCE_C_COMMENTDOC (rgb->scintilla #x99 #x99 #x99)) + (editor-style-set-background ed SCE_C_COMMENTDOC (rgb->scintilla #x18 #x18 #x18)) + (editor-style-set-italic ed SCE_C_COMMENTDOC #t) + + ;; Numbers: orange + (editor-style-set-foreground ed SCE_C_NUMBER (rgb->scintilla #xf9 #x91 #x57)) + (editor-style-set-background ed SCE_C_NUMBER (rgb->scintilla #x18 #x18 #x18)) + + ;; Keywords: purple, bold + (editor-style-set-foreground ed SCE_C_WORD (rgb->scintilla #xcc #x99 #xcc)) + (editor-style-set-background ed SCE_C_WORD (rgb->scintilla #x18 #x18 #x18)) + (editor-style-set-bold ed SCE_C_WORD #t) + + ;; Types (keyword set 1): yellow + (editor-style-set-foreground ed SCE_C_WORD2 (rgb->scintilla #xff #xcc #x66)) + (editor-style-set-background ed SCE_C_WORD2 (rgb->scintilla #x18 #x18 #x18)) + + ;; Strings: green + (editor-style-set-foreground ed SCE_C_STRING (rgb->scintilla #x99 #xcc #x99)) + (editor-style-set-background ed SCE_C_STRING (rgb->scintilla #x18 #x18 #x18)) + + ;; Character literals: green + (editor-style-set-foreground ed SCE_C_CHARACTER (rgb->scintilla #x99 #xcc #x99)) + (editor-style-set-background ed SCE_C_CHARACTER (rgb->scintilla #x18 #x18 #x18)) + + ;; Preprocessor: orange + (editor-style-set-foreground ed SCE_C_PREPROCESSOR (rgb->scintilla #xf9 #x91 #x57)) + (editor-style-set-background ed SCE_C_PREPROCESSOR (rgb->scintilla #x18 #x18 #x18)) + + ;; Operators: slightly brighter + (editor-style-set-foreground ed SCE_C_OPERATOR (rgb->scintilla #xb8 #xb8 #xb8)) + (editor-style-set-background ed SCE_C_OPERATOR (rgb->scintilla #x18 #x18 #x18)) + + ;; Identifiers: light gray + (editor-style-set-foreground ed SCE_C_IDENTIFIER (rgb->scintilla #xd8 #xd8 #xd8)) + (editor-style-set-background ed SCE_C_IDENTIFIER (rgb->scintilla #x18 #x18 #x18)) + + ;; Unterminated strings: red + (editor-style-set-foreground ed SCE_C_STRINGEOL (rgb->scintilla #xf2 #x77 #x7a)) + (editor-style-set-background ed SCE_C_STRINGEOL (rgb->scintilla #x28 #x18 #x18)) + (editor-style-set-eol-filled ed SCE_C_STRINGEOL #t) + + (editor-colourise ed 0 -1)) + + ;;;========================================================================== + ;;; Python lexer style IDs (from SciLexer.h -- SCLEX_PYTHON) + ;;;========================================================================== + + (define SCE_P_DEFAULT 0) + (define SCE_P_COMMENTLINE 1) + (define SCE_P_NUMBER 2) + (define SCE_P_STRING 3) + (define SCE_P_CHARACTER 4) + (define SCE_P_WORD 5) ;; keyword set 0 + (define SCE_P_TRIPLE 6) ;; triple-quoted string + (define SCE_P_TRIPLEDOUBLE 7) ;; triple double-quoted string + (define SCE_P_CLASSNAME 8) + (define SCE_P_DEFNAME 9) + (define SCE_P_OPERATOR 10) + (define SCE_P_IDENTIFIER 11) + (define SCE_P_COMMENTBLOCK 12) + (define SCE_P_STRINGEOL 13) + (define SCE_P_WORD2 14) ;; keyword set 1 (builtins) + (define SCE_P_DECORATOR 15) + (define SCE_P_FSTRING 16) + (define SCE_P_FTRIPLE 17) + (define SCE_P_FTRIPLEDOUBLE 18) + + (define *python-keywords* + (string-join + '("False" "None" "True" "and" "as" "assert" "async" "await" + "break" "class" "continue" "def" "del" "elif" "else" "except" + "finally" "for" "from" "global" "if" "import" "in" "is" + "lambda" "nonlocal" "not" "or" "pass" "raise" "return" + "try" "while" "with" "yield" "match" "case" "type") + " ")) + + (define *python-builtins* + (string-join + '("print" "len" "range" "int" "str" "float" "list" "dict" + "tuple" "set" "bool" "type" "isinstance" "issubclass" + "open" "input" "map" "filter" "zip" "enumerate" + "sorted" "reversed" "sum" "min" "max" "abs" "any" "all" + "super" "property" "staticmethod" "classmethod" + "hasattr" "getattr" "setattr" "delattr" "repr" "hash" + "id" "iter" "next" "callable" "vars" "dir" "help" + "ValueError" "TypeError" "KeyError" "IndexError" + "Exception" "RuntimeError" "StopIteration" + "AttributeError" "ImportError" "OSError" "IOError" + "FileNotFoundError" "PermissionError" "NotImplementedError" + "object" "bytes" "bytearray" "memoryview" "frozenset" + "complex" "slice" "format" "globals" "locals" "exec" "eval" + "compile" "breakpoint" "exit" "quit") + " ")) + + (define (setup-python-highlighting! ed) + (editor-set-lexer-language ed "python") + + ;; Keywords + (editor-set-keywords ed 0 *python-keywords*) + (editor-set-keywords ed 1 *python-builtins*) + + ;; Default: light gray on dark + (editor-style-set-foreground ed SCE_P_DEFAULT (rgb->scintilla #xd8 #xd8 #xd8)) + (editor-style-set-background ed SCE_P_DEFAULT (rgb->scintilla #x18 #x18 #x18)) + + ;; Comments: gray, italic + (editor-style-set-foreground ed SCE_P_COMMENTLINE (rgb->scintilla #x99 #x99 #x99)) + (editor-style-set-background ed SCE_P_COMMENTLINE (rgb->scintilla #x18 #x18 #x18)) + (editor-style-set-italic ed SCE_P_COMMENTLINE #t) + (editor-style-set-foreground ed SCE_P_COMMENTBLOCK (rgb->scintilla #x99 #x99 #x99)) + (editor-style-set-background ed SCE_P_COMMENTBLOCK (rgb->scintilla #x18 #x18 #x18)) + (editor-style-set-italic ed SCE_P_COMMENTBLOCK #t) + + ;; Numbers: orange + (editor-style-set-foreground ed SCE_P_NUMBER (rgb->scintilla #xf9 #x91 #x57)) + (editor-style-set-background ed SCE_P_NUMBER (rgb->scintilla #x18 #x18 #x18)) + + ;; Keywords: purple, bold + (editor-style-set-foreground ed SCE_P_WORD (rgb->scintilla #xcc #x99 #xcc)) + (editor-style-set-background ed SCE_P_WORD (rgb->scintilla #x18 #x18 #x18)) + (editor-style-set-bold ed SCE_P_WORD #t) + + ;; Builtins (keyword set 1): cyan + (editor-style-set-foreground ed SCE_P_WORD2 (rgb->scintilla #x66 #xcc #xcc)) + (editor-style-set-background ed SCE_P_WORD2 (rgb->scintilla #x18 #x18 #x18)) + + ;; Strings: green + (editor-style-set-foreground ed SCE_P_STRING (rgb->scintilla #x99 #xcc #x99)) + (editor-style-set-background ed SCE_P_STRING (rgb->scintilla #x18 #x18 #x18)) + (editor-style-set-foreground ed SCE_P_CHARACTER (rgb->scintilla #x99 #xcc #x99)) + (editor-style-set-background ed SCE_P_CHARACTER (rgb->scintilla #x18 #x18 #x18)) + (editor-style-set-foreground ed SCE_P_TRIPLE (rgb->scintilla #x99 #xcc #x99)) + (editor-style-set-background ed SCE_P_TRIPLE (rgb->scintilla #x18 #x18 #x18)) + (editor-style-set-foreground ed SCE_P_TRIPLEDOUBLE (rgb->scintilla #x99 #xcc #x99)) + (editor-style-set-background ed SCE_P_TRIPLEDOUBLE (rgb->scintilla #x18 #x18 #x18)) + + ;; F-strings: green + (editor-style-set-foreground ed SCE_P_FSTRING (rgb->scintilla #x99 #xcc #x99)) + (editor-style-set-background ed SCE_P_FSTRING (rgb->scintilla #x18 #x18 #x18)) + (editor-style-set-foreground ed SCE_P_FTRIPLE (rgb->scintilla #x99 #xcc #x99)) + (editor-style-set-background ed SCE_P_FTRIPLE (rgb->scintilla #x18 #x18 #x18)) + (editor-style-set-foreground ed SCE_P_FTRIPLEDOUBLE (rgb->scintilla #x99 #xcc #x99)) + (editor-style-set-background ed SCE_P_FTRIPLEDOUBLE (rgb->scintilla #x18 #x18 #x18)) + + ;; Class/def names: cyan + (editor-style-set-foreground ed SCE_P_CLASSNAME (rgb->scintilla #x66 #xcc #xcc)) + (editor-style-set-background ed SCE_P_CLASSNAME (rgb->scintilla #x18 #x18 #x18)) + (editor-style-set-bold ed SCE_P_CLASSNAME #t) + (editor-style-set-foreground ed SCE_P_DEFNAME (rgb->scintilla #x66 #xcc #xcc)) + (editor-style-set-background ed SCE_P_DEFNAME (rgb->scintilla #x18 #x18 #x18)) + + ;; Decorators: orange + (editor-style-set-foreground ed SCE_P_DECORATOR (rgb->scintilla #xf9 #x91 #x57)) + (editor-style-set-background ed SCE_P_DECORATOR (rgb->scintilla #x18 #x18 #x18)) + + ;; Operators: slightly brighter + (editor-style-set-foreground ed SCE_P_OPERATOR (rgb->scintilla #xb8 #xb8 #xb8)) + (editor-style-set-background ed SCE_P_OPERATOR (rgb->scintilla #x18 #x18 #x18)) + + ;; Identifiers: light gray + (editor-style-set-foreground ed SCE_P_IDENTIFIER (rgb->scintilla #xd8 #xd8 #xd8)) + (editor-style-set-background ed SCE_P_IDENTIFIER (rgb->scintilla #x18 #x18 #x18)) + + ;; Unterminated strings: red + (editor-style-set-foreground ed SCE_P_STRINGEOL (rgb->scintilla #xf2 #x77 #x7a)) + (editor-style-set-background ed SCE_P_STRINGEOL (rgb->scintilla #x28 #x18 #x18)) + (editor-style-set-eol-filled ed SCE_P_STRINGEOL #t) + + (editor-colourise ed 0 -1)) + + ;;;========================================================================== + ;;; Dark theme color palette (shared across all languages) + ;;;========================================================================== + + (define *theme-bg* (rgb->scintilla #x18 #x18 #x18)) + (define *theme-fg* (rgb->scintilla #xd8 #xd8 #xd8)) + (define *theme-comment* (rgb->scintilla #x99 #x99 #x99)) + (define *theme-keyword* (rgb->scintilla #xcc #x99 #xcc)) + (define *theme-string* (rgb->scintilla #x99 #xcc #x99)) + (define *theme-number* (rgb->scintilla #xf9 #x91 #x57)) + (define *theme-type* (rgb->scintilla #x66 #xcc #xcc)) + (define *theme-function* (rgb->scintilla #x66 #x99 #xcc)) + (define *theme-operator* (rgb->scintilla #xb8 #xb8 #xb8)) + (define *theme-error* (rgb->scintilla #xf2 #x77 #x7a)) + (define *theme-tag* (rgb->scintilla #xf2 #x77 #x7a))