├── README.md ├── cl.lisp ├── documentation ├── geneva-document.mk2 ├── issues.mk2 ├── mk2.mk2 └── open-geneva.mk2 ├── errors.lisp ├── geneva-cl.asd ├── geneva-html.asd ├── geneva-latex.asd ├── geneva-mk2.asd ├── geneva-plain-text.asd ├── geneva-tex.asd ├── geneva.asd ├── geneva.lisp ├── grammar.lisp ├── html.lisp ├── latex.lisp ├── macros.lisp ├── mk2.lisp ├── normalize.lisp ├── open-geneva.asd ├── plain-text.lisp ├── print.lisp ├── read.lisp ├── struct.lisp ├── syntax.lisp ├── test ├── geneva-test.lisp └── mk2-test.lisp ├── tex.lisp ├── tokens.lisp └── utilities.lisp /README.md: -------------------------------------------------------------------------------- 1 | # Open Geneva 2 | 3 | *Geneva* is the portable document preparation system. It follows the 4 | principle *Write once, read anywhere*. Geneva enables the creation and 5 | archival of truly portable documents by isolating document content and 6 | structure from document presentation. 7 | 8 | Geneva achieves this by introducing a generic but well defined document 9 | structure independent from its stored representation. In addition to 10 | classic document features such as paragraphs, listings, sections, tables 11 | and text markup, Geneva defines a generic *media type* for embedding 12 | arbitrary content and enable extensibility in a plug-in oriented way. 13 | 14 | *Open Geneva* is the reference implementation of Geneva written in 15 | *Common Lisp*. It implements Geneva and defines a diverse toolchain 16 | composed of input interfaces and presentation backends. Its input 17 | interfaces, such as the plain text oriented *Mk2 markup language* and the 18 | Geneva API, are user and programmer facing frontends to document 19 | authoring. Its presentation backends render documents to several targets 20 | including web, print and plain text media. 21 | 22 | 23 | ## Documentation 24 | 25 | * [Geneva Document Specification](http://inters.co/geneva/geneva-document.html) 26 | * [Open Geneva Manual](http://inters.co/geneva/open-geneva.html) 27 | * [The Mk2 Markup Language](http://inters.co/geneva/mk2.html) 28 | 29 | ## Dependencies 30 | 31 | * [maxpc](https://github.com/eugeneia/maxpc) 32 | * [file-types](https://github.com/eugeneia/file-types) 33 | * [macro-html](https://github.com/eugeneia/macro-html) 34 | * [trivial-documentation](https://github.com/eugeneia/trivial-documentation) 35 | * [texp](https://github.com/eugeneia/texp) 36 | -------------------------------------------------------------------------------- /cl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Compile Geneva documents from Common Lisp on-line documentation. 2 | 3 | (defpackage geneva.common-lisp 4 | (:nicknames :geneva.cl) 5 | (:documentation 6 | "Compile a Geneva _document_ from Common Lisp on-line documentation.") 7 | (:use :cl 8 | :named-readtables 9 | :geneva 10 | :geneva.mk2 11 | :geneva.macros 12 | :split-sequence 13 | :trivial-documentation) 14 | (:export :api-document 15 | :symbol-document)) 16 | 17 | (in-package :geneva.common-lisp) 18 | 19 | (in-readtable geneva.macros:syntax) 20 | 21 | (defun nobreak-hyphens (string) 22 | (format nil "~{~a~^‑~}" (split-sequence #\- string))) 23 | 24 | (defun name* (string-or-symbol &key nobreak-p) 25 | "Canonicalize STRING-OR-SYMBOL to string." 26 | (etypecase string-or-symbol 27 | (symbol (name* (let ((name (symbol-name string-or-symbol))) 28 | (if nobreak-p 29 | (nobreak-hyphens name) 30 | name)))) 31 | (string (if (find-if #'lower-case-p string-or-symbol) 32 | string-or-symbol 33 | (string-downcase string-or-symbol))))) 34 | 35 | (defun definition-template (&key kind name syntax document) 36 | "Template for common definition formatting." 37 | (make-section 38 | `(,name " (" ,kind ")") 39 | `(,@(when syntax 40 | `(,(paragraph #b"Syntax:") 41 | ,(make-paragraph 42 | `("— " ,kind ": " ,(make-bold name) " " ,@syntax)))) 43 | ,@document))) 44 | 45 | 46 | (defun docstring-paragraphs (docstring) 47 | "Split DOCSTRING into Geneva paragraphs." 48 | ;; This is a haskish approach. Deal with it. 49 | (mapcar (lambda (p) (paragraph (format nil "~{~a~%~}" p))) 50 | (split-sequence "" (split-sequence #\Newline docstring) 51 | :test 'equal))) 52 | 53 | (defun docstring-document (docstring) 54 | "Compile document from DOCSTRING." 55 | (when docstring 56 | ;; Try parsing DOCSTRING as Mk2. 57 | (handler-case (read-mk2 docstring) 58 | (error (e) 59 | (declare (ignore e)) 60 | ;; If that fails, fall back to basic paragraph formatting. 61 | (make-document (docstring-paragraphs docstring)))))) 62 | 63 | (defun value-string (value) 64 | "Return pretty string for VALUE." 65 | (let ((*print-pretty* t) 66 | (*print-circle* t) 67 | (*print-readably* t) 68 | (*print-escape* t) 69 | (*print-miser-width* *print-right-margin*)) 70 | (handler-case (write-to-string value) 71 | (print-not-readable (c) 72 | (declare (ignore c)) 73 | (let ((*print-readably* nil)) 74 | (write-to-string value)))))) 75 | 76 | (defun render-variable (name variable-definition) 77 | "Render VARIABLE-DEFINITION with NAME." 78 | (destructuring-bind (&key kind documentation value) 79 | variable-definition 80 | (definition-template 81 | :kind (ecase kind 82 | (:variable "Variable") 83 | (:constant "Constant Variable")) 84 | :name name 85 | :document (append 86 | (document 87 | (paragraph #b"Initial Value:") 88 | (let ((value-string (value-string value))) 89 | (if (find #\Newline value-string) 90 | (plaintext nil value-string) 91 | (paragraph (make-fixed-width value-string))))) 92 | (docstring-document documentation))))) 93 | 94 | (defun render-lambda-list (lambda-list) 95 | "Render LAMBDA-LIST." 96 | (if (null lambda-list) 97 | (list #i"") 98 | (loop for head = lambda-list then (cdr head) while head 99 | for x = (car head) 100 | with keyword-p = nil 101 | when (eq '&key x) do (setf keyword-p t) 102 | if (listp x) 103 | append `(,#f"(" ,@(render-lambda-list x) ,#f")") 104 | else collect 105 | (if (member x lambda-list-keywords) 106 | (make-fixed-width (name* x :nobreak-p t)) 107 | (make-italic (name* x :nobreak-p (not keyword-p)))) 108 | when (cdr head) collect " "))) 109 | 110 | (defun render-function (name function-definition) 111 | "Render FUNCTION-DEFINITION with NAME." 112 | (destructuring-bind (&key kind documentation lambda-list) 113 | function-definition 114 | (definition-template 115 | :kind (ecase kind 116 | (:function "Function") 117 | (:generic-function "Generic Function") 118 | (:macro "Macro")) 119 | :name name 120 | :syntax (render-lambda-list lambda-list) 121 | :document (docstring-document documentation)))) 122 | 123 | (defun render-class-precedence-list (precedence-list) 124 | "Render class PRECEDENCE-LIST." 125 | (make-paragraph 126 | (loop for head = precedence-list then (cdr head) while head 127 | collect (make-fixed-width (name* (car head))) 128 | when (cdr head) collect ", "))) 129 | 130 | (defun render-initargs (initargs) 131 | "Render class INITARGS." 132 | (when initargs 133 | (render-lambda-list (list* '&key initargs)))) 134 | 135 | (defun render-slots (slots) 136 | (loop for head = slots then (cddr head) while head 137 | for (slot docstring . ()) = head 138 | collect (paragraph (make-fixed-width (name* slot))) 139 | append (docstring-document docstring))) 140 | 141 | (defun render-class (name class-definition) 142 | "Render CLASS-DEFINITION with NAME." 143 | (destructuring-bind (&key kind documentation precedence-list initargs slots) 144 | class-definition 145 | (declare (ignore kind)) 146 | (let ((document 147 | (append 148 | (document (paragraph #b"Class Precedence List:") 149 | (render-class-precedence-list precedence-list)) 150 | (docstring-document documentation) 151 | (when slots 152 | (append (document (paragraph #b"Slots:")) 153 | (make-document (render-slots slots))))))) 154 | (if (member 'condition precedence-list) 155 | (definition-template 156 | :kind "Condition Type" 157 | :name name 158 | :document document) 159 | (definition-template 160 | :kind "Class" 161 | :name name 162 | :syntax (render-initargs initargs) 163 | :document document))))) 164 | 165 | (defun render-type (name type-definition) 166 | "Render TYPE-DEFINITION with NAME." 167 | (destructuring-bind (&key kind documentation) 168 | type-definition 169 | (declare (ignore kind)) 170 | (definition-template 171 | :kind "Type" 172 | :name name 173 | :document (docstring-document documentation)))) 174 | 175 | (defun render-definition (name definition) 176 | "Render DEFINITION for NAME." 177 | (case (getf definition :kind) 178 | ((:variable :constant) 179 | (render-variable name definition)) 180 | ((:function :generic-function :macro) 181 | (render-function name definition)) 182 | (:class 183 | (render-class name definition)) 184 | ((:structure :type) 185 | (render-type name definition)))) 186 | 187 | (defun render-symbol-definitions (symbol definitions) 188 | "Render DEFINITIONS for SYMBOL." 189 | (let ((name (name* symbol))) 190 | (make-document 191 | (loop for definition in definitions collect 192 | (render-definition name definition))))) 193 | 194 | (defun render-package (package) 195 | "Compile section for PACKAGE." 196 | (definition-template 197 | :name (name* (package-name package)) 198 | :kind "Package" 199 | :document 200 | (multiple-value-bind (docstring definitions) 201 | (package-api package) 202 | (append (read-mk2 docstring) 203 | (loop for head = definitions then (cddr head) while head 204 | for symbol = (car head) for defs = (cadr head) 205 | if defs append (render-symbol-definitions symbol defs)))))) 206 | 207 | (defun api-document (&rest packages) 208 | "*Arguments and Values:* 209 | 210 | _packages_—_packages_ or _string designators_ naming _packages_. 211 | 212 | *Description:* 213 | 214 | {api-document} renders the on-line documentation for the _external 215 | symbols_ of _packages_ as a Geneva document." 216 | (make-document (mapcar #'render-package packages))) 217 | 218 | (defun symbol-document (symbol) 219 | "*Arguments and Values:* 220 | 221 | _symbol_—a _symbol_. 222 | 223 | *Description:* 224 | 225 | {symbol-document} renders the on-line documentation for _symbol_ as a 226 | Geneva document." 227 | (render-symbol-definitions symbol (symbol-definitions symbol))) 228 | -------------------------------------------------------------------------------- /documentation/geneva-document.mk2: -------------------------------------------------------------------------------- 1 | _This is a draft standard, this notice will disappear once the 2 | specification is final._ 3 | 4 | A _Geneva document_ is an ordered collection of _elements_. Geneva 5 | defines the following _element types_: 6 | 7 | + Pargraph 8 | + Listing 9 | + Table 10 | + Plaintext 11 | + Media 12 | + Section 13 | 14 | 15 | < Rich Text 16 | 17 | A central component of all element types is _rich text_. Rich text is 18 | defined as a sequence of _text tokens_, each made up of a variable 19 | number of character strings and an attribute to signify its 20 | appearance. There are five different types of text tokens: 21 | 22 | #table *Table 1.* Text token types.# 23 | | Token | Description 24 | | plain _s_ | Render _s_ in regular font. 25 | | bold _s_ | Recommends to render _s_ in bold font. 26 | | italic _s_ | Recommends to render _s_ in italic font. 27 | | fixed-width _s_ | Recommends to render _s_ in fixed-width font. 28 | | url _s_ | Interpret _s_ as a _Uniform Resource Locator_. 29 | | url _s_, _u_ | Interpret _u_ as a _Uniform Resource Locator_ and _s_ as its label. 30 | 31 | The occurrence of _whitespace characters_ in text token strings is 32 | restricted by the following rules: 33 | 34 | + All whitespace character sequences are to be reduced to a single 35 | _space character_ (ASCII {0x20} or equivalent). 36 | + For all token types except the plain type, discard prefixes and 37 | suffixes of whitespace character sequences. 38 | + For the first and last text tokens in a rich text sequence, discard 39 | prefixes and suffixes of whitespace character sequences respectively. 40 | 41 | At least the following conceptual characters have to be recognized as 42 | whitespace: 43 | 44 | + _Space_ 45 | + _Tab_ 46 | + _Newline_ (including _Carriage Return_) 47 | + _Vertical Tab_ 48 | + _Page break_ 49 | 50 | > 51 | 52 | 53 | < Element Types 54 | 55 | A *paragraph* consists of exactly one rich text sequence. It signifies a 56 | self-contained piece of text. 57 | 58 | A *listing* consists of a finite sequence of rich text sequences. It 59 | signifies an ordered group of self-contained text pieces. 60 | 61 | A *table* consists of a two-dimensional matrix of rich text sequences 62 | and a single rich text sequence being its description. It signifies a 63 | tabular relation of the matrix of rich text pieces. 64 | 65 | A *plaintext* element consists of a verbatim character string and a 66 | single rich text sequence being its description. It signifies a sequence 67 | of characters which has to be preserved as is except for whitespace 68 | prefixes and suffixes (including newlines). 69 | 70 | A *media* element consists of an _Unique Resource Locator_ string and a 71 | single rich text sequence being its description. It signifies the 72 | embedment of an external resource. 73 | 74 | A description as mentioned above, is a piece of text elaborating the 75 | contents of a given element. 76 | 77 | A *section* consists of a Geneva document and a single rich text 78 | sequence being its heading. It signifies a continuous subsequence of the 79 | document, introduced by a headline (the heading). 80 | 81 | > 82 | 83 | 84 | < Formal Definition 85 | 86 | The table below defines a Geneva document formally using the modifed BNF 87 | syntax described in ANSI Common Lisp's _Notational Conventions_.¹ 88 | 89 | #table *Table 2.* Formal definition of a Geneva document.# 90 | | Symbol | Expression 91 | | document | document-element{*} 92 | | document-element | pargraph {|} listing {|} table {|} plaintext {|} media {|} section 93 | | paragraph | text-token{+} 94 | | listing | rich-text{+} 95 | | table | rich-text table-row{+} 96 | | table-row | rich-text{+} 97 | | plaintext | rich-text string 98 | | media | rich-text string 99 | | section | rich-text document-element{*} 100 | | rich-text | text-token{*} 101 | | text-token | _A text token, see “Rich Text”_ 102 | | string | _A character string_ 103 | 104 | + 1. [ANSI Common Lisp: Notational Conventions](http://users-phys.au.dk/harder/Notational-Conventions.html) 105 | 106 | > 107 | -------------------------------------------------------------------------------- /documentation/issues.mk2: -------------------------------------------------------------------------------- 1 | < Feature Want-list 2 | 3 | + *Stop token* {#} (like an HTML {
}, for poetry.) 4 | 5 | > 6 | 7 | < Ugliness 8 | 9 | + Figure out a way to properly display CODE in LaTeX, break lines or 10 | floating figure? 11 | + {GENEVA.PLAIN-TEXT}'s implementation is an ugly hack on top of 12 | {GENEVA.MK2} and could use refactoring. 13 | 14 | > 15 | -------------------------------------------------------------------------------- /documentation/mk2.mk2: -------------------------------------------------------------------------------- 1 | _This is a draft standard, this notice will disappear once the 2 | specification is final._ 3 | 4 | _Mk2_ is a human readable plain text language for expressing Geneva 5 | documents.¹ It is designed with both ergonomics and technical pragmatism 6 | in mind. 7 | 8 | + 1. [Geneva Document Specification](geneva-document.html) 9 | 10 | 11 | < Syntax 12 | 13 | This formal definition uses the modified _BNF syntax_ of _ANSI CL's 14 | Notational Conventions_.¹ The following axioms are used throughout the 15 | definition: 16 | 17 | _String_—A character sequence. The exact grammar depends on the 18 | surrounding context. See _Escape Rules_. 19 | 20 | _LF_—A character sequence denoting a line break. The exact 21 | representation is platform dependent. 22 | 23 | _EOF_—The end of input. 24 | 25 | _SP_—A whitespace character. The exact set of characters considered 26 | whitespace is platform dependent. 27 | 28 | + 1. [ANSI Common Lisp: Notational Conventions](http://users-phys.au.dk/harder/Notational-Conventions.html) 29 | 30 | < Document and Section 31 | 32 | #table *Table 1.* _Document_ and _section_ syntax.# 33 | | Symbol | Expression 34 | | document | {[} element separator {]}{*} _EOF_ 35 | | section | {"<"} title separator {[} element separator {]}{*} {">"} separator 36 | | title | rich-text 37 | | element | section {|} table {|} plaintext {|} media {|} listing {|} paragraph 38 | | separator | double-lf {|} _EOF_ 39 | | double-lf | _LF_ {[} _LF_ {]}{+} 40 | 41 | > 42 | 43 | < Paragraph and Listing 44 | 45 | #table *Table 2.* _Paragraph_ and _Listing_ syntax.# 46 | | Symbol | Expression 47 | | paragraph | text-token{+} 48 | | listing | item{+} 49 | | item | {"+"} rich-text 50 | 51 | > 52 | 53 | < Table, Media and Plaintext 54 | 55 | #table *Table 3.* _Table_ syntax.# 56 | | Symbol | Expression 57 | | table | {"#table"} description {"#"} _LF_ table-body 58 | | description | rich-text 59 | | table-body | row{*} last-row 60 | | row | column{+} _LF_ 61 | | last-row | column{+} 62 | | column | {"|"} rich-text 63 | 64 | #table *Table 4.* _Media_ syntax.# 65 | | Symbol | Expression 66 | | media | {"#media"} description {"#"} _LF_ _String_ 67 | | description | rich-text 68 | 69 | #table *Table 5.* _Plaintext_ syntax.# 70 | | Symbol | Expression 71 | | plaintext | {"#code"} description {"#"} _LF_ line{+} end 72 | | description | rich-text 73 | | line | _String_ _LF_ 74 | | end | _SP_{*} {"#"} 75 | 76 | > 77 | 78 | < Rich Text 79 | 80 | #table *Table 6.* _Rich text_ syntax.# 81 | | Symbol | Expression 82 | | rich-text | text-token{*} 83 | | text-token | bold {|} italic {|} fixed-width {|} url {|} plain 84 | | bold | {"*"} _String_ {"*"} 85 | | italic | {"_"} _String_ {"_"} 86 | | fixed-width | {"{"} _String_ {"\}"} 87 | | url | {"["} _String_ {"]"} {[} {"("} _String_ {")"} {]} 88 | | plain | _String_ 89 | 90 | > 91 | 92 | < Escape Rules 93 | 94 | The “{\\}” (backslash) can be used to _escape_ the next character. The 95 | grammatical significance of a character following “{\\}” is ignored. 96 | 97 | The exact grammar of the _String_ axiom is context dependent. A 98 | _String_ may not contain unescaped _terminating sequences_. A 99 | terminating sequence is the set of any token following the _String_ 100 | axiom in a rule and _double-lf_. In order to escape a terminating 101 | sequence its first character must be escaped. 102 | 103 | For illustration consider the grammar in _Table 7_ which utilizes the 104 | _String_ axiom. In _rule_ the _String_ axiom is followed by 105 | _terminator_, thus “{foo}” is a _terminating sequence_ of _String_ in 106 | _rule_. Valid and invalid character sequences for _String_ in _rule_ 107 | are shown in _Table 8_. 108 | 109 | #table *Table 7.* Exemplary grammar rules to illustrate escape rules 110 | for the _String_ axiom.# 111 | | Symbol | Expression 112 | | rule | _String_ terminator 113 | | terminator | {"foo"} 114 | 115 | #table *Table 8.* Valid and invalid character sequences for _String_ in 116 | _rule_.# 117 | | Valid | Invalid 118 | | {quick brown \\foo} | {quick brown foo} 119 | 120 | > 121 | 122 | > 123 | 124 | 125 | < Examples 126 | 127 | < Document and Section 128 | 129 | The Mk2 file in Figure 1 contains a paragraph (_A quick brown fox..._) 130 | and a section titled “On Pangrams” which contains another paragraph (_A 131 | pangram is..._). 132 | 133 | #code *Figure 1*# 134 | A quick brown fox jumps over the lazy dog. 135 | 136 | < On Pangrams 137 | 138 | A pangram is a phrase that contains all of the letters of the 139 | alphabet. 140 | 141 | > 142 | # 143 | 144 | > 145 | 146 | < Listing and Text Tokens 147 | 148 | The listing in Figure 2 contains six items, each being a single text 149 | token. 150 | 151 | #code *Figure 2*# 152 | + Plain text token 153 | + *Bold text token* 154 | + _Italic text token_ 155 | + {Fixed-width text token} 156 | + [http://example.org/url/text-token] 157 | + [Labeled URL](http://example.org) 158 | # 159 | 160 | > 161 | 162 | < Table, Media and Plaintext 163 | 164 | The Mk2 file in Figure 3 contains table, media and plaintext object, 165 | each having a description and their respective bodies. 166 | 167 | #code *Figure 3*# 168 | #table Source: Wikipedia.# 169 | | State | Area | Total Population 170 | | Bavaria | 70,549.44 km² | 12,604,244 171 | | North Rhine-Westphalia | 34,084.13 km² | 17,571,856 172 | 173 | #media Imaginary embedded video.# 174 | http://example.org/video.ogv 175 | 176 | #code {SQUARE} function in Common Lisp.# 177 | (defun square (n) 178 | (expt n 2)) 179 | # 180 | # 181 | 182 | > 183 | 184 | < Escaping 185 | 186 | Mk2 is designed to avoid the need of escaping control tokens as much as 187 | possible. Still there are some cases where the user has to use the {\\} 188 | (backslash) character to avoid the semantics of a specific token. Below 189 | are examples of the most common cases. 190 | 191 | #table *Figure 4* Escaping unintended text token markup.# 192 | | Mk2 | Result 193 | | {In ECMAScript anonymous functions can be expressed using the {function (...) { ... \\\}\} special form.} \ 194 | | In ECMAScript anonymous functions can be expressed using the {function (...) { ... \}} special form. 195 | 196 | The Mk2 file in Figure 4 escapes the first {\}} (curly bracket) 197 | character inside a fixed width text token in order to avoid terminating 198 | the fixed width token prematurely. Not that only the closing bracket 199 | needs to be escaped because it is the only terminating token of the 200 | _String_ in a fixed width token. 201 | 202 | 203 | #table *Figure 5* Including the literal backslash character.# 204 | | Mk2 | Result 205 | | {On DOS, {\\\\\} (backslash) is used to separate the components of a pathname.} \ 206 | | On DOS, {\\} (backslash) is used to separate the components of a pathname. 207 | 208 | Sometimes the user needs to include the literal backslash character in 209 | his prose. The {\\} (backslash) character can be escaped using itself 210 | just like any other character as Figure 5 shows. 211 | 212 | > 213 | 214 | > 215 | -------------------------------------------------------------------------------- /documentation/open-geneva.mk2: -------------------------------------------------------------------------------- 1 | _Open Geneva_ is an implementation of the _Geneva document preparation 2 | system_ written in _Common Lisp_. This user manual describes the 3 | components of Open Geneva from a high level perspective and explains 4 | their operation by example. For a complete API documentation see the 5 | _Open Geneva API_.¹ 6 | 7 | Open Geneva is divided into several subsystems, each implementing a 8 | different functionality of the system. For convenience, a “master system” 9 | is provided, which depends on every subsystem of Open Geneva. If you want 10 | to load and/or compile Open Geneva as a whole, then you may use the 11 | {open-geneva} system. The various subsystems are described in the 12 | sections below. 13 | 14 | + 1. [Open Geneva API](open-geneva-api.html) 15 | 16 | 17 | < Geneva: The Document API 18 | 19 | At the core of Open Geneva are a set of constructors and readers used to 20 | programatically create and inspect Geneva documents. These functions are 21 | in the {geneva} package. These constructors verify the integrity of 22 | their arguments and their return values are normalized as defined in the 23 | _Geneva Document Specification_.¹ 24 | 25 | There are three different kinds of constructors: The _document_ 26 | constructor {make-document}, _document element_ constructors 27 | ({make-pargraph} for instance) and _text token_ constructors 28 | ({make-bold} etc.). 29 | 30 | #code Example: Dynamically creating a document.# 31 | (defun make-birthday-invitation (date guest-name) 32 | (make-document 33 | (list 34 | (make-section 35 | '("Birthday Invitation") 36 | (list 37 | (make-paragraph 38 | `(,(make-bold (format nil "Hi ~a!" guest-name)))) 39 | (make-paragraph 40 | `(,(format nil "You are invited to my birthday party on ~a. " 41 | date) 42 | ,(make-italic "Bring your friends!")))))))) 43 | 44 | (make-birthday-invitation "Friday" "John") → document 45 | # 46 | 47 | The readers {content-type} and {content-values} work on document 48 | elements as well as on text tokens and can be used to inspect the 49 | contents of a document. {Content-type} returns the type of its argument 50 | and {content-values} returns the components of it argument a seperate 51 | values. 52 | 53 | #code Examples: Inspecting document contents.# 54 | (content-type (make-bold "foo")) → :BOLD 55 | (content-type "bar") → :PLAIN ; Strings have a CONTENT-TYPE. 56 | (content-values (make-section <body)) → <title> <body> 57 | # 58 | 59 | A document is just a list of document elements. It can be traversed by 60 | the standard list manipulation functions. 61 | 62 | #code Example: Traversing a document.# 63 | ;; Return list of element types used in document. 64 | (defun document-features (document) 65 | (remove-duplicates 66 | (loop for element in document 67 | for type = (content-type element) 68 | if (eq type :section) 69 | then append (multiple-value-bind (title body) 70 | (content-values element) 71 | `(:section ,@(document-features body))) 72 | else collect (content-type element)))) 73 | 74 | (document-features (make-document 75 | (make-paragraph '("foo")) 76 | (make-paragraph '("bar"))) 77 | → (:PARAGRAPH) 78 | # 79 | 80 | A document can be printed _readably_ by the Common Lisp printer. The 81 | easiest way to (de)serialize a document is to use {read} and {print}. 82 | 83 | #code Example: (De)serializing a document.# 84 | (let ((document (make-document ...))) 85 | (equal document 86 | (read-from-string 87 | (prin1-to-string document)))) 88 | → T 89 | # 90 | 91 | The {geneva.macros} package provides macro counterparts of the element 92 | constructors and a readtable² {geneva.macros:syntax} which can come in 93 | handy when dynamically creating documents. Below is the “birthday 94 | invitation” example from above revisited using {geneva.macros}. 95 | 96 | #code Example: Dynamically creating documents using {geneva.macros}.# 97 | (in-readtable geneva.macros:syntax) 98 | 99 | (defun make-birthday-invitation (date guest-name) 100 | (document 101 | (section ("Birthday invitation") 102 | (paragraph (make-bold (format nil "Hi ~a!" guest-name))) 103 | (paragraph 104 | (format nil "You are invited to my birthday party on ~a. " 105 | date) 106 | ;; Note the reader macro below. 107 | #i"Bring your friends!")))) 108 | # 109 | 110 | + 1. [Geneva Document Specification](geneva-document.html) 111 | + 2. See _Named-Readtables_ ({editor-hints.named-readtables}) 112 | 113 | > 114 | 115 | 116 | < Geneva-mk2: Reading and Writing Mk2 Files 117 | 118 | _Mk2_¹ is a human readable serialization format for Geneva documents. 119 | Open Geneva implements the Mk2 markup language in the {geneva.mk2} 120 | package. Geneva documents can be read from and printed as Mk2 using 121 | {read-mk2} and {print-mk2}. 122 | 123 | Note that an Mk2 file is a precise representation of a Geneva 124 | document. The following holds true: 125 | 126 | #code# 127 | (let ((document (make-document ...))) 128 | (equal document 129 | (read-mk2 (with-output-to-string (out) 130 | (print-mk2 document out))))) 131 | → T 132 | # 133 | 134 | + 1. [The Mk2 Markup Language](mk2.html) 135 | 136 | > 137 | 138 | 139 | < Rendering Geneva Documents 140 | 141 | Open Geneva supports rendering Geneva documents as plain text, HTML and 142 | LaTeX. The implementing functions can be loaded as the 143 | {geneva-plaintext}, {geneva-html} and {geneva-latex} systems 144 | respectively. 145 | 146 | < Common Rendering Interface 147 | 148 | The various rendering systems share a common subset of their interface. 149 | 150 | — Function: *render-plain-text* | *render-html* | *render-latex* 151 | _document_ 152 | {&key} _stream_ _title_ _author_ _date_ _index-p_ 153 | _index-caption_ _index-headers-p_ 154 | {&allow-other-keys} 155 | 156 | *Arguments and Values:* 157 | 158 | _document_—a Geneva _document_. 159 | 160 | _stream_—a _character stream_. The default is _standard output_. 161 | 162 | _title_—a _string_. 163 | 164 | _author_—a _string_. 165 | 166 | _date_—a _string_. 167 | 168 | _index-p_—a _generalized boolean_. The default is _true_. 169 | 170 | _index-caption_—a _string_. The default is {"Table of Contents"}. 171 | 172 | _index-headers-p_—a _generalized boolean_. The default is _true_. 173 | 174 | *Description:* 175 | 176 | Renders _document_ to _stream_. The document rendering can optionally 177 | be prepended by a title section and a section index. _Title_, _author_ 178 | and _date_ are used in the title section. _Index-caption_ can be 179 | supplied to customize the heading of the section index. If _index-p_ is 180 | _false_ the section index will be omitted. Section headers will be 181 | enumerated unless _index-headers-p_ is _false_. 182 | 183 | *Exceptional Situations:* 184 | 185 | If _document_ is not a valid Geneva _document_ an _error_ of _type_ 186 | {type-error} is signaled. 187 | 188 | > 189 | 190 | > 191 | 192 | 193 | < Geneva-cl: Compiling Geneva Documents from Common Lisp On-Line 194 | Documentation 195 | 196 | The {geneva.common-lisp} package provides a function {api-document} 197 | which can be used to compile Geneva documents from Common Lisp on-line 198 | documentation. Its usage is quite simple and can be explained by 199 | example: 200 | 201 | #code Creating an API document from a package.# 202 | (defpackage foo 203 | (:documentation "Foo is a demo package.") 204 | (:use :cl) 205 | (:export :bar)) 206 | 207 | (defun foo:bar (x) "{bar} is a _NO-OP_." x) 208 | 209 | (api-document :foo) 210 | → ((:SECTION ("foo") 211 | ((:PARAGRAPH ("Foo is a demo package.")) 212 | (:SECTION ("bar") 213 | ((:PARAGRAPH ("— Function: " (:BOLD "bar") " " (:ITALIC "x"))) 214 | (:PARAGRAPH ((:FIXED-WIDTH "bar") " is a " 215 | (:ITALIC "NO-OP") "."))))))) 216 | # 217 | 218 | Note that documentation strings are parsed as _Mk2_ files using 219 | {read-mk2}. 220 | 221 | > 222 | -------------------------------------------------------------------------------- /errors.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Error conditions and routines used by the grammar of GENEVA.MK2. 2 | 3 | (in-package :geneva.mk2) 4 | 5 | 6 | ;;; Syntax error conditions. 7 | 8 | (define-condition syntax-error (error) 9 | ((line-position 10 | :type (unsigned integer) 11 | :initform (error "Must supply LINE-POSITION.") 12 | :initarg :line 13 | :reader line-position 14 | :documentation "Line position of SYNTAX-ERROR.") 15 | (character-position 16 | :type (unsigned integer) 17 | :initform (error "Must supply CHARACTER-POSITION.") 18 | :initarg :character 19 | :reader character-position 20 | :documentation "Character position of SYNTAX-ERROR.")) 21 | (:report print-syntax-error) 22 | (:documentation 23 | "*Description:* 24 | 25 | The _type_ {syntax-error} consists of error conditions that occur 26 | during {read-mk2}. It denotes a syntax error in the input to 27 | {read-mk2}. The functions {line-position} and {character-position} 28 | can be used to retrieve the position where the error occurred. 29 | 30 | *See Also:* 31 | 32 | + character-position 33 | + line-position")) 34 | 35 | (setf (documentation 'line-position 'function) 36 | "*Arguments and Values:* 37 | 38 | _syntax-error_—an _error_ of type {syntax-error}. 39 | 40 | *Description:* 41 | 42 | {line-position} returns a _positive integer_ specifying the line 43 | of input on which _syntax-error_ occured. 44 | 45 | *See Also:* 46 | 47 | + syntax-error") 48 | 49 | (setf (documentation 'character-position 'function) 50 | "*Arguments and Values:* 51 | 52 | _syntax-error_—an _error_ of type {syntax-error}. 53 | 54 | *Description:* 55 | 56 | {character-position} returns a _positive integer_ specifying the 57 | character position in the line on which _syntax-error_ occured. 58 | 59 | *See Also:* 60 | 61 | + syntax-error") 62 | 63 | (defun print-syntax-error (syntax-error 64 | &optional (stream *error-output*)) 65 | "Print SYNTAX-ERROR to STREAM (which defaults to *ERROR-OUTPUT*)." 66 | (format stream "~a at position ~a:~a." 67 | (type-of syntax-error) 68 | (line-position syntax-error) 69 | (character-position syntax-error))) 70 | #| TEST (let ((err (make-instance 'syntax-error :line 10 :character 17))) 71 | (print-syntax-error err) 72 | (format t "~&~a~%" err)) 73 | Should print "SYNTAX-ERROR at position 10:17." twice. |# 74 | 75 | (define-condition malformed-element (syntax-error) () 76 | (:documentation 77 | "*Description:* 78 | 79 | The _type_ {malformed-element} is an error condition of type 80 | {syntax-error}. It occurs during parsing a _table_, _media_ or 81 | _plaintext_ element. 82 | 83 | *See Also:* 84 | 85 | + syntax-error")) 86 | 87 | (define-condition section-not-closed (syntax-error) () 88 | (:documentation 89 | "Internal syntax error describing an unclosed section.")) 90 | 91 | (define-condition open-section (syntax-error) () 92 | (:documentation 93 | "*Description:* 94 | 95 | The _type_ {open-section} is an error condition of type 96 | {syntax-error}. It denotes an unclosed section. 97 | 98 | *See Also:* 99 | 100 | + syntax-error")) 101 | 102 | (define-condition unrecognized-input (syntax-error) () 103 | (:documentation 104 | "*Description:* 105 | 106 | The _type_ {unrecognized-input} is an error condition of type 107 | {syntax-error}. It denotes that a portion of the input could not be 108 | interpreted as _Mk2_. 109 | 110 | *See Also:* 111 | 112 | + syntax-error")) 113 | 114 | 115 | ;;; Error signaling routine. 116 | 117 | (defun ?syntax-error (error) 118 | "Signal ERROR at current position." 119 | (?fail (multiple-value-bind (position line character) 120 | (get-input-position) 121 | (declare (ignore position)) 122 | (error error :line line :character character)))) 123 | -------------------------------------------------------------------------------- /geneva-cl.asd: -------------------------------------------------------------------------------- 1 | ;;;; System definition for GENEVA-CL. 2 | 3 | (defsystem geneva-cl 4 | :long-name "geneva-common-lisp" 5 | :description 6 | "Compile Geneva documents from Common Lisp on-inline documentation." 7 | :author "Max Rottenkolber <max@mr.gy>" 8 | :license "GNU AGPL" 9 | :components ((:file "cl")) 10 | :depends-on ("named-readtables" 11 | "split-sequence" 12 | "geneva" 13 | "geneva-mk2" 14 | "trivial-documentation")) 15 | -------------------------------------------------------------------------------- /geneva-html.asd: -------------------------------------------------------------------------------- 1 | ;;;; System definition for GENEVA-HTML. 2 | 3 | (defsystem geneva-html 4 | :description 5 | "Render Geneva documents as HTML." 6 | :author "Max Rottenkolber <max@mr.gy>" 7 | :license "GNU AGPL" 8 | :components ((:file "html")) 9 | :depends-on ("geneva" "macro-html" "file-types")) 10 | -------------------------------------------------------------------------------- /geneva-latex.asd: -------------------------------------------------------------------------------- 1 | ;;;; System definition for GENEVA.LATEX. 2 | 3 | (defsystem geneva-latex 4 | :description 5 | "Render Geneva documents as LaTeX manuscripts." 6 | :author "Max Rottenkolber <max@mr.gy>" 7 | :license "GNU AGPL" 8 | :components ((:file "latex")) 9 | :depends-on ("geneva" "geneva-tex" "texp" "named-readtables")) 10 | -------------------------------------------------------------------------------- /geneva-mk2.asd: -------------------------------------------------------------------------------- 1 | ;;;; System definition for GENEVA-MK2. 2 | 3 | (defsystem geneva-mk2 4 | :description 5 | "Plain text markup language for the Geneva document preparation 6 | system." 7 | :author "Max Rottenkolber <max@mr.gy>" 8 | :license "GNU AGPL" 9 | :components ((:file "mk2") 10 | (:file "tokens" 11 | :depends-on ("mk2")) 12 | (:file "errors" 13 | :depends-on ("mk2")) 14 | (:file "grammar" 15 | :depends-on ("mk2" 16 | "errors")) 17 | (:file "read" 18 | :depends-on ("mk2" 19 | "tokens" 20 | "errors" 21 | "grammar")) 22 | (:file "print" 23 | :depends-on ("mk2" 24 | "tokens"))) 25 | :depends-on ("geneva" "maxpc" "split-sequence")) 26 | -------------------------------------------------------------------------------- /geneva-plain-text.asd: -------------------------------------------------------------------------------- 1 | ;;;; System definition for GENEVA-PLAIN-TEXT. 2 | 3 | (defsystem geneva-plain-text 4 | :description 5 | "Render Geneva documents as plain text." 6 | :author "Max Rottenkolber <max@mr.gy>" 7 | :license "GNU AGPL" 8 | :components ((:file "plain-text")) 9 | :depends-on ("geneva" "geneva-mk2")) 10 | -------------------------------------------------------------------------------- /geneva-tex.asd: -------------------------------------------------------------------------------- 1 | ;;;; System definition for GENEVA-TEX. 2 | 3 | (defsystem geneva-tex 4 | :description 5 | "Render Geneva documents as TeX manuscripts." 6 | :author "Max Rottenkolber <max@mr.gy>" 7 | :license "GNU AGPL" 8 | :components ((:file "tex")) 9 | :depends-on ("geneva" "texp" "file-types" "named-readtables")) 10 | -------------------------------------------------------------------------------- /geneva.asd: -------------------------------------------------------------------------------- 1 | ;;;; System definition for GENEVA. 2 | 3 | (defsystem geneva 4 | :description 5 | "Core of the Geneva document preparation system. Provides data 6 | structures and syntax sugar." 7 | :author "Max Rottenkolber <max@mr.gy>" 8 | :license "GNU AGPL" 9 | :components ((:file "geneva") 10 | (:file "normalize" 11 | :depends-on ("geneva")) 12 | (:file "struct" 13 | :depends-on ("geneva")) 14 | (:file "macros" 15 | :depends-on ("geneva" "struct")) 16 | (:file "syntax" 17 | :depends-on ("geneva" 18 | "struct" 19 | "macros")) 20 | (:file "utilities" 21 | :depends-on ("geneva" "struct"))) 22 | :depends-on ("split-sequence" "named-readtables")) 23 | -------------------------------------------------------------------------------- /geneva.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Open Geneva base packages. 2 | 3 | (defpackage geneva 4 | (:documentation 5 | "Geneva core package. Exports functions to programatically create 6 | and inspect _Geneva documents_. 7 | 8 | In Open Geneva a _document_ is represented as a _list_ of _document 9 | elements_. A _document element_ can be obtained using the element 10 | constructors {make-paragraph}, {make-listing}, {make-table}, 11 | {make-media} and {make-section}. In order to ensure integrity, it is 12 | recommended to use {make-document} to produce _documents_. 13 | 14 | _Rich text_ is represeted as a _list_ of _text tokens_. A _text 15 | token_ may be a _string_ or an object obtained using the text token 16 | constructors {make-bold}, {make-italic}, {make-fixed-width} and 17 | {make-url}. 18 | 19 | _Document elements_ and _text tokens_ can be inspected using the 20 | readers {content-type} and {content-values}. 21 | 22 | _Documents_ and _document elements_ are printable and readable using 23 | the Common Lisp printer and reader. 24 | 25 | *Exceptional Situations:* 26 | 27 | All functions external to this _package_ validate their parameters 28 | and will signal an _error_ of _type_ {type-error} on mismatch. 29 | 30 | *See Also:* 31 | 32 | + [Geneva Document Specification](geneva-document.html) 33 | + [Open Geneva User Manual](open-geneva.html)") 34 | (:use :cl 35 | :split-sequence) 36 | (:export :make-paragraph 37 | :make-listing 38 | :make-table 39 | :make-media 40 | :make-plaintext 41 | :make-section 42 | :make-bold 43 | :make-italic 44 | :make-fixed-width 45 | :make-url 46 | :make-document 47 | :content-type 48 | :content-values)) 49 | 50 | (defpackage geneva.macros 51 | (:documentation 52 | "Macros and reader macros to help with procedural creation of Geneva 53 | documents.") 54 | (:use :cl 55 | :geneva 56 | :named-readtables) 57 | (:export :paragraph 58 | :listing 59 | :table 60 | :media 61 | :plaintext 62 | :section 63 | :document 64 | :syntax)) 65 | -------------------------------------------------------------------------------- /grammar.lisp: -------------------------------------------------------------------------------- 1 | ;;;; MaxPC grammar used by GENEVA.MK2. 2 | 3 | (in-package :geneva.mk2) 4 | 5 | (defun unescape (str) 6 | "Unescape backslash escaped STR." 7 | (flet ((next (s) (position #\\ str :start s))) 8 | (with-output-to-string (out) 9 | (loop with l = (length str) 10 | for s = 0 then (1+ p) 11 | for p = (next s) then (when (> l s) (next (1+ s))) 12 | do (write-string (subseq str s p) out) 13 | while p)))) 14 | 15 | (defun ?escape () 16 | (?char *escape-directive*)) 17 | 18 | (defun ?escaped-char () 19 | (?seq (?escape) (?not (?end)))) 20 | 21 | (defun ?plain-char () 22 | (%or (?escaped-char) (?not (?end)))) 23 | 24 | (defun =plain-text (until) 25 | (=transform (=subseq (%some (%diff (?plain-char) until))) 26 | 'unescape)) 27 | 28 | (defun ?token (char) 29 | (%diff (?char char) (?escaped-char))) 30 | 31 | (defun ?newline* () 32 | (?seq (%any (%diff (?whitespace) (?newline))) 33 | (?newline))) 34 | 35 | (defun ?double-newline () 36 | (?seq (?newline*) (?newline*))) 37 | 38 | (defun =markup1 (constructor start &optional (end start)) 39 | (=destructure (_ text _) 40 | (=list (?token start) 41 | (=plain-text (%or (?token end) (?double-newline))) 42 | (?token end)) 43 | (funcall constructor text))) 44 | 45 | (defun =url-text () 46 | (=destructure (x y) 47 | (=list (=markup1 #'identity *url-directive-start* *url-directive-end*) 48 | (%maybe (=markup1 #'identity #\( #\)))) 49 | (make-url x y))) 50 | 51 | (defun =markup () 52 | (%or (=markup1 #'make-bold 53 | *bold-directive*) 54 | (=markup1 #'make-italic 55 | *italic-directive*) 56 | (=markup1 #'make-fixed-width 57 | *fixed-width-directive-start* 58 | *fixed-width-directive-end*) 59 | (=url-text))) 60 | 61 | (defun ?markup-directive () 62 | (?test ('member *markup-directives*))) 63 | 64 | (defun =text-token (until) 65 | (%or (=markup) 66 | (=plain-text (%or (?markup-directive) until)) 67 | ;; Ignore incomplete markup. 68 | (=subseq (?markup-directive)))) 69 | 70 | (defun =text (until) 71 | (%any (=text-token until))) 72 | 73 | (defun ?end-of-document () 74 | (?seq (%any (?whitespace)) (?end))) 75 | 76 | (defun ?content-delimiter () 77 | (%or (?double-newline) (?end-of-document))) 78 | 79 | (defun =paragraph () 80 | (=destructure (text _) 81 | (=list (%some (=text-token (%or (?content-delimiter) 82 | (?token *section-end*)))) 83 | (?content-delimiter)) 84 | (make-paragraph text))) 85 | 86 | (defun =list-item () 87 | (=destructure (_ text) 88 | (=list (?token *listing-item*) 89 | (=text (%or (?token *listing-item*) 90 | (?content-delimiter)))))) 91 | 92 | (defun =listing () 93 | (=destructure (items _) 94 | (=list (%some (=list-item)) 95 | (?content-delimiter)) 96 | (make-listing items))) 97 | 98 | (defun =object1 (keyword constructor parser 99 | &aux (delimiter (?token *object-delimiter*))) 100 | (=destructure (_ _ description _ body) 101 | (=list delimiter 102 | (?string keyword nil) 103 | (=text (%or delimiter (?content-delimiter))) 104 | (%or (?seq delimiter (?newline*)) 105 | ;; Description is not terminated properly 106 | (?syntax-error 'malformed-element)) 107 | parser) 108 | (funcall constructor description body))) 109 | 110 | (defun ?horizontal-whitespace () 111 | (%diff (?whitespace) (?newline))) 112 | 113 | (defun =url () 114 | "We are liberal as to whats a valid URL. That decision is out of scope. We 115 | even allow multiline strings with escaped newlines." 116 | (=destructure (_ url _) 117 | (=list (%any (?horizontal-whitespace)) 118 | (=transform (=subseq (%any (?not (?token #\Newline)))) 'unescape) 119 | (%or (?content-delimiter) 120 | ;; Object is not terminated properly 121 | (?syntax-error 'malformed-element))))) 122 | 123 | (defun =table-column () 124 | (=destructure (_ text) 125 | (=list (?token *table-item*) 126 | (=text (%or (?token *table-item*) 127 | (?newline*)))))) 128 | 129 | (defun =table-row () 130 | (=destructure (_ row _) 131 | (=list (%any (?horizontal-whitespace)) 132 | (%some (=table-column)) 133 | (%maybe (?newline*))))) 134 | 135 | (defun =table-body () 136 | (=destructure (rows _) 137 | (=list (%some (=table-row)) 138 | (%or (?content-delimiter) 139 | ;; Single newline is ok in case last row ate one. 140 | (?newline*) 141 | ;; Object is not terminated properly 142 | (?syntax-error 'malformed-element))))) 143 | 144 | (defun ?plaintext-terminator () 145 | (?seq (%any (?whitespace)) 146 | (?token *object-delimiter*) 147 | (?content-delimiter))) 148 | 149 | (defun =plaintext-line () 150 | (%diff (=line) (%or (?plaintext-terminator) (?end-of-document)))) 151 | 152 | (defun =plaintext-body () 153 | (=destructure (lines _) 154 | (=list (%any (=plaintext-line)) 155 | (%or (?plaintext-terminator) 156 | (?syntax-error 'malformed-element))) 157 | (format nil "~{~a~^~%~}" lines))) 158 | 159 | (defun =object () 160 | (%or 161 | (=object1 *media-keyword* #'make-media (=url)) 162 | (=object1 *table-keyword* #'make-table (=table-body)) 163 | (=object1 *plaintext-keyword* #'make-plaintext (=plaintext-body)))) 164 | 165 | (defun =section () 166 | (%handler-case (=destructure (_ header _ contents _) 167 | (=list (?token *section-start*) 168 | (=text (?content-delimiter)) 169 | (?content-delimiter) 170 | '=contents/p 171 | (%or (?seq (%any (?whitespace)) 172 | (?token *section-end*)) 173 | ;; Sections must be closed aye. 174 | (?syntax-error 'section-not-closed))) 175 | (make-section header contents)) 176 | ;; We have an unclosed section so we signal where it opened. 177 | (section-not-closed () (?syntax-error 'open-section)))) 178 | 179 | (defun =contents () 180 | (%any (=destructure (_ element) 181 | (=list (%any (?whitespace)) ; Leading whitespace is insignificant. 182 | (%or '=section/p 183 | (=object) 184 | (=listing) 185 | (=paragraph)))))) 186 | 187 | ;; We make the parsers of =SECTION and =CONTENTS callable by symbol. This is 188 | ;; necessary because they are mutually recursive. 189 | (setf (fdefinition '=section/p) (=section) 190 | (fdefinition '=contents/p) (=contents)) 191 | 192 | (defun =document () 193 | (=destructure (contents _) 194 | (=list 195 | '=contents/p 196 | (%or (?end-of-document) 197 | ;; Unless all input was successfully parsed something went wrong. 198 | (?syntax-error 'unrecognized-input))))) 199 | -------------------------------------------------------------------------------- /html.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Render Geneva documents as HTML. 2 | 3 | (defpackage geneva.html 4 | (:documentation "Render Geneva documents as HTML.") 5 | (:use :cl 6 | :geneva 7 | :geneva.utilities 8 | :macro-html 9 | :macro-html.widgets 10 | :named-readtables 11 | :file-types) 12 | (:shadow :map 13 | :time) 14 | (:export :render-html 15 | :render-html-file)) 16 | 17 | (in-package :geneva.html) 18 | 19 | (in-readtable macro-html:syntax) 20 | 21 | (defparameter *id-prefix* "section" 22 | "Prefix for generated id strings.") 23 | 24 | (defparameter *header-level* 0 25 | "Header level.") 26 | 27 | (defun render-text (text) 28 | "Render TEXT as HTML." 29 | (dolist (text-token text) 30 | (ecase (content-type text-token) 31 | (:plain (text #1=(content-values text-token))) 32 | (:bold (b #1#)) 33 | (:italic (i #1#)) 34 | (:fixed-width (code #1#)) 35 | (:url (multiple-value-bind (string url) #1# 36 | (a [:href (or url string)] (or string url))))))) 37 | 38 | (defun render-paragraph (paragraph) 39 | "Render PARAGRAPH as HTML." 40 | (p (render-text (content-values paragraph)))) 41 | 42 | (defun render-listing (listing) 43 | "Render LISTING as HTML." 44 | (ul (dolist (item (content-values listing)) 45 | (li (render-text item))))) 46 | 47 | (defun render-object-description (description) 48 | "Render DESCRIPTION for an object as HTML." 49 | (when description 50 | (figcaption (render-text description)))) 51 | 52 | (defun render-table (table) 53 | "Render TABLE as HTML." 54 | (figure 55 | (multiple-value-bind (description rows) 56 | (content-values table) 57 | (table 58 | (thead (tr (dolist (header (first rows)) 59 | (th (render-text header))))) 60 | (tbody (dolist (row (rest rows)) 61 | (tr (dolist (column row) 62 | (td (render-text column))))))) 63 | (render-object-description description)))) 64 | 65 | (defun render-media (media-object) 66 | "Render MEDIA-OBJECT as HTML." 67 | (figure 68 | (multiple-value-bind (description url) 69 | (content-values media-object) 70 | (let ((tags (file-tags url))) 71 | (cond ((member :image tags) 72 | (img :alt (text-string description) :src url) 73 | (render-object-description description)) 74 | ((member :video tags) 75 | (video [:src url :controls nil]) 76 | (render-object-description description)) 77 | ((member :audio tags) 78 | (audio [:src url :controls nil]) 79 | (render-object-description description)) 80 | (t 81 | (a [:href url] (render-text description)))))))) 82 | 83 | (defun render-plaintext (plaintext-object) 84 | "Render PLAINTEXT-OBJECT as HTML." 85 | (figure 86 | (multiple-value-bind (description plaintext) 87 | (content-values plaintext-object) 88 | (pre plaintext) 89 | (render-object-description description)))) 90 | 91 | (defun make-section-id-string (level) 92 | "Returns id string for section at LEVEL with leading *id-prefix*." 93 | (format nil "~a-~{~a~^-~}" *id-prefix* level)) 94 | 95 | (defun render-headline (headline &optional level) 96 | "Render HEADLINE as HTML. When *INDEX-HEADERS-P* and LEVEL are not NIL, 97 | prefix headline with LEVEL." 98 | (when (and *index-headers-p* level) 99 | (span [:class "geneva-index"] (level-string level)) 100 | (format t " ")) 101 | (render-text headline)) 102 | 103 | (defun render-header (headline level) 104 | "Render header with HEADLINE and LEVEL as HTML." 105 | (flet ((render-h () 106 | (case (+ (length level) *header-level*) 107 | (1 (h1 (render-headline headline level))) 108 | (2 (h2 (render-headline headline level))) 109 | (3 (h3 (render-headline headline level))) 110 | (4 (h4 (render-headline headline level))) 111 | (5 (h5 (render-headline headline level))) 112 | (t (h6 (render-headline headline level)))))) 113 | (header (a [:name (make-section-id-string level)] (render-h))))) 114 | 115 | (defun render-section (section level) 116 | "Render SECTION as HTML." 117 | (multiple-value-bind (description contents) 118 | (content-values section) 119 | (let ((level (or level (null-level)))) 120 | (section 121 | (render-header description level) 122 | (render-contents contents (descend-level level))) 123 | (incf-level level)))) 124 | 125 | (defun render-content (content level) 126 | "Render CONTENT as HTML." 127 | (case (content-type content) 128 | (:paragraph (render-paragraph content)) 129 | (:listing (render-listing content)) 130 | (:table (render-table content)) 131 | (:media (render-media content)) 132 | (:plaintext (render-plaintext content)) 133 | (:section (render-section content level)) 134 | (t (error "Invalid content type in CONTENT: ~S." 135 | (content-type content))))) 136 | 137 | (defun render-contents (contents &optional (level (null-level))) 138 | "Render document or section CONTENTS as HTML, starting at LEVEL for 139 | headlines." 140 | (dolist (content contents) 141 | (render-content content level))) 142 | 143 | (defun render-title (title) 144 | "Render TITLE with respect to *HEADER-LEVEL*." 145 | (case *header-level* 146 | (0 (h1 title)) 147 | (1 (h2 title)) 148 | (2 (h3 title)) 149 | (3 (h4 title)) 150 | (4 (h5 title)) 151 | (t (h6 title)))) 152 | 153 | (defun make-id-href-string (id-string) 154 | "Returns id href string for ID-STRING." 155 | (concatenate 'string "#" id-string)) 156 | 157 | (defmacro render-index-list (&body body) 158 | "Convenience macro for RENDER-INDEX." 159 | `(if *index-headers-p* 160 | (ol ,@body) 161 | (ul ,@body))) 162 | 163 | (defun render-index (index) 164 | "Render INDEX as HTML." 165 | (render-index-list 166 | (dolist (section index) 167 | (destructuring-bind (level title subsections) 168 | section 169 | (li (a [:href (make-id-href-string 170 | (make-section-id-string level))] 171 | (render-headline title)) 172 | (when subsections 173 | (render-index subsections))))))) 174 | 175 | (defun render-html (document &key (stream *standard-output*) 176 | title 177 | author 178 | date 179 | (index-p *index-p*) 180 | (index-caption *default-index-caption*) 181 | (index-headers-p *index-headers-p*) 182 | (header-level *header-level*) 183 | (id-prefix *id-prefix*)) 184 | "*Arguments and Values:* 185 | 186 | _header-level_—an _unsigned integer_. The default is {0}. 187 | 188 | _id-prefix_—a _string_. The default is {\"section\"}. 189 | 190 | *Description:* 191 | 192 | {render-html} renders _document_ as HTML. _header-level_ controls the 193 | initial headline level. For instance a _header-level_ of {1} will 194 | cause the top level headlines to be rendered as {H2} elements and so 195 | forth. _Id-prefix_ is used as a prefix to {NAME} attribute values of 196 | HTML anchor elements. 197 | 198 | *See Also:* 199 | 200 | + [Common Rendering Interface](open-geneva.html#section-3-1)" 201 | (let ((*standard-output* stream) 202 | (*index-headers-p* index-headers-p) 203 | (*header-level* header-level) 204 | (*id-prefix* id-prefix)) 205 | (when (or title author date) 206 | (header (when title 207 | (render-title title) 208 | (incf *header-level*)) 209 | (when author 210 | (p author)) 211 | (when date 212 | (p date)))) 213 | (when index-p 214 | (let ((index (document-index document))) 215 | (when index 216 | (nav (header (p (b index-caption))) 217 | (render-index index))))) 218 | (render-contents document))) 219 | 220 | (defun render-html-file (document 221 | &key (stream *standard-output*) 222 | title 223 | author 224 | date 225 | (index-p *index-p*) 226 | (index-caption *default-index-caption*) 227 | (index-headers-p *index-headers-p*) 228 | stylesheets 229 | (encoding :utf-8)) 230 | "*Arguments and Values:* 231 | 232 | _stylesheets_—a _list_ of stylesheets applicable to 233 | {macro-html.widgets:html-widget-document}. 234 | 235 | _encoding_—a _keyword_ designating a valid character encoding 236 | (defaults to {:utf-8}). 237 | 238 | *Description:* 239 | 240 | {render-html-file} renders _document_ as a standalone HTML file. The 241 | resulting HTML file will use _stylesheets_ and declare its content to 242 | be in _encoding_. 243 | 244 | *See Also:* 245 | 246 | + [Common Rendering Interface](open-geneva.html#section-3-1)" 247 | (let ((*standard-output* stream)) 248 | (html-widget-document 249 | title 250 | (lambda () 251 | (render-html document 252 | :title title 253 | :author author 254 | :date date 255 | :index-p index-p 256 | :index-caption index-caption 257 | :index-headers-p index-headers-p 258 | :header-level 0)) 259 | :encoding encoding 260 | :stylesheets stylesheets))) 261 | -------------------------------------------------------------------------------- /latex.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Render Geneva documents as LaTeX manuscripts. 2 | 3 | (defpackage geneva.latex 4 | (:documentation 5 | "Render Geneva documents as LaTeX manuscripts.") 6 | (:use :cl 7 | :named-readtables 8 | :texp 9 | :geneva.tex 10 | :geneva.utilities) 11 | (:export :render-latex)) 12 | 13 | (in-package :geneva.latex) 14 | 15 | (in-readtable texp:syntax) 16 | 17 | (defun latex-text () 18 | "Text formatting implementation for LaTeX." 19 | (deftex genbold (text) (textbf {($ text)})) 20 | (deftex genitalic (text) (textit {($ text)})) 21 | (deftex genfixedwidth (text) (texttt {($ text)})) 22 | (deftex genurl (text) (texttt {($ text)})) 23 | 24 | (deftex gentinyparagraph (text) 25 | (medskip) 26 | (br) 27 | (noindent) 28 | ($ text) 29 | (br) 30 | (medskip))) 31 | 32 | (defun latex-listing () 33 | "Listing implementation for LaTeX." 34 | (deftex genitem (text) (item ($ text))) 35 | (deftex genlisting (items) 36 | (begin {itemize}) 37 | (raggedright) 38 | ($ items) 39 | (end {itemize}))) 40 | 41 | (defun latex-figure () 42 | "Figure implementation for LaTeX." 43 | (deftex genfigure (description content) 44 | (begin {figure} ["H"]) 45 | (centering) 46 | ($ content) 47 | (caption {($ description)}) 48 | (end {figure}))) 49 | 50 | (defun latex-table () 51 | "Table implementaton for LaTeX." 52 | (deftex gencolsep () " & ") 53 | (deftex gencolumn (text) ($ text)) 54 | (deftex genhead (text) (genbold {($ text)})) 55 | (deftex genrow (columns) ($ columns) "\\\\[0.5em]") 56 | (deftex gentable (description format rows) 57 | (genfigure {($ description)} 58 | {(begin {tabularx} {(columnwidth)} 59 | {($ format)}) 60 | ($ rows) 61 | (end {tabularx})}))) 62 | 63 | (defun latex-graphic-figure () 64 | "Graphic figure implementation for LaTeX." 65 | (deftex gengraphic (description url) 66 | (genfigure {($ description)} 67 | {(includegraphics [width=(columnwidth)] 68 | {($ url)})}))) 69 | 70 | (defun latex-fallback-figure () 71 | "Fallback figure implementation for LaTeX." 72 | (deftex genfallbackfigure (description url) 73 | (genfigure {($ description)} 74 | {(texttt {($ url)})}))) 75 | 76 | (defun latex-text-figure () 77 | "Text figure implementation for LaTeX." 78 | (deftex genverbatimstart () 79 | (begin {figure} ["H"]) 80 | (begin {alltt})) 81 | (deftex genverbatimend () 82 | "\\end{alltt}" 83 | (vspace {-1em})) 84 | (deftex genverbatimdescription (description) 85 | (caption {($ description)}) 86 | (end {figure}))) 87 | 88 | (defun latex-sections () 89 | "Sections implementation for LaTeX." 90 | (if *index-headers-p* 91 | (progn 92 | (deftex gensection (header) 93 | (section {($ header)})) 94 | (deftex gensubsection (header) 95 | (subsection {($ header)})) 96 | (deftex gensubsubsection (header) 97 | (subsubsection {($ header)}))) 98 | (progn 99 | (deftex gensection (header) 100 | (section* {($ header)}) 101 | (addcontentsline {toc} {section} {($ header)})) 102 | (deftex gensubsection (header) 103 | (subsection* {($ header)}) 104 | (addcontentsline {toc} {subsection} {($ header)})) 105 | (deftex gensubsubsection (header) 106 | (subsubsection* {($ header)}) 107 | (addcontentsline {toc} {subsubsection} {($ header)}))))) 108 | 109 | (defun document-implementation () 110 | "Implementation of the document primitives for LaTeX." 111 | (latex-text) 112 | (latex-listing) 113 | (latex-figure) 114 | (latex-table) 115 | (latex-graphic-figure) 116 | (latex-fallback-figure) 117 | (latex-text-figure) 118 | (latex-sections)) 119 | 120 | (defun default-preamble () 121 | "Minimal default preamble." 122 | (tex (documentclass {article}) 123 | (usepackage {graphicx}) 124 | (usepackage {tabularx}) 125 | (usepackage {alltt}) 126 | (usepackage {float}))) 127 | 128 | (defun render-latex (document 129 | &key (stream *standard-output*) 130 | title 131 | author 132 | (date :today) 133 | (index-p *index-p*) 134 | (index-caption *default-index-caption*) 135 | (index-headers-p *index-headers-p*) 136 | (preamble #'default-preamble) 137 | appendix) 138 | "*Arguments and Values:* 139 | 140 | _preamble_—a _function_ without arguments that prints LaTeX 141 | expressions to {*standard-output*}. The produced LaTeX expressions 142 | will be inserted at the beginning of the LaTeX manuscript. 143 | 144 | _appendix_—a _function_ without arguments that prints LaTeX 145 | expressions to {*standard-output*}. The produced LaTeX expressions 146 | will be appended to the LaTeX manuscript. 147 | 148 | *Description:* 149 | 150 | {render-latex} renders _document_ as a LaTeX manuscript. _Preamble_ 151 | and _appendix_ may be supplied to customize the LaTeX layout and 152 | functionality. Their output will be inserted at the beginning or 153 | appended to the end of the LaTeX manuscript respectively. 154 | 155 | *See Also:* 156 | 157 | + [Common Rendering Interface](open-geneva.html#section-3-1)" 158 | (let ((*standard-output* stream) 159 | (*index-headers-p* index-headers-p)) 160 | (document-implementation) 161 | (when preamble (funcall preamble)) 162 | (tex (br) 163 | (begin {document}) 164 | (pagenumbering {roman})) 165 | (tex (title {($ (or title ""))})) 166 | (when author (tex (author {($ author)}))) 167 | (cond ((eq date :today) (tex (date {(today)}))) 168 | ((stringp date) (tex (date {($ date)}))) 169 | ((not date) (tex (date {})))) 170 | (when (or title author date) 171 | (tex (maketitle))) 172 | (when (and index-p (document-index document)) 173 | (tex (renewcommand {(contentsname)} 174 | {($ index-caption)}) 175 | (tableofcontents) 176 | (bigskip))) 177 | (tex (pagenumbering {arabic}) 178 | (setcounter {page} {1}) 179 | (br)) 180 | (render-tex document) 181 | (when appendix (funcall appendix)) 182 | (tex (end {document})))) 183 | -------------------------------------------------------------------------------- /macros.lisp: -------------------------------------------------------------------------------- 1 | ;;;; (Read) macros for document construction. 2 | 3 | (in-package :geneva.macros) 4 | 5 | (defmacro paragraph (&rest text) 6 | "*Arguments and Values:* 7 | 8 | _text_—_forms_ which evaluate to Geneva _text tokens_. 9 | 10 | *Description:* 11 | 12 | {paragraph} returns a Geneva paragraph made up of _text_ as if by 13 | {geneva:make-paragraph}. 14 | 15 | *Notes:* 16 | 17 | #code# 18 | (paragraph {text}*) ≡ (make-paragraph (list {text}*)) 19 | #" 20 | `(make-paragraph (list ,@text))) 21 | 22 | (defmacro listing (&rest items) 23 | "*Arguments and Values:* 24 | 25 | _items_—_forms_ which evaluate to Geneva _rich text_. 26 | 27 | *Description:* 28 | 29 | {listing} returns a Geneva listing of _items_ as if by 30 | {geneva:make-listing}. 31 | 32 | *Notes:* 33 | 34 | #code# 35 | (listing {items}*) ≡ (make-listing (list {items}*)) 36 | #" 37 | `(make-listing (list ,@(loop for item in items 38 | collect `(list ,@item))))) 39 | 40 | (defmacro table ((&rest description) &rest rows) 41 | "*Arguments and Values:* 42 | 43 | _description_—_forms_ which evaluate to Geneva _text tokens_. 44 | 45 | _rows_—a list of column lists containing _forms_ which evaluate to 46 | Geneva _text tokens_. 47 | 48 | *Description:* 49 | 50 | {table} returns a Geneva table with _rows_ and _description_ as if by 51 | {geneva:make-table}. 52 | 53 | *Examples:* 54 | 55 | #code# 56 | (table (\"10° Celsius in various units.\") 57 | ((\"Fahrenheit\") ((prin1-to-string (+ (* 1.8 10) 32)))) 58 | ((\"Kelvin\") ((prin1-to-string (+ 10 273.15))))) 59 | ≡ (make-table (list \"10° Celsius in various units.\") 60 | (list (list \"Fahrenheit\") 61 | (list (prin1-to-string (+ (* 1.8 10) 32)))) 62 | (list (list \"Kelvin\") 63 | (list (prin1-to-string (+ 10 273.15))))) 64 | #" 65 | `(make-table 66 | (list ,@description) 67 | (list ,@(loop for row in rows 68 | collect `(list ,@(loop for column in row 69 | collect `(list ,@column))))))) 70 | 71 | (defmacro media ((&rest description) url) 72 | "*Arguments and Values:* 73 | 74 | _description_—_forms_ which evaluate to Geneva _text tokens_. 75 | 76 | _url_—a _form_ which evaluates to a _string_ designating an URL. 77 | 78 | *Description:* 79 | 80 | {media} returns a Geneva _media element_ for _url_ with _description_ 81 | as if by {geneva:make-media}. 82 | 83 | *Notes:* 84 | 85 | #code# 86 | (media ({description}*) {url}) 87 | ≡ (make-media (list {description}*) {url}) 88 | #" 89 | `(make-media (list ,@description) ,url)) 90 | 91 | (defmacro plaintext ((&rest description) plaintext) 92 | "*Arguments and Values:* 93 | 94 | _description_—_forms_ which evaluate to Geneva _text tokens_. 95 | 96 | _plaintext_—a _form_ which evaluates to a _string_. 97 | 98 | *Description:* 99 | 100 | {plaintext} returns a Geneva _plaintext element_ for _plaintext_ with 101 | _description_ as if by {geneva:make-plaintext}. 102 | 103 | *Notes:* 104 | 105 | #code# 106 | (plaintext ({description}*) {plaintext}) 107 | ≡ (make-plaintext (list {description}*) {plaintext}) 108 | #" 109 | `(make-plaintext (list ,@description) ,plaintext)) 110 | 111 | (defmacro section ((&rest header) &rest content) 112 | "*Arguments and Values:* 113 | 114 | _header_—_forms_ which evaluate to Geneva _text tokens_. 115 | 116 | _content_—_forms_ which evaluate to Geneva _elements_. 117 | 118 | *Description:* 119 | 120 | {section} returns a Geneva _section element_ with _header_ and 121 | _content_ as if by {geneva:make-section}. 122 | 123 | *Notes:* 124 | 125 | #code# 126 | (section ({header}*) {body}*) 127 | ≡ (make-section (list {header}*) (list {body}*)) 128 | #" 129 | `(make-section (list ,@header) 130 | (list ,@content))) 131 | 132 | (defmacro document (&rest content) 133 | "*Arguments and Values:* 134 | 135 | _document_—_forms_ which evaluate to Geneva _elements_. 136 | 137 | *Description:* 138 | 139 | {section} returns a Geneva _docuent_ with _content_ as if by 140 | {geneva:make-document}. 141 | 142 | *Notes:* 143 | 144 | #code# 145 | (document {content}*) ≡ (make-document (list {content}*)) 146 | #" 147 | `(make-document (list ,@content))) 148 | -------------------------------------------------------------------------------- /mk2.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Package definitions for GENEVA-MK2. 2 | 3 | (defpackage geneva.mk2.tokens 4 | (:documentation "Tokens used by the _Mk2_ markup language.") 5 | (:use :cl) 6 | (:export :*section-start* 7 | :*section-end* 8 | :*listing-item* 9 | :*table-item* 10 | :*object-delimiter* 11 | :*bold-directive* 12 | :*italic-directive* 13 | :*fixed-width-directive-start* 14 | :*fixed-width-directive-end* 15 | :*url-directive-start* 16 | :*url-directive-end* 17 | :*escape-directive* 18 | :*special-tokens* 19 | :*markup-directives* 20 | :*table-keyword* 21 | :*media-keyword* 22 | :*plaintext-keyword*)) 23 | 24 | (defpackage geneva.mk2 25 | (:documentation 26 | "Implementation of _Mk2_¹, a plain text markup language for the Geneva 27 | document preparation system. 28 | 29 | + 1. [The Mk2 Markup Language](mk2.html)") 30 | (:use :cl 31 | :geneva 32 | :geneva.mk2.tokens 33 | :maxpc 34 | :maxpc.char 35 | :split-sequence) 36 | (:import-from :geneva.utilities :wrap-string) 37 | (:export :read-mk2 38 | :syntax-error 39 | :open-section 40 | :malformed-element 41 | :unrecognized-input 42 | :line-position 43 | :character-position 44 | :print-mk2)) 45 | -------------------------------------------------------------------------------- /normalize.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Normalize text for Geneva. 2 | 3 | (in-package :geneva) 4 | 5 | (defun join-strings (text) 6 | "Join :PLAIN text tokens in TEXT." 7 | (reduce (lambda (text item) 8 | (let ((last-item (first (last text)))) 9 | (if (and text 10 | (eq (content-type item) :plain) 11 | (eq (content-type last-item) :plain)) 12 | `(,@(butlast text) 13 | ,(concatenate 'string last-item item)) 14 | (append text (list item))))) 15 | (cons nil text))) 16 | 17 | (defparameter *whitespace* '(#\Tab #\Newline #\Vt #\Ff #\Return #\Space) 18 | "Characters considered whitespace.") 19 | 20 | (defun normalize-whitespace (string &key trim) 21 | "Normalize *WHITESPACE* in STRING and optionally TRIM :LEFT, 22 | :RIGHT or :BOTH." 23 | (if (string= string "") "" 24 | (let* ((words (split-sequence-if 25 | (lambda (char) 26 | (member char *whitespace*)) 27 | string)) 28 | (stripped (remove "" words :test #'equal))) 29 | (if stripped 30 | (format nil "~:[ ~;~]~{~a~^ ~}~:[ ~;~]" 31 | (or (null stripped) 32 | (eq :left trim) 33 | (eq :both trim) 34 | (< 0 (length (first words)))) 35 | stripped 36 | (or (null stripped) 37 | (eq :right trim) 38 | (eq :both trim) 39 | (< 0 (length (first (last words)))))) 40 | ;; STRING was only whitespace. 41 | " ")))) 42 | 43 | (defun normalize-text-item (item &key trim) 44 | "Normalize *WHITESPACE* in text ITEM and optionally TRIM :LEFT or 45 | :RIGHT." 46 | (ecase #1=(content-type item) 47 | (:plain 48 | (normalize-whitespace #2=(content-values item) :trim trim)) 49 | ((:bold :italic :fixed-width) 50 | (list #1# (normalize-whitespace #2# :trim :both))) 51 | (:url 52 | (multiple-value-bind (string url) #2# 53 | `(,#1# ,(normalize-whitespace string :trim :both) 54 | ,@(when url 55 | `(,(normalize-whitespace url :trim :both)))))))) 56 | 57 | (defun position-non-whitespace-item (text &optional from-end) 58 | "Get position of first non-whitespace item in TEXT and maybe start 59 | FROM-END." 60 | (labels ((whitespace-p (c) (member c *whitespace*)) 61 | (whitespace-item-p (item) 62 | (not (find-if-not #'whitespace-p (content-values item))))) 63 | (position-if-not #'whitespace-item-p text :from-end from-end))) 64 | 65 | (defun trim-whitespace-items (text) 66 | "Remove whitespace from start and end of TEXT." 67 | (let ((start (position-non-whitespace-item text))) 68 | (when start 69 | (subseq text start (1+ (position-non-whitespace-item text t)))))) 70 | 71 | (defun normalize-text-whitespace (text) 72 | "Remove obsoltete whitespace from TEXT." 73 | (case (length text) 74 | ;; NIL → NIL. 75 | (0 nil) 76 | ;; (X) → Trim X both. 77 | (1 `(,(normalize-text-item (first text) :trim :both))) 78 | ;; (X Y) → Trim X left, trim Y right. 79 | (2 `(,(normalize-text-item (first text) :trim :left) 80 | ,(normalize-text-item (second text) :trim :right))) 81 | ;; (X1 .. Xn) → Trim X1 left, trim Xn right. 82 | (otherwise 83 | `(,(normalize-text-item (first text) :trim :left) 84 | ,@(loop for item in (butlast (rest text)) 85 | collect (normalize-text-item item)) 86 | ,(normalize-text-item (first (last text)) :trim :right))))) 87 | 88 | (defun remove-empty-markup (text) 89 | "Remove empty markup from TEXT." 90 | (flet ((empty-p (string) 91 | (not (find-if-not (lambda (char) 92 | (member char *whitespace*)) 93 | string)))) 94 | (remove-if (lambda (text) 95 | (and (listp text) 96 | (empty-p (second text)))) 97 | text))) 98 | 99 | (defun normalize-text (text) 100 | "Remove empty markup and join adjacent strings in TEXT, then remove 101 | superfluous whitespace." 102 | (remove "" 103 | (normalize-text-whitespace 104 | (trim-whitespace-items 105 | (join-strings 106 | (remove-empty-markup text)))) 107 | :test #'equal)) 108 | 109 | (defun trim-whitespace-suffixes (lines) 110 | "Trim whitespace suffixes from LINE." 111 | (loop for line in lines collect 112 | (string-right-trim *whitespace* line))) 113 | 114 | (defun normalize-plaintext (string) 115 | "Remove leading and ending whitespace, global indent and whitespace 116 | line-suffixes from plaintext STRING ." 117 | (let* ((lines (trim-whitespace-suffixes 118 | (trim-whitespace-items 119 | (split-sequence #\Newline string)))) 120 | (indent (loop for line in lines 121 | for start = (position-if-not 122 | (lambda (char) 123 | (char= #\Space char)) 124 | line) 125 | when start minimize start)) 126 | (unindented (mapcar (lambda (line) 127 | (if (> (length line) 0) 128 | (subseq line indent) 129 | line)) 130 | lines))) 131 | (format nil "~{~a~^~%~}" unindented))) 132 | -------------------------------------------------------------------------------- /open-geneva.asd: -------------------------------------------------------------------------------- 1 | ;;;; System definition for OPEN-GENEVA. 2 | 3 | (defsystem open-geneva 4 | :description 5 | "Meta system for Open Geneva, an implementation of the Geneva document 6 | preparation system written in Common Lisp. This system pulls in all 7 | subsystems provided by Open Geneva." 8 | :author "Max Rottenkolber <max@mr.gy>" 9 | :license "GNU AGPL" 10 | :depends-on ("geneva" 11 | "geneva-mk2" 12 | "geneva-plain-text" 13 | "geneva-html" 14 | "geneva-tex" 15 | "geneva-latex" 16 | "geneva-cl")) 17 | -------------------------------------------------------------------------------- /plain-text.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Render Geneva documents as plain text. 2 | 3 | (defpackage geneva.plain-text 4 | (:documentation 5 | "Render Geneva documents as plain text.") 6 | (:use :cl 7 | :geneva 8 | :geneva.utilities) 9 | (:export :render-plain-text)) 10 | 11 | (in-package :geneva.plain-text) 12 | 13 | ;;; This package is an ugly hack on top of GENEVA.MK2:PRINT-MK2 and uses 14 | ;;; many otherwise internal routines of the Mk2 package. Assuming the Mk2 15 | ;;; package is stable, this is a reasonable and *short* implemetation 16 | ;;; despite its lack of style. 17 | 18 | (defmacro with-indent/mk2 ((indent) &body body) 19 | "Evaluate BODY with GENEVA.MK2::*INDENT* bound to INDENT." 20 | `(let ((geneva.mk2::*indent* ,indent)) 21 | ,@body)) 22 | 23 | (defmacro with-no-escape/mk2 (&body body) 24 | "Disable Mk2 escaping for BODY." 25 | `(let ((geneva.mk2::*to-escape* nil)) 26 | ,@body)) 27 | 28 | (defun render-text/mk2 (text) 29 | "Render TEXT using internal functions of GENEVA.MK2." 30 | (geneva.mk2::print-string 31 | (geneva.mk2::text-string text))) 32 | 33 | (defun render-table/mk2 (rows) 34 | "Render table ROWS using internal functions of GENEVA.MK2." 35 | (geneva.mk2::print-string 36 | (geneva.mk2::table-string rows " ") 37 | :wrap nil)) 38 | 39 | (defun render-listing/mk2 (items) 40 | "Render listing ITEMS using internal functions of GENEVA.MK2." 41 | (dolist (item items) 42 | (geneva.mk2::write-string 43 | (geneva.mk2::listing-string (list item) " * ")) 44 | (terpri))) 45 | 46 | (defun render-plaintext/mk2 (string) 47 | "Render plaintext STRING using internal functions of GENEVA.MK2." 48 | (geneva.mk2::print-string string :wrap nil)) 49 | 50 | (defun render-header/mk2 (level text) 51 | "Render TEXT as header at LEVEL using internal functions of 52 | GENEVA.MK2." 53 | (with-indent/mk2 (0) 54 | (write-string (geneva.mk2::listing-string 55 | (list text) 56 | (format nil "~@[~a ~]" (when *index-headers-p* 57 | (level-string level))))) 58 | (terpri))) 59 | 60 | (defun render-content (content &optional (level (null-level))) 61 | "Render CONTENT at LEVEL." 62 | (with-no-escape/mk2 63 | (with-indent/mk2 (3) 64 | (ecase (content-type content) 65 | 66 | (:paragraph (render-text/mk2 (content-values content)) 67 | (terpri)) 68 | 69 | (:listing (render-listing/mk2 (content-values content))) 70 | 71 | (:table (multiple-value-bind (caption rows) 72 | (content-values content) 73 | (render-table/mk2 rows) 74 | (when caption 75 | (with-indent/mk2 (7) 76 | (render-text/mk2 caption)) 77 | (terpri)))) 78 | 79 | (:media (multiple-value-bind (caption url) 80 | (content-values content) 81 | (format t " URI: ~a~%~%" url) 82 | (when caption 83 | (with-indent/mk2 (7) 84 | (render-text/mk2 caption)) 85 | (terpri)))) 86 | 87 | (:plaintext (multiple-value-bind (caption pre) 88 | (content-values content) 89 | (with-indent/mk2 (5) 90 | (render-plaintext/mk2 pre)) 91 | (format t "~&") 92 | (terpri) 93 | (when caption 94 | (with-indent/mk2 (7) 95 | (render-text/mk2 caption)) 96 | (terpri)))) 97 | 98 | (:section (multiple-value-bind (header contents) 99 | (content-values content) 100 | (render-header/mk2 level header) 101 | (let ((sublevel (descend-level level))) 102 | (dolist (content contents) 103 | (render-content content sublevel))) 104 | (incf-level level))))))) 105 | 106 | (defun render-index/mk2 (index &optional (indent " ")) 107 | "Render INDEX as plain text using interal Mk2 functions." 108 | (flet ((indent-string (n) (make-string n :initial-element #\Space))) 109 | (loop for (level header subsections) in index 110 | do (let ((prefix 111 | (format nil "~a~a" 112 | indent 113 | (if *index-headers-p* 114 | (format nil "~a " (level-string level)) 115 | (indent-string 116 | (* 2 (1- (length level)))))))) 117 | (with-no-escape/mk2 118 | (write-string 119 | (geneva.mk2::listing-string (list header) prefix))) 120 | (render-index/mk2 subsections 121 | (indent-string (length prefix))))))) 122 | 123 | (defun render-plain-text (document 124 | &key (stream *standard-output*) 125 | title 126 | author 127 | date 128 | (index-p *index-p*) 129 | (index-caption *default-index-caption*) 130 | (index-headers-p *index-headers-p*)) 131 | "*Description:* 132 | 133 | {render-plain-text} renders _document_ as plain text. 134 | 135 | *See Also:* 136 | 137 | + [Common Rendering Interface](open-geneva.html#section-3-1)" 138 | (let ((level (null-level)) 139 | (*standard-output* stream) 140 | (*index-headers-p* index-headers-p) 141 | (geneva.mk2::*discard-text-markup-p* t)) 142 | (when title 143 | (write-string (align-string (string-upcase title) 144 | :center geneva.mk2::*columns*)) 145 | (terpri)) 146 | (when author 147 | (write-string (align-string author :right geneva.mk2::*columns*))) 148 | (when date 149 | (write-string 150 | (align-string date :right geneva.mk2::*columns*))) 151 | (when (or author date) 152 | (terpri)) 153 | (when index-p 154 | (let ((index (document-index document))) 155 | (when index 156 | (format t "~a~%~%" index-caption) 157 | (render-index/mk2 index) 158 | (terpri)))) 159 | (dolist (content document) 160 | (render-content content level)))) 161 | -------------------------------------------------------------------------------- /print.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Print mk2 documents. 2 | 3 | (in-package :geneva.mk2) 4 | 5 | (defparameter *columns* 72 6 | "Maximum line width.") 7 | 8 | (defparameter *table-padding* 1 9 | "Minimum number of spaces between table columns.") 10 | 11 | (defvar *indent* 0 12 | "Indent level.") 13 | 14 | (defparameter *indent-max* (/ *columns* 4) 15 | "Indent limit.") 16 | 17 | (defparameter *to-escape* (append *special-tokens* *markup-directives*) 18 | "Tokens to escape.") 19 | 20 | (defparameter *beginning* t 21 | "Flag indicating wether this is the beginning of the document.") 22 | 23 | (defparameter *discard-text-markup-p* nil 24 | "This hook is used by GENEVA.PLAIN-TEXT to disable text markup. Its a 25 | hack!") 26 | 27 | (defun escape (string) 28 | "Escape special tokens STRING." 29 | (flet ((needs-escape-p (char) (member char *to-escape*)) 30 | (escape-char (char) (format nil "\\~c" char))) 31 | (with-output-to-string (out) 32 | (loop for start = 0 then (1+ pos) 33 | for pos = (position-if #'needs-escape-p string :start start) 34 | do (write-sequence string out :start start :end pos) 35 | when pos do (write-sequence (escape-char (char string pos)) out) 36 | while pos)))) 37 | 38 | (defun print-spaces (n) 39 | "Print N spaces." 40 | (dotimes (x n) 41 | (write-char #\Space))) 42 | 43 | (defun print-string (string &key (wrap t)) 44 | "Print STRING indented and optionally WRAP it." 45 | (let ((lines (split-sequence 46 | #\Newline 47 | (if wrap 48 | (wrap-string string (- *columns* *indent*)) 49 | string)))) 50 | (loop for line in (if wrap (butlast lines) lines) 51 | do 52 | (print-spaces *indent*) 53 | (write-string line) 54 | (terpri)))) 55 | 56 | (defun markup-string (markup) 57 | "Return string for MARKUP." 58 | (flet ((escape-and-decorate 59 | (string delimiter &optional (delimiter2 delimiter)) 60 | (format nil "~a~a~a" 61 | delimiter 62 | (escape string) 63 | delimiter2))) 64 | (ecase (content-type markup) 65 | (:bold (escape-and-decorate #1=(content-values markup) #\*)) 66 | (:italic (escape-and-decorate #1# #\_)) 67 | (:fixed-width (escape-and-decorate #1# #\{ #\})) 68 | (:url (multiple-value-bind (string url) #1# 69 | (format nil "~a~@[~a~]" 70 | (escape-and-decorate string #\[ #\]) 71 | (when url 72 | (escape-and-decorate url #\( #\))))))))) 73 | 74 | (defun text-string (text) 75 | "Return string for TEXT." 76 | (with-output-to-string (*standard-output*) 77 | (dolist (text-token text) 78 | (write-string (ecase (content-type text-token) 79 | (:plain 80 | (escape #1=(content-values text-token))) 81 | ((:bold :italic :fixed-width :url) 82 | (if *discard-text-markup-p* 83 | (multiple-value-bind (string url) #1# 84 | (format nil "~a~@[ (~a)~]" 85 | (escape string) 86 | (and url (escape url)))) 87 | (markup-string text-token)))))))) 88 | 89 | (defun listing-string (items &optional (bullet "+ ")) 90 | "Return listing string for ITEMS using BULLET." 91 | (with-output-to-string (*standard-output*) 92 | (dolist (item items) 93 | (format t "~a~a" 94 | bullet 95 | (let* ((*indent* (length bullet)) 96 | (*columns* (- *columns* *indent*))) 97 | (subseq 98 | (with-output-to-string (*standard-output*) 99 | (print-string (text-string item))) 100 | *indent*)))))) 101 | 102 | (defun caption-string (type-string caption) 103 | "Return caption string for TYPE-STRING and CAPTION." 104 | (format nil "#~a~@[ ~a~]#" 105 | (string-downcase type-string) 106 | (when caption (text-string caption)))) 107 | 108 | (defun table-string (rows &optional (delimiter "| ")) 109 | "Return string for ROWS using DELIMITER." 110 | (flet ((widths (rows) 111 | (let ((widths nil)) 112 | (dotimes (x (length (first rows)) (reverse widths)) 113 | (push (loop for row in rows 114 | maximize (length (nth x row))) 115 | widths)))) 116 | (items-to-strings (rows) 117 | (loop for row in rows 118 | collect (loop for item in row 119 | collect (text-string item))))) 120 | (let* ((string-table (items-to-strings rows)) 121 | (table-widths (widths string-table))) 122 | (with-output-to-string (*standard-output*) 123 | (dolist (row string-table) 124 | (loop for item in row 125 | for width in table-widths 126 | do 127 | (format t "~a~a" delimiter item) 128 | (print-spaces (- (+ width *table-padding*) 129 | (length item)))) 130 | (terpri)))))) 131 | 132 | (defun print-plaintext (string) 133 | "Print STRING as plaintext body (with escaped 134 | <object-deilimiter> <element-delimiter> sequences)." 135 | (let ((terminator (format nil "~%#~%~%")) 136 | (escaped (format nil "~%\\#~%~%"))) 137 | (loop for start = 0 then (+ pos (length terminator)) 138 | for pos = (search terminator string :start1 1 :start2 start) 139 | then (search terminator string :start2 start) 140 | do (write-string string *standard-output* :start start :end pos) 141 | when pos do 142 | (case pos 143 | (0 (write-string escaped *standard-output* :start 1)) 144 | (otherwise (write-string escaped))) 145 | while pos))) 146 | 147 | (defun print-content (content) 148 | "Print CONTENT." 149 | (ecase (content-type content) 150 | 151 | (:paragraph (print-string 152 | (text-string (content-values content))) 153 | (terpri)) 154 | 155 | (:listing (print-string 156 | (listing-string (content-values content)) 157 | :wrap nil)) 158 | 159 | (:table (multiple-value-bind (caption rows) 160 | (content-values content) 161 | (print-string 162 | (caption-string *table-keyword* caption)) 163 | (print-string (table-string rows) :wrap nil))) 164 | 165 | (:media (multiple-value-bind (caption url) 166 | (content-values content) 167 | (print-string 168 | (caption-string *media-keyword* caption)) 169 | (print-string url :wrap nil) 170 | (terpri))) 171 | 172 | (:plaintext (multiple-value-bind (caption pre) 173 | (content-values content) 174 | (print-string 175 | (caption-string *plaintext-keyword* caption)) 176 | (print-plaintext pre) 177 | (format t "~&") 178 | (print-string "#" :wrap nil) 179 | (terpri))) 180 | 181 | (:section (multiple-value-bind (header contents) 182 | (content-values content) 183 | ;; Delimit following sections with extra whitespace 184 | (if *beginning* 185 | (setf *beginning* nil) 186 | (terpri)) 187 | (print-string 188 | (format nil "< ~a" (text-string header))) 189 | (terpri) 190 | (incf *indent*) 191 | (unwind-protect 192 | (dolist (content contents) 193 | (print-content content)) 194 | (decf *indent*)) 195 | (print-string ">" :wrap nil) 196 | (terpri))))) 197 | 198 | (defun print-mk2 (document &optional (stream *standard-output*) 199 | &key (columns *columns*)) 200 | "*Arguments and Values:* 201 | 202 | _document_—a Geneva _document_. 203 | 204 | _stream_—a _character stream_. The default is _standard output_. 205 | 206 | _columns_—an _unsigned integer_. The default is 72. 207 | 208 | *Description:* 209 | 210 | {print-mk2} writes the _Mk2_ representation of _document_ to _stream_. 211 | {print-mk2} attempts to produce lines no longer than _comlums_ in its 212 | output. 213 | 214 | *Exceptional Situations:* 215 | 216 | If _document_ is not a valid Geneva _document_ an _error_ of _type_ 217 | {type-error} is signaled. 218 | 219 | *See Also:* 220 | 221 | + [The Mk2 markup language](mk2.html)" 222 | (let ((*columns* columns) 223 | (*standard-output* stream) 224 | (*indent* 0) 225 | (*beginning* t)) 226 | (dolist (content document) 227 | (print-content content)))) 228 | -------------------------------------------------------------------------------- /read.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Read mk2 documents. 2 | 3 | (in-package :geneva.mk2) 4 | 5 | (defun read-mk2 (&optional (input *standard-input*)) 6 | "*Arguments and Values:* 7 | 8 | _input_—a _string_ or _character stream_. The default is _standard 9 | input_. 10 | 11 | *Description:* 12 | 13 | {read-mk2} reads an _Mk2_ file from INPUT and returns a _document_. 14 | 15 | *Exceptional Situations:* 16 | 17 | If _input_ is not a valid _Mk2_ file an _error_ of _type_ 18 | {syntax-error} is signaled. 19 | 20 | *See Also:* 21 | 22 | + syntax-error 23 | + [The Mk2 markup language](mk2.html)" 24 | (make-document (parse input (=document)))) 25 | -------------------------------------------------------------------------------- /struct.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Internal data format for Geneva. 2 | 3 | (in-package :geneva) 4 | 5 | (defun make-markup (type &rest strings) 6 | "Make markup of TYPE for STRINGS. Signal a TYPE-ERROR if STRINGS are 7 | not of type string." 8 | (loop for string in strings do (check-type string string)) 9 | `(,type ,@strings)) 10 | 11 | (defun make-bold (string) 12 | "*Arguments and Values:* 13 | 14 | _string_—a _string_. 15 | 16 | *Description*: 17 | 18 | {make-bold} returns a _text token_ of type {:bold} for _string_." 19 | (make-markup :bold string)) 20 | 21 | (defun make-italic (string) 22 | "*Arguments and Values:* 23 | 24 | _string_—a _string_. 25 | 26 | *Description*: 27 | 28 | {make-italic} returns a _text token_ of type {:bold} for _string_." 29 | (make-markup :italic string)) 30 | 31 | (defun make-fixed-width (string) 32 | "*Arguments and Values:* 33 | 34 | _string_—a _string_. 35 | 36 | *Description*: 37 | 38 | {make-fixed-width} returns a _text token_ of type {:fixed-width} for 39 | _string_." 40 | (make-markup :fixed-width string)) 41 | 42 | (defun make-url (string &optional url) 43 | "*Arguments and Values:* 44 | 45 | _string_—a _string_. 46 | 47 | _url_—a _string_. 48 | 49 | *Description*: 50 | 51 | {make-url} returns a _text token_ of type {:url} for _string_. If 52 | _url_ is given then _string_ is used as the label, otherwise _string_ 53 | is both label and URL." 54 | (if url 55 | (make-markup :url string url) 56 | (make-markup :url string))) 57 | 58 | (defun assert-text-token (thing) 59 | "Assert that THING is a valid text token. On failure signal a 60 | TYPE-ERROR." 61 | (etypecase thing 62 | (list (check-type (first thing) 63 | (member :bold :italic :fixed-width :url))) 64 | (string))) 65 | 66 | (defun assert-rich-text (thing) 67 | "Assert that THING is a valid rich text sequence. On failure signal a 68 | TYPE-ERROR." 69 | (check-type thing list) 70 | (loop for token in thing do (assert-text-token token))) 71 | 72 | (defun make-paragraph (text) 73 | "*Arguments and Values:* 74 | 75 | _text_—a _rich text_ sequence. 76 | 77 | *Description*: 78 | 79 | {make-paragraph} returns _document element_ of type {:paragraph} with 80 | _text_." 81 | (assert-rich-text text) 82 | (list :paragraph (normalize-text text))) 83 | 84 | (defun make-listing (items) 85 | "*Arguments and Values:* 86 | 87 | _items_—a _list_ of _rich text_ sequences. 88 | 89 | *Description*: 90 | 91 | {make-listing} returns a _document element_ of type {:listing} with 92 | _items_." 93 | (list :listing (loop for item in items 94 | do (assert-rich-text item) 95 | collect (normalize-text item)))) 96 | 97 | (defun make-object (type description &rest content) 98 | "Make an object of TYPE for DESCRIPTION text and CONTENT. Assert that 99 | DESCRIPTION is a valid rich text sequence." 100 | (assert-rich-text description) 101 | `(,type ,(normalize-text description) ,@content)) 102 | 103 | (defun make-table (description rows) 104 | "*Arguments and Values:* 105 | 106 | _description_—a _rich text_ sequence. 107 | 108 | _rows_—a two dimensional list of _rich text_ sequences. 109 | 110 | *Description*: 111 | 112 | {make-table} returns a _document element_ of type {:table} with 113 | _description_ and _rows_." 114 | (make-object :table description 115 | (loop for row in rows 116 | collect (loop for column in row 117 | do (assert-rich-text column) 118 | collect (normalize-text column))))) 119 | 120 | (defun make-media (description url) 121 | "*Arguments and Values:* 122 | 123 | _description_—a _rich text_ sequence. 124 | 125 | _url_—a _string_. 126 | 127 | *Description*: 128 | 129 | {make-media} returns a _document element_ of type {:media} with 130 | _description_ and _url_." 131 | (check-type url string) 132 | (make-object :media description url)) 133 | 134 | (defun make-plaintext (description plaintext) 135 | "*Arguments and Values:* 136 | 137 | _description_—a _rich text_ sequence. 138 | 139 | _plaintext_—a _string_. 140 | 141 | *Description*: 142 | 143 | {make-plaintext} returns a _document element_ of type {:plaintext} 144 | with _description_ and _plaintext_." 145 | (check-type plaintext string) 146 | (make-object :plaintext description (normalize-plaintext plaintext))) 147 | 148 | (defun assert-element (thing) 149 | "Assert that THING is a valid element. On failure signal a TYPE-ERROR." 150 | (check-type thing list) 151 | (check-type (first thing) (member :paragraph :listing :table 152 | :plaintext :media :section))) 153 | 154 | (defun make-document (elements) 155 | "*Arguments and Values:* 156 | 157 | _elements_—a _list_ of _document elements_. 158 | 159 | *Description*: 160 | 161 | {make-document} returns a _document_ consisting of _elements_." 162 | (loop for thing in elements do (assert-element thing)) 163 | (remove-if (lambda (element) 164 | (member element '((:paragraph nil) (:list nil)) 165 | :test #'equal)) 166 | elements)) 167 | 168 | (defun make-section (header elements) 169 | "*Arguments and Values:* 170 | 171 | _header_—a _rich text_ sequence. 172 | 173 | _elements_—a _list_ of _document elements_. 174 | 175 | *Description*: 176 | 177 | {make-section} returns a _document element_ of type {section} with 178 | _header_ and _elements_." 179 | (make-object :section header (make-document elements))) 180 | 181 | (defun assert-content (thing) 182 | "Assert that thing is a valid element or text token. On failure signal 183 | a TYPE-ERROR." 184 | (etypecase thing 185 | (list (check-type (first thing) 186 | (member :paragraph :listing :table 187 | :plaintext :media :section 188 | :bold :italic :fixed-width :url))) 189 | (string))) 190 | 191 | (defun content-type (content) 192 | "*Arguments and Values:* 193 | 194 | _content_—an _element_ or a _text token_. 195 | 196 | *Description*: 197 | 198 | {content-type} returns a _keyword_ denoting the type of _content_ 199 | which may be one of {:paragraph}, {:listing}, {:table}, {:plaintext}, 200 | {:media}, {:section}, {:plain}, {:bold}, {:italic}, {:fixed-width} or 201 | {:url}." 202 | (assert-content content) 203 | (typecase content 204 | (list (first content)) 205 | (string :plain))) 206 | 207 | (defun content-values (content) 208 | "*Arguments and Values:* 209 | 210 | _content_—an _element_ or a _text token_. 211 | 212 | *Description*: 213 | 214 | {content-values} returns the components of _content_. The returned 215 | values are the _normalized_ forms of their respective content 216 | constructor's arguments and therefore depend on the type of 217 | _content_." 218 | (assert-content content) 219 | (typecase content 220 | (list (apply #'values (rest content))) 221 | (string content))) 222 | -------------------------------------------------------------------------------- /syntax.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Defines named readtable for text markup syntax. 2 | 3 | (in-package :geneva.macros) 4 | 5 | (defun make-markup-reader (constructor) 6 | "Returns function that reads string literal and applies CONSTRUCTOR." 7 | (lambda (stream subchar arg) 8 | `(quote ,(funcall constructor (read stream t))))) 9 | 10 | (defreadtable syntax 11 | (:merge :standard) 12 | (:dispatch-macro-char #\# #\b (make-markup-reader #'make-bold)) 13 | (:dispatch-macro-char #\# #\i (make-markup-reader #'make-italic)) 14 | (:dispatch-macro-char #\# #\f (make-markup-reader #'make-fixed-width)) 15 | (:dispatch-macro-char #\# #\u (make-markup-reader #'make-url)) 16 | (:case :invert)) 17 | 18 | (defparameter syntax (find-readtable 'syntax) 19 | "*Description:* 20 | 21 | Readtable containing reader macros for markup literals. Defines {#B}, 22 | {#I}, {#F} and {#U} to be expanded to code generating Geneva markup at 23 | read-time using _make-bold_, _make-italic_, _make-fixed-width_ and 24 | _make-url_ respectively. 25 | 26 | *Notes:* 27 | 28 | This readtable is registered as _geneva.macros:syntax_. In 29 | order to use it invoke {named-readtable}'s {in-readtable} like so: 30 | 31 | #code# 32 | (in-readtable geneva.macros:syntax) 33 | # 34 | 35 | *Examples:* 36 | 37 | #code# 38 | #b\"bold string\" ≡ (geneva:make-bold \"bold string\") 39 | #i\"italic string\" ≡ (geneva:make-italic \"italic string\") 40 | #f\"fixed-width string\" ≡ (geneva:make-fixed-width \"fixed-width string\") 41 | #u\"url string\" ≡ (geneva:make-url \"url string\") 42 | # 43 | 44 | *See Also:* 45 | 46 | + Named-Readtables ({editor-hints.named-readtables})") 47 | -------------------------------------------------------------------------------- /test/geneva-test.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Tests for GENEVA. 2 | 3 | (defpackage geneva.test 4 | (:use :cl 5 | :geneva) 6 | (:export :test-join-strings 7 | :test-normalize-whitespace 8 | :test-normalize-text-whitespace 9 | :test-normalize-text 10 | :test-normalize-plaintext)) 11 | 12 | (in-package :geneva.test) 13 | 14 | (defun test-join-strings () 15 | "Test JOIN-STRINGS." 16 | (assert (equal (geneva::join-strings 17 | '("foo" " bar" (:bold "|") "baz " (:bold "|") 18 | "boom" "yeah")) 19 | '("foo bar" (:bold "|") "baz " (:bold "|") 20 | "boomyeah")))) 21 | 22 | (defun test-normalize-whitespace () 23 | "Test NORMALIZE-WHITESPACE." 24 | (assert (string= (geneva::normalize-whitespace 25 | " foo bar baz ") 26 | " foo bar baz ")) 27 | (assert (string= (geneva::normalize-whitespace 28 | " foo bar baz " 29 | :trim :left) 30 | "foo bar baz ")) 31 | (assert (string= (geneva::normalize-whitespace 32 | " foo bar baz " 33 | :trim :right) 34 | " foo bar baz")) 35 | (assert (string= (geneva::normalize-whitespace 36 | " foo bar baz " 37 | :trim :both) 38 | "foo bar baz")) 39 | (assert (string= (geneva::normalize-whitespace 40 | "") 41 | "")) 42 | (assert (string= (geneva::normalize-whitespace 43 | " ") 44 | " "))) 45 | 46 | (defun test-normalize-text-whitespace () 47 | "Test NORMALIZE-TEXT-WHITESPACE." 48 | (assert (equal (geneva::normalize-text-whitespace 49 | '(" Hello world what " 50 | (:bold "are you") "? ")) 51 | '("Hello world what " 52 | (:bold "are you") "?"))) 53 | (assert (equal (geneva::normalize-text-whitespace 54 | '()) 55 | '())) 56 | (assert (equal (geneva::normalize-text-whitespace 57 | '("")) 58 | '(""))) 59 | (assert (equal (geneva::normalize-text-whitespace 60 | '(" Hello ")) 61 | '("Hello"))) 62 | (assert (equal (geneva::normalize-text-whitespace 63 | '(" Hello you ")) 64 | '("Hello you")))) 65 | 66 | (defun test-normalize-text () 67 | "Test NORMALIZE-TEXT." 68 | (assert (equal (geneva::normalize-text 69 | '((:italic "") " Hello world " " what " 70 | (:bold "are you") "? ")) 71 | '("Hello world what " 72 | (:bold "are you") "?"))) 73 | (assert (equal (geneva::normalize-text 74 | '(" " (:italic "") " Hello world " " what " 75 | (:bold "are you") " ")) 76 | '("Hello world what " 77 | (:bold "are you")))) 78 | (assert (equal (geneva::normalize-text 79 | '("" (:italic " ") " f " (:bold " ") "")) 80 | '("f")))) 81 | 82 | (defun test-normalize-plaintext () 83 | "Test NORMALIZE-PLAINTEXT." 84 | (assert (string= (geneva::normalize-plaintext 85 | " foo 86 | 87 | bar 88 | boom 89 | baz") 90 | " foo 91 | 92 | bar 93 | boom 94 | baz"))) 95 | -------------------------------------------------------------------------------- /test/mk2-test.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Test GENEVA.MK2's READ-MK2 and PRINT-MK2. 2 | 3 | (defpackage geneva.mk2-test 4 | (:use :cl 5 | :geneva 6 | :geneva.mk2 7 | :geneva.mk2.tokens) 8 | (:export :random-paragraph 9 | :random-listing 10 | :random-table 11 | :random-media 12 | :random-plaintext 13 | :random-section 14 | :test-mk2)) 15 | 16 | (in-package :geneva.mk2-test) 17 | 18 | (defparameter *test-iterations* 8 19 | "Number of test iterations. Due to sections, this variable will 20 | increase the runtime of TEST-MK2 exponentially.") 21 | 22 | (defmacro one-of (&body body) 23 | "Evaluate a randomly chosen BODY form." 24 | (let ((length (length body))) 25 | `(case (random ,length) 26 | ,@(loop for i from 0 to length 27 | for form in body 28 | collect `(,i ,form))))) 29 | 30 | (defun random-character () 31 | (one-of #\x #\Space 32 | *section-start* 33 | *section-end* 34 | *listing-item* 35 | *table-item* 36 | *object-delimiter* 37 | *bold-directive* 38 | *italic-directive* 39 | *fixed-width-directive-start* 40 | *fixed-width-directive-end* 41 | *url-directive-start* 42 | *url-directive-end* 43 | *escape-directive*)) 44 | 45 | (defun random-string (length) 46 | "Return a random string of LENGTH." 47 | (let ((string (make-string length))) 48 | (loop for i from 0 to (1- length) 49 | do (setf (aref string i) (random-character))) 50 | string)) 51 | 52 | (defun random* () 53 | "Return a random number ranging from zero to *TEST-ITERATIONS*." 54 | (random *test-iterations*)) 55 | 56 | (defmacro collect-n (n &body forms) 57 | "Evaluate and collect the result of FORMS (implicit PROGN) N times." 58 | (let ((i-sym (gensym "counter"))) 59 | `(loop for ,i-sym from 0 to ,n collect (progn ,@forms)))) 60 | 61 | (defun random-text-token () 62 | "Generate random text token." 63 | (let ((random-string (random-string (1+ (random*))))) 64 | (one-of random-string 65 | (make-bold random-string) 66 | (make-italic random-string) 67 | (make-fixed-width random-string) 68 | (make-url random-string) 69 | (make-url random-string random-string)))) 70 | 71 | (defun random-text () 72 | "Generate random text." 73 | (collect-n (random*) 74 | (random-text-token))) 75 | 76 | (defun random-paragraph () 77 | "Generate random paragraph." 78 | (make-paragraph (list* (random-text-token) (random-text)))) 79 | 80 | (defun random-listing () 81 | "Generate random listing." 82 | (make-listing (collect-n (random*) (random-text)))) 83 | 84 | (defun random-table () 85 | "Generate random table." 86 | (let ((columns (1+ (random 4)))) 87 | (make-table (random-text) 88 | (collect-n (1+ (random 4)) 89 | (collect-n columns (random-text)))))) 90 | 91 | (defun random-media () 92 | "Generate a random media element." 93 | (make-media (random-text) "xxxxx")) 94 | 95 | (defun random-plaintext () 96 | "Generate random plaintext element." 97 | (make-plaintext (random-text) (random-string (random*)))) 98 | 99 | (defun random-section () 100 | "Generate random section." 101 | (make-section (random-text) 102 | (collect-n (random*) 103 | ;; 50% chance of possible subsection. 104 | (one-of (one-of (random-paragraph) 105 | (random-listing) 106 | (random-table) 107 | (random-media) 108 | (random-plaintext)) 109 | ;; With possible subsection. 110 | (one-of (random-element)))))) 111 | 112 | (defun random-element () 113 | "Generate random element." 114 | (one-of (random-paragraph) 115 | (random-listing) 116 | (random-table) 117 | (random-media) 118 | (random-plaintext) 119 | (random-section))) 120 | 121 | (defun random-elements () 122 | "Generate a list of random elements." 123 | (collect-n (random*) (random-element))) 124 | 125 | (defun test-integrity (elements) 126 | "Perform integrity test for ELEMENTS, printed and subsequently parsed." 127 | (let* ((document (make-document elements)) 128 | (mk2 (with-output-to-string (*standard-output*) 129 | (print-mk2 document))) 130 | read-document) 131 | (handler-case 132 | (progn (setf read-document (read-mk2 mk2)) 133 | (assert (equal document read-document))) 134 | (error (error) 135 | (format t "FAIL: ~a ~S~%~a~:S~%~:S~%~%" 136 | error error mk2 document read-document))))) 137 | 138 | (defun test-mk2 (&rest tests) 139 | "Run TESTS." 140 | (if tests 141 | (loop for test in tests do 142 | (format t "~A~%" test) 143 | (dotimes (i *test-iterations*) 144 | (test-integrity (list (funcall test))))) 145 | (progn 146 | (format t "DOCUMENT~%") 147 | (dotimes (i *test-iterations*) 148 | (test-integrity (random-elements)))))) 149 | -------------------------------------------------------------------------------- /tex.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Render Geneva document as TeX manuscript. 2 | 3 | ;;; Expects macros as implicated below: 4 | ;;; 5 | ;;; Text: 6 | ;;; \genbold{#1} \genitalic{#1} \genfixedwidth{#1} \genurl{#1} 7 | ;;; E.g.: \genbold{...} ... 8 | ;;; 9 | ;;; \gentinyparagraph{#1} (For very short paragraphs) 10 | ;;;; E.g. \gentinyparagraph{...} 11 | ;;; 12 | ;;; Listing: 13 | ;;; \genlisting{#1} \genitem{#1} 14 | ;;; E.g.: \genlisting{\genitem{...} ...} 15 | ;;; 16 | ;;; Table: 17 | ;;; \gentable{#1}{#2}{#3} \genhead{#1} \genrow{#1} \gencolumn{#1} 18 | ;;; E.g.: \gentable{Description...}{XX...}{ 19 | ;;; \genrow{\genhead{...} \gencolsep... \genhead{...}} 20 | ;;; \genrow{\gencolumn{...} \gencolsep \gencolumn{...}...} 21 | ;;; ... 22 | ;;; } 23 | ;;; 24 | ;;; Figures: 25 | ;;; \gengraphic{#1}{#2} 26 | ;;; \genfallbackfigure{#1}{#2} 27 | ;;; \genverbatimstart 28 | ;;; \genverbatimend 29 | ;;; \genverbatimdescription{#1} 30 | ;;; E.g.: 31 | ;;; (Graphic figure) \gengraphic{...}{<URL>} 32 | ;;; (Fallback figure) \genfallbackfigure{...}{<URL>} 33 | ;;; (Plaintext figure) \genverbatimstart ... \genverbatimend 34 | ;;; \genverbatimdescription{...} 35 | ;;; 36 | ;;; Sections: 37 | ;;; \gensection{#1} \gensubsection{#1} \gensubsubsection{#1} 38 | ;;; E.g.: \gensection{...} ... 39 | 40 | (defpackage geneva.tex 41 | (:documentation 42 | "Render Geneva document as TeX manuscript.") 43 | (:use :cl 44 | :geneva 45 | :texp 46 | :file-types 47 | :named-readtables) 48 | (:export :render-tex)) 49 | 50 | (in-package :geneva.tex) 51 | 52 | (in-readtable texp:syntax) 53 | 54 | (defvar *section-level* 0 55 | "Section level.") 56 | 57 | (defun render-url (url) 58 | (flet ((break-p (c) (member c '(#\/ #\? #\= #\& #\#)))) 59 | (with-output-to-string (*standard-output*) 60 | (loop for start = 0 then (1+ end) 61 | for end = (position-if #'break-p url :start start) 62 | do (write-string (escape (subseq url start (if end (1+ end))))) 63 | while end do (tex (allowbreak "")))))) 64 | 65 | (defun render-text-token (text-token) 66 | "Render TEXT-TOKEN as TeX using macro calls for markup tokens." 67 | (ecase (content-type text-token) 68 | (:plain (write-string #1=(escape (content-values text-token)))) 69 | (:bold (tex (genbold {($ #1#)}))) 70 | (:italic (tex (genitalic {($ #1#)}))) 71 | (:fixed-width (tex (genfixedwidth {($ #1#)}))) 72 | (:url (multiple-value-bind (string url) 73 | (content-values text-token) 74 | (if url 75 | (tex (genitalic {($ (escape string))}) 76 | " (" (genurl {($ (render-url url))}) ")") 77 | (tex (genurl {($ (render-url string))}))))))) 78 | 79 | (defun render-text (text) 80 | "Render TEXT in TeX representation." 81 | (dolist (text-token text) 82 | (render-text-token text-token)) 83 | (values)) 84 | 85 | (defun text-length (text) 86 | "Number of characters in TEXT." 87 | (loop for token in text sum (length (content-values token)))) 88 | 89 | (defun tiny-paragraph-p (paragraph) 90 | "If PARAGRAPH contains less than 128 characters its a _tiny 91 | paragraph_." 92 | (< (text-length (content-values paragraph)) 128)) 93 | 94 | (defun render-paragraph (paragraph) 95 | "Render PARAGRAPH in TeX representation." 96 | (if (tiny-paragraph-p paragraph) 97 | (tex (gentinyparagraph 98 | {($ (render-text (content-values paragraph)))})) 99 | (tex ($ (render-text (content-values paragraph))) 100 | (br)))) 101 | 102 | (defun render-listing (listing) 103 | "Render LISTING in TeX representation." 104 | (tex (genlisting 105 | {($ (dolist (item (content-values listing)) 106 | (tex (genitem {($ (render-text item))}))))}) 107 | (br))) 108 | 109 | (defun render-table-row (row &optional (type :column)) 110 | "Render ROW in TeX representation." 111 | (loop for head = row then (cdr head) 112 | for column = (car head) 113 | while head do 114 | (ecase type 115 | (:column (tex (gencolumn {($ (render-text column))}))) 116 | (:head (tex (genhead {($ (render-text column))})))) 117 | (when (cdr head) 118 | (tex (gencolsep))))) 119 | 120 | (defun table-format (rows) 121 | "Compute table format for ROWS." 122 | (let* ((thresh 16) 123 | (n (loop for row in rows maximize (length row))) 124 | (cs (loop for i from 0 to (1- n) 125 | for max = (loop for row in rows 126 | maximize (text-length (nth i row))) 127 | if (> max thresh) collect max 128 | else collect thresh)) 129 | (sum (loop for c in cs sum c)) 130 | (rs (loop for c in cs 131 | collect (float (* (/ c sum) n))))) 132 | (format nil "~{>{\\hsize~a\\hsize}X~}" rs))) 133 | 134 | (defun render-table (table) 135 | "Render TABLE in TeX representation." 136 | (multiple-value-bind (description rows) 137 | (content-values table) 138 | (tex (gentable 139 | {($ (render-text description))} 140 | {($ (table-format rows))} 141 | {(genrow {($ (render-table-row (first rows) :head))}) 142 | ($ (dolist (row (rest rows)) 143 | (tex (genrow {($ (render-table-row row))}))))}) 144 | (br)))) 145 | 146 | (defun render-media (media-object) 147 | "Render MEDIA in TeX representation." 148 | (multiple-value-bind (description url) 149 | (content-values media-object) 150 | (if (file-tags url :image) 151 | (tex (gengraphic {($ (render-text description))} 152 | {($ (escape url))}) 153 | (br)) 154 | (tex (genfallbackfigure {($ (render-text description))} 155 | {($ (escape url))}) 156 | (br))))) 157 | 158 | (defun render-plaintext (plaintext-object) 159 | "Render PLAINTEXT-OBJECT in TeX representation." 160 | (multiple-value-bind (description text) 161 | (content-values plaintext-object) 162 | (tex (genverbatimstart) 163 | ($ (fresh-line)) 164 | ($ (escape text)) 165 | ($ (fresh-line)) 166 | (genverbatimend) 167 | (genverbatimdescription {($ (render-text description))}) 168 | (br)))) 169 | 170 | (defun render-header (header) 171 | "Render HEADER in TeX representation." 172 | (case *section-level* 173 | (0 (tex (gensection {($ (render-text header))}))) 174 | (1 (tex (gensubsection {($ (render-text header))}))) 175 | (otherwise (tex (gensubsubsection {($ (render-text header))})))) 176 | (tex (br))) 177 | 178 | (defun render-section (section) 179 | "Render SECTION in TeX representation." 180 | (multiple-value-bind (header contents) 181 | (content-values section) 182 | (render-header header) 183 | (let ((*section-level* (1+ *section-level*))) 184 | (render-contents contents)) 185 | (tex (br)))) 186 | 187 | (defun render-content (content) 188 | "Render CONTENT in html representation." 189 | (case (content-type content) 190 | (:paragraph (render-paragraph content)) 191 | (:listing (render-listing content)) 192 | (:table (render-table content)) 193 | (:media (render-media content)) 194 | (:plaintext (render-plaintext content)) 195 | (:section (render-section content)) 196 | (t (error "Invalid content type in CONTENT: ~S." 197 | (content-type content))))) 198 | 199 | (defun render-contents (contents) 200 | "Render document or section CONTENTS in TeX representation." 201 | (dolist (content contents) (render-content content))) 202 | 203 | (defun render-tex (document &key (stream *standard-output*) 204 | (section-level *section-level*)) 205 | "*Arguments and Values:* 206 | 207 | _document_—a _Geneva document_. 208 | 209 | _stream_—a _character stream_. The default is {*standard-output*}. 210 | 211 | _section-level_—an _unsigned integer_. The default is {0}. 212 | 213 | *Description:* 214 | 215 | {render-tex} renders _document_ as a TeX manuscript to _stream_. The 216 | sections will be rendered at _section level_. 217 | 218 | *See Also:* 219 | 220 | + geneva.latex:render-latex" 221 | (let ((*standard-output* stream) 222 | (*section-level* section-level)) 223 | (render-contents document))) 224 | -------------------------------------------------------------------------------- /tokens.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Tokens used in MK2 document syntax. 2 | 3 | (in-package :geneva.mk2.tokens) 4 | 5 | ;;; Syntax tokens 6 | (defparameter *section-start* 7 | #\< "Section start character.") 8 | (defparameter *section-end* 9 | #\> "Section end character.") 10 | (defparameter *listing-item* 11 | #\+ "Listing item character.") 12 | (defparameter *table-item* 13 | #\| "Table item character.") 14 | (defparameter *object-delimiter* 15 | #\# "Object delimiter character.") 16 | (defparameter *bold-directive* 17 | #\* "Bold directive character.") 18 | (defparameter *italic-directive* 19 | #\_ "Bold directive character.") 20 | (defparameter *fixed-width-directive-start* 21 | #\{ "Fixed-Width directive start character.") 22 | (defparameter *fixed-width-directive-end* 23 | #\} "Fixed-Width directive end character.") 24 | (defparameter *url-directive-start* 25 | #\[ "URL directive start character.") 26 | (defparameter *url-directive-end* 27 | #\] "URL directive end character.") 28 | (defparameter *url-url-start* 29 | #\( "URL url start character.") 30 | (defparameter *url-url-end* 31 | #\) "URL url end character.") 32 | (defparameter *escape-directive* 33 | #\\ "Escape directive character.") 34 | 35 | (defparameter *special-tokens* (list *section-start* 36 | *section-end* 37 | *listing-item* 38 | *table-item* 39 | *object-delimiter* 40 | *escape-directive*) 41 | "Special tokens.") 42 | 43 | (defparameter *markup-directives* (list *bold-directive* 44 | *italic-directive* 45 | *fixed-width-directive-start* 46 | *fixed-width-directive-end* 47 | *url-directive-start* 48 | *url-directive-end* 49 | *url-url-start* 50 | *url-url-end*) 51 | "Markup directives.") 52 | 53 | 54 | ;;; Syntax keywords 55 | (defparameter *table-keyword* "TABLE" "Table tag word.") 56 | (defparameter *media-keyword* "MEDIA" "Media tag word.") 57 | (defparameter *plaintext-keyword* "CODE" "Plaintext tag word.") 58 | -------------------------------------------------------------------------------- /utilities.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Shared utility functions used by various components of Geneva. 2 | 3 | (defpackage geneva.utilities 4 | (:documentation 5 | "Shared utility functions used by various components of Geneva.") 6 | (:use :geneva 7 | :cl 8 | :split-sequence) 9 | (:export :*default-index-caption* 10 | :*index-p* 11 | :*index-headers-p* 12 | :null-level 13 | :descend-level 14 | :incf-level 15 | :level-string 16 | :text-string 17 | :document-index 18 | :wrap-string 19 | :align-string)) 20 | 21 | (in-package :geneva.utilities) 22 | 23 | (defparameter *default-index-caption* "Table of Contents" 24 | "Default caption for indexes.") 25 | 26 | (defparameter *index-p* t 27 | "Controls wether an index is rendered.") 28 | 29 | (defparameter *index-headers-p* t 30 | "Controls wether headers are numbered.") 31 | 32 | (defun null-level () 33 | "Returns the root level." 34 | (cons 1 nil)) 35 | 36 | (defun descend-level (level) 37 | "Returns the next deeper LEVEL." 38 | (append level (null-level))) 39 | 40 | (defun incf-level (level) 41 | "Increment LEVEL by one." 42 | (incf (elt level (length (rest level))))) 43 | 44 | (defun level-string (level) 45 | "Return string representation for LEVEL." 46 | (format nil "~{~a~^.~}" level)) 47 | 48 | (defun text-string (text) 49 | "Return TEXT string without markup." 50 | (with-output-to-string (*standard-output*) 51 | (dolist (text-token text) 52 | (write-string (content-values text-token))))) 53 | 54 | (defun document-index-2 (document level) 55 | "Base function for DOCUMENT-INDEX." 56 | (flet ((section-p (content) 57 | (eq (content-type content) :section)) 58 | (section-entry (section) 59 | (prog1 (multiple-value-bind (header contents) 60 | (content-values section) 61 | (list (copy-list level) 62 | header 63 | (document-index-2 64 | contents (descend-level level)))) 65 | (incf-level level)))) 66 | (mapcar #'section-entry (remove-if-not #'section-p document)))) 67 | 68 | (defun document-index (document) 69 | "Returns section hierarchy on DOCUMENT." 70 | (document-index-2 document (null-level))) 71 | 72 | (defun wrap-string (string &optional (columns 72)) 73 | "Return copy of STRING with spaces replaced by newlines so that lines 74 | do not exceed COLUMNS characters when possible. COLUMNS defaults to 72." 75 | (with-output-to-string (out) 76 | (loop for line in (split-sequence #\Newline string) 77 | do 78 | (loop for word in (split-sequence #\Space line) 79 | for word-length = (length word) 80 | with count = 0 81 | do (cond ((> (+ count word-length) (1+ columns)) 82 | (fresh-line out) 83 | (write-string word out) 84 | (setf count (1+ word-length))) 85 | (t 86 | (unless (= count 0) 87 | ;; No Space at beginning of line 88 | (write-char #\Space out)) 89 | (write-string word out) 90 | (incf count (1+ word-length))))) 91 | (terpri out)))) 92 | 93 | (defun align-string (string alignment &optional (columns 72)) 94 | "Return aligned copy of STRING with respect to COLUMNS. Possible values 95 | for ALIGNMENT are :RIGHT and :CENTER." 96 | (with-output-to-string (*standard-output*) 97 | (loop for line 98 | in (split-sequence #\Newline (wrap-string string columns)) 99 | when (not (string-equal "" line)) 100 | do (format t "~a~a~%" 101 | (make-string 102 | (ecase alignment 103 | (:right (1+ (- columns (length line)))) 104 | (:center (ceiling (- columns (length line)) 2))) 105 | :initial-element #\Space) 106 | line)))) 107 | --------------------------------------------------------------------------------