Add emacsclient.ss and full org-mode/persist test suite
ober
f9a7e4bb1df9ebc2f078477de4a0de784848b110
--- a/Makefile +++ b/Makefile @@ -7,7 +7,7 @@ JERBUILD = $(SCHEME) --libdirs $(JERBOA)/lib --script $(JERBOA)/jerbuild.ss export LD_LIBRARY_PATH := $(HOME)/mine/chez-pcre2:$(HOME)/mine/chez-scintilla:$(HOME)/mine/jerboa-shell:$(LD_LIBRARY_PATH) export CHEZ_SCINTILLA_LIB := $(HOME)/mine/chez-scintilla -.PHONY: all build rebuild run test-tier0 test-tier2 test-tier3 test-tier4 test-tier5 test clean clean-generated +.PHONY: all build rebuild run test-tier0 test-tier2 test-tier3 test-tier4 test-tier5 test-org test clean clean-generated all: build test @@ -22,7 +22,7 @@ rebuild: run: build $(SCHEME) $(LIBDIRS) --script main.ss -test: build test-tier0 test-tier2 test-tier3 test-tier4 test-tier5 +test: build test-tier0 test-tier2 test-tier3 test-tier4 test-tier5 test-org test-tier0: $(SCHEME) $(LIBDIRS) --script tests/test-tier0.ss @@ -39,6 +39,37 @@ test-tier4: test-tier5: $(SCHEME) $(LIBDIRS) --program tests/test-tier5.ss +test-org: test-org-parse test-org-clock test-org-table test-org-agenda \ + test-org-babel test-org-capture test-org-export test-org-list \ + test-persist + +test-org-parse: + $(SCHEME) $(LIBDIRS) --script tests/test-org-parse.ss + +test-org-clock: + $(SCHEME) $(LIBDIRS) --script tests/test-org-clock.ss + +test-org-table: + $(SCHEME) $(LIBDIRS) --script tests/test-org-table.ss + +test-org-agenda: + $(SCHEME) $(LIBDIRS) --script tests/test-org-agenda.ss + +test-org-babel: + $(SCHEME) $(LIBDIRS) --script tests/test-org-babel.ss + +test-org-capture: + $(SCHEME) $(LIBDIRS) --script tests/test-org-capture.ss + +test-org-export: + $(SCHEME) $(LIBDIRS) --script tests/test-org-export.ss + +test-org-list: + $(SCHEME) $(LIBDIRS) --script tests/test-org-list.ss + +test-persist: + $(SCHEME) $(LIBDIRS) --script tests/test-persist.ss + clean: find lib -name '*.so' -delete 2>/dev/null; true new file mode 100644 --- /dev/null +++ b/emacsclient.ss @@ -0,0 +1,136 @@ +#!chezscheme +;;; emacsclient.ss — Open files in a running jerboa-emacs session. +;;; Analogous to Emacs's emacsclient. + +(import (chezscheme) + (std net tcp) + (jerboa-emacs ipc)) + +(include "manifest.ss") + +;;; ======================================================================== +;;; Helpers +;;; ======================================================================== + +(define (string-prefix? prefix str) + (and (>= (string-length str) (string-length prefix)) + (string=? (substring str 0 (string-length prefix)) prefix))) + +(define (string-trim-right s) + (let loop ([i (string-length s)]) + (if (and (> i 0) + (let ([c (string-ref s (- i 1))]) + (or (char=? c #\space) (char=? c #\return) (char=? c #\tab)))) + (loop (- i 1)) + (substring s 0 i)))) + +(define (path-expand file) + "Make FILE an absolute path relative to the current directory." + (if (and (> (string-length file) 0) + (char=? (string-ref file 0) #\/)) + file + (string-append (current-directory) "/" file))) + +;;; ======================================================================== +;;; Server file reading +;;; ======================================================================== + +(define (read-server-file) + "Read the server file and return (host . port) or #f." + (if (file-exists? *ipc-server-file*) + (guard (exn [else #f]) + (let ([content (call-with-input-file *ipc-server-file* + (lambda (p) (get-line p)))]) + (if (eof-object? content) + #f + (let loop ([i (- (string-length content) 1)]) + (if (< i 0) + #f + (if (char=? (string-ref content i) #\:) + (cons (substring content 0 i) + (string->number + (substring content (+ i 1) (string-length content)))) + (loop (- i 1)))))))) + #f)) + +;;; ======================================================================== +;;; File sending +;;; ======================================================================== + +(define (send-files! files) + "Connect to the running server and send file paths." + (let ([server-info (read-server-file)]) + (unless server-info + (display "jerboa-client: no server running (missing ") + (display *ipc-server-file*) + (display ")") + (newline) + (exit 1)) + (let ([host (car server-info)] + [port-num (cdr server-info)]) + (let-values ([(in-port out-port) + (guard (exn [else + (display "jerboa-client: cannot connect to ") + (display host) + (display ":") + (display port-num) + (newline) + (exit 1)]) + (tcp-connect host port-num))]) + (dynamic-wind + (lambda () (void)) + (lambda () + (for-each + (lambda (file) + (let ([abs-path (path-expand file)]) + (display abs-path out-port) + (newline out-port) + (flush-output-port out-port) + (let ([response (get-line in-port)]) + (when (or (eof-object? response) + (not (string=? (string-trim-right response) "OK"))) + (display "jerboa-client: unexpected response for ") + (display abs-path) + (newline))))) + files)) + (lambda () + (close-port in-port) + (close-port out-port))))))) + +;;; ======================================================================== +;;; Entry point +;;; ======================================================================== + +(define (main . args) + (cond + [(member "--version" args) + (display "jerboa-client ") + (display (cdar version-manifest)) + (newline)] + [(or (member "--help" args) (member "-h" args)) + (display "Usage: jerboa-client [OPTIONS] FILE...") + (newline) + (display "Open files in a running jerboa-emacs session.") + (newline) + (newline) + (display "Options:") + (newline) + (display " --version Show version information") + (newline) + (display " --help, -h Show this help message") + (newline)] + [(null? args) + (display "jerboa-client: no files specified") + (newline) + (display "Usage: jerboa-client FILE...") + (newline) + (exit 1)] + [else + (let ([files (filter (lambda (a) (not (string-prefix? "-" a))) args)]) + (when (null? files) + (display "jerboa-client: no files specified") + (newline) + (exit 1)) + (send-files! files))])) + +(apply main (command-line-arguments)) new file mode 100644 --- /dev/null +++ b/tests/test-org-agenda.ss @@ -0,0 +1,253 @@ +#!chezscheme +;;; test-org-agenda.ss — Tests for org-agenda module +;;; Ported from gerbil-emacs/org-agenda-test.ss + +(import (except (chezscheme) + make-hash-table hash-table? iota 1+ 1-) + (jerboa core) + (jerboa runtime) + (jerboa-emacs org-agenda) + (jerboa-emacs org-parse) + (std srfi srfi-13)) + +(define pass-count 0) +(define fail-count 0) + +(define-syntax check + (syntax-rules (=>) + ((_ expr => expected) + (let ((result expr) (exp expected)) + (if (equal? result exp) + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (display "FAIL: ") + (write 'expr) + (display " => ") + (write result) + (display " expected ") + (write exp) + (newline))))))) + +(define-syntax check-true + (syntax-rules () + ((_ expr) + (check (and expr #t) => #t)))) + +(define-syntax check-false + (syntax-rules () + ((_ expr) + (check (not expr) => #t)))) + +;; Adapters: test functions omit file-path arg; actual functions require it. +(define (org-collect-agenda-items-test text date-from date-to) + (org-collect-agenda-items text "" date-from date-to)) + +(define (zero-pad-2 n) + (if (< n 10) (string-append "0" (number->string n)) (number->string n))) + +(define (make-agenda-item heading-title type date hour minute) + (let ((h (make-org-heading 1 #f #f heading-title '() #f #f #f #f '() 0 #f))) + (make-org-agenda-item h type date + (string-append (zero-pad-2 hour) ":" (zero-pad-2 minute)) + "" 0))) + +(define (org-agenda-todo-list-test text) + (org-agenda-todo-list text "")) + +(define (org-agenda-tags-match-test text tag-expr) + (org-agenda-tags-match text "" tag-expr)) + +(define (org-agenda-search-test text query) + (org-agenda-search text "" query)) + +;;; ======================================================================== +;;; Date utility functions +;;; ======================================================================== + +(display "--- date-utilities ---\n") + +(check (org-date-weekday 2024 1 15) => 1) ; Monday +(check (org-date-weekday 2024 1 14) => 0) ; Sunday +(check (org-date-weekday 2024 1 13) => 6) ; Saturday +(check (org-date-weekday 2024 1 17) => 3) ; Wednesday +(check (org-date-weekday 2024 1 19) => 5) ; Friday + +;;; ======================================================================== +;;; Date timestamp creation +;;; ======================================================================== + +(display "--- date-ts-creation ---\n") + +(let ((ts (org-make-date-ts 2024 3 15))) + (check-true ts)) + +(let ((ts1 (org-make-date-ts 2024 1 1)) + (ts2 (org-make-date-ts 2024 12 31))) + (check-true ts1) + (check-true ts2)) + +;;; ======================================================================== +;;; Timestamp range checking +;;; ======================================================================== + +(display "--- timestamp-range ---\n") + +(let ((ts (org-make-date-ts 2024 1 15)) + (start (org-make-date-ts 2024 1 10)) + (end (org-make-date-ts 2024 1 20))) + (check (org-timestamp-in-range? ts start end) => #t)) + +(let ((ts (org-make-date-ts 2024 1 5)) + (start (org-make-date-ts 2024 1 10)) + (end (org-make-date-ts 2024 1 20))) + (check (org-timestamp-in-range? ts start end) => #f)) + +(let ((ts (org-make-date-ts 2024 1 25)) + (start (org-make-date-ts 2024 1 10)) + (end (org-make-date-ts 2024 1 20))) + (check (org-timestamp-in-range? ts start end) => #f)) + +;; Boundary conditions +(let ((ts (org-make-date-ts 2024 1 10)) + (start (org-make-date-ts 2024 1 10)) + (end (org-make-date-ts 2024 1 20))) + (check (org-timestamp-in-range? ts start end) => #t)) + +(let ((ts (org-make-date-ts 2024 1 20)) + (start (org-make-date-ts 2024 1 10)) + (end (org-make-date-ts 2024 1 20))) + (check (org-timestamp-in-range? ts start end) => #t)) + +;;; ======================================================================== +;;; Date advancing +;;; ======================================================================== + +(display "--- date-advancing ---\n") + +(let ((result (org-advance-date-ts (org-make-date-ts 2024 1 30) 3))) + (check-true result)) + +(let ((result (org-advance-date-ts (org-make-date-ts 2024 6 15) 0))) + (check-true result)) + +(let ((result (org-advance-date-ts (org-make-date-ts 2024 12 30) 5))) + (check-true result)) + +;;; ======================================================================== +;;; Agenda item collection +;;; ======================================================================== + +(display "--- agenda-collection ---\n") + +(let* ((text (string-append + "* TODO Task 1\n" + "SCHEDULED: <2024-01-15 Mon 09:00>\n" + "* TODO Task 2\n" + "DEADLINE: <2024-01-20 Sat 17:00>\n" + "* DONE Completed\n" + "CLOSED: [2024-01-10 Wed]\n")) + (start (org-make-date-ts 2024 1 1)) + (end (org-make-date-ts 2024 1 31)) + (items (org-collect-agenda-items-test text start end))) + (check-true (>= (length items) 2))) + +(let ((items (org-collect-agenda-items-test + "" (org-make-date-ts 2024 1 1) (org-make-date-ts 2024 1 31)))) + (check (null? items) => #t)) + +;;; ======================================================================== +;;; Agenda sorting +;;; ======================================================================== + +(display "--- agenda-sorting ---\n") + +(let* ((item1 (make-agenda-item "Task 1" 'scheduled + (org-make-date-ts 2024 1 15) 9 0)) + (item2 (make-agenda-item "Task 2" 'deadline + (org-make-date-ts 2024 1 15) 17 0)) + (sorted (org-agenda-sort-items (list item2 item1)))) + (check (equal? (org-heading-title (org-agenda-item-heading (car sorted))) "Task 1") => #t)) + +;;; ======================================================================== +;;; TODO list +;;; ======================================================================== + +(display "--- todo-list ---\n") + +(let* ((text (string-append + "* TODO Active task\n" + "* DONE Completed task\n" + "* TODO Another active\n")) + (todos (org-agenda-todo-list-test text))) + (check-true (string-contains todos "Active task")) + (check-true (string-contains todos "Another active")) + (check-false (string-contains todos "Completed task"))) + +(let ((todos (org-agenda-todo-list-test "* Just a heading\n"))) + (check-true (string-contains todos "No TODO"))) + +;;; ======================================================================== +;;; Tag search +;;; ======================================================================== + +(display "--- tag-search ---\n") + +(let* ((text (string-append + "* Task A :work:\n" + "* Task B :home:\n" + "* Task C :work:urgent:\n")) + (results (org-agenda-tags-match-test text "work"))) + (check-true (string-contains results "Task A")) + (check-true (string-contains results "Task C"))) + +(let* ((text (string-append + "* Task A :work:\n" + "* Task B :home:\n")) + (results (org-agenda-tags-match-test text "nonexistent"))) + (check-true (string-contains results "No matches"))) + +;;; ======================================================================== +;;; Text search +;;; ======================================================================== + +(display "--- text-search ---\n") + +(let* ((text (string-append + "* Meeting with Alice\n" + "* Lunch with Bob\n" + "* Call with ALICE\n")) + (results (org-agenda-search-test text "alice"))) + (check-true (string-contains results "Alice"))) + +(let* ((text "* Task A\n* Task B\n") + (results (org-agenda-search-test text "nonexistent"))) + (check-true (string-contains results "No matches"))) + +;;; ======================================================================== +;;; Agenda item formatting +;;; ======================================================================== + +(display "--- agenda-formatting ---\n") + +(let* ((item (make-agenda-item "Review code" 'scheduled + (org-make-date-ts 2024 1 15) 10 0)) + (formatted (org-format-agenda-item item))) + (check-true (string-contains formatted "Review code"))) + +(let* ((item (make-agenda-item "Review code" 'scheduled + (org-make-date-ts 2024 1 15) 10 0)) + (formatted (org-format-agenda-item item))) + (check-true (string-contains formatted "10:00"))) + +;;; ======================================================================== +;;; Summary +;;; ======================================================================== + +(newline) +(display "========================================\n") +(display (string-append "org-agenda Tests: " + (number->string pass-count) " passed, " + (number->string fail-count) " failed\n")) +(display "========================================\n") +(when (> fail-count 0) (exit 1)) new file mode 100644 --- /dev/null +++ b/tests/test-org-babel.ss @@ -0,0 +1,319 @@ +#!chezscheme +;;; test-org-babel.ss — Tests for org-babel module +;;; Ported from gerbil-emacs/org-babel-test.ss and org-src-test.ss + +(import (except (chezscheme) + make-hash-table hash-table? iota 1+ 1-) + (jerboa core) + (jerboa runtime) + (jerboa-emacs org-babel) + (jerboa-emacs org-parse) + (std srfi srfi-13)) + +(define pass-count 0) +(define fail-count 0) + +(define-syntax check + (syntax-rules (=>) + ((_ expr => expected) + (let ((result expr) (exp expected)) + (if (equal? result exp) + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (display "FAIL: ") + (write 'expr) + (display " => ") + (write result) + (display " expected ") + (write exp) + (newline))))))) + +(define-syntax check-true + (syntax-rules () + ((_ expr) + (check (and expr #t) => #t)))) + +;; Split text on newlines into a list of lines +(define (split-lines text) + (let loop ([i 0] [start 0] [result '()]) + (cond + [(= i (string-length text)) + (reverse (if (> i start) + (cons (substring text start i) result) + result))] + [(char=? (string-ref text i) #\newline) + (loop (+ i 1) (+ i 1) (cons (substring text start i) result))] + [else + (loop (+ i 1) start result)]))) + +;; Adapter: tests pass text + 1-based line number, but actual takes lines + 0-based index. +;; org-babel-find-src-block returns (values lang header-args body begin end name). +;; Return lang (truthy if found, #f if not). +(define (org-babel-find-src-block-text text line-num) + (let-values (((lang header-args body begin-l end-l name) + (org-babel-find-src-block (split-lines text) (- line-num 1)))) + lang)) + +(define (org-babel-inside-src-block?-text text line-num) + (org-babel-inside-src-block? (split-lines text) (- line-num 1))) + +;; Adapter: tests pass symbol but actual takes string +(define (org-babel-format-result-sym output type) + (org-babel-format-result output (symbol->string type))) + +;; Adapter: tests pass text + 1-based line number +(define (org-ctrl-c-ctrl-c-context-text text line-num) + (org-ctrl-c-ctrl-c-context (split-lines text) (- line-num 1))) + +;; Adapter: inject-variables tests pass (body lang vars) +(define (org-babel-inject-variables-sym body lang vars) + (org-babel-inject-variables (symbol->string lang) vars)) + +;;; ======================================================================== +;;; Header argument parsing +;;; ======================================================================== + +(display "--- header-arg-parsing ---\n") + +(let ((args (org-babel-parse-header-args + ":var x=5 :results output :dir /tmp"))) + (check-true (hash-table? args)) + (check (hash-get args "var") => "x=5") + (check (hash-get args "results") => "output") + (check (hash-get args "dir") => "/tmp")) + +(let ((args (org-babel-parse-header-args ""))) + (check-true (hash-table? args))) + +(let ((args (org-babel-parse-header-args + ":exports both :results output :tangle yes"))) + (check (hash-get args "exports") => "both") + (check (hash-get args "tangle") => "yes")) + +(let ((args (org-babel-parse-header-args + ":session *my-session* :results value"))) + (check (hash-get args "session") => "*my-session*")) + +;;; ======================================================================== +;;; Begin line parsing +;;; ======================================================================== + +(display "--- begin-line-parsing ---\n") + +(let ((result (org-babel-parse-begin-line "#+BEGIN_SRC python :var x=5"))) + (check-true result)) + +(let ((result (org-babel-parse-begin-line "#+BEGIN_SRC bash"))) + (check-true result)) + +(let ((result (org-babel-parse-begin-line "#+begin_src python"))) + (check-true result)) + +(let ((result (org-babel-parse-begin-line + "#+BEGIN_SRC python :var x=5 :results output :dir /tmp"))) + (check-true result)) + +(let ((result (org-babel-parse-begin-line "not a begin line"))) + (check result => #f)) + +;; Various languages +(for-each + (lambda (lang) + (let ((result (org-babel-parse-begin-line + (string-append "#+BEGIN_SRC " lang)))) + (check-true result))) + '("python" "bash" "sh" "ruby" "scheme" "sql")) + +;;; ======================================================================== +;;; Source block detection +;;; ======================================================================== + +(display "--- src-block-detection ---\n") + +(let* ((text (string-append + "Some text\n" + "#+BEGIN_SRC python\n" + "print('hello')\n" + "#+END_SRC\n" + "More text\n")) + (block (org-babel-find-src-block-text text 2))) + (check-true block)) + +(let ((text (string-append + "#+BEGIN_SRC python\n" + "print('hello')\n" + "#+END_SRC\n"))) + (check (org-babel-inside-src-block?-text text 2) => #t)) + +(let ((text (string-append + "Some text\n" + "#+BEGIN_SRC python\n" + "print('hello')\n" + "#+END_SRC\n" + "More text\n"))) + (check (org-babel-inside-src-block?-text text 1) => #f) + (check (org-babel-inside-src-block?-text text 5) => #f)) + +;;; ======================================================================== +;;; Result formatting +;;; ======================================================================== + +(display "--- result-formatting ---\n") + +(let ((result (org-babel-format-result-sym "hello\nworld" 'output))) + (check-true (string-contains result "hello")) + (check-true (string-contains result "world"))) + +(let ((result (org-babel-format-result-sym "42" 'value))) + (check-true (string-contains result "42"))) + +(let ((result (org-babel-format-result-sym "" 'output))) + (check-true (string? result))) + +(let ((result (org-babel-format-result-sym "line1\nline2\nline3" 'output))) + (check-true (string-contains result "line1")) + (check-true (string-contains result "line3"))) + +;;; ======================================================================== +;;; Named blocks +;;; ======================================================================== + +(display "--- named-blocks ---\n") + +(let* ((text (string-append + "#+NAME: greet\n" + "#+BEGIN_SRC python\n" + "return 'hello'\n" + "#+END_SRC\n")) + (block (org-babel-find-named-block text "greet"))) + (check-true block)) + +(let* ((text (string-append + "#+NAME: greet\n" + "#+BEGIN_SRC python\n" + "return 'hello'\n" + "#+END_SRC\n")) + (block (org-babel-find-named-block text "nonexistent"))) + (check block => #f)) + +;;; ======================================================================== +;;; Tangling +;;; ======================================================================== + +(display "--- tangling ---\n") + +(let* ((text (string-append + "#+BEGIN_SRC bash :tangle /tmp/test.sh\n" + "echo hello\n" + "#+END_SRC\n" + "#+BEGIN_SRC python :tangle /tmp/test.py\n" + "print('world')\n" + "#+END_SRC\n")) + (result (org-babel-tangle text))) + (check-true (not (null? result)))) + +(let* ((text (string-append + "#+BEGIN_SRC bash :tangle no\n" + "echo skipped\n" + "#+END_SRC\n")) + (result (org-babel-tangle text))) + (check (null? result) => #t)) + +;;; ======================================================================== +;;; Variable injection +;;; ======================================================================== + +(display "--- variable-injection ---\n") + +(let ((result (org-babel-inject-variables-sym + "echo $x" 'bash '(("x" . "5") ("y" . "hello"))))) + (check-true (string-contains result "x"))) + +(let ((result (org-babel-inject-variables-sym + "print(x)" 'python '(("x" . "5"))))) + (check-true (string-contains result "x"))) + +;;; ======================================================================== +;;; Noweb expansion +;;; ======================================================================== + +(display "--- noweb-expansion ---\n") + +(let* ((text (string-append + "#+NAME: helper\n" + "#+BEGIN_SRC python\n" + "def helper():\n" + " return 42\n" + "#+END_SRC\n" + "\n" + "#+BEGIN_SRC python :noweb yes\n" + "<<helper>>\n" + "print(helper())\n" + "#+END_SRC\n")) + (result (org-babel-expand-noweb text "<<helper>>\nprint(helper())\n"))) + (check-true result)) + +;;; ======================================================================== +;;; C-c C-c context detection +;;; ======================================================================== + +(display "--- ctrl-c-context ---\n") + +(let ((ctx (org-ctrl-c-ctrl-c-context-text "* TODO My Task" 1))) + (check ctx => 'heading)) + +(let* ((text (string-append + "#+BEGIN_SRC python\n" + "print('hello')\n" + "#+END_SRC\n")) + (ctx (org-ctrl-c-ctrl-c-context-text text 2))) + (check ctx => 'src-block)) + +(let ((ctx (org-ctrl-c-ctrl-c-context-text "| a | b | c |" 1))) + (check ctx => 'table)) + +;;; ======================================================================== +;;; Source block in buffer context (from org-src-test) +;;; ======================================================================== + +(display "--- src-in-buffer ---\n") + +(let* ((text (string-append + "* Heading\n" + "Some text.\n" + "#+BEGIN_SRC python\n" + "print('hello')\n" + "#+END_SRC\n" + "More text.\n")) + (block (org-babel-find-src-block-text text 4))) + (check-true block)) + +(let ((text (string-append + "#+BEGIN_SRC python\n" + "x = 42\n" + "print(x)\n" + "#+END_SRC\n"))) + (check (org-babel-inside-src-block?-text text 2) => #t) + (check (org-babel-inside-src-block?-text text 3) => #t)) + +(let ((text (string-append + "Before\n" + "#+BEGIN_SRC python\n" + "code\n" + "#+END_SRC\n" + "After\n"))) + (check (org-babel-inside-src-block?-text text 1) => #f) + (check (org-babel-inside-src-block?-text text 5) => #f)) + +;;; ======================================================================== +;;; Summary +;;; ======================================================================== + +(newline) +(display "========================================\n") +(display (string-append "org-babel Tests: " + (number->string pass-count) " passed, " + (number->string fail-count) " failed\n")) +(display "========================================\n") +(when (> fail-count 0) (exit 1)) new file mode 100644 --- /dev/null +++ b/tests/test-org-capture.ss @@ -0,0 +1,161 @@ +#!chezscheme +;;; test-org-capture.ss — Tests for org-capture module +;;; Ported from gerbil-emacs/org-capture-test.ss + +(import (except (chezscheme) + make-hash-table hash-table? iota 1+ 1-) + (jerboa core) + (jerboa runtime) + (jerboa-emacs org-capture) + (std srfi srfi-13)) + +(define pass-count 0) +(define fail-count 0) + +(define-syntax check + (syntax-rules (=>) + ((_ expr => expected) + (let ((result expr) (exp expected)) + (if (equal? result exp) + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (display "FAIL: ") + (write 'expr) + (display " => ") + (write result) + (display " expected ") + (write exp) + (newline))))))) + +(define-syntax check-true + (syntax-rules () + ((_ expr) + (check (and expr #t) => #t)))) + +;; Adapter: org-capture-expand-template with optional source-file arg +(define (expand-template tmpl . args) + (if (null? args) + (org-capture-expand-template tmpl) + (org-capture-expand-template tmpl (car args)))) + +;;; ======================================================================== +;;; Template expansion +;;; ======================================================================== + +(display "--- template-expansion ---\n") + +(let ((result (expand-template "* TODO %?\n %U"))) + (check-true (string-contains result "[")) + (check (not (string-contains result "%?")) => #t)) + +(let ((result (expand-template "Created: %t"))) + (check-true (string-contains result "<")) + (check-true (string-contains result ">"))) + +(let ((result (expand-template "Time: %T"))) + (check-true (string-contains result "<"))) + +(let ((result (expand-template "From: %f" "myfile.org"))) + (check-true (string-contains result "myfile.org"))) + +(let ((result (expand-template "100%% done"))) + (check-true (string-contains result "100%")) + (check (not (string-contains result "%%")) => #t)) + +(let ((result (expand-template "* TODO Task\n Notes here"))) + (check-true (string-contains result "TODO Task")) + (check-true (string-contains result "Notes here"))) + +(let ((result (expand-template "Plain text without placeholders"))) + (check result => "Plain text without placeholders")) + +;;; ======================================================================== +;;; Cursor position +;;; ======================================================================== + +(display "--- cursor-position ---\n") + +(let ((pos (org-capture-cursor-position "* TODO %?\n %U"))) + (check (= pos 7) => #t)) + +(let ((pos (org-capture-cursor-position "%?Rest of template"))) + (check (= pos 0) => #t)) + +(let ((pos (org-capture-cursor-position "No cursor marker"))) + (check pos => #f)) + +;;; ======================================================================== +;;; Capture menu +;;; ======================================================================== + +(display "--- capture-menu ---\n") + +(let ((saved *org-capture-templates*)) + (set! *org-capture-templates* + (list (make-org-capture-template "t" "TODO" 'entry '(file "test.org") "* TODO %?\n %U") + (make-org-capture-template "n" "Note" 'entry '(file "test.org") "* %?\n %U"))) + (let ((menu (org-capture-menu-string))) + (check-true (string-contains menu "[t]")) + (check-true (string-contains menu "TODO")) + (check-true (string-contains menu "[n]")) + (check-true (string-contains menu "Note"))) + (set! *org-capture-templates* saved)) + +;;; ======================================================================== +;;; Refile targets +;;; ======================================================================== + +(display "--- refile-targets ---\n") + +(let* ((text (string-append + "* Projects\n" + "** Project A\n" + "** Project B\n" + "* Tasks\n" + "** Daily\n")) + (targets (org-refile-targets text))) + (check-true (>= (length targets) 3))) + +(let ((targets (org-refile-targets "No headings here\n"))) + (check (null? targets) => #t)) + +;;; ======================================================================== +;;; Insert under heading +;;; ======================================================================== + +(display "--- insert-under-heading ---\n") + +(let* ((text (string-append + "* Tasks\n" + "** Existing task\n" + "* Notes\n")) + (result (org-insert-under-heading text "Tasks" "** New task\n"))) + (check-true (string-contains result "New task")) + (check-true (string-contains result "Existing task"))) + +;;; ======================================================================== +;;; Capture lifecycle +;;; ======================================================================== + +(display "--- capture-lifecycle ---\n") + +(let ((saved *org-capture-active?*)) + (set! *org-capture-active?* #f) + (org-capture-start "t" "" "") + (check *org-capture-active?* => #t) + (org-capture-abort) + (check *org-capture-active?* => #f) + (set! *org-capture-active?* saved)) + +;;; ======================================================================== +;;; Summary +;;; ======================================================================== + +(newline) +(display "========================================\n") +(display (string-append "org-capture Tests: " + (number->string pass-count) " passed, " + (number->string fail-count) " failed\n")) +(display "========================================\n") +(when (> fail-count 0) (exit 1)) new file mode 100644 --- /dev/null +++ b/tests/test-org-clock.ss @@ -0,0 +1,130 @@ +#!chezscheme +;;; test-org-clock.ss — Tests for org-clock module +;;; Ported from gerbil-emacs/org-clock-test.ss + +(import (except (chezscheme) + make-hash-table hash-table? iota 1+ 1-) + (jerboa core) + (jerboa runtime) + (jerboa-emacs org-clock) + (jerboa-emacs org-parse)) + +(define pass-count 0) +(define fail-count 0) + +(define-syntax check + (syntax-rules (=>) + ((_ expr => expected) + (let ((result expr) (exp expected)) + (if (equal? result exp) + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (display "FAIL: ") + (write 'expr) + (display " => ") + (write result) + (display " expected ") + (write exp) + (newline))))))) + +(define-syntax check-true + (syntax-rules () + ((_ expr) + (check (and expr #t) => #t)))) + +;; Adapter: tests call (org-elapsed-minutes h1 m1 h2 m2) with 4 ints, +;; but actual function takes two timestamp objects. +(define (make-ts h m) + (make-org-timestamp 'active 2024 1 1 #f h m #f #f #f #f)) + +(define (org-elapsed-minutes-4 h1 m1 h2 m2) + (org-elapsed-minutes (make-ts h1 m1) (make-ts h2 m2))) + +;; Adapter: org-parse-clock-line returns (values start end dur); just check start +(define (parse-clock-start line) + (let-values (((start end dur) (org-parse-clock-line line))) + start)) + +;;; ======================================================================== +;;; Elapsed minutes +;;; ======================================================================== + +(display "--- elapsed-minutes ---\n") + +(check (org-elapsed-minutes-4 10 0 11 30) => 90) +(check (org-elapsed-minutes-4 10 0 10 0) => 0) +(check (org-elapsed-minutes-4 10 0 10 1) => 1) +(check (org-elapsed-minutes-4 9 0 10 0) => 60) +(check (org-elapsed-minutes-4 9 0 17 45) => 525) ; 8h45m = 525 +(check (org-elapsed-minutes-4 11 30 13 15) => 105) ; 1h45m = 105 +(check (org-elapsed-minutes-4 14 10 14 55) => 45) + +;;; ========================================================================