diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/guile/skribilo/reader/outline.scm | 162 |
1 files changed, 133 insertions, 29 deletions
diff --git a/src/guile/skribilo/reader/outline.scm b/src/guile/skribilo/reader/outline.scm index 688fcdc..4b7d00d 100644 --- a/src/guile/skribilo/reader/outline.scm +++ b/src/guile/skribilo/reader/outline.scm @@ -43,7 +43,8 @@ ;;; TODO: ;;; ;;; - add source position information; -;;; - handle `itemize' and/or `enumerate'; +;;; - handle `blockquote' (indented paragraph); +;;; - handle sublists (indented lists) --- optional; ;;; - handle inline Skribe code: `\n{skribe\n(table (tr ... ))\n}\n' @@ -62,6 +63,16 @@ procedure returns true." (let ((result (apply (car procs) args))) (if result result (loop (cdr procs))))))) +(define (make-markup name body) + "Return a clean markup form, i.e., an s-exp whose @code{car} is a symbol +equal to @var{name}, a markup name." + (cond ((list? body) + (cond ((null? body) `(,name)) + ((symbol? (car body)) `(,name ,body)) + (else `(,name ,@body)))) + (else + (list name body)))) + (define (append-trees . trees) "Append markup trees @var{trees}. Trees whose car is a symbol (e.g., @@ -192,11 +203,70 @@ takes a string and returns a list." (let ((line (line-proc line))) (append-trees result line "\n")))))) +(define (make-list-processor rx node-type extract-line-proc line-proc + end-of-node?) + "Return a procedure (a @dfn{list processor}) that takes a line and a port +and returns an AST node of type @var{node-type} (a symbol, typically +@code{itemize} or @code{enumerate}) along with a line. If the processor is +not triggered, i.e., it is passed a line that does not match @var{rx}, then +it returns @code{#f}." + (lambda (line port) + (let ((match (regexp-exec rx line))) + (if (not match) + #f + (let loop ((line line) + (contiguous-empty-lines 0) + (item '()) + (body '())) + (if (eof-object? line) + (let ((body (if (null? item) + body + (cons `(item ,@(reverse! item)) body)))) + (values line `(,node-type ,@(reverse! body)))) + (let ((match (regexp-exec rx line))) + (cond (match + ;; reading the first line of an item + (loop (read-line port) 0 + (append-trees + (line-proc (extract-line-proc match))) + body)) + + ((and (procedure? end-of-node?) + (end-of-node? line)) + (values line + `(,node-type ,@(reverse! body)))) + + ((empty-line? line) + (cond ((>= contiguous-empty-lines 1) + ;; end of list + (values line + `(,node-type ,@(reverse! body)))) + + ((= contiguous-empty-lines 0) + ;; end of item: add ITEM to BODY + (loop (read-line port) 1 '() + (cons (make-markup 'item item) + body))) + + (else + ;; skipping empty line + (loop (read-line port) + (+ 1 contiguous-empty-lines) + item body)))) + + (else + ;; reading an item: add LINE to ITEM + (loop (read-line port) 0 + (append-trees item (line-proc line)) + body)))))))))) + (define (make-node-processor rx node-type title-proc line-proc - subnode-proc end-of-node?) + subnode-procs end-of-node?) "Return a procedure that reads the given string and return an AST node of type @var{node-type} or @code{#f}. When the original string matches the node -header, then the rest of the node is read from @var{port}." +header, then the rest of the node is read from @var{port}. +@var{subnode-procs} is a list of node processors for node types subordinate +to @var{node-type}." (lambda (line port) (let ((match (regexp-exec rx line))) (if (not match) @@ -204,45 +274,79 @@ header, then the rest of the node is read from @var{port}." (let ((title (line-proc (title-proc match)))) (let loop ((line (read-line port)) (body '())) - (cond ((or (eof-object? line) - (regexp-exec rx line) - (and (procedure? end-of-node?) - (end-of-node? line))) - (values line - `(,node-type :title ,title ,@(reverse! body)))) - - ((empty-line? line) - (loop (read-line port) body)) - - (else - (let ((subnode (and subnode-proc - (apply subnode-proc - (list line port))))) - (if subnode - (let-values (((line node) subnode)) - (loop line (cons node body))) + + (let ((subnode (and (not (eof-object? line)) + (apply-any subnode-procs + (list line port))))) + (cond (subnode + (let-values (((line node) subnode)) + (loop line (cons node body)))) + + ((or (eof-object? line) + (regexp-exec rx line) + (and (procedure? end-of-node?) + (end-of-node? line))) + (values line + `(,node-type :title ,title ,@(reverse! body)))) + + ((empty-line? line) + (loop (read-line port) body)) + + (else (let ((par (process-paragraph line line-proc port))) (loop (read-line port) - (cons par body))))))))))))) + (cons par body)))))))))))) (define (node-markup-line? line) (define node-rx (make-regexp "^\\*+ (.+)$" regexp/extended)) (regexp-exec node-rx line)) +(define %list-processors + (list (make-list-processor (make-regexp "^[-~o] (.+)$" regexp/extended) + 'itemize + (lambda (m) (match:substring m 1)) + %line-processor + node-markup-line?) + (make-list-processor (make-regexp "^([0-9]+)\\.? (.+)$" + regexp/extended) + 'enumerate + (lambda (m) (match:substring m 2)) + %line-processor + node-markup-line?))) + (define %node-processors - (let ((section-proc - (make-node-processor (make-regexp "^\\*\\* (.+)$" regexp/extended) - 'section - (lambda (m) (match:substring m 1)) - %line-processor - #f - node-markup-line?))) + (let* ((subsubsection-proc + (make-node-processor (make-regexp "^\\*\\*\\*\\* (.+)$" + regexp/extended) + 'subsection + (lambda (m) (match:substring m 1)) + %line-processor + %list-processors ;; no further subnodes + node-markup-line?)) + (subsection-proc + (make-node-processor (make-regexp "^\\*\\*\\* (.+)$" + regexp/extended) + 'subsection + (lambda (m) (match:substring m 1)) + %line-processor + (append %list-processors + (list subsubsection-proc)) + node-markup-line?)) + (section-proc + (make-node-processor (make-regexp "^\\*\\* (.+)$" regexp/extended) + 'section + (lambda (m) (match:substring m 1)) + %line-processor + (append %list-processors + (list subsection-proc)) + node-markup-line?))) (list (make-node-processor (make-regexp "^\\* (.+)$" regexp/extended) 'chapter (lambda (m) (match:substring m 1)) %line-processor - section-proc + (append %list-processors + (list section-proc)) #f)))) |