diff options
author | Ludovic Court`es | 2006-10-11 07:43:47 +0000 |
---|---|---|
committer | Ludovic Court`es | 2006-10-11 07:43:47 +0000 |
commit | d4360259d60722eaa175a483f792fce7b8c66d97 (patch) | |
tree | 622cc21b820e3dd4616890bc9ccba74de6637d8a /src/guile/skribilo/reader | |
parent | fc42fe56a57eace2dbdb31574c2e161f0eacf839 (diff) | |
download | skribilo-d4360259d60722eaa175a483f792fce7b8c66d97.tar.gz skribilo-d4360259d60722eaa175a483f792fce7b8c66d97.tar.lz skribilo-d4360259d60722eaa175a483f792fce7b8c66d97.zip |
slide: Propagate the `outline?' parameter in `slide-(sub)?topic'.
* src/guile/skribilo/package/slide.scm (slide-topic): Propagate the
`outline?' parameter as an option.
(slide-subtopic): Likewise.
git-archimport-id: skribilo@sv.gnu.org--2006/skribilo--devo--1.2--patch-1
Diffstat (limited to 'src/guile/skribilo/reader')
-rw-r--r-- | src/guile/skribilo/reader/Makefile.am | 2 | ||||
-rw-r--r-- | src/guile/skribilo/reader/outline.scm | 426 | ||||
-rw-r--r-- | src/guile/skribilo/reader/skribe.scm | 113 |
3 files changed, 541 insertions, 0 deletions
diff --git a/src/guile/skribilo/reader/Makefile.am b/src/guile/skribilo/reader/Makefile.am new file mode 100644 index 0000000..807e4a7 --- /dev/null +++ b/src/guile/skribilo/reader/Makefile.am @@ -0,0 +1,2 @@ +guilemoduledir = $(GUILE_SITE)/skribilo/reader +dist_guilemodule_DATA = skribe.scm outline.scm diff --git a/src/guile/skribilo/reader/outline.scm b/src/guile/skribilo/reader/outline.scm new file mode 100644 index 0000000..09792f5 --- /dev/null +++ b/src/guile/skribilo/reader/outline.scm @@ -0,0 +1,426 @@ +;;; outline.scm -- A reader for Emacs' outline syntax. +;;; +;;; Copyright 2006 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo reader outline) + :use-module (skribilo utils syntax) + :use-module (skribilo reader) + :use-module (ice-9 optargs) + :use-module (srfi srfi-11) + + :autoload (ice-9 rdelim) (read-line) + :autoload (ice-9 regex) (make-regexp) + + :export (reader-specification + make-outline-reader)) + +(fluid-set! current-reader %skribilo-module-reader) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; A reader for Emacs' outline-mode syntax. +;;; +;;; Code: + +;;; TODO: +;;; +;;; - add source position information; +;;; - handle `blockquote' (indented paragraph); +;;; - handle sublists (indented lists) --- optional; +;;; - handle inline Skribe code: `\n{skribe\n(table (tr ... ))\n}\n' + + + + +;;; +;;; Tools. +;;; + +(define (apply-any procs args) + "Apply the procedure listed in @var{procs} to @var{args} until one of these +procedure returns true." + (let loop ((procs procs)) + (if (null? procs) + #f + (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., +@code{(bold \"paf\")} will be considered as sub-trees of the resulting tree." + (let loop ((trees trees) + (result '())) + (if (null? trees) + result + (let ((tree (car trees))) + (loop (cdr trees) + (append result + (if (list? tree) + (cond ((null? tree) '()) + ((symbol? (car tree)) (list tree)) + (else tree)) + (list tree)))))))) + +(define (null-string? s) + (and (string? s) (string=? s ""))) + + +(define empty-line-rx (make-regexp "^([[:space:]]*|;.*)$")) +(define (empty-line? s) + "Return true if string @var{s} denotes an ``empty'' line, i.e., a blank +line or a line comment." + (regexp-exec empty-line-rx s)) + + + +;;; +;;; In-line markup, i.e., markup that doesn't span over multiple lines. +;;; + +(define %inline-markup + ;; Note: the order matters because, for instance, URLs must be searched for + ;; _before_ italics (`/italic/'). + `(("_([^_]+)_" . + ,(lambda (m) + (values (match:prefix m) ;; before + (match:substring m 1) ;; body + (match:suffix m) ;; after + (lambda (body) `(emph ,body))))) ;; process-body + ("(f|ht)tp://[a-zA-Z0-9\\._~%/-]+" . + ,(lambda (m) + (values (match:prefix m) + (match:substring m) + (match:suffix m) + (lambda (url) `(ref :url ,url))))) + ("\\/([^\\/]+)\\/" . + ,(lambda (m) + (values (match:prefix m) + (match:substring m 1) + (match:suffix m) + (lambda (body) `(it ,body))))) + ("\\*([^\\*]+)\\*" . + ,(lambda (m) + (values (match:prefix m) + (match:substring m 1) + (match:suffix m) + (lambda (body) `(bold ,body))))) + ("``(([^`^'])+)''" . + ,(lambda (m) + (values (match:prefix m) + (match:substring m 1) + (match:suffix m) + (lambda (body) `(q ,body))))) + ("`(([^`^'])+)'" . + ,(lambda (m) + (values (match:prefix m) + (match:substring m 1) + (match:suffix m) + (lambda (body) `(tt ,body))))))) + +(define (make-markup-processor rx proc) + (lambda (line) + (let ((match (regexp-exec rx line))) + (if match + (proc match) + #f)))) + +(define (make-line-processor markup-alist) + "Returns a @dfn{line processor}. A line processor is a procedure that +takes a string and returns a list." + (let* ((markups (map (lambda (rx+proc) + (cons (make-regexp (car rx+proc) regexp/extended) + (cdr rx+proc))) + markup-alist)) + (procs (map (lambda (rx+proc) + (make-markup-processor (car rx+proc) (cdr rx+proc))) + markups))) + (lambda (line) + (let self ((line line)) + ;;(format #t "self: ~a~%" line) + (cond ((string? line) + (let ((result (apply-any procs (list line)))) + (if result + (let-values (((before body after proc-body) + result)) + (let ((body+ + (if (string=? (string-append before body after) + line) + body (self body)))) + (if (and (null-string? before) + (null-string? after)) + (proc-body body+) + (append-trees (self before) + (proc-body body+) + (self after))))) + line))) + (else + (error "line-processor: internal error" line))))))) + +(define %line-processor + (make-line-processor %inline-markup)) + + + +;;; +;;; Large-scale structures: paragraphs, chapters, sections, etc. +;;; + +(define (process-paragraph line line-proc port) + (let loop ((line line) + (result '())) + (if (or (eof-object? line) (empty-line? line)) + (cons 'p result) + (loop (read-line port) + (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-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}. +@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) + #f + (let ((title (line-proc (title-proc match)))) + (let loop ((line (read-line port)) + (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)))))))))))) + + +(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* ((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 + (append %list-processors + (list section-proc)) + #f)))) + + + + +;;; +;;; The top-level parser. +;;; + +(define (make-document-processor node-procs line-proc) + (lambda (line port) + (let self ((line line) + (doc '())) + ;;(format #t "doc-proc: ~a~%" line) + (if (eof-object? line) + (if (null? doc) + line + (reverse! doc)) + (if (empty-line? line) + (self (read-line port) doc) + (let ((result (apply-any node-procs (list line port)))) + (if result + (let-values (((line node) result)) + (self line (cons node doc))) + (let ((par (process-paragraph line line-proc port))) + (self (read-line port) + (cons par doc)))))))))) + + +(define* (outline-reader :optional (port (current-input-port))) + (define modeline-rx + (make-regexp "^[[:space:]]*-\\*- [a-zA-Z-]+ -\\*-[[:space:]]*$")) + (define title-rx (make-regexp "^[Tt]itle: (.+)$" regexp/extended)) + (define author-rx (make-regexp "^[Aa]uthor: (.+)$" regexp/extended)) + + (let ((doc-proc (make-document-processor %node-processors %line-processor))) + + (let loop ((title #f) + (author #f) + (line (read-line port))) + + (if (eof-object? line) + (if (or title author) + `(document :title ,title :author (author :name ,author) '()) + line) + (if (or (empty-line? line) + (regexp-exec modeline-rx line)) + (loop title author (read-line port)) + (let ((title-match (regexp-exec title-rx line))) + (if title-match + (loop (match:substring title-match 1) + author (read-line port)) + (let ((author-match (regexp-exec author-rx line))) + (if author-match + (loop title (match:substring author-match 1) + (read-line port)) + + ;; Let's go. + `(document :title ,title + :author (author :name ,author) + ,@(doc-proc line port))))))))))) + + +(define* (make-outline-reader :optional (version "0.1")) + outline-reader) + + + +;;; The reader specification. + +(define-reader outline "0.1" make-outline-reader) + + +;;; arch-tag: 53473e73-c811-4eed-a0b4-22ada4d6ef08 + +;;; outline.scm ends here + diff --git a/src/guile/skribilo/reader/skribe.scm b/src/guile/skribilo/reader/skribe.scm new file mode 100644 index 0000000..d3dbb5f --- /dev/null +++ b/src/guile/skribilo/reader/skribe.scm @@ -0,0 +1,113 @@ +;;; skribe.scm -- A reader for the Skribe syntax. +;;; +;;; Copyright 2005, 2006 Ludovic Courtès <ludovic.courtes@laas.fr> +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +;;; USA. + +(define-module (skribilo reader skribe) + :use-module (skribilo reader) + :use-module (ice-9 optargs) + :use-module (srfi srfi-1) + + ;; the Scheme reader composition framework + :use-module ((system reader) #:renamer (symbol-prefix-proc 'r:)) + + :export (reader-specification + make-skribe-reader)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; A reader for the Skribe syntax, i.e. roughly R5RS Scheme plus DSSSL-style +;;; keywords and sk-exps (expressions introduced using a square bracket). +;;; +;;; Code: + +;;; Note: We need guile-reader 0.2 at least. + +(define* (make-skribe-reader #:optional (version "1.2d")) + "Return a Skribe reader (a procedure) suitable for version @var{version} of +the Skribe syntax." + (if (string> version "1.2d") + (error "make-skribe-reader: unsupported version" version) + %skribe-reader)) + +(define (make-colon-free-token-reader tr) + ;; Stolen from `guile-reader' 0.3. + "If token reader @var{tr} handles the @code{:} (colon) character, remove it +from its specification and return the new token reader." + (let* ((spec (r:token-reader-specification tr)) + (proc (r:token-reader-procedure tr))) + (r:make-token-reader (filter (lambda (chr) + (not (char=? chr #\:))) + spec) + proc))) + +(define &sharp-reader + ;; The reader for what comes after a `#' character. + (let* ((dsssl-keyword-reader ;; keywords à la `#!key' + (r:make-token-reader #\! + (r:token-reader-procedure + (r:standard-token-reader 'keyword))))) + (r:make-reader (cons dsssl-keyword-reader + (map r:standard-token-reader + '(character srfi-4 vector + number+radix boolean + srfi30-block-comment + srfi62-sexp-comment))) + #f ;; use default fault handler + 'reader/record-positions))) + +(define (%make-skribe-reader) + (let ((colon-keywords ;; keywords à la `:key' fashion + (r:make-token-reader #\: + (r:token-reader-procedure + (r:standard-token-reader 'keyword)))) + (symbol-misc-chars-tr + ;; Make sure `:' is handled only by the keyword token reader. + (make-colon-free-token-reader + (r:standard-token-reader 'r6rs-symbol-misc-chars)))) + + + ;; Note: we use the `r6rs-symbol-*' and `r6rs-number' token readers since + ;; they consider square brackets as delimiters. + (r:make-reader (cons* (r:make-token-reader #\# &sharp-reader) + colon-keywords + symbol-misc-chars-tr + (map r:standard-token-reader + `(whitespace + sexp string r6rs-number + r6rs-symbol-lower-case + r6rs-symbol-upper-case + quote-quasiquote-unquote + semicolon-comment + skribe-exp))) + #f ;; use the default fault handler + 'reader/record-positions + ))) + +;; We actually cache an instance here. +(define %skribe-reader (%make-skribe-reader)) + + + +;;; The reader specification. + +(define-reader skribe "1.2d" make-skribe-reader) + +;;; skribe.scm ends here |