├── .circleci └── config.yml ├── LICENSE ├── Makefile ├── README.md ├── all.lisp ├── lisp-markup.el ├── markup.asd ├── markup.lisp ├── optimizer.lisp ├── run-circleci.lisp ├── stream.lisp ├── tags.lisp ├── test-markup.lisp ├── test-optimizer.lisp ├── test-stream.lisp ├── test-walk.lisp └── walk.lisp /.circleci/config.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | jobs: 3 | build: 4 | docker: 5 | - image: cimg/base:2021.04 6 | steps: 7 | - checkout 8 | - run: 9 | name: Install SBCL 10 | command: sudo apt-get update && sudo apt-get install -y sbcl 11 | - run: 12 | name: Install quicklisp 13 | command: | 14 | curl -O https://beta.quicklisp.org/quicklisp.lisp 15 | sbcl --load quicklisp.lisp --eval '(quicklisp-quickstart:install)' 16 | - run: 17 | name: Run tests 18 | command: sbcl --script run-circleci.lisp 19 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright [yyyy] [name of copyright owner] 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | CL?=sbcl --quit --eval "(require :asdf)" --eval 3 | TMP:=$(shell tempfile) 4 | 5 | test: 6 | $(CL) '(progn (pushnew #P"./" asdf:*central-registry*) (ql:quickload "markup") (asdf:test-system "markup.test"))' 2>&1 | tee $(TMP) 7 | grep "Fail: 0 " $(TMP) 8 | rm -f $(TMP) 9 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # markup 2 | 3 | [![tdrhq](https://circleci.com/gh/moderninterpreters/markup.svg?style=shield)](https://app.circleci.com/pipelines/github/moderninterpreters/markup?branch=main) 4 | 5 | ### Arnold Noronha 6 | 7 | Markup let's you write HTML code inside of common lisp, for instance 8 | 9 | ```lisp 10 | (let ((x "hello")) 11 |

,(progn x) world!

) 12 | ``` 13 | 14 | ## Motivation 15 | 16 | There are several HTML generation libraries for Common Lisp, for 17 | example CL-WHO. However, these libraries follow the Lisp style of 18 | building up the structure in parenthesis. 19 | 20 | For example, it might look like something like this: 21 | 22 | 23 | ```lisp 24 | ;; CL-WHO syntax, not markup's 25 | (:p "hello" (:em "world") "!") 26 | ``` 27 | 28 | There are many advantages to this structure, but there are a few 29 | prominent disadvantages. 30 | 31 | First, there's all that double-quotes that becomes hard to track. 32 | 33 | Second, and more importantly: There are hundreds of templates and HTML 34 | snippets on the internet that are hard to copy-paste into your project 35 | if you have to transform them into CL-WHO structures. Time is money. 36 | 37 | Finally, it's already hard to hire Lisp engineers. Don't you want to 38 | be able to hire designers who might at least modify HTML they 39 | recognize inside your lisp project? 40 | 41 | ## Performance 42 | 43 | Performance is not a motivation for Markup. We're focussing on 44 | developer productivity. For instance, compared to CL-WHO we generate 45 | the entire tree of HTML tags before serializing it into the stream at 46 | the last step. We haven't reached a situation where this is a 47 | bottleneck for our use cases. 48 | 49 | Building the tree also lets us build more complex components that can 50 | go modify the tree. 51 | 52 | It might be possible to build a streaming version of Markup, but 53 | that's not on our radar. 54 | 55 | ## Full example with Hunchentoot 56 | 57 | ```lisp 58 | (markup:enable-reader) 59 | 60 | (markup:deftag template (children &key title) 61 | 62 | 63 | ,(progn title) 64 | 65 | 66 | ,@(progn children) 67 | 68 | ) 69 | 70 | (hunchentoot:define-easy-handler (foobar :uri "/") () 71 | (markup:write-html 72 | )) 75 | ``` 76 | 77 | ## Installation 78 | 79 | markup is available via quicklisp 80 | 81 | ```lisp 82 | (ql:quickload "markup") 83 | ``` 84 | 85 | (If that doesn't load, make sure you update your dists, `(ql:update-all-dists)`) 86 | 87 | ## Editor support 88 | 89 | ```emacs-lisp 90 | (use-package lisp-markup 91 | :load-path "~/quicklisp/dists/quicklisp/software/markup--git/" 92 | :hook (lisp-mode . lisp-markup-minor-mode)) 93 | 94 | ;; if you don't use use-package 95 | (add-to-list 'load-path "~/quicklisp/dists/quicklisp/software/markup--git/") 96 | (require 'lisp-markup) 97 | (add-hook 'lisp-mode-hook #'lisp-markup-minor-mode) 98 | ``` 99 | 100 | ## FAQ 101 | 102 | ### What about expressions like `(< x 2)`? 103 | 104 | Markdown requires tags to follow the `<` operator, otherwise (or if it's `<=`) treats it as a symbol. 105 | 106 | ### Are custom tags namespaced? 107 | 108 | Of course, custom tags are just lisp symbols. So you can define a tag like `...`. 109 | 110 | Certain tag names are treated as special (``, `` etc.) since they're HTML elements. 111 | 112 | If you want to output the equivalent HTML element for a tag that isn't 113 | treated as special you can also specify the tag using keyword symbols `<:foo>..`. 114 | 115 | ### How do you embed lisp code in markup? 116 | 117 | You have already seen some examples in this README. Use `,(...)` to 118 | escape some lisp code that returns a single element, or ,@sexp that 119 | returns a list of elements. (Side note, we really don't need to have 120 | both of these, but it matches the backquote syntax much better this 121 | way). 122 | 123 | You can also embed lisp code as attribute values. 124 | 125 | ```lisp 126 | ... 127 | ``` 128 | 129 | That is, any expression after the an attribute is read using the 130 | standard Lisp reader. A small caveat to this is that in some cases you need to have a space after the ending `>`. For instance the following will result in an error: 131 | 132 | ```lisp 133 | ;; bad code 134 | ... 135 | ;; correct code 136 | ... 137 | ``` 138 | 139 | ### Is markup used in production? 140 | 141 | Yes it is! Right now it's used on several websites we've 142 | built. They've solved all of our use cases reliably. The primary 143 | website we use this on is [Screenshotbot](http://screenshotbot.io), if 144 | you're building web interfaces, you might enjoy using Screenshotbot to 145 | keep testing the rendering of your UI in Continuous Integration. (For 146 | instance, we use Selenium tests to generate screenshots of 147 | Screenshotbot's UI.) 148 | 149 | Please do let us know if you use Markup on the sites you're 150 | building. We'd love to include them here. 151 | 152 | ## See also 153 | 154 | XHP for PHP, and JSX for React both support HTML inside of code for very similar 155 | motivations. 156 | 157 | @fukamachi released [LSX](https://github.com/fukamachi/lsx) in the 158 | same Quicklisp release that markup came out (although his repo goes 159 | back much longer, around the time I first started working on Markup 160 | internally.). Functionally, it's super similar to Markup and Fukamachi 161 | is a pretty fantastic Lisper, and maybe in the future we should 162 | consolidate. 163 | 164 | ## License 165 | 166 | Apache License, Version 2.0 167 | -------------------------------------------------------------------------------- /all.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:markup 2 | (:use-reexport #:markup/markup 3 | #:markup/walk)) 4 | -------------------------------------------------------------------------------- /lisp-markup.el: -------------------------------------------------------------------------------- 1 | ;;;; lisp-markup.el 2 | ;;;; Charles Jackson 3 | (require 'sgml-mode) 4 | (require 'lisp-mode) 5 | 6 | (defvar lisp-markup-minor-mode-map 7 | (let ((keymap (make-keymap))) 8 | (define-key keymap (kbd "/") #'lisp-markup-/-close-tag) 9 | (define-key keymap (kbd "C-c C-o") #'sgml-tag) 10 | (define-key keymap (kbd "") #'newline-and-indent) 11 | keymap) 12 | "Additional key bindings for `lisp-markup-minor-mode'.") 13 | 14 | (defvar lisp-markup-sgml-tag-syntax-table 15 | (let ((table (make-syntax-table sgml-tag-syntax-table))) 16 | (modify-syntax-entry ?' "." table) 17 | (modify-syntax-entry 40 "|" table) 18 | (modify-syntax-entry 41 "|" table) 19 | table) 20 | "A modified `sgml-tag-syntax-table' that effectively ignores 21 | content between ?( and ?) by mapping them to symbol-escape 22 | characters. Additionally maps ?' to be a punctuation character 23 | which separates symbols.") 24 | 25 | (defvar *lisp-markup-mode-keywords* 26 | '(("/=[:space:]]+\\)" 1 font-lock-builtin-face) 27 | ;; regular tag names 28 | ("/=[:space:]]*\\)" 1 font-lock-function-name-face) 29 | ;; attribute names 30 | ("[[:space:]]\\([-[:alpha:]]+\\)=" 1 font-lock-constant-face) 31 | ;; deftag faces 32 | ("(\\(deftag\\)" 1 font-lock-keyword-face) 33 | ("(deftag \\([^ ]+\\) " 1 font-lock-function-name-face) 34 | ;; warning about single symbol lisp forms at the end of tags 35 | ("=[^[:space:]<>]+[^\"/) ]\\(/\\|>\\)" 1 font-lock-warning-face)) 36 | "`font-lock' configuration for `lisp-markup-minor-mode' to 37 | provide highlighting to HTML code within lisp files.") 38 | 39 | (define-minor-mode lisp-markup-minor-mode 40 | "Enhance `lisp-mode' with additional features to support embedded HTML markup. 41 | 42 | This changes syntax highlighting, indentation rules, and adds 43 | some extra keybindings to make editing of markup in lisp files 44 | easier." 45 | :lighter " markup" 46 | :keymap lisp-markup-minor-mode-map 47 | (if (eq major-mode 'lisp-mode) 48 | (if lisp-markup-minor-mode 49 | (enter-lisp-markup-minor-mode) 50 | (exit-lisp-markup-minor-mode)) 51 | (progn 52 | (setf lisp-markup-minor-mode nil) 53 | (error "lisp-markup-minor-mode only supports running in lisp-mode")))) 54 | 55 | (defun lisp-markup--font-lock-update () 56 | (unless (version< emacs-version "28.1") 57 | (font-lock-update))) 58 | 59 | (defun enter-lisp-markup-minor-mode () 60 | "Perform the setup required by `lisp-markup-minor-mode'." 61 | (font-lock-add-keywords nil *lisp-markup-mode-keywords*) 62 | (lisp-markup--font-lock-update) 63 | (setq-local indent-line-function #'lisp-markup-indent-line 64 | indent-region-function #'indent-region-line-by-line ; Less efficient, but still correct 65 | forward-sexp-function #'lisp-markup-forward-sexp 66 | comment-region-function #'lisp-markup-comment-region 67 | syntax-propertize-function lisp-markup-syntax-propertize-function) 68 | (sgml-electric-tag-pair-mode 1)) 69 | 70 | (defun exit-lisp-markup-minor-mode () 71 | "Undo the setup performed by `enter-lisp-markup-minor-mode'." 72 | (font-lock-remove-keywords nil *lisp-markup-mode-keywords*) 73 | (lisp-markup--font-lock-update) 74 | (setq-local indent-line-function #'lisp-indent-line 75 | indent-region-function #'lisp-indent-region 76 | forward-sexp-function nil 77 | comment-region-function #'comment-region-default 78 | syntax-propertize-function nil) 79 | (sgml-electric-tag-pair-mode -1)) 80 | 81 | (defvar lisp-markup-syntax-propertize-function 82 | (syntax-propertize-rules 83 | ("\\(<\\)!--" (1 "< b")) 84 | ("--[ \t\n]*\\(>\\)" (1 "> b")) 85 | ("\\(<\\)[?!]" (1 (prog1 "|>" 86 | (sgml-syntax-propertize-inside end))))) 87 | "Function to apply syntax-propertize rules for mixed Lisp and HTML. 88 | 89 | This handles adding the required syntax properties to HTML 90 | comments embedded in Lisp code. This is mostly just stolen from 91 | sgml-mode.") 92 | 93 | (defun lisp-marker-infer-comment-settings () 94 | "Infer the right comment characters when in `lisp-markup-minor-mode'. 95 | 96 | This handles checking if we're in Lisp mode or HTML mode, and 97 | setting `comment-start' and `comment-end' appropriately." 98 | (when lisp-markup-minor-mode ; Having this lets us use this as global advice on `comment-normalize-vars' 99 | (if (lisp-markup-in-html-p) 100 | (setq-local comment-start "") 102 | (setq-local comment-start ";" 103 | comment-end "")))) 104 | 105 | (advice-add 'comment-normalize-vars :before #'lisp-marker-infer-comment-settings) 106 | 107 | (defmacro lisp-markup-with-<>-as-brackets (&rest body) 108 | "Run BODY in a context where ?< and ?> behave as brackets, and ?( 109 | and ?) behave as string delimiters. This is useful to run SGML 110 | functions on code that contains both Lisp and HTML." 111 | (declare (indent 0)) 112 | `(with-syntax-table (make-syntax-table (syntax-table)) 113 | (modify-syntax-entry ?< "(") 114 | (modify-syntax-entry ?> ")") 115 | (modify-syntax-entry 40 "\"") 116 | (modify-syntax-entry 41 "\"") 117 | (progn ,@body))) 118 | 119 | (defmacro lisp-markup-with-sgml-tag-table (&rest body) 120 | "Run BODY in a context where `sgml-tag-syntax-table' is resolved 121 | to be our custom syntax table. This allows us to run SGML 122 | functions which internally change the syntax table without them 123 | getting confused by Lisp code.." 124 | `(let ((sgml-tag-syntax-table lisp-markup-sgml-tag-syntax-table)) 125 | ,@body)) 126 | 127 | ;;; Determining context 128 | ;;; =================== 129 | 130 | (defun lisp-markup-in-html-p () 131 | "Check if point is currently in an HTML context." 132 | (let ((html (lisp-markup-enclosing-html-tag))) 133 | (when html 134 | (let ((lisp (lisp-markup-enclosing-lisp-section))) 135 | (and (<= (car lisp) (car html)) 136 | (<= (cdr html) (cdr lisp))))))) 137 | 138 | (defun lisp-markup-find-enclosing (find-start goto-end not-found) 139 | "Find the nearest enclosing \"section\" defined by FIND-START and GOTO-END. 140 | 141 | This function looks backwards in the buffer to find the start of 142 | the nearest section by calling FIND-START. This function defines 143 | what the start of a section is by moving point to be before the 144 | first character of a section. This will often involve a call to 145 | `search-backward-regexp' or similar. If FIND-START throws an 146 | error the search will end and NOT-FOUND will be returned. 147 | 148 | Once the start of a section has been found, GOTO-END will be 149 | called to move point to the end of this section. If GOTO-END 150 | throws an error, `point-max' will be used as the end value. 151 | 152 | Returns a pair of beginning and end points, or NOT-FOUND." 153 | (save-excursion 154 | (catch 'return 155 | (let ((initial (point))) 156 | (while t 157 | (let* ((start (or (ignore-errors 158 | (funcall find-start) 159 | (while (nth 4 (syntax-ppss)) ; is in a comment 160 | (funcall find-start)) ; so keep looking 161 | (point)) 162 | (throw 'return not-found))) 163 | (end (or (ignore-errors 164 | (funcall goto-end) 165 | (point)) 166 | (throw 'return (cons start (point-max)))))) 167 | (when (and (<= start initial) 168 | (< initial end)) 169 | (throw 'return (cons start end))) 170 | ;; Reset for the next iteration 171 | (goto-char start))))))) 172 | 173 | (defun lisp-markup-enclosing-lisp-section () 174 | "Find the nearest enclosing Lisp section. 175 | 176 | This function looks backwards in the buffer to find the start of 177 | the nearest Lisp section, then looks forwards to find its end. If 178 | no start/end is found, returns the values of `point-min' and 179 | `point-max' as the beginning and end, respectively. 180 | 181 | Returns a pair of beginning and end points." 182 | (lisp-markup-find-enclosing 183 | (lambda () 184 | (search-backward-regexp ",(\\|,@\\|=(")) 185 | (lambda () 186 | (skip-chars-forward "=,@") 187 | (forward-sexp)) 188 | (cons (point-min) (point-max)))) 189 | 190 | (defun lisp-markup-enclosing-html-tag () 191 | "Find the nearest enclosing HTML tag. 192 | 193 | This function looks backwards in the buffer to find the start of 194 | the nearest HTML section, then looks forwards to find its end. 195 | 196 | Returns a pair of beginning and end points. If no end is found, 197 | returns a pair of start and `point-max'. If no start is found, 198 | returns nil." 199 | (lisp-markup-find-enclosing 200 | (lambda () 201 | (search-backward-regexp "<[^/=![:space:]()]")) 202 | (lambda () 203 | (lisp-markup-with-sgml-tag-table 204 | (or (sgml-skip-tag-forward 1) 205 | (error "No end tag found!")))) 206 | nil)) 207 | 208 | ;;; Indentation 209 | ;;; =========== 210 | 211 | (defun lisp-markup-indent-line () 212 | "Indent a line of Lisp or HTML, according to the line's context." 213 | (interactive) 214 | (save-excursion 215 | (lisp-markup-with-sgml-tag-table 216 | (with-syntax-table (if (>= emacs-major-version 28) 217 | lisp-mode-syntax-table 218 | lisp--mode-syntax-table) 219 | (back-to-indentation) 220 | (let ((prev-html (save-excursion 221 | (forward-line -1) 222 | (end-of-line) 223 | (lisp-markup-in-html-p)))) 224 | (cond 225 | ;; closing tag 226 | ((looking-at-p "-as-brackets 262 | (sgml-indent-line))) 263 | ;; lisp indent 264 | (:else 265 | (let ((indent (calculate-lisp-indent))) 266 | (cond 267 | ((and indent (listp indent)) (indent-line-to (car indent))) 268 | (indent (indent-line-to indent)))))))))) 269 | (when (< (point) (save-excursion (back-to-indentation) (point))) 270 | (back-to-indentation))) 271 | 272 | ;;; Comments 273 | ;;; ======== 274 | 275 | (defun lisp-markup-comment-region (beg end &optional arg) 276 | "Comment region in the way you'd expect, depending on the context of BEG." 277 | (save-excursion 278 | (goto-char beg) 279 | (lisp-marker-infer-comment-settings)) 280 | (comment-region-default beg end arg)) 281 | 282 | ;;; Forward/backward by sexp 283 | ;;; ======================== 284 | 285 | (defun lisp-markup-forward-sexp (&optional n interactive) 286 | "Move over the next \"sexp\" in the buffer, which includes an entire HTML tag. 287 | 288 | This mostly tries to guess if the next thing is HTML or Lisp by 289 | looking at the beginning of it. It's not foolproof, but it's 290 | still pretty useful." 291 | (let ((n (or n 1))) 292 | (cond 293 | ((< 0 n) 294 | (if (looking-at-p "[[:space:]\n]*<[^/=\"![:space:]()]") 295 | (lisp-markup-with-sgml-tag-table 296 | (sgml-skip-tag-forward n)) 297 | (let ((forward-sexp-function nil)) 298 | (forward-sexp n interactive)))) 299 | ((< n 0) 300 | (if (save-excursion (let ((whitespace-chars (string-to-list " \t\r\n"))) 301 | (while (member (char-before) whitespace-chars) 302 | (backward-char))) 303 | (backward-char 2) 304 | (looking-at-p "[^[:space:]'()]>")) 305 | (lisp-markup-with-sgml-tag-table 306 | (sgml-skip-tag-backward (- n))) 307 | (let ((forward-sexp-function nil)) 308 | (forward-sexp n interactive))))))) 309 | 310 | ;;; Automatic tag closing 311 | ;;; ===================== 312 | 313 | (defun lisp-markup-html-closed-p () 314 | "Test whether the current HTML tag has a corresponding closing tag. 315 | 316 | This method must be called with point before the opening < of a tag." 317 | (save-excursion 318 | (lisp-markup-with-sgml-tag-table 319 | (when (sgml-skip-tag-forward 1) 320 | (point))))) 321 | 322 | (defun lisp-markup-find-unclosed-tag-name () 323 | "This function only looks backwards to find unclosed tags, and 324 | thus a tag that is closed further forwards in the file will not 325 | be considered as being closed. Hence in an example like this: 326 | 327 |
328 | 329 | | 330 |
331 | 332 | with point at |, \"div\" will be returned." 333 | (let ((html (lisp-markup-enclosing-html-tag))) 334 | (if html 335 | (save-excursion 336 | (goto-char (car html)) 337 | (buffer-substring-no-properties 338 | (+ (point) 1) 339 | (- (search-forward-regexp "[>/[:space:]]") 1))) 340 | (error "No HTML tag found to close")))) 341 | 342 | (defun lisp-markup-html-close-tag () 343 | "Insert a closing tag for the nearest tag before point that is unclosed. 344 | 345 | This function only looks backwards to find unclosed tags, and 346 | thus a tag that is closed further forwards in the file will not 347 | be considered as being closed. Hence in an example like this: 348 | 349 |
350 | 351 | | 352 |
353 | 354 | with point at |, a will be inserted." 355 | (interactive) 356 | (insert "")) 357 | 358 | (defun lisp-markup-/-close-tag () 359 | "Automatically insert a closing tag if this character was typed 360 | after a <. Otherwise, just insert a /." 361 | (interactive) 362 | (insert "/") 363 | (when (save-excursion (backward-char 2) 364 | (looking-at-p "") 367 | (insert ">")) 368 | (lisp-markup-indent-line))) 369 | 370 | (defun lisp-markup--lisp-mode-hook () 371 | "Detect if this Lisp file looks like a markup file, if so enable 372 | the minor mode." 373 | (save-excursion 374 | (goto-char (point-min)) 375 | (when (re-search-forward 376 | "^(\\(markup:enable-reader\\|named-readtables:in-readtable.*markup:syntax\\))" 377 | nil t) 378 | (lisp-markup-minor-mode)))) 379 | 380 | (add-hook 'lisp-mode-hook #'lisp-markup--lisp-mode-hook) 381 | 382 | (provide 'lisp-markup) 383 | ;;; lisp-markup.el ends here 384 | -------------------------------------------------------------------------------- /markup.asd: -------------------------------------------------------------------------------- 1 | ;; Copyright 2019, Modern Interpreters Inc 2 | 3 | (asdf:defsystem #:markup 4 | :description "markup provides a reader-macro to read HTML/XML tags inside of Common Lisp code" 5 | :author "Arnold Noronha " 6 | :license "Apache License, Version 2.0" 7 | :version "0.0.1" 8 | :serial t 9 | :depends-on (#:str 10 | #:alexandria 11 | #:named-readtables 12 | #:trivial-gray-streams) 13 | :components ((:file "stream") 14 | (:file "tags") 15 | (:file "markup") 16 | (:file "optimizer") 17 | (:file "walk") 18 | (:file "all"))) 19 | 20 | (defsystem :markup/tests 21 | :description "Tests for the markup library" 22 | :author "Arnold Noronha " 23 | :license "Apache License, Version 2.0" 24 | :depends-on (:markup 25 | :fiveam) 26 | :serial t 27 | :components ((:file "test-markup") 28 | (:file "test-walk") 29 | (:file "test-optimizer") 30 | (:file "test-stream")) 31 | 32 | :perform (test-op (op system) 33 | (funcall (read-from-string "fiveam:run-all-tests")))) 34 | -------------------------------------------------------------------------------- /markup.lisp: -------------------------------------------------------------------------------- 1 | ;; Copyright 2019, Modern Interpreters Inc 2 | 3 | (uiop:define-package #:markup/markup 4 | (:use #:cl 5 | #:named-readtables) 6 | (:import-from #:alexandria 7 | #:assoc-value) 8 | (:import-from #:markup/stream 9 | #:markup-stream 10 | #:read-so-far 11 | #:wrap-stream) 12 | (:import-from #:markup/tags 13 | #:*void-tags* 14 | #:*standard-names*) 15 | (:export #:read-xml 16 | #:make-xml-tag 17 | #:make-merge-tag 18 | #:write-xml ;; deprecated 19 | #:write-html 20 | #:xml-tag-name 21 | #:xml-tag-attributes 22 | #:unescaped 23 | #:xml-merge-tag-children 24 | #:xml-merge-tag 25 | #:enable-reader 26 | #:write-xml-to-stream ;; deprecated 27 | #:write-html-to-stream 28 | #:format-attr-val 29 | #:deftag 30 | #:undefined-markup-tag-condition 31 | #:merge-tag 32 | #:xml-tag 33 | #:xml-tag-children 34 | #:get-attr 35 | #:write 36 | #:syntax 37 | #:markup-enable-reader 38 | #:read-xml-from-string 39 | #:empty-attribute 40 | #:+empty+ 41 | #:optimize-markup 42 | #:abstract-xml-tag 43 | #:xml-tag-p)) 44 | (in-package #:markup/markup) 45 | 46 | (defmacro enable-reader () 47 | `(named-readtables:in-readtable syntax)) 48 | 49 | #+lispworks 50 | (dspec:define-dspec-class deftag nil 51 | "A markup deftag") 52 | 53 | #+lispworks 54 | (dspec:define-form-parser deftag (name &rest rest) 55 | `(deftag ,name)) 56 | 57 | (defconstant +empty+ 'empty-attribute 58 | "If you use this as an attribute value, it will render as an empty 59 | attribute. For instance, you might have something like this: 60 | 61 | ") 62 | 63 | 64 | (define-condition html-parse-error (error) 65 | ((message :initarg :message) 66 | (stream :initarg :stream) 67 | (last-few-chars :initarg :last-few-chars))) 68 | 69 | (defmethod print-object ((x html-parse-error) stream) 70 | (with-slots (message last-few-chars) x 71 | (if *print-escape* (call-next-method) 72 | (format stream "~a~%Most recent read chars:~%`~a`" 73 | message last-few-chars)))) 74 | 75 | (defun read-tag (stream) 76 | (flet ((peek-next-char () (peek-char nil stream t nil t)) 77 | (read-next-char () (read-char stream t nil t))) 78 | (let ((response nil)) 79 | (block loop 80 | (loop 81 | until 82 | (or 83 | (whitespacep (peek-next-char)) 84 | (eql (peek-next-char) #\/) 85 | (eql (peek-next-char) #\>)) 86 | do 87 | (progn 88 | (push (read-next-char) response) 89 | (when (equalp '(#\- #\- #\!) response) 90 | (return-from loop))))) 91 | (coerce (nreverse response) 'string)))) 92 | 93 | (defun whitespacep (char) 94 | (or 95 | (not (graphic-char-p char)) 96 | (eql char #\Space) 97 | (eql char #\Newline) 98 | (eql char #\Linefeed))) 99 | 100 | (defun read-whitespace (stream) 101 | (flet ((peek-next-char () (peek-char nil stream t nil t)) 102 | (read-next-char () (read-char stream t nil t))) 103 | (loop 104 | while (whitespacep (peek-next-char)) 105 | do (read-next-char)) 106 | (peek-next-char))) 107 | 108 | (defun read-attr-key (stream) 109 | (flet ((peek-next-char () (peek-char nil stream t nil t)) 110 | (read-next-char () (read-char stream t nil t))) 111 | (coerce 112 | (loop 113 | until (or 114 | (eql #\= (peek-next-char)) 115 | (eql #\/ (peek-next-char)) 116 | (eql #\> (peek-next-char))) 117 | 118 | 119 | collect (read-next-char)) 120 | 'string))) 121 | 122 | (defun read-attr-val (stream) 123 | (read-preserving-whitespace stream)) 124 | 125 | 126 | (defun read-attributes (stream) 127 | (flet ((peek-next-char () (peek-char nil stream t nil t)) 128 | (read-next-char () (read-char stream t nil t))) 129 | (read-whitespace stream) 130 | (loop 131 | until (or 132 | (eql (peek-next-char) #\>) 133 | (eql (peek-next-char) #\/)) 134 | collect 135 | (let ((attr-key (read-attr-key stream))) 136 | (cons attr-key 137 | (progn 138 | (let ((next-char (peek-next-char))) 139 | (cond 140 | ((not (eql #\= next-char)) 141 | '+empty+) 142 | (t 143 | (read-next-char) ;; the #\= we peeked at 144 | (let ((ret (read-attr-val stream))) 145 | (read-whitespace stream) 146 | ret)))))))))) 147 | 148 | (defun read-string-from-xml (stream next) 149 | (declare (ignore next)) 150 | (flet ((peek-next-char () (peek-char nil stream t nil t)) 151 | (read-next-char () (read-char stream t nil t))) 152 | (coerce 153 | (loop 154 | until (or 155 | (eql (peek-next-char) #\<) 156 | (eql (peek-next-char) #\,)) 157 | collect (read-next-char)) 158 | 'string))) 159 | 160 | (defun read-comment (stream) 161 | (flet ((peek-next-char () (peek-char nil stream t nil t)) 162 | (read-next-char () (read-char stream t nil t))) 163 | (let ((state 0)) 164 | (coerce 165 | (loop while (< state 3) 166 | collect 167 | (progn 168 | (cond 169 | ((eql (peek-next-char) #\-) 170 | (setf state (min (+ 1 state) 2))) 171 | ((and 172 | (eql (peek-next-char) #\>) 173 | (eql state 2)) 174 | (setf state 3)) 175 | (t 176 | (setf state 0))) 177 | (read-next-char))) 178 | 'string)))) 179 | 180 | (defun make-list-merge-tag (list) 181 | (make-merge-tag (mapcar #'make-escaped list))) 182 | 183 | (defun read-xml-after-bracket (stream char) 184 | (declare (ignore char)) 185 | (flet ((peek-next-char () (peek-char nil stream t nil t)) 186 | (read-next-char () (read-char stream t nil t)) 187 | (parse-error (&rest args) 188 | (error 'html-parse-error 189 | :message (apply 'format nil args) 190 | :stream stream 191 | :last-few-chars (last-few-chars stream)))) 192 | (let ((name (read-tag stream)) 193 | (ends-with-slash nil) 194 | children 195 | attributes) 196 | 197 | (if (string= name "") 198 | (return-from read-xml-after-bracket (intern "<" "CL"))) 199 | 200 | (if (string= name "=") 201 | (return-from read-xml-after-bracket (intern "<=" "CL"))) 202 | 203 | (if (string= name "!--") 204 | (return-from read-xml-after-bracket (list 'unescaped (concatenate 'string "" 296 | (markup:write-html <:body> ))))) 297 | 298 | (test comments-without-prefix-space 299 | (with-fixture state () 300 | (is (equal 301 | " " 302 | (markup:write-html <:body> ))))) 303 | 304 | (test comments-without-space 305 | (with-fixture state () 306 | (is (equal 307 | " " 308 | (markup:write-html <:body> ))))) 309 | 310 | (test comments-with-multiple-hyphens 311 | (with-fixture state () 312 | (is (equal 313 | " " 314 | (markup:write-html <:body> ))))) 315 | 316 | 317 | (test />-without-space 318 | (with-fixture state () 319 | (is (equal 320 | "" 321 | (markup:write-html <:body/>))))) 322 | 323 | (test undefined-tag-signals-condition 324 | (with-fixture state () 325 | ;; this convoluted eval avoids a style-warning while running the tests 326 | (signals undefined-markup-tag-condition (eval ')))) 327 | 328 | (test default-escaping 329 | (with-fixture state () 330 | (is (equal 331 | "News & Events" 332 | (markup:write-html News & Events 333 | ))))) 334 | 335 | (test but-escapes-inline-commas 336 | (with-fixture state () 337 | (let ((val "News & Events")) 338 | (is (equal 339 | "News & Events" 340 | (markup:write-html ,(progn val))))))) 341 | 342 | (test utf-8 343 | (with-fixture state () 344 | (is (equal 345 | "

they’re

" 346 | (markup:write-html

they’re

))))) 347 | 348 | (test write-empty-attribute 349 | (with-fixture state () 350 | (is (equal 351 | "" 352 | (markup:write-html <:foo car/>))))) 353 | 354 | (defun compiled-expr (val) 355 | <:option selected=val />) 356 | 357 | (test write-nil-attribute () 358 | (with-fixture state () 359 | (let ((val nil)) 360 | (is (equal "" 361 | (markup:write-html (compiled-expr val)))) 362 | (is (equal "" 363 | (markup:write-html (compiled-expr "car"))))))) 364 | 365 | (test |escaping-inside-,@| 366 | (let ((val "")) 367 | (is 368 | (equal 369 | "<script>alert(1)</script>" 370 | (markup:write-html 371 | ,(progn val)))) 372 | (is 373 | (equal 374 | "<script>alert(1)</script>" 375 | (markup:write-html 376 | ,@(list val)))) 377 | (is 378 | (equal 379 | "<script>alert(1)</script>hello" 380 | (markup:write-html 381 | ,@(list val hello)))) 382 | (is 383 | (equal 384 | "hello world" 385 | (markup:write-html 386 | ,@(list hello ,@ (list "world"))))))) 387 | 388 | (markup:deftag xyz1 (children) 389 | ,@(progn children)) 390 | 391 | (test a-weird-complex-interaction-of-escapes 392 | (let ((var "foobar")) 393 | (is 394 | (equal "foobar" 395 | (markup:write-html 396 | ,(progn var)))))) 397 | 398 | (test unescaped-remains-unescaped-interaction-of-escapes 399 | (let ((var "

")) 400 | (is 401 | (equal "

" 402 | (markup:write-html 403 | ,(markup:unescaped var)))) 404 | (is 405 | (equal "

" 406 | (markup:write-html 407 | ,(markup:unescaped var)))))) 408 | -------------------------------------------------------------------------------- /test-optimizer.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :markup/test-optimizer 2 | (:use #:cl 3 | #:fiveam) 4 | (:import-from #:markup/markup 5 | #:make-toplevel-node 6 | #:make-xml-tag 7 | #:optimize-markup) 8 | (:import-from #:markup/optimizer 9 | #:make-lazy-xml-tag) 10 | (:local-nicknames (#:a #:alexandria))) 11 | (in-package :markup/test-optimizer) 12 | 13 | 14 | (def-suite* :markup/test-optimizer :in :markup) 15 | 16 | (def-fixture state () 17 | (&body)) 18 | 19 | (test happy-path 20 | (with-fixture state () 21 | (is (equal '(let nil 22 | (make-lazy-xml-tag 23 | () 24 | (div) 25 | (make-xml-tag 'div :attributes nil :children nil :unused nil))) 26 | (optimize-markup '(make-xml-tag 'div :children nil :attributes nil :unused nil)))))) 27 | 28 | (test simple-escape 29 | (with-fixture state () 30 | (is (equal '(let ((r1 (format nil "~a" car))) 31 | (make-lazy-xml-tag 32 | (r1) 33 | (div) 34 | (make-xml-tag 'div :attributes nil :children (list r1) :unused nil))) 35 | (optimize-markup '(make-xml-tag 'div :children (list 36 | (format nil "~a" car)) 37 | :attributes nil 38 | :unused nil)))))) 39 | 40 | (test escaping-multiple 41 | (with-fixture state () 42 | (is (equal '(let ((r1 (format nil "~a" car)) 43 | (r2 bar)) 44 | (make-lazy-xml-tag 45 | (r1 r2) 46 | (span) 47 | (make-xml-tag 'span :attributes nil :children (list r1 r2) :unused nil))) 48 | (optimize-markup '(make-xml-tag 'span :children (list 49 | (format nil "~a" car) 50 | bar) 51 | :attributes nil 52 | :unused nil)))))) 53 | 54 | (test escaping-attributes 55 | (with-fixture state () 56 | (is (equal '(let ((r1 (format nil "~a" car))) 57 | (make-lazy-xml-tag 58 | (r1) 59 | (input) 60 | (make-xml-tag 'input :attributes (list (cons "car" r1)) :children nil 61 | :unused nil))) 62 | (optimize-markup '(make-xml-tag 'input :children nil 63 | :attributes (list (cons "car" (format nil "~a" car))) 64 | :unused nil)))))) 65 | 66 | (test attributes-get-the-first-register 67 | (with-fixture state () 68 | (is (equal '(let ((r1 (format nil "~a" car)) 69 | (r2 bar)) 70 | (make-lazy-xml-tag 71 | (r1 r2) 72 | (div) 73 | (make-xml-tag 'div :attributes (list (cons "car" r1)) :children (list r2) 74 | :unused nil))) 75 | (optimize-markup '(make-xml-tag 'div :children (list bar) 76 | :attributes (list (cons "car" (format nil "~a" car))) 77 | :unused nil)))))) 78 | 79 | (test if-the-tag-is-not-builtin-then-we-move-it-to-register 80 | (with-fixture state () 81 | (is (equal '(let ((r1 (make-xml-tag 'foo :attributes nil :children nil :unused nil))) 82 | r1) 83 | (optimize-markup '(make-xml-tag 'foo :children nil :attributes nil :unused nil)))))) 84 | 85 | (test get-topleveled-on-children 86 | (with-fixture state () 87 | (is (equal '(let ((r1 (make-xml-tag 'foo 88 | :attributes nil 89 | :children (list 90 | (make-toplevel-node 91 | "foo")) 92 | :unused nil))) 93 | r1) 94 | (optimize-markup 95 | '(make-xml-tag 'foo 96 | :children (list "foo") 97 | :attributes nil 98 | :unused nil)))))) 99 | -------------------------------------------------------------------------------- /test-stream.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :markup.test-stream 2 | (:use :cl 3 | :fiveam 4 | :markup) 5 | (:import-from #:markup/stream 6 | #:wrap-stream 7 | #:read-so-far) 8 | (:export)) 9 | (in-package :markup.test-stream) 10 | 11 | (def-suite* :markup.test-stream) 12 | 13 | (test simple-flow 14 | (let ((stream (make-string-input-stream "foobar car war"))) 15 | (let ((copy (wrap-stream stream))) 16 | (is (equal "" (read-so-far copy))) 17 | (read-char copy) 18 | (read-char copy) 19 | (read-char copy) 20 | 21 | (is (equal "foo" (read-so-far copy))) 22 | (read-char copy) 23 | 24 | (is (equal "foob" (read-so-far copy))) 25 | (is (equal #\a (peek-char nil copy))) 26 | (is (equal "foob" (read-so-far copy)))))) 27 | -------------------------------------------------------------------------------- /test-walk.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:markup/test-walk 2 | (:use #:cl 3 | #:markup/walk 4 | #:markup/markup 5 | #:fiveam)) 6 | (in-package #:markup/test-walk) 7 | 8 | (markup:enable-reader) 9 | 10 | (def-suite* :markup.test-walk) 11 | 12 | (test identity-walk 13 | (is (equal 14 | (write-html

foobar

) 15 | (write-html (walk

foobar

'identity))))) 16 | 17 | (test simple-replace 18 | (is (equal 19 | (write-html

foobar

) 20 | (write-html (walk

foobar

21 | (lambda (x) 22 | (add-attrs x :foo "2"))))))) 23 | 24 | (test check-name 25 | (is (equal :h1 (xml-tag-name

hello

)))) 26 | 27 | (test replace-in-inner-place 28 | (is (equal 29 | (write-html fdfd

foobar

) 30 | (write-html (walk fdfd

foobar

 31 | (lambda (x) 32 | (cond 33 | ((equal :h1 (xml-tag-name x)) 34 | (add-attrs x :foo "2")) 35 | (t 36 | x)))))))) 37 | 38 | 39 | (test replace-in-with-comma 40 | (is (equal 41 | (write-html fdfd

foobar

) 42 | (write-html (walk fdfd,(progn

foobar

) 43 | (lambda (x) 44 | (cond 45 | ((equal :h1 (xml-tag-name x)) 46 | (add-attrs x :foo "2")) 47 | (t 48 | x)))))))) 49 | -------------------------------------------------------------------------------- /walk.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:markup/walk 2 | (:use #:cl) 3 | (:export #:walk 4 | #:add-attrs) 5 | (:import-from #:markup/markup 6 | #:unescaped-string 7 | #:escaped-string 8 | #:make-xml-tag 9 | #:make-xml-merge-tag 10 | #:xml-merge-tag 11 | #:xml-tag-name 12 | #:xml-merge-tag-children 13 | #:xml-tag-children 14 | #:abstract-xml-tag 15 | #:xml-tag-attributes)) 16 | (in-package #:markup/walk) 17 | 18 | (defgeneric walk (tree fn) 19 | (:documentation "Walk the tree, giving you the option to transform 20 | each element")) 21 | 22 | (defmethod walk (tree fn) 23 | ;; do nothin 24 | (error "unexpected ~S" tree)) 25 | 26 | (defmethod walk ((tree string) fn) 27 | tree) 28 | 29 | (defmethod walk ((tree unescaped-string) fn) 30 | tree) 31 | 32 | (defmethod walk ((tree escaped-string) fn) 33 | tree) 34 | 35 | (Defmethod walk ((tree xml-merge-tag) fn) 36 | (make-xml-merge-tag 37 | :children (loop for child in (xml-merge-tag-children tree) collect 38 | (walk child fn)))) 39 | 40 | (defmethod walk ((tree list) fn) 41 | (loop for x in tree collect 42 | (walk x fn))) 43 | 44 | (Defmethod walk ((tree abstract-xml-tag) fn) 45 | (let ((ret (funcall fn tree))) 46 | (make-xml-tag (xml-tag-name ret) 47 | :attributes (xml-tag-attributes ret) 48 | :children (walk (xml-tag-children ret) fn)))) 49 | 50 | (defmethod add-attrs ((tag abstract-xml-tag) &rest args &key &allow-other-keys) 51 | (let ((attr (xml-tag-attributes tag))) 52 | (dolist (item (alexandria:plist-alist args)) 53 | (destructuring-bind (key . value) item 54 | (setf (alexandria:assoc-value attr (string-downcase (string key))) value))) 55 | (make-xml-tag (xml-tag-name tag) 56 | :attributes attr 57 | :children (xml-tag-children tag)))) 58 | --------------------------------------------------------------------------------