From 815e669310f5e73d13cc121bd7f6cdaec5b6ec0d Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Sun, 26 May 2024 22:49:44 -0500 Subject: Updates! I totally forgot to actually commit things for a while, so uh Updates!!! --- src/emit.scm | 61 +++++++++++++++++++++++--------------- src/read.scm | 95 ++++++++++++++++++++++++++++++------------------------------ src/wrap.scm | 20 +++++++++---- 3 files changed, 99 insertions(+), 77 deletions(-) (limited to 'src') diff --git a/src/emit.scm b/src/emit.scm index aa36eb5..d6fe19e 100644 --- a/src/emit.scm +++ b/src/emit.scm @@ -34,18 +34,6 @@ (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 "*" "" "") @@ -58,16 +46,27 @@ (line . ,(lambda (ln) (let ((ws (cond ((list? ln) ln) ((string? ln) (string-split ln))))) - (list (car ws) (string-join (cdr ws))))))) + (let ((x (list (car ws) (string-join (cdr ws))))) + x))))) (default - (line . ,list) + (line . ,(lambda (x) (print x) (if (list? x) x (list x)))) (block . ,identity)))) +(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 (get-from from type subtype) (or (alist-walk from type subtype) - (if (eq? subtype 'inline) - (alist-walk from type 'list) - (lambda _ '(""))))) + (get-from from 'default subtype))) (define (get-format type subtype) (get-from formats type subtype)) (define (get-filter type subtype) (get-from filters type subtype)) @@ -76,19 +75,19 @@ (cond ;; if LINE is a string, wrap it in a list ((string? line) - (set! line (list line))) + (sprintf (get-format type 'line) + ((get-filter type 'line) 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))) + (sprintf (get-format type 'line) + (apply string-append ((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)) + (sprintf* (get-format (car line) 'inline) + ((get-filter (car line) 'line) (cdr line)))) + (else (error "Malformed line" line)))) (define (format-block block) (if (assq (car block) formats) @@ -107,3 +106,17 @@ (sprintf (get-format type 'block) ((get-filter type 'block) text))) "")) + +(define (sprintf* fmt lis) + (let loop ((num (length (irregex-extract "~[aA]" fmt))) + (lis lis) + (out '())) + (cond + ((null? lis) + (apply sprintf fmt (reverse out))) + ((= 1 num) + (loop 0 '() (cons (string-join lis) out))) + (else + (loop (- num 1) + (cdr lis) + (cons (car lis) out)))))) diff --git a/src/read.scm b/src/read.scm index 00ffad4..5e655a7 100644 --- a/src/read.scm +++ b/src/read.scm @@ -2,73 +2,72 @@ (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) + ;; (sigil type inlines word-select) + `((default para (link) ,identity) ; if nothing else matches + ("```" verb) + ("=>" link) (">" quot) ("#" hdr1) ("##" hdr2) ("###" hdr3) ("*" list) - ("```" verb) ;; extra! (":" meta))) -(define-public (parse inport) - (parse-lines (read-lines inport) '())) +(define-public (parse #!optional port) + (parse-lines (read-lines (or port (current-input-port))) '())) (define (line-type line) - (let ((it (assoc (car (string-split line)) line-types))) - (if it (cadr it) - 'para))) + (let ((lin (if (string? line) (string-split line) line)) + (def (cdr (assoc 'default line-types)))) + (cond + ((null? lin) def) ; empty line + ((assoc (car lin) line-types) => cdr) ; a line type exists + (else def)))) ; otherwise ... -(define (parse-lines lines document) - (if (null? lines) (reverse document) +(define (parse-lines lines doc) + (if (null? lines) (reverse doc) (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)))))) + ((null? words) ; empty line + (parse-lines (cdr lines) doc)) + ((equal? (car words) "```") ; verbatim + (parse-verbatim (cdr lines) doc '())) + (else ; another line type + (apply parse-stanza lines doc '() (line-type words))))))) -(define (parse-verbatim lines document verb) +(define (parse-verbatim lines doc block) + (define (close-verbatim) (cons (cons 'verb (reverse block)) doc)) (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))))) + ((null? lines) ; end of document + (parse-lines lines (close-verbatim))) + ((equal? (car lines) "```") ; end of verbatim block + (parse-lines (cdr lines) (close-verbatim))) + (else ; verbatim block continues + (parse-verbatim (cdr lines) doc (cons (car lines) block))))) -(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) +(define (parse-stanza lines doc stanza st-type + #!optional (st-inlines '()) (st-words cdr)) + (define (close-stanza) (cons (cons st-type (reverse stanza)) doc)) + (if (null? lines) ; end of document + (parse-lines lines (close-stanza)) (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))))) + (lt (line-type ln))) + (cond + ((null? ws) ; end of stanza (blank line) + (parse-lines (cdr lines) (close-stanza))) + ((memq (car lt) st-inlines) ; in-line for *this* stanza + (parse-stanza (cdr lines) doc + (cons (cons (car lt) (cdr ws)) stanza) + st-type st-inlines st-words)) + ((not (eq? st-type (car (line-type ws)))) ; beginning of a new stanza + (parse-lines lines (close-stanza))) + (else ; continue this stanza + (parse-stanza (cdr lines) doc + (cons (st-words ws) stanza) + st-type st-inlines st-words)))))) diff --git a/src/wrap.scm b/src/wrap.scm index 3537dea..0ed8868 100644 --- a/src/wrap.scm +++ b/src/wrap.scm @@ -1,13 +1,23 @@ (declare (module (jimmy wrap))) (import scheme (chicken base) + (jimmy emit) (jimmy util) - (chicken format)) + (only (chicken io) read-string) + (only (chicken port) with-output-to-string) + (only (chicken string) string-translate*)) -;;; open question: how to do templating? +;; templates are strings with variables interpolated with "{{variables}}" (define-public (wrap document template) - #f) + (let* ((meta (map (lambda (el) + (cons (string-append "{{" (car el) "}}") + (string-intersperse (cdr el) " "))) + (alist-walk document 'meta))) + (body (cons "{{body}}" + (with-output-to-string + (lambda () (emit document)))))) + (string-translate* template (cons body meta)))) -(define (meta-get key document) - (alist-walk document 'meta key)) +(define-public (wrap-with document file) + (wrap document (with-input-from-file file read-string))) -- cgit 1.4.1-21-gabe81