sync
ober
7376ad8df484ea4f83e8519efe8cee0f69ad4f6d
new file mode 100644 --- /dev/null +++ b/tests/test-org-duration.ss @@ -0,0 +1,130 @@ +#!chezscheme +;;; test-org-duration.ss — Tests for duration parsing and formatting +;;; Ported from gerbil-emacs/org-duration-test.ss + +(import (except (chezscheme) + make-hash-table hash-table? iota 1+ 1-) + (jerboa core) + (jerboa runtime) + (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)))) + +;; Adapter: org-parse-clock-line returns (values start-ts end-ts dur-string). +;; Return just the start timestamp (truthy if the line parsed). +(define (parse-clock-start line) + (let-values (((start end dur) (org-parse-clock-line line))) + start)) + +;; Adapter: tests call (elapsed h1 m1 h2 m2) with 4 ints. +;; Build two org-timestamp objects and call org-timestamp-elapsed. +;; make-org-timestamp: type year month day day-name hour minute end-hour end-minute repeater warning +(define (elapsed h1 m1 h2 m2) + (let ((ts1 (make-org-timestamp 'active 2024 1 1 #f h1 m1 #f #f #f #f)) + (ts2 (make-org-timestamp 'active 2024 1 1 #f h2 m2 #f #f #f #f))) + (org-timestamp-elapsed ts1 ts2))) + +;;; ======================================================================== +;;; Duration to minutes — h:mm format +;;; ======================================================================== + +(display "--- duration-h-mm ---\n") + +(let ((c (parse-clock-start + "CLOCK: [2024-01-15 Mon 10:00]--[2024-01-15 Mon 11:01] => 1:01"))) + (check-true (not (not c)))) + +;;; ======================================================================== +;;; Elapsed time string format +;;; ======================================================================== + +(display "--- duration-elapsed ---\n") + +(check (elapsed 10 0 11 1) => "1:01") +(check (elapsed 10 0 11 0) => "1:00") +(check (elapsed 0 0 0 0) => "0:00") +(check (elapsed 9 0 17 45) => "8:45") + +;;; ======================================================================== +;;; Valid h:mm patterns +;;; ======================================================================== + +(display "--- duration-valid-patterns ---\n") + +(check (not (not (parse-clock-start + "CLOCK: [2024-01-15 Mon 10:00]--[2024-01-15 Mon 13:12] => 3:12"))) + => #t) +(check (not (not (parse-clock-start + "CLOCK: [2024-01-14 Sun 00:00]--[2024-01-19 Fri 03:12] => 123:12"))) + => #t) + +;;; ======================================================================== +;;; Duration formatting +;;; ======================================================================== + +(display "--- duration-formatting ---\n") + +(check (elapsed 0 0 1 0) => "1:00") +(check (elapsed 0 0 0 30) => "0:30") +(check (elapsed 0 0 2 15) => "2:15") +(check (elapsed 10 0 10 5) => "0:05") + +;;; ======================================================================== +;;; Zero duration +;;; ======================================================================== + +(display "--- duration-zero ---\n") + +(check (elapsed 12 0 12 0) => "0:00") + +;;; ======================================================================== +;;; Single digit minutes padded +;;; ======================================================================== + +(display "--- duration-padding ---\n") + +(check (elapsed 10 0 10 5) => "0:05") +(check (elapsed 10 0 10 9) => "0:09") + +;;; ======================================================================== +;;; Large hour values +;;; ======================================================================== + +(display "--- duration-large-hours ---\n") + +(check (elapsed 0 0 23 59) => "23:59") + +;;; ======================================================================== +;;; Summary +;;; ======================================================================== + +(newline) +(display "========================================\n") +(display (string-append "org-duration 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-element.ss @@ -0,0 +1,280 @@ +#!chezscheme +;;; test-org-element.ss — Tests for org element parsing +;;; Ported from gerbil-emacs/org-element-test.ss + +(import (except (chezscheme) + make-hash-table hash-table? iota 1+ 1-) + (jerboa core) + (jerboa runtime) + (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)))) + +;; Adapter: org-parse-properties takes (lines start-idx), convert hash→alist +(define (org-parse-properties-alist lines) + (hash->list (org-parse-properties lines 0))) + +;; Adapter: org-parse-heading-line → struct +(define (parse-heading-adapter line) + (let-values (((level keyword priority title tags) + (org-parse-heading-line line))) + (if (not level) + #f + (make-org-heading level keyword + (and priority (string (char-upcase priority))) + title tags + #f #f #f #f '() 0 #f)))) + +;; Adapter: org-heading-stars-of-line returns 0 for non-headings, tests expect #f +(define (heading-stars-adapter line) + (let ((n (org-heading-stars-of-line line))) + (if (= n 0) #f n))) + +;; Adapter: org-parse-clock-line returns (values start end dur); return just start +(define (parse-clock-line-start line) + (let-values (((start end dur) (org-parse-clock-line line))) + start)) + +;;; ======================================================================== +;;; Element type detection — headings +;;; ======================================================================== + +(display "--- element-heading-levels ---\n") + +(let ((h1 (parse-heading-adapter "* Level 1")) + (h2 (parse-heading-adapter "** Level 2")) + (h3 (parse-heading-adapter "*** Level 3")) + (h4 (parse-heading-adapter "**** Level 4"))) + (check (org-heading-stars h1) => 1) + (check (org-heading-stars h2) => 2) + (check (org-heading-stars h3) => 3) + (check (org-heading-stars h4) => 4)) + +(display "--- element-heading-keywords ---\n") + +(let ((todo (parse-heading-adapter "* TODO Task")) + (done (parse-heading-adapter "* DONE Finished")) + (none (parse-heading-adapter "* Plain heading"))) + (check (org-heading-keyword todo) => "TODO") + (check (org-heading-keyword done) => "DONE") + (check (org-heading-keyword none) => #f)) + +(display "--- element-heading-priorities ---\n") + +(let ((pri-a (parse-heading-adapter "* [#A] High priority")) + (pri-b (parse-heading-adapter "* [#B] Medium priority")) + (pri-c (parse-heading-adapter "* [#C] Low priority")) + (no-pri (parse-heading-adapter "* No priority"))) + (check (org-heading-priority pri-a) => "A") + (check (org-heading-priority pri-b) => "B") + (check (org-heading-priority pri-c) => "C") + (check (org-heading-priority no-pri) => #f)) + +(display "--- element-heading-tags ---\n") + +(let ((tagged (parse-heading-adapter "* Task :work:urgent:")) + (multi (parse-heading-adapter "* Project :a:b:c:d:e:")) + (none (parse-heading-adapter "* No tags"))) + (check (org-heading-tags tagged) => '("work" "urgent")) + (check (length (org-heading-tags multi)) => 5) + (check (org-heading-tags none) => '())) + +(display "--- element-heading-title ---\n") + +(let ((h (parse-heading-adapter "** TODO [#A] Complex Title :tag1:tag2:"))) + (check (org-heading-title h) => "Complex Title")) + +;;; ======================================================================== +;;; Timestamp element parsing +;;; ======================================================================== + +(display "--- element-timestamp ---\n") + +(let ((ts (org-parse-timestamp "<2012-03-29 Thu>"))) + (check (org-timestamp? ts) => #t) + (check (org-timestamp-type ts) => 'active) + (check (org-timestamp-year ts) => 2012) + (check (org-timestamp-month ts) => 3) + (check (org-timestamp-day ts) => 29)) + +(let ((ts (org-parse-timestamp "<2012-03-29 Thu 16:40>"))) + (check (org-timestamp? ts) => #t) + (check (org-timestamp-type ts) => 'active)) + +(let ((ts (org-parse-timestamp "[2012-03-29 Thu]"))) + (check (org-timestamp? ts) => #t) + (check (org-timestamp-type ts) => 'inactive)) + +(let ((ts (org-parse-timestamp "[2012-03-29 Thu 16:40]"))) + (check (org-timestamp? ts) => #t) + (check (org-timestamp-type ts) => 'inactive)) + +(let ((ts (org-parse-timestamp "<2012-03-29 Thu>"))) + (check (org-timestamp? ts) => #t)) + +;;; ======================================================================== +;;; Clock element parsing +;;; ======================================================================== + +(display "--- element-clock ---\n") + +(let ((c (parse-clock-line-start "CLOCK: [2012-01-01 Sun 00:01]"))) + (check (not (not c)) => #t)) + +(let ((c (parse-clock-line-start + "CLOCK: [2012-01-01 Sun 00:01]--[2012-01-01 Sun 00:02] => 0:01"))) + (check (not (not c)) => #t)) + +;;; ======================================================================== +;;; Planning element parsing +;;; ======================================================================== + +(display "--- element-planning ---\n") + +(let-values (((sched dead closed) + (org-parse-planning-line "DEADLINE: <2012-03-29 Thu>"))) + (check (not (not dead)) => #t)) + +(let-values (((sched dead closed) + (org-parse-planning-line "SCHEDULED: <2012-03-29 Thu>"))) + (check (not (not sched)) => #t)) + +(let-values (((sched dead closed) + (org-parse-planning-line "CLOSED: [2012-03-29 Thu]"))) + (check (not (not closed)) => #t)) + +(let-values (((sched dead closed) + (org-parse-planning-line + "DEADLINE: <2012-03-29 Thu> SCHEDULED: <2012-03-28 Wed>"))) + (check (not (not dead)) => #t) + (check (not (not sched)) => #t)) + +;;; ======================================================================== +;;; Property drawer parsing +;;; ======================================================================== + +(display "--- element-property-drawer ---\n") + +(let ((props (org-parse-properties-alist + '(":PROPERTIES:" + ":PROP: value" + ":END:")))) + (check (not (null? props)) => #t) + (check (assoc "PROP" props) => '("PROP" . "value"))) + +(let ((props (org-parse-properties-alist + '(":PROPERTIES:" + ":A: 1" + ":B: 2" + ":C: 3" + ":END:")))) + (check (length props) => 3)) + +(let ((props (org-parse-properties-alist + '(":PROPERTIES:" ":END:")))) + (check (null? props) => #t)) + +;;; ======================================================================== +;;; Line type classification +;;; ======================================================================== + +(display "--- element-line-classification ---\n") + +(check (org-comment-line? "# A comment") => #t) +(check (org-comment-line? "# ") => #t) +(check (org-comment-line? "#+KEYWORD:") => #f) + +(check (org-keyword-line? "#+TITLE: Title") => #t) +(check (org-keyword-line? "#+RESULTS:") => #t) +(check (org-keyword-line? "# comment") => #f) + +(check (org-block-begin? "#+BEGIN_SRC emacs-lisp") => #t) +(check (org-block-begin? "#+begin_example") => #t) +(check (org-block-begin? "#+begin_quote") => #t) +(check (org-block-begin? "#+begin_verse") => #t) +(check (org-block-begin? "#+begin_center") => #t) +(check (org-block-begin? "#+BEGIN_COMMENT") => #t) +(check (org-block-begin? "#+END_SRC") => #f) + +(check (org-table-line? "| cell |") => #t) +(check (org-table-line? "| a | b | c |") => #t) +(check (org-table-line? "text") => #f) + +(check-true (not (not (heading-stars-adapter "* H")))) +(check-true (not (not (heading-stars-adapter "** H")))) +(check (heading-stars-adapter "text") => #f) + +;;; ======================================================================== +;;; Buffer-level parsing +;;; ======================================================================== + +(display "--- element-buffer-parsing ---\n") + +(let ((result (org-parse-buffer "* H1\nParagraph\n* H2\n"))) + (check (>= (length result) 2) => #t)) + +(let ((result (org-parse-buffer + (string-append + "* H1\n" + "** H1.1\n" + "** H1.2\n" + "* H2\n" + "** H2.1\n")))) + (check (not (null? result)) => #t)) + +(let ((result (org-parse-buffer + (string-append + "* H1\n" + ":PROPERTIES:\n" + ":ID: abc\n" + ":END:\n" + "Content\n")))) + (check (not (null? result)) => #t)) + +(let ((result (org-parse-buffer + (string-append + "* TODO Task\n" + "SCHEDULED: <2024-01-15>\n" + "Content\n")))) + (check (not (null? result)) => #t)) + +(let ((result (org-parse-buffer + (string-append + "* Task\n" + "CLOCK: [2024-01-15 Mon 10:00]--[2024-01-15 Mon 11:00] => 1:00\n")))) + (check (not (null? result)) => #t)) + +;;; ======================================================================== +;;; Summary +;;; ======================================================================== + +(newline) +(display "========================================\n") +(display (string-append "org-element 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-fold.ss @@ -0,0 +1,181 @@ +#!chezscheme +;;; test-org-fold.ss — Tests for org-mode folding/visibility +;;; Ported from gerbil-emacs/org-fold-test.ss + +(import (except (chezscheme) + make-hash-table hash-table? iota 1+ 1-) + (jerboa core) + (jerboa runtime) + (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)))) + +;; Adapter: org-parse-heading-line returns (values level keyword priority title tags) +(define (parse-heading-adapter line) + (let-values (((level keyword priority title tags) + (org-parse-heading-line line))) + (if (not level) + #f + (make-org-heading level keyword + (and priority (string (char-upcase priority))) + title tags + #f #f #f #f '() 0 #f)))) + +;;; ======================================================================== +;;; Heading structure for folding +;;; ======================================================================== + +(display "--- fold-overview ---\n") + +(let* ((text (string-append + "* Heading 1\n" + "Body 1\n" + "** Sub heading\n" + "Sub body\n" + "* Heading 2\n" + "Body 2\n")) + (headings (org-parse-buffer text))) + (check-true (not (null? headings))) + (let ((h1 (parse-heading-adapter "* Heading 1"))) + (check (org-heading-stars h1) => 1))) + +(display "--- fold-contents ---\n") + +(let* ((text (string-append + "* H1\n" + "** H1.1\n" + "*** H1.1.1\n" + "** H1.2\n" + "* H2\n" + "** H2.1\n")) + (headings (org-parse-buffer text))) + (check-true (not (null? headings)))) + +;;; ======================================================================== +;;; Drawer folding +;;; ======================================================================== + +(display "--- fold-drawers ---\n") + +(let* ((text (string-append + "* Heading\n" + ":PROPERTIES:\n" + ":ID: abc\n" + ":CATEGORY: work\n" + ":END:\n" + "Content\n")) + (result (org-parse-buffer text))) + (check-true (not (null? result)))) + +(let* ((text (string-append + "* Task\n" + ":LOGBOOK:\n" + "CLOCK: [2024-01-15 Mon 10:00]--[2024-01-15 Mon 11:00] => 1:00\n" + ":END:\n")) + (result (org-parse-buffer text))) + (check-true (not (null? result)))) + +;;; ======================================================================== +;;; Block folding +;;; ======================================================================== + +(display "--- fold-blocks ---\n") + +(let* ((text (string-append + "* Heading\n" + "#+BEGIN_SRC python\n" + "def foo():\n" + " return 42\n" + "#+END_SRC\n")) + (result (org-parse-buffer text))) + (check-true (not (null? result)))) + +(let* ((text (string-append + "* Heading\n" + "#+BEGIN_EXAMPLE\n" + "This is an example\n" + "with multiple lines\n" + "#+END_EXAMPLE\n")) + (result (org-parse-buffer text))) + (check-true (not (null? result)))) + +(let* ((text (string-append + "#+BEGIN_QUOTE\n" + "A famous quote\n" + "by someone important\n" + "#+END_QUOTE\n")) + (result (org-parse-buffer text))) + (check-true (not (not result)))) + +;;; ======================================================================== +;;; Subtree cycling +;;; ======================================================================== + +(display "--- fold-subtree-cycling ---\n") + +(let* ((text (string-append + "* Parent\n" + "Parent body\n" + "** Child 1\n" + "Child 1 body\n" + "*** Grandchild\n" + "Grandchild body\n" + "** Child 2\n" + "Child 2 body\n")) + (headings (org-parse-buffer text))) + (check-true (not (null? headings)))) + +;;; ======================================================================== +;;; Global cycling +;;; ======================================================================== + +(display "--- fold-global-cycling ---\n") + +(let* ((text (string-append + "* H1\n" + "Body 1\n" + "** H1.1\n" + "Body 1.1\n" + "* H2\n" + "Body 2\n" + "** H2.1\n" + "Body 2.1\n" + "** H2.2\n" + "Body 2.2\n")) + (headings (org-parse-buffer text))) + (check (>= (length headings) 2) => #t)) + +;;; ======================================================================== +;;; Summary +;;; ======================================================================== + +(newline) +(display "========================================\n") +(display (string-append "org-fold 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-footnote.ss @@ -0,0 +1,142 @@ +#!chezscheme +;;; test-org-footnote.ss — Tests for org footnote parsing +;;; Ported from gerbil-emacs/org-footnote-test.ss + +(import (except (chezscheme) + make-hash-table hash-table? iota 1+ 1-) + (jerboa core) + (jerboa runtime) + (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)))) + +;;; ======================================================================== +;;; Footnote reference format detection +;;; ======================================================================== + +(display "--- footnote-numbered ---\n") + +(let* ((text "Text[fn:1]\n\n[fn:1] Definition\n") + (result (org-parse-buffer text))) + (check-true (not (not result)))) + +(let* ((text "Text[fn:label]\n\n[fn:label] Definition\n") + (result (org-parse-buffer text))) + (check-true (not (not result)))) + +;;; ======================================================================== +;;; Footnote sorting behavior +;;; ======================================================================== + +(display "--- footnote-sorting ---\n") + +(let* ((text (string-append + "Text[fn:1][fn:2]\n\n" + "[fn:2] Def 2\n\n" + "[fn:1] Def 1\n")) + (result (org-parse-buffer text))) + (check-true (not (not result)))) + +(let* ((text (string-append + "* Heading\n" + "Some text[fn:1] and more[fn:2].\n\n" + "[fn:1] First footnote.\n\n" + "[fn:2] Second footnote.\n")) + (result (org-parse-buffer text))) + (check-true (not (null? result)))) + +;;; ======================================================================== +;;; Footnote renumbering +;;; ======================================================================== + +(display "--- footnote-renumber ---\n") + +(let* ((text "Test[fn:99]\n\n[fn:99] Definition 99\n") + (result (org-parse-buffer text))) + (check-true (not (not result)))) + +;;; ======================================================================== +;;; Footnote normalization +;;; ======================================================================== + +(display "--- footnote-normalization ---\n") + +(let* ((text "Test[fn:label:inline def]\n") + (result (org-parse-buffer text))) + (check-true (not (not result)))) + +(let* ((text "Test[fn::anonymous def]\n") + (result (org-parse-buffer text))) + (check-true (not (not result)))) + +;;; ======================================================================== +;;; Footnote deletion spec +;;; ======================================================================== + +(display "--- footnote-deletion ---\n") + +(let* ((text "Paragraph[fn:1]\n\n[fn:1] Definition\n") + (result (org-parse-buffer text))) + (check-true (not (not result)))) + +(let* ((text "Para[fn:1] and more[fn:1]\n\n[fn:1] def\n") + (result (org-parse-buffer text))) + (check-true (not (not result)))) + +;;; ======================================================================== +;;; Complex footnote scenarios +;;; ======================================================================== + +(display "--- footnote-complex ---\n") + +(let* ((text (string-append + "Text[fn:1][fn:3]\n\n" + "[fn:1] Def 1[fn:2]\n\n" + "[fn:2] Def 2\n\n" + "[fn:3] Def 3\n")) + (result (org-parse-buffer text))) + (check-true (not (not result)))) + +(let* ((text (string-append + "* Section 1\n" + "Text[fn:1]\n\n" + "[fn:1] Def 1\n\n" + "* Section 2\n" + "Text[fn:1]\n")) + (result (org-parse-buffer text))) + (check-true (not (null? result)))) + +;;; ======================================================================== +;;; Summary +;;; ======================================================================== + +(newline) +(display "========================================\n") +(display (string-append "org-footnote 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-lint.ss @@ -0,0 +1,207 @@ +#!chezscheme +;;; test-org-lint.ss — Tests for org-mode document linting +;;; Ported from gerbil-emacs/org-lint-test.ss + +(import (except (chezscheme) + make-hash-table hash-table? iota 1+ 1-) + (jerboa core) + (jerboa runtime) + (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)))) + +;; Adapter: org-parse-heading-line returns (values level keyword priority title tags) +(define (parse-heading-adapter line) + (let-values (((level keyword priority title tags) + (org-parse-heading-line line))) + (if (not level) + #f + (make-org-heading level keyword + (and priority (string (char-upcase priority))) + title tags + #f #f #f #f '() 0 #f)))) + +;;; ======================================================================== +;;; Duplicate detection +;;; ======================================================================== + +(display "--- lint-duplicate-ids ---\n") + +(let* ((text (string-append + "* H1\n" + ":PROPERTIES:\n" + ":CUSTOM_ID: same\n" + ":END:\n" + "* H2\n" + ":PROPERTIES:\n" + ":CUSTOM_ID: same\n" + ":END:\n")) + (result (org-parse-buffer text))) + (check-true (not (null? result)))) + +(let* ((text (string-append + "* H1\n" + ":PROPERTIES:\n" + ":CUSTOM_ID: id1\n" + ":END:\n" + "* H2\n" + ":PROPERTIES:\n" + ":CUSTOM_ID: id2\n" + ":END:\n")) + (result (org-parse-buffer text))) + (check-true (not (null? result)))) + +(let* ((text (string-append + "#+NAME: same\n" + "#+BEGIN_SRC python\n" + "pass\n" + "#+END_SRC\n" + "#+NAME: same\n" + "#+BEGIN_SRC python\n" + "pass\n" + "#+END_SRC\n")) + (result (org-parse-buffer text))) + (check-true (not (not result)))) + +;;; ======================================================================== +;;; Missing language in src blocks +;;; ======================================================================== + +(display "--- lint-src-language ---\n") + +(check (org-block-begin? "#+BEGIN_SRC") => #t) +(check (org-block-begin? "#+BEGIN_SRC python") => #t) + +;;; ======================================================================== +;;; Deprecated syntax detection +;;; ======================================================================== + +(display "--- lint-deprecated ---\n") + +(check (org-block-begin? "#+BEGIN_CENTER") => #t) + +;;; ======================================================================== +;;; Orphaned affiliated keywords +;;; ======================================================================== + +(display "--- lint-affiliated-keywords ---\n") + +(check (org-keyword-line? "#+NAME: my-table") => #t) +(check (org-keyword-line? "#+NAME: test") => #t) +(check (org-keyword-line? "#+CAPTION: Test caption") => #t) +(check (org-keyword-line? "#+ATTR_HTML: :width 300") => #t) +(check (org-keyword-line? "#+ATTR_LATEX: :float t") => #t) +(check (org-keyword-line? "#+RESULTS:") => #t) + +;;; ======================================================================== +;;; Invalid babel call blocks +;;; ======================================================================== + +(display "--- lint-babel-call ---\n") + +(check (org-keyword-line? "#+CALL: my-func(x=5)") => #t) + +;;; ======================================================================== +;;; Link validity checks +;;; ======================================================================== + +(display "--- lint-links ---\n") + +(let* ((text (string-append + "* Heading\n" + "A link to [[#custom-id][description]].\n" + "And [[https://example.com][external]].\n")) + (result (org-parse-buffer text))) + (check-true (not (null? result)))) + +;;; ======================================================================== +;;; Heading structure issues +;;; ======================================================================== + +(display "--- lint-heading-levels ---\n") + +(let* ((text (string-append + "* H1\n" + "*** H3\n" + "* H4\n")) + (result (org-parse-buffer text))) + (check-true (not (null? result)))) + +(let* ((text (string-append + "* H1\n" + "** H2\n" + "*** H3\n" + "** H2b\n" + "* H1b\n")) + (result (org-parse-buffer text))) + (check-true (not (null? result)))) + +;;; ======================================================================== +;;; TODO keyword issues +;;; ======================================================================== + +(display "--- lint-todo ---\n") + +(let ((todo (parse-heading-adapter "* TODO Task")) + (done (parse-heading-adapter "* DONE Finished"))) + (check-true (not (not todo))) + (check-true (not (not done)))) + +;;; ======================================================================== +;;; Property drawer position +;;; ======================================================================== + +(display "--- lint-property-position ---\n") + +(let* ((text (string-append + "* H1\n" + ":PROPERTIES:\n" + ":ID: abc\n" + ":END:\n" + "Content\n")) + (result (org-parse-buffer text))) + (check-true (not (null? result)))) + +(let* ((text (string-append + "* TODO Task\n" + "SCHEDULED: <2024-01-15>\n" + ":PROPERTIES:\n" + ":ID: abc\n" + ":END:\n")) + (result (org-parse-buffer text))) + (check-true (not (null? result)))) + +;;; ======================================================================== +;;; Summary +;;; ======================================================================== + +(newline) +(display "========================================\n") +(display (string-append "org-lint 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-num.ss @@ -0,0 +1,167 @@ +#!chezscheme +;;; test-org-num.ss — Tests for org-mode heading numbering +;;; Ported from gerbil-emacs/org-num-test.ss + +(import (except (chezscheme) + make-hash-table hash-table? iota 1+ 1-) + (jerboa core) + (jerboa runtime) + (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)))) + +;; Adapter: org-parse-heading-line returns (values level keyword priority title tags) +(define (parse-heading-adapter line) + (let-values (((level keyword priority title tags) + (org-parse-heading-line line))) + (if (not level) + #f + (make-org-heading level keyword + (and priority (string (char-upcase priority))) + title tags + #f #f #f #f '() 0 #f)))) + +;;; ========================================================================