|
16 | 16 |
|
17 | 17 | ; Design: DSL for manpulating textblocks. |
18 | 18 | ; This means well defined operations that are ideally closed. |
19 | | - |
20 | 19 | ; For example: |
21 | 20 | ; - append two blocks and get a block |
22 | 21 | ; - include references in a block to get a new block |
|
36 | 35 | list)) |
37 | 36 |
|
38 | 37 | (defun textblock-slug (title) (string-to-slug title)) |
39 | | - |
40 | | -(defun leading-whitespace (code-line) |
41 | | - (if (stringp (car code-line)) |
42 | | - (multiple-value-bind (match groups) |
43 | | - (ppcre:scan-to-strings "(\\s*)" (car code-line)) |
44 | | - (assert match) |
45 | | - (aref groups 0)) "")) |
46 | 38 |
|
47 | 39 | (defun textblock-concat (a b) |
48 | | - "concatenate the text of two blocks" |
| 40 | + "concatenate the text of two blocks. The modification date is the most recent of the two dates." |
49 | 41 | (make-textblock |
50 | 42 | :modify-date (max (textblock-modify-date a) |
51 | 43 | (textblock-modify-date b)) |
52 | 44 | :lines (concatenate 'vector |
53 | 45 | (textblock-lines a) |
54 | 46 | (textblock-lines b)))) |
| 47 | + |
| 48 | + |
| 49 | +(defun leading-whitespace (code-line) |
| 50 | + (if (stringp (car code-line)) |
| 51 | + (multiple-value-bind (match groups) |
| 52 | + (ppcre:scan-to-strings "(\\s*)" (car code-line)) |
| 53 | + (assert match) |
| 54 | + (aref groups 0)) "")) |
55 | 55 |
|
56 | 56 | (defun include-lines (block prefix whitespace output) |
57 | 57 | (let* ((src (textblock-lines block)) |
|
65 | 65 | (cons whitespace (aref src (- n 1))))))) |
66 | 66 |
|
67 | 67 | (defun include-helper (line output block-table) |
| 68 | + ; Handling white space properly in block inclusion is tricky. |
| 69 | + ; Suppose you have something like this: |
| 70 | + ; int main() { |
| 71 | + ; @{body} |
| 72 | + ; } |
| 73 | + ; We want all the lines from body to be indented at same level. |
| 74 | + ; So we need to record the whitespace prefix and prepend that to each line. |
| 75 | + ; See the tests for additional examples. |
| 76 | + |
| 77 | + ; What should the following do if body has multiple lines? |
| 78 | + ; int main() { @{body} } |
| 79 | + |
68 | 80 | (let ((prefix '())) |
69 | 81 | (loop for expr in line do |
70 | 82 | (cond ((stringp expr) (setf prefix (append prefix (list expr)))) |
71 | 83 | ((commandp expr) |
72 | 84 | (case (first expr) |
73 | 85 | (:INCLUDE |
74 | | - (multiple-value-bind (other present) |
| 86 | + (multiple-value-bind (other-block present) |
75 | 87 | (gethash (textblock-slug (second expr)) block-table) |
76 | 88 | (if present |
77 | 89 | (setf prefix (include-lines |
78 | | - other |
| 90 | + other-block |
79 | 91 | prefix |
80 | 92 | (leading-whitespace line) output)) |
81 | | - (error 'user-error |
82 | | - :format-control "cannot find block to include: ~s" |
83 | | - :format-arguments (list (second expr)))))) |
| 93 | + (warn "attempting to include unknown block: ~s" (second expr))))) |
84 | 94 | (otherwise (error "unknown code command ~S" (first expr))))) |
85 | 95 | (t (error "unknown structure")))) |
86 | 96 | (vector-push-extend prefix output))) |
87 | 97 |
|
88 | 98 | (defun textblock-include (root block-table) |
89 | 99 | "form a new block by including the contents of all immediate dependencies (nonrecursive)." |
90 | | - (let* ((titles (textblock-referenced-titles root)) |
91 | | - (dependencies (mapcar (lambda (title) |
92 | | - (gethash (textblock-slug title) block-table)) titles)) |
93 | | - (output (make-array 16 :fill-pointer 0 :adjustable t))) |
94 | | - |
| 100 | + (let ((output (make-array 16 :fill-pointer 0 :adjustable t))) |
95 | 101 | (loop for line across (textblock-lines root) do |
96 | 102 | (include-helper line output block-table)) |
97 | 103 |
|
98 | | - (make-textblock :modify-date (reduce #'max |
99 | | - (mapcar #'textblock-modify-date dependencies) |
100 | | - :initial-value (textblock-modify-date root)) |
101 | | - :lines output))) |
| 104 | + (let* ((titles (textblock-referenced-titles root)) |
| 105 | + (dependencies (remove-if #'null (mapcar (lambda (title) |
| 106 | + (gethash (textblock-slug title) block-table)) |
| 107 | + titles)))) |
| 108 | + (make-textblock :modify-date (reduce #'max |
| 109 | + (mapcar #'textblock-modify-date dependencies) |
| 110 | + :initial-value (textblock-modify-date root)) |
| 111 | + :lines output)))) |
102 | 112 |
|
103 | 113 |
|
104 | 114 | (defun textblock-find-title (block) |
| 115 | + "Find the first title command in the block." |
105 | 116 | (find-map (lambda (line) |
106 | 117 | (find-map (lambda (expr) |
107 | | - (when (and (commandp expr) (eq (first expr) :TITLE)) |
| 118 | + (when (and (commandp expr) |
| 119 | + (eq (first expr) :TITLE)) |
108 | 120 | (second expr))) |
109 | 121 | line)) |
110 | 122 | (textblock-lines block))) |
|
168 | 180 | table)) |
169 | 181 |
|
170 | 182 | (defun textblockdefs-apply (defs) |
171 | | - "construct a table of blocks by evaluating combination operations" |
| 183 | + "construct a table of blocks by evaluating the block operations (include, concat, etc)." |
172 | 184 | (let ((block-table (make-hash-table :test #'equal))) |
173 | 185 | (loop for def in defs do |
174 | 186 | (let ((block (textblockdef-block def)) |
|
0 commit comments