Scheme bit!

8 files changed, 354 insertions, 0 deletions

@@ -0,0 +1,40 @@
+NAME = jimmy
+
+CSC = /usr/bin/csc
+CSI = /usr/bin/csi
+CSC_OPTIONS = \
+        -host \
+        -D compiling-extension \
+        -emit-all-import-libraries \
+        -dynamic \
+        -regenerate-import-libraries \
+        -setup-mode \
+        -I $(PWD) \
+        -C -I$(PWD) \
+
+CSC_OPTIONS_EXTRA = \
+        -X utf8 \
+        -X module-declarations
+
+BUILD = $(PWD)/build
+
+.PHONY: all test
+build: $(patsubst src/%.scm,$(BUILD)/%.so,$(wildcard src/*.scm))
+
+test: build
+        $(CSI) -s $(PWD)/tests/run.scm $(NAME)
+
+# Program!
+
+# Libraries!
+
+$(BUILD)/%.so: src/%.scm
+        mkdir -p "$(dir $@)"
+        $(CSC) $(CSC_OPTIONS) $(CSC_OPTIONS_EXTRA) $< -o $@
+
+## Library dependency graph
+# here's a convenience macro
+lib = $(BUILD)/$(NAME).$(1).so
+
+$(call lib,read): $(call lib,util)
+$(call lib,emit): $(call lib,util)
@@ -0,0 +1,17 @@
+((author "Case Duckworth")
+ (synopsis "The ssg king")
+ (dependencies (chicken "5.3.0")
+               module-declarations
+               utf8)
+ (test-dependencies test)
+ (component-options
+  (csc-options -X utf8 -X module-declarations))
+ (components
+  (extension jimmy.util
+             (source src/util.scm))
+  (extension jimmy.read
+             (source src/read.scm)
+             (component-dependencies jimmy.util))
+  (extension jimmy.emit
+             (source src/emit.scm)
+             (component-dependencies jimmy.util))))
@@ -0,0 +1,109 @@
+(declare (module (jimmy emit)))
+
+(import scheme (chicken base)
+        (jimmy util)
+        (chicken format)
+        (chicken irregex)
+        (chicken string))
+
+(define-public (emit document)
+  (for-each display
+            (map format-block document)))
+
+(define-public formats
+  ;;; (type line-format block-format [line-in-block-format])
+  ;; these default to gemtext
+  '((para (line . "~A ")
+          (block . "~A~%~%"))
+    (verb (line . "~A~%")
+          (block . "```~%~A```~%~%"))
+    (link (line . "=> ~A ~A~%")
+          (block . "~A~%")
+          (inline . "~%=> ~A ~A~%")) ;TODO: have 2 args to format
+    (list (line . "* ~A~%")
+          (block . "~A~%"))
+    (quot (line . "~A ")
+          (block . "> ~A~%~%"))
+    (hdr1 (line . "# ~A~%")
+          (block . "~A~%"))
+    (hdr2 (line . "## ~A~%")
+          (block . "~A~%"))
+    (hdr3 (line . "### ~A~%")
+          (block . "~A~%"))
+    (default
+      (line . "~A")
+      (block . "~A~%~%"))))
+
+(define (string-join ss #!optional sep)
+  (if (string? ss) ss
+      (string-intersperse ss (or sep " "))))
+
+(define (char->tag char beg end)
+  (lambda (str)
+    (irregex-replace/all `(: ($ (or bos space))
+                             ,char ($ (+ (~ ,char))) ,char
+                             ($ (or space eos)))
+                         str
+                         1 beg 2 end 3)))
+
+(define-public filters
+  `((para
+     (line . ,(o (char->tag "*" "<strong>" "</strong>")
+                 (char->tag "_" "<em>" "</em>")
+                 (char->tag "`" "<code>" "</code>")
+                 string-join))
+     (block . ,(lambda (ln)
+                 (irregex-replace/all '(: bol (* " ")) ln ""))))
+    (link
+     (line . ,(lambda (ln)
+                (let ((ws (cond ((list? ln) ln)
+                                ((string? ln) (string-split ln)))))
+                  (list (car ws) (string-join (cdr ws)))))))
+    (default
+      (line . ,list)
+      (block . ,identity))))
+
+(define (get-from from type subtype)
+  (or (alist-walk from type subtype)
+      (if (eq? subtype 'inline)
+          (alist-walk from type 'list)
+          (lambda _ '("")))))
+
+(define (get-format type subtype) (get-from formats type subtype))
+(define (get-filter type subtype) (get-from filters type subtype))
+
+(define (format-line fmt line type)
+  (cond
+   ;; if LINE is a string, wrap it in a list
+   ((string? line)
+    (set! line (list line)))
+   ;; if it's a list of strings, join them together and filter them
+   ((and (list? line)
+         (string? (car line)))
+    (set! line ((get-filter type 'line) line)))
+   ;; if the car of LINE is a symbol, it's an inline thing.
+   ((and (list? line)
+         (symbol? (car line)))
+    (set! line (format-line (get-format (car line) 'inline)
+                            ((get-filter (car line) 'line) (cdr line))
+                            type)))
+   (else (error "Malformed line" line)))
+  (apply sprintf fmt line))
+
+(define (format-block block)
+  (if (assq (car block) formats)
+      (let* ((type (car block))
+             (data (cdr block))
+             (text (cond
+                    ((string? data) data)
+                    ((list? data)
+                     (apply string-append
+                            (map (lambda (ln)
+                                   (format-line (get-format type 'line)
+                                                ln
+                                                type))
+                                 data)))
+                    (else (error "Malformed block" block)))))
+        (sprintf (get-format type 'block)
+                 ((get-filter type 'block) text)))
+      ""))
@@ -0,0 +1,3 @@
+(declare (module (jimmy html)))
+
+
@@ -0,0 +1,74 @@
+(declare (module (jimmy read)))
+
+(import scheme (chicken base)
+        (jimmy util)
+        (only (chicken condition) handle-exceptions)
+        (only (chicken io) read-lines)
+        (only (chicken string) string-split))
+
+(define-public line-types
+  ;; (sigil type inlines preproc)
+  '(("=>" link)
+    (">" quot)
+    ("#" hdr1)
+    ("##" hdr2)
+    ("###" hdr3)
+    ("*" list)
+    ("```" verb)
+    ;; extra!
+    (":" meta)))
+
+(define-public (parse inport)
+  (parse-lines (read-lines inport) '()))
+
+(define (line-type line)
+  (let ((it (assoc (car (string-split line)) line-types)))
+    (if it (cadr it)
+        'para)))
+
+(define (parse-lines lines document)
+  (if (null? lines) (reverse document)
+      (let ((words (string-split (car lines))))
+        (cond
+         ((null? words)
+          (parse-lines (cdr lines) document))
+         ((equal? (car words) "```")
+          (parse-verbatim (cdr lines) document '()))
+         ((assoc (car words) line-types)
+          => (lambda (it)
+               (apply parse-block lines document '() (cdr it))))
+         (else
+          (parse-block lines document '() 'para '(link) identity))))))
+
+(define (parse-verbatim lines document verb)
+  (cond
+   ((null? lines)
+    (parse-lines lines (cons (cons 'verb (reverse verb)) document)))
+   ((equal? (car lines) "```")
+    (parse-lines (cdr lines) (cons (cons 'verb (reverse verb)) document)))
+   (else
+    (parse-verbatim (cdr lines) document (cons (car lines) verb)))))
+
+(define (parse-block lines document block type #!optional inlines preproc)
+  (let ((inlines (or inlines '()))
+        (preproc (or preproc (lambda (ln) (cdr (string-split ln))))))
+    (cond
+     ((null? lines)
+      (parse-lines lines (cons (cons type (reverse block)) document)))
+     ((equal? (car lines) "")
+      (parse-lines (cdr lines) (cons (cons type (reverse block)) document)))
+     ((and (not (eq? type (line-type (car lines))))
+           (not (memq (line-type (car lines)) inlines)))
+      (parse-lines lines (cons (cons type (reverse block)) document)))
+     ((memq (line-type (car lines)) inlines)
+      (let* ((ln (car lines))
+             (ws (string-split ln))
+             (lt (cdr (assoc (car ws) line-types))))
+        (parse-block (cdr lines) document
+                     (cons (cons (car lt)
+                                 ((or (ignore-errors (caddr lt)) cdr) ws))
+                           block)
+                     type inlines preproc)))
+     (else
+      (parse-block (cdr lines) document (cons (preproc (car lines)) block)
+                   type inlines preproc)))))
@@ -0,0 +1,37 @@
+(module (jimmy util) *
+
+  (import scheme (chicken base)
+          (chicken condition))
+
+  (define-syntax define-public
+    (syntax-rules ()
+      ((define-public (name . arg) forms ...)
+       (begin (export name)
+              (define (name . arg) forms ...)))
+      ((define-public (name args ...) forms ...)
+       (begin (export name)
+              (define (name args ...) forms ...)))
+      ((define-public name value)
+       (begin (export name)
+              (define name value)))))
+
+  (define-syntax ignore-errors
+    (syntax-rules ()
+      ((ignore-errors x)
+       (handle-exceptions e #f x))))
+
+  (define (alist-walk lis . keys)
+    (if (null? keys)
+        lis
+        (let ((kv (assoc (car keys) lis)))
+          (cond
+           ((not kv) #f)
+           ((atom? (cdr kv))
+            (and (null? (cdr keys))       ; this shouldn't error...
+                 (cdr kv)))
+           ((list? (cdr kv))
+            (apply alist-walk (cdr kv) (cdr keys)))))))
+
+  )
+
+
@@ -0,0 +1,13 @@
+(declare (module (jimmy wrap)))
+
+(import scheme (chicken base)
+        (jimmy util)
+        (chicken format))
+
+;;; open question: how to do templating?
+
+(define-public (wrap document template)
+  #f)
+
+(define (meta-get key document)
+  (alist-walk document 'meta key))
@@ -0,0 +1,61 @@
+(import scheme
+        (chicken base)
+        (chicken load)
+        (chicken port)
+        (chicken process-context)
+        test)
+
+;;; Setup
+
+(import (jimmy emit)
+        (jimmy read)
+        #;(jimmy wrap))
+
+(define test-doc #<<end-document
+: title a test document
+: date 2024-05-13T03:02:45Z
+: uuid b3daebf1-440b-4828-a4d9-9089c7bd7c61
+
+# a test document of some kind
+
+here is a test document.
+it has paragraphs
+=> example.com with links!
+and other things.
+
+## a code example
+```
+for (a=1;a<=4;a++) {
+        printf("%d\n", a);
+}
+```
+
+### other examples
+
+> a blockquote is a quote
+> that is blocky.
+
+* list 1
+* list 2
+* list 3
+=> example.com link list 1
+=> example.com link list 2
+=> example.com link list 3
+
+ok, now for another test:
+will *strong* in-line text be converted?
+as well as `code`, _emph_ and such?
+what if *i _nest_ them*
+what if *i _nest them* wrong_ ?
+what about *breaking them
+over two lines?*
+end-document
+)
+
+;;; Tests
+
+(test "read"
+      '((meta ("title" "a" "test" "document") ("date" "2024-05-13T03:02:45Z") ("uuid" "b3daebf1-440b-4828-a4d9-9089c7bd7c61")) (hdr1 ("a" "test" "document" "of" "some" "kind")) (para "here is a test document." "it has paragraphs" (link "example.com" "with" "links!") "and other things.") (hdr2 ("a" "code" "example")) (verb "for (a=1;a<=4;a++) {" "\tprintf(\"%d\\n\", a);" "}") (hdr3 ("other" "examples")) (quot ("a" "blockquote" "is" "a" "quote") ("that" "is" "blocky.")) (list ("list" "1") ("list" "2") ("list" "3")) (link ("example.com" "link" "list" "1") ("example.com" "link" "list" "2") ("example.com" "link" "list" "3")) (para "ok, now for another test:" "will *strong* in-line text be converted?" "as well as `code`, _emph_ and such?" "what if *i _nest_ them*" "what if *i _nest them* wrong_ ?" "what about *breaking them" "over two lines?*"))
+      (call-with-input-string test-doc parse))
+
+(test-exit)