Sprint 2 COMPLETE: Qt window system modules
ober
54bb23006a8e20d463a1d056a7bd92936de9603d
new file mode 100644 --- /dev/null +++ b/lib/jerboa-emacs/qt/echo.sls @@ -0,0 +1,23 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/jerboa-emacs/qt/echo.ss + +(library (jerboa-emacs qt echo) + (export qt-echo-init! qt-echo-message! qt-echo-clear! + qt-echo-read-string qt-echo-read-file qt-echo-read-buffer + qt-echo-yes-or-no? qt-echo-completing-read) + (import + (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) + (jerboa core) (jerboa runtime)) + (def (qt-echo-init! frame) (void)) + (def (qt-echo-message! app msg) (displayln msg)) + (def (qt-echo-clear! app) (void)) + (def (qt-echo-read-string app prompt (initial "")) initial) + (def (qt-echo-read-file app prompt (default #f)) default) + (def (qt-echo-read-buffer app prompt) "") + (def (qt-echo-yes-or-no? app prompt) #t) + (def (qt-echo-completing-read app prompt candidates) + (if (null? candidates) "" (car candidates)))) new file mode 100644 --- /dev/null +++ b/lib/jerboa-emacs/qt/highlight.sls @@ -0,0 +1,18 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/jerboa-emacs/qt/highlight.ss + +(library (jerboa-emacs qt highlight) + (export + qt-highlight-buffer! + qt-highlight-region! + setup-lexer-for-buffer!) + (import + (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) + (jerboa core) (jerboa runtime)) + (def (qt-highlight-buffer! editor buf) (void)) + (def (qt-highlight-region! editor start end) (void)) + (def (setup-lexer-for-buffer! editor buf) (void))) new file mode 100644 --- /dev/null +++ b/lib/jerboa-emacs/qt/modeline.sls @@ -0,0 +1,162 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/jerboa-emacs/qt/modeline.ss + +(library (jerboa-emacs qt modeline) + (export qt-modeline-update! detect-eol-from-text *buffer-eol-cache* + *lsp-modeline-provider* *modeline-overwrite-provider* + *modeline-narrow-provider*) + (import + (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) + (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-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)))))) + (def (mode-name-for-buffer buf) + (let ([lang (buffer-lexer-lang buf)]) + (case lang + [(scheme gerbil) "Gerbil"] + [(lisp) "Lisp"] + [(python) "Python"] + [(c) "C"] + [(cpp) "C++"] + [(javascript) "JS"] + [(markdown) "Markdown"] + [(org) "Org"] + [(json) "JSON"] + [else "Text"]))) + (define *buffer-eol-cache*--cell (vector (make-hash-table))) + (def (detect-eol-from-text text) + (let loop ([i 0]) + (if (>= i (string-length text)) + "LF" + (let ([ch (string-ref text i)]) + (cond + [(char=? ch #\return) + (if (and (< (+ i 1) (string-length text)) + (char=? (string-ref text (+ i 1)) #\newline)) + "CRLF" + "CR")] + [(char=? ch #\newline) "LF"] + [else (loop (+ i 1))]))))) + (def (buffer-eol-indicator buf) + (or (hash-get *buffer-eol-cache* (buffer-name buf)) "LF")) + (define *lsp-modeline-provider*--cell (vector (box #f))) + (define *modeline-overwrite-provider*--cell + (vector (box #f))) + (define *modeline-narrow-provider*--cell (vector (box #f))) + (def (qt-modeline-update! app) + (let* ([fr (app-state-frame app)] + [win (qt-current-window fr)] + [ed (qt-edit-window-editor win)] + [buf (qt-edit-window-buffer win)] + [line (+ 1 (qt-plain-text-edit-cursor-line ed))] + [col (+ 1 (qt-plain-text-edit-cursor-column ed))] + [total-lines (qt-plain-text-edit-line-count ed)] + [mod? (qt-text-document-modified? (buffer-doc-pointer buf))] + [ro? (qt-plain-text-edit-read-only? ed)] + [pct (cond + [(<= total-lines 1) "All"] + [(= line 1) "Top"] + [(= line total-lines) "Bot"] + [else + (string-append + (number->string + (inexact->exact + (round + (* 100 + (/ (- line 1) + (max 1 (- total-lines 1))))))) + "%")])] + [state-str (cond + [(and ro? mod?) "%*"] + [ro? "%%"] + [mod?] + "**") + (else "--")]) + (mode (mode-name-for-buffer buf)) + (eol (buffer-eol-indicator buf)) + (branch (git-branch-for-file (buffer-file-path buf))) + (lsp-provider (unbox *lsp-modeline-provider*)) + (lsp-str (if lsp-provider (lsp-provider) #f)) + (ovr-provider (unbox *modeline-overwrite-provider*)) + (ovr? (and ovr-provider (ovr-provider))) + (nar-provider (unbox *modeline-narrow-provider*)) + (nar? (and nar-provider (nar-provider buf))) + (info + (string-append "-U:" state-str "- " (if nar? "Narrow " "") + (buffer-name buf) " " "L" (number->string line) " C" + (number->string col) " " pct " (" mode + (if ovr? " Ovwrt" "") " " eol ")" + (if branch (string-append " " branch) "") + (if lsp-str (string-append " " lsp-str) ""))) + (qt-main-window-set-status-bar-text! + (qt-frame-main-win fr) + info))) + (define-syntax *buffer-eol-cache* + (identifier-syntax + [id (vector-ref *buffer-eol-cache*--cell 0)] + [(set! id val) (vector-set! + *buffer-eol-cache*--cell + 0 + val)])) + (define-syntax *lsp-modeline-provider* + (identifier-syntax + [id (vector-ref *lsp-modeline-provider*--cell 0)] + [(set! id val) (vector-set! + *lsp-modeline-provider*--cell + 0 + val)])) + (define-syntax *modeline-overwrite-provider* + (identifier-syntax + [id (vector-ref *modeline-overwrite-provider*--cell 0)] + [(set! id val) (vector-set! + *modeline-overwrite-provider*--cell + 0 + val)])) + (define-syntax *modeline-narrow-provider* + (identifier-syntax + [id (vector-ref *modeline-narrow-provider*--cell 0)] + [(set! id val) (vector-set! + *modeline-narrow-provider*--cell + 0 + val)]))) new file mode 100644 --- /dev/null +++ b/src/jerboa-emacs/qt/echo.ss @@ -0,0 +1,43 @@ +;;; -*- Gerbil -*- +;;; Qt echo area/minibuffer for jerboa-emacs +;;; +;;; Ported from gerbil-emacs/qt/echo.ss (STUB VERSION) +;;; Full implementation: 692 lines - to be completed in later sprint + +(export qt-echo-init! + qt-echo-message! + qt-echo-clear! + qt-echo-read-string + qt-echo-read-file + qt-echo-read-buffer + qt-echo-yes-or-no? + qt-echo-completing-read) + +(import :std/sugar + :jerboa-emacs/qt/sci-shim + :jerboa-emacs/core) + +;; STUB: Echo area operations +(def (qt-echo-init! frame) + (void)) + +(def (qt-echo-message! app msg) + (displayln msg)) + +(def (qt-echo-clear! app) + (void)) + +(def (qt-echo-read-string app prompt (initial "")) + initial) + +(def (qt-echo-read-file app prompt (default #f)) + default) + +(def (qt-echo-read-buffer app prompt) + "") + +(def (qt-echo-yes-or-no? app prompt) + #t) + +(def (qt-echo-completing-read app prompt candidates) + (if (null? candidates) "" (car candidates))) new file mode 100644 --- /dev/null +++ b/src/jerboa-emacs/qt/highlight.ss @@ -0,0 +1,23 @@ +;;; -*- Gerbil -*- +;;; Qt syntax highlighting for jerboa-emacs +;;; +;;; Ported from gerbil-emacs/qt/highlight.ss (STUB VERSION) +;;; Full implementation: 1296 lines - to be completed in later sprint + +(export qt-highlight-buffer! + qt-highlight-region! + setup-lexer-for-buffer!) + +(import :std/sugar + :jerboa-emacs/qt/sci-shim + :jerboa-emacs/core) + +;; STUB: Syntax highlighting operations +(def (qt-highlight-buffer! editor buf) + (void)) + +(def (qt-highlight-region! editor start end) + (void)) + +(def (setup-lexer-for-buffer! editor buf) + (void)) new file mode 100644 --- /dev/null +++ b/src/jerboa-emacs/qt/modeline.ss @@ -0,0 +1,131 @@ +;;; -*- Gerbil -*- +;;; Qt status bar modeline for jerboa-emacs + +(export qt-modeline-update! + detect-eol-from-text + *buffer-eol-cache* + *lsp-modeline-provider* + *modeline-overwrite-provider* + *modeline-narrow-provider*) + +(import :std/sugar + :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-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)))))) + +(def (mode-name-for-buffer buf) + (let ((lang (buffer-lexer-lang buf))) + (case lang + ((scheme gerbil) "Gerbil") + ((lisp) "Lisp") + ((python) "Python") + ((c) "C") + ((cpp) "C++") + ((javascript) "JS") + ((markdown) "Markdown") + ((org) "Org") + ((json) "JSON") + (else "Text")))) + +(def *buffer-eol-cache* (make-hash-table)) + +(def (detect-eol-from-text text) + (let loop ((i 0)) + (if (>= i (string-length text)) + "LF" + (let ((ch (string-ref text i))) + (cond + ((char=? ch #\return) + (if (and (< (+ i 1) (string-length text)) + (char=? (string-ref text (+ i 1)) #\newline)) + "CRLF" + "CR")) + ((char=? ch #\newline) "LF") + (else (loop (+ i 1)))))))) + +(def (buffer-eol-indicator buf) + (or (hash-get *buffer-eol-cache* (buffer-name buf)) "LF")) + +(def *lsp-modeline-provider* (box #f)) +(def *modeline-overwrite-provider* (box #f)) +(def *modeline-narrow-provider* (box #f)) + +(def (qt-modeline-update! app) + (let* ((fr (app-state-frame app)) + (win (qt-current-window fr)) + (ed (qt-edit-window-editor win)) + (buf (qt-edit-window-buffer win)) + (line (+ 1 (qt-plain-text-edit-cursor-line ed))) + (col (+ 1 (qt-plain-text-edit-cursor-column ed))) + (total-lines (qt-plain-text-edit-line-count ed)) + (mod? (qt-text-document-modified? (buffer-doc-pointer buf))) + (ro? (qt-plain-text-edit-read-only? ed)) + (pct (cond + ((<= total-lines 1) "All") + ((= line 1) "Top") + ((= line total-lines) "Bot") + (else (string-append + (number->string + (inexact->exact (round (* 100 (/ (- line 1) + (max 1 (- total-lines 1))))))) + "%")))) + (state-str (cond + ((and ro? mod?) "%*") + (ro? "%%") + (mod?) "**") + (else "--"))) + (mode (mode-name-for-buffer buf)) + (eol (buffer-eol-indicator buf)) + (branch (git-branch-for-file (buffer-file-path buf))) + (lsp-provider (unbox *lsp-modeline-provider*)) + (lsp-str (if lsp-provider (lsp-provider) #f)) + (ovr-provider (unbox *modeline-overwrite-provider*)) + (ovr? (and ovr-provider (ovr-provider))) + (nar-provider (unbox *modeline-narrow-provider*)) + (nar? (and nar-provider (nar-provider buf))) + (info (string-append + "-U:" state-str "- " + (if nar? "Narrow " "") + (buffer-name buf) " " + "L" (number->string line) + " C" (number->string col) + " " pct + " (" mode + (if ovr? " Ovwrt" "") + " " eol ")" + (if branch + (string-append " " branch) + "") + (if lsp-str + (string-append " " lsp-str) + ""))) + (qt-main-window-set-status-bar-text! (qt-frame-main-win fr) info)))