├── .gitattributes ├── .gitignore ├── server ├── package.lisp ├── data │ ├── README.md │ ├── file.ctml │ ├── list.ctml │ ├── nav.ctml │ ├── error.ctml │ ├── search.js │ ├── stylesheet.css │ ├── Length.min.js │ ├── stylesheet.lass │ ├── github.css │ └── view.js ├── staple-server.asd ├── README.md ├── documentation.lisp └── server.lisp ├── markless.lisp ├── markdown.lisp ├── .github └── workflows │ ├── documentation.yml │ └── build.yml ├── README.md ├── staple-markless.asd ├── staple-restructured-text.asd ├── staple-markdown.asd ├── staple-package-recording.asd ├── README.markdown.md ├── restructured-text.lisp ├── README.markless.md ├── README.restructured-text.md ├── LICENSE ├── parser ├── package.lisp ├── staple-code-parser.asd ├── environment.lisp ├── README.md ├── to-definitions.lisp ├── standard-forms.lisp └── documentation.lisp ├── staple.asd ├── transform.lisp ├── default ├── default.js ├── default.css ├── default.lass └── default.ctml ├── staple.ext.lisp ├── package.lisp ├── recording.lisp ├── action.yml ├── code-format.lisp ├── project.lisp ├── main.lisp ├── xref.lisp ├── clip.lisp ├── inference.lisp ├── docs ├── staple-markdown │ ├── index.html │ └── logo.svg ├── staple-restructured-text │ ├── index.html │ └── logo.svg ├── staple-markless │ ├── index.html │ └── logo.svg ├── logo.svg ├── staple-server │ └── logo.svg ├── staple-code-parser │ └── logo.svg └── staple-package-recording │ └── logo.svg └── logo.svg /.gitattributes: -------------------------------------------------------------------------------- 1 | doc/ linguist-vendored -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | staple.run 2 | staple.o 3 | staple.exe 4 | -------------------------------------------------------------------------------- /server/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:staple-server 2 | (:nicknames #:org.shirakumo.staple.server) 3 | (:use #:cl) 4 | (:export 5 | #:*tmpdir* 6 | #:cache-system 7 | #:clear-cache 8 | #:start 9 | #:stop)) 10 | -------------------------------------------------------------------------------- /markless.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.staple) 2 | 3 | (define-source-compiler (:markless "mess") (input) 4 | (cl-markless:output (cl-markless:parse input T) 5 | :target (plump-dom:make-root) 6 | :format 'cl-markless-plump:plump)) 7 | -------------------------------------------------------------------------------- /server/data/README.md: -------------------------------------------------------------------------------- 1 | ## Foreign Sources 2 | The following files were copied: 3 | 4 | * [highlight-lisp.js](https://github.com/orthecreedence/highlight-lisp) 5 | * [github.css](https://github.com/orthecreedence/highlight-lisp) 6 | * [Length.min.js](https://github.com/heygrady/Units) 7 | -------------------------------------------------------------------------------- /markdown.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.staple) 2 | 3 | (define-source-compiler (:markdown "md") (input) 4 | (let ((3bmd-code-blocks:*code-blocks* T) 5 | (#.(or (find-symbol (string '#:*GENERATE-HEADER-IDS*) :3BMD) 6 | (gensym "stub")) T)) 7 | (with-output-to-string (out) 8 | (3bmd:parse-string-and-print-to-stream 9 | input out)))) 10 | -------------------------------------------------------------------------------- /.github/workflows/documentation.yml: -------------------------------------------------------------------------------- 1 | name: documentation 2 | on: 3 | push: 4 | branches: 5 | - master 6 | permissions: 7 | pages: write 8 | id-token: write 9 | jobs: 10 | publish: 11 | runs-on: ubuntu-latest 12 | steps: 13 | - uses: actions/checkout@v1 14 | - uses: shinmera/staple@v2.0.0 15 | with: 16 | gh-pages: true 17 | dist: http://dist.shirakumo.org/shirakumo.txt 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # This repository has [moved](https://shinmera.com/projects/staple)! 2 | Due to Microsoft's continued enshittification of the platform this repository has been moved to [Codeberg](https://shinmera.com/projects/staple) in August of 2025. It will not receive further updates or patches. **Issues and pull requests will not be looked at here either**, please submit your patches and issue tickets on Codeberg, or send them directly via good old email patches to [shirakumo@tymoon.eu](mailto:shirakumo@tymoon.eu). 3 | 4 | Thanks. -------------------------------------------------------------------------------- /staple-markless.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem staple-markless 2 | :version "1.0.0" 3 | :license "zlib" 4 | :author "Yukari Hafner " 5 | :maintainer "Yukari Hafner " 6 | :description "Markdown processing support for Staple" 7 | :homepage "https://shinmera.com/docs/staple/" 8 | :bug-tracker "https://shinmera.com/project/staple/issues" 9 | :source-control (:git "https://shinmera.com/project/staple.git") 10 | :serial T 11 | :components ((:file "markless")) 12 | :depends-on (:staple 13 | :cl-markless-plump)) 14 | -------------------------------------------------------------------------------- /staple-restructured-text.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem staple-restructured-text 2 | :version "1.0.0" 3 | :license "zlib" 4 | :author "Yukari Hafner " 5 | :maintainer "Yukari Hafner " 6 | :description "Markdown processing support for Staple" 7 | :homepage "https://shinmera.com/docs/staple/" 8 | :bug-tracker "https://shinmera.com/project/staple/issues" 9 | :source-control (:git "https://shinmera.com/project/staple.git") 10 | :serial T 11 | :components ((:file "restructured-text")) 12 | :depends-on (:staple 13 | :docutils)) 14 | -------------------------------------------------------------------------------- /staple-markdown.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem staple-markdown 2 | :version "1.0.0" 3 | :license "zlib" 4 | :author "Yukari Hafner " 5 | :maintainer "Yukari Hafner " 6 | :description "Markdown processing support for Staple" 7 | :homepage "https://shinmera.com/docs/staple/" 8 | :bug-tracker "https://shinmera.com/project/staple/issues" 9 | :source-control (:git "https://shinmera.com/project/staple.git") 10 | :serial T 11 | :components ((:file "markdown")) 12 | :depends-on (:staple 13 | :3bmd 14 | :3bmd-ext-code-blocks)) 15 | -------------------------------------------------------------------------------- /staple-package-recording.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem staple-package-recording 2 | :name "Staple System Package Recorder" 3 | :version "1.0.1" 4 | :license "zlib" 5 | :author "Yukari Hafner " 6 | :maintainer "Yukari Hafner " 7 | :description "Collects information about packages being defined with an ASDF system." 8 | :homepage "https://shinmera.com/docs/staple/" 9 | :bug-tracker "https://shinmera.com/project/staple/issues" 10 | :source-control (:git "https://shinmera.com/project/staple.git") 11 | :serial T 12 | :components ((:file "recording")) 13 | :depends-on ()) 14 | -------------------------------------------------------------------------------- /README.markdown.md: -------------------------------------------------------------------------------- 1 | ## About 2 | This system adds support for Markdown syntax in both documents and docstrings. When this system is loaded, Staple will automatically scan for documents with the ending `md` to use as primary documents on inferred pages. It also adds the source-compiler `:markdown` that can be used to markup documentation source. 3 | 4 | To use Markdown for docstrings as well, use a customisation like this on your page type: 5 | 6 | (defmethod staple:format-documentation ((docstring string) (page my-page)) 7 | (let ((*package* (first (staple:packages page)))) 8 | (staple:markup-code-snippets-ignoring-errors 9 | (staple:compile-source docstring :markdown)))) 10 | -------------------------------------------------------------------------------- /restructured-text.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.staple) 2 | 3 | (defclass docutils-writer (docutils.writer.html:html-writer) 4 | () 5 | (:default-initargs :parts '(docutils.writer.html:body-pre-docinfo body))) 6 | 7 | (defmethod docutils:visit-node ((writer docutils-writer) (document docutils:document)) 8 | (setf (slot-value writer 'docutils:parts) 9 | '(docutils.writer.html:body-pre-docinfo body))) 10 | 11 | (define-source-compiler (:restructured-text "rst") (input) 12 | (docutils:register-settings-spec '((:generator NIL) 13 | (:datestamp NIL))) 14 | (docutils:write-document 15 | (make-instance 'docutils-writer) 16 | (docutils:read-rst input) 17 | 'string)) 18 | -------------------------------------------------------------------------------- /README.markless.md: -------------------------------------------------------------------------------- 1 | ## About 2 | This system adds support for [Markless](https://shirakumo.github.io/markless) syntax in both documents and docstrings. When this system is loaded, Staple will automatically scan for documents with the ending `mess` to use as primary documents on inferred pages. It also adds the source-compiler `:markless` that can be used to markup documentation source. 3 | 4 | To use Markless for docstrings as well, use a customisation like this on your page type: 5 | 6 | (defmethod staple:format-documentation ((docstring string) (page my-page)) 7 | (let ((*package* (first (staple:packages page)))) 8 | (staple:markup-code-snippets-ignoring-errors 9 | (staple:compile-source docstring :markless)))) 10 | -------------------------------------------------------------------------------- /server/data/file.ctml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 |
10 |
11 |

12 |
13 |
14 |
15 | 18 | 19 | 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /server/staple-server.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem staple-server 2 | :version "2.0.0" 3 | :license "zlib" 4 | :author "Yukari Hafner " 5 | :maintainer "Yukari Hafner " 6 | :description "An interactive documentation viewer using Staple" 7 | :homepage "https://shinmera.com/docs/staple/" 8 | :bug-tracker "https://shinmera.com/project/staple/issues" 9 | :source-control (:git "https://shinmera.com/project/staple.git") 10 | :serial T 11 | :components ((:file "package") 12 | (:file "server") 13 | (:file "documentation")) 14 | :depends-on (:staple-markdown 15 | :staple-markless 16 | :hunchentoot 17 | :documentation-utils 18 | :dissect)) 19 | -------------------------------------------------------------------------------- /README.restructured-text.md: -------------------------------------------------------------------------------- 1 | ## About 2 | This system adds support for [ReStructuredText](http://docutils.sourceforge.net/rst.html) syntax in both documents and docstrings. When this system is loaded, Staple will automatically scan for documents with the ending `rst` to use as primary documents on inferred pages. It also adds the source-compiler `:restructured-text` that can be used to markup documentation source. 3 | 4 | To use ReStructuredText for docstrings as well, use a customisation like this on your page type: 5 | 6 | (defmethod staple:format-documentation ((docstring string) (page my-page)) 7 | (let ((*package* (first (staple:packages page)))) 8 | (staple:markup-code-snippets-ignoring-errors 9 | (staple:compile-source docstring :restructured-text)))) 10 | -------------------------------------------------------------------------------- /server/data/list.ctml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | System List 5 | 6 | 7 | 8 |
9 |
10 |

System List

11 |
12 | 13 |
    14 |
  • 15 |
    16 |

    Name

    17 |

    Description

    18 |
    19 |
    • 20 |
21 |
22 | 23 | 24 | 25 | -------------------------------------------------------------------------------- /server/data/nav.ctml: -------------------------------------------------------------------------------- 1 | 31 | -------------------------------------------------------------------------------- /server/data/error.ctml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Error 5 | 6 | 7 | 8 |
9 |
10 |

Error

11 |
12 |

13 | Description 14 |

15 |
    16 |
  1. call 17 |
      18 |
    1. CALL
    2. 19 |
20 |
21 | 22 | 23 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 Yukari Hafner 2 | 3 | This software is provided 'as-is', without any express or implied 4 | warranty. In no event will the authors be held liable for any damages 5 | arising from the use of this software. 6 | 7 | Permission is granted to anyone to use this software for any purpose, 8 | including commercial applications, and to alter it and redistribute it 9 | freely, subject to the following restrictions: 10 | 11 | 1. The origin of this software must not be misrepresented; you must not 12 | claim that you wrote the original software. If you use this software 13 | in a product, an acknowledgment in the product documentation would be 14 | appreciated but is not required. 15 | 2. Altered source versions must be plainly marked as such, and must not be 16 | misrepresented as being the original software. 17 | 3. This notice may not be removed or altered from any source distribution. 18 | -------------------------------------------------------------------------------- /server/data/search.js: -------------------------------------------------------------------------------- 1 | window.addEventListener("DOMContentLoaded", function(){ 2 | var filterChildren = function(container, filter){ 3 | [].forEach.call(container.children, function(child){ 4 | if(child.textContent.indexOf(filter) !== -1){ 5 | child.style.display = null; 6 | } else { 7 | child.style.display = "none"; 8 | } 9 | }); 10 | }; 11 | 12 | var registerSearch = function(search, list){ 13 | list = list || search.nextElementSibling; 14 | search.addEventListener("keyup", function(ev){ 15 | filterChildren(list, search.value); 16 | }); 17 | filterChildren(list, search.value); 18 | }; 19 | 20 | var registerAllSearches = function(root){ 21 | root = root || document; 22 | [].forEach.call(root.querySelectorAll(".search"), registerSearch); 23 | }; 24 | 25 | registerAllSearches(); 26 | }); 27 | -------------------------------------------------------------------------------- /parser/package.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:staple-code-parser 3 | (:nicknames #:org.shirakumo.staple.code-parser) 4 | (:use #:cl #:alexandria) 5 | (:local-nicknames 6 | (#:cst #:concrete-syntax-tree)) 7 | ;; environment.lisp 8 | (:export 9 | #:environment 10 | #:lookup 11 | #:augment-environment! 12 | #:augmented-environment) 13 | ;; to-definitions.lisp 14 | (:export 15 | #:find-definitions 16 | #:define-definition-resolver 17 | #:tie-to-source 18 | #:sub-results 19 | #:define-sub-results 20 | #:parse-result->definition-list) 21 | ;; walker.lisp 22 | (:export 23 | #:placeholder 24 | #:placeholder-name 25 | #:placeholder-package 26 | #:placeholder-intern 27 | #:walk 28 | #:walk-bindings 29 | #:walk-implicit-progn 30 | #:walk-body 31 | #:walk-lambda-like 32 | #:walk-atom 33 | #:walk-form 34 | #:define-walk-compound-form 35 | #:define-walker-form 36 | #:read-toplevel 37 | #:parse)) 38 | -------------------------------------------------------------------------------- /parser/staple-code-parser.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem staple-code-parser 2 | :version "1.0.0" 3 | :license "zlib" 4 | :author "Yukari Hafner " 5 | :maintainer "Yukari Hafner " 6 | :description "A code parser tool for documentation markup" 7 | :homepage "https://shinmera.com/docs/staple/" 8 | :bug-tracker "https://shinmera.com/project/staple/issues" 9 | :source-control (:git "https://shinmera.com/project/staple.git") 10 | :serial T 11 | :components ((:file "package") 12 | (:file "environment") 13 | (:file "walker") 14 | (:file "special-forms") 15 | (:file "standard-forms") 16 | (:file "to-definitions") 17 | (:file "documentation")) 18 | :depends-on (:alexandria 19 | :definitions 20 | :concrete-syntax-tree 21 | :concrete-syntax-tree-lambda-list 22 | :concrete-syntax-tree-destructuring 23 | :eclector 24 | :eclector-concrete-syntax-tree 25 | :documentation-utils)) 26 | -------------------------------------------------------------------------------- /server/data/stylesheet.css: -------------------------------------------------------------------------------- 1 | html{font-family:sans-serif;font-size:14pt;}html body{padding:0;margin:0 auto 0 auto;max-width:1024px;overflow-y:scroll;}html body a{text-decoration:none;}html body a[href]{color:#0055AA;}html body a[href]:hover{color:#0088EE;}article header h1{font-size:2em;text-align:center;}.system-list .search{width:100%;box-sizing:border-box;font-size:inherit;}.system-list ul{list-style:none;padding:0;}.system-list ul h2{text-indent:1em;margin:0;padding:0;}.condition header{background:#FF3333;}.condition .description{font-size:1.5em;}.condition .frame{margin:0.2em;font-family:monospace;}.condition .frame .arguments{padding:0;display:inline;list-style:none;}.condition .frame .arguments li{display:inline;}.condition .frame .argument:hover{background:#DDDDDD;}.condition .frame:before{content:"(";}.condition .frame:after{content:")";}#staple-server-nav{position:fixed;bottom:0;left:0;background:#0055AA;display:flex;align-items:stretch;font-weight:bold;height:30px;font-size:14pt;}#staple-server-nav a{color:white;padding:0.2em;}#staple-server-nav a:hover{background:#0088EE;}#staple-server-nav:after{content:"";position:absolute;right:-30px;border-top:30px solid transparent;border-left:30px solid #0055AA;} -------------------------------------------------------------------------------- /server/data/Length.min.js: -------------------------------------------------------------------------------- 1 | (function(t,e,o){"use strict";function r(t,e,r,p){r=r||"width";var n,l,m,c=(e.match(s)||[])[2],f="px"===c?1:d[c+"toPx"],u=/r?em/i;if(f||u.test(c)&&!p)t=f?t:"rem"===c?i:"fontSize"===r?t.parentNode||t:t,f=f||parseFloat(a(t,"fontSize")),m=parseFloat(e)*f;else{n=t.style,l=n[r];try{n[r]=e}catch(x){return 0}m=n[r]?parseFloat(a(t,r)):0,n[r]=l!==o?l:null}return m}function a(t,e){var o,n,i,l,d,c=/^top|bottom/,f=["paddingTop","paddingBottom","borderTop","borderBottom"],u=4;if(o=m?m(t)[e]:(n=t.style["pixel"+e.charAt(0).toUpperCase()+e.slice(1)])?n+"px":"fontSize"===e?r(t,"1em","left",1)+"px":t.currentStyle[e],i=(o.match(s)||[])[2],"%"===i&&p)if(c.test(e)){for(l=(d=t.parentNode||t).offsetHeight;u--;)l-=parseFloat(a(d,f[u]));o=parseFloat(o)/100*l+"px"}else o=r(t,o);else("auto"===o||i&&"px"!==i)&&m?o=0:i&&"px"!==i&&!m&&(o=r(t,o)+"px");return o}var p,n=e.createElement("test"),i=e.documentElement,l=e.defaultView,m=l&&l.getComputedStyle,s=/^(-?[\d+\.\-]+)([a-z]+|%)$/i,d={},c=[1/25.4,1/2.54,1/72,1/6],f=["mm","cm","pt","pc","in","mozmm"],u=6;for(i.appendChild(n),m&&(n.style.marginTop="1%",p="1%"===m(n).marginTop);u--;)d[f[u]+"toPx"]=c[u]?c[u]*d.inToPx:r(n,"1"+f[u]);i.removeChild(n),n=o,t.Length={toPx:r}})(this,this.document); 2 | /* 3 | //@ sourceMappingURL=Length.min.js.map 4 | */ 5 | -------------------------------------------------------------------------------- /staple.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem staple 2 | :version "2.0.0" 3 | :license "zlib" 4 | :author "Yukari Hafner " 5 | :maintainer "Yukari Hafner " 6 | :description "A tool to generate documentation about Lisp projects through an HTML template." 7 | :homepage "https://shinmera.com/docs/staple/" 8 | :bug-tracker "https://shinmera.com/project/staple/issues" 9 | :source-control (:git "https://shinmera.com/project/staple.git") 10 | :serial T 11 | :components ((:file "package") 12 | (:file "toolkit") 13 | (:file "xref") 14 | (:file "transform") 15 | (:file "code-format") 16 | (:file "clip") 17 | (:file "page") 18 | (:file "project") 19 | (:file "inference") 20 | (:file "documentation")) 21 | :depends-on (:staple-package-recording 22 | :staple-code-parser 23 | :babel 24 | :clip 25 | :cl-ppcre 26 | :definitions 27 | :pathname-utils 28 | :language-codes 29 | :documentation-utils)) 30 | 31 | (asdf:defsystem staple/standalone 32 | :components ((:file "main")) 33 | :depends-on (:staple :staple-markless :staple-markdown :staple-restructured-text) 34 | :build-operation "program-op" 35 | :build-pathname #+win32 "staple" 36 | #+linux "staple.run" 37 | #-(or win32 linux) "staple.o" 38 | :entry-point "staple::main") 39 | -------------------------------------------------------------------------------- /server/README.md: -------------------------------------------------------------------------------- 1 | ## About Staple-Server 2 | This is a live browser variant of Staple, giving you an immediate way of viewing documentation for all currently loaded systems. 3 | 4 | ## How To 5 | Load `staple-server` and start it up: 6 | 7 | (staple-server:start) 8 | 9 | It should print the address of the server to your REPL. Simply paste it into your browser and you should be greeted with a systems index. The documentation for each system is generated on demand, so the first time you click on a system, it might take a bit to load it. 10 | 11 | When you're done and want to stop the server, you can simply run 12 | 13 | (staple-server:stop) 14 | 15 | The server keeps a cache of generated documentation in the system's temporary directory, so the cache will be automatically deleted once you reboot. If you would like to delete the cache immediately, you can run `clear-cache`. 16 | 17 | ## Assumptions About Generated Documentation 18 | The server makes some assumptions about how the documentation of a system is generated. If the system does not customise staple, this is no problem. However, for systems that might customise it a lot, these assumptions might matter. The assumptions are as follows: 19 | 20 | * The documentation output is HTML files. 21 | * The links within the HTML are either relative or `file://` URLs. 22 | * All files generated by the documentation are within the `:output-directory`. 23 | * There is an `index.html` file directly within the `:output-directory` that shows the entry page for the system's documentation. 24 | -------------------------------------------------------------------------------- /server/data/stylesheet.lass: -------------------------------------------------------------------------------- 1 | (html 2 | :font-family sans-serif 3 | :font-size 14pt 4 | (body 5 | :padding 0 6 | :margin 0 auto 0 auto 7 | :max-width 1024px 8 | :overflow-y scroll 9 | (a 10 | :text-decoration none) 11 | (a[href] 12 | :color (hex 0055AA)) 13 | ((:and a[href] :hover) 14 | :color (hex 0088EE)))) 15 | 16 | (article 17 | (header 18 | (h1 :font-size 2em 19 | :text-align center))) 20 | 21 | (.system-list 22 | (.search 23 | :width 100% 24 | :box-sizing border-box 25 | :font-size inherit) 26 | (ul 27 | :list-style none 28 | :padding 0 29 | (h2 30 | :text-indent 1em 31 | :margin 0 :padding 0))) 32 | 33 | (.condition 34 | (header 35 | :background (hex FF3333)) 36 | (.description 37 | :font-size 1.5em) 38 | (.frame 39 | :margin 0.2em 40 | :font-family monospace 41 | (.arguments 42 | :padding 0 43 | :display inline 44 | :list-style none 45 | (li :display inline)) 46 | ((:and .argument :hover) 47 | :background (hex DDDDDD))) 48 | ((:and .frame :before) :content "(") 49 | ((:and .frame :after) :content ")")) 50 | 51 | ("#staple-server-nav" 52 | :position fixed 53 | :bottom 0 :left 0 54 | :background (hex 0055AA) 55 | :display flex 56 | :align-items stretch 57 | :font-weight bold 58 | :height 30px 59 | :font-size 14pt 60 | (a :color white 61 | :padding 0.2em) 62 | ((:and a :hover) 63 | :background (hex 0088EE))) 64 | ("#staple-server-nav:after" 65 | :content "" 66 | :position absolute 67 | :right -30px 68 | :border-top 30px solid transparent 69 | :border-left 30px solid (hex 0055AA)) 70 | -------------------------------------------------------------------------------- /parser/environment.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.staple.code-parser) 2 | 3 | (defclass environment () 4 | ((parent :initarg :parent :initform NIL :reader parent) 5 | (namespaces :initform (make-hash-table :test 'eq) :reader namespaces))) 6 | 7 | (defun namespace (namespace environment) 8 | (gethash namespace (namespaces environment))) 9 | 10 | (defun ensure-namespace (namespace environment) 11 | (ensure-gethash namespace (namespaces environment) 12 | (make-hash-table :test 'eq))) 13 | 14 | (defmethod lookup (name namespace (environment environment)) 15 | (multiple-value-bind (value defined-p) 16 | (when-let ((namespace (namespace namespace environment))) 17 | (gethash name namespace)) 18 | (if defined-p 19 | (values value T) 20 | (when-let ((parent (parent environment))) 21 | (lookup name namespace parent))))) 22 | 23 | (defmethod (setf lookup) (value name namespace (environment environment)) 24 | (setf (gethash name (ensure-namespace namespace environment)) value)) 25 | 26 | (defun augment-environment! (environment names values) 27 | (loop for name in names 28 | for value in values 29 | do (etypecase name 30 | (symbol 31 | (setf (lookup name 'variable environment) value)) 32 | ((cons symbol symbol) 33 | (destructuring-bind (name . namespace) name 34 | (setf (lookup name namespace environment) value))))) 35 | environment) 36 | 37 | (defun augmented-environment (parent names values &key (class (class-of parent))) 38 | (augment-environment! (make-instance class :parent parent) names values)) 39 | -------------------------------------------------------------------------------- /transform.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.staple) 2 | 3 | (defvar *pathname-type-type-map* ()) 4 | 5 | (defun pathname-type->type (type &optional errorp) 6 | (loop for (result . types) in *pathname-type-type-map* 7 | do (when (find type types :test #'string-equal) 8 | (return result)) 9 | finally (when errorp (error "Unknown pathname-type ~s." type)))) 10 | 11 | (defun (setf pathname-type->type) (types type) 12 | (check-type type keyword) 13 | (check-type types list) 14 | (setf *pathname-type-type-map* 15 | (remove type *pathname-type-type-map* :key #'car)) 16 | (when types 17 | (setf *pathname-type-type-map* 18 | (list* (list* type types) 19 | *pathname-type-type-map*))) 20 | types) 21 | 22 | (defgeneric compile-source (source type)) 23 | 24 | (defmethod compile-source (source (type string)) 25 | (compile-source source (pathname-type->type type T))) 26 | 27 | (defmethod compile-source ((source pathname) type) 28 | (compile-source (read-file source) type)) 29 | 30 | (defmethod compile-source ((source pathname) (type (eql T))) 31 | (compile-source source (pathname-type source))) 32 | 33 | (defmacro define-source-compiler ((type &rest pathname-types) (input) &body body) 34 | (check-type type keyword) 35 | `(progn 36 | ,@(when pathname-types `((setf (pathname-type->type ,type) ',pathname-types))) 37 | (defmethod compile-source ((,input string) (type (eql ,type))) 38 | ,@body) 39 | ',type)) 40 | 41 | (define-source-compiler (:html "htm" "html" "xhtml") (input) 42 | (plump:parse input)) 43 | 44 | (define-source-compiler (:text "txt" "text") (input) 45 | input) 46 | -------------------------------------------------------------------------------- /server/data/github.css: -------------------------------------------------------------------------------- 1 | pre { white-space: pre; background-color: #f8f8f8; border: 1px solid #ccc; font-size: 13px; line-height: 19px; overflow: auto; padding: 6px 10px; border-radius: 3px; } 2 | pre code.hl-highlighted {white-space: pre; margin: 0; padding: 0; background: none; border: none; overflow-x: auto; font-size: 13px;} 3 | code.hl-highlighted {margin: 0 2px; padding: 0 5px; white-space: nowrap; font-family: Consolas, "Liberation Mono", Courier, monospace; background: #f8f8f8; border: 1px solid #eaeaea; border-radius: 3px;} 4 | 5 | code.hl-highlighted {color: #008080;} 6 | code.hl-highlighted .function {color: #008080;} 7 | code.hl-highlighted .function.known {color: #800603;} 8 | code.hl-highlighted .function.known.special {color: #2d2d2d; font-weight: bold;} 9 | code.hl-highlighted .keyword {color: #990073;} 10 | code.hl-highlighted .keyword.known {color: #990073;} 11 | code.hl-highlighted .symbol {color: #75a;} 12 | code.hl-highlighted .lambda-list {color: #966;} 13 | code.hl-highlighted .number {color: #800;} 14 | code.hl-highlighted .variable.known {color: #c3c;} 15 | code.hl-highlighted .variable.global {color: #939;} 16 | code.hl-highlighted .variable.constant {color: #229;} 17 | code.hl-highlighted .nil {color: #f00;} 18 | code.hl-highlighted .list {color: #222;} 19 | 20 | code.hl-highlighted .string, code.hl-highlighted .string * {color: #d14 !important;} 21 | code.hl-highlighted .comment, 22 | code.hl-highlighted .comment *, 23 | code.hl-highlighted .comment .string 24 | code.hl-highlighted .comment .string * {color: #777777 !important;} 25 | code.hl-highlighted .string .comment {color: #d14 !important;} 26 | 27 | code.hl-highlighted .list.active {display: inline-block; background: #aefff7;} 28 | -------------------------------------------------------------------------------- /server/data/view.js: -------------------------------------------------------------------------------- 1 | window.addEventListener("DOMContentLoaded", function(){ 2 | var getStyle = function(el,styleProp){ 3 | if(el.currentStyle){ 4 | return el.currentStyle[styleProp]; 5 | }else if(window.getComputedStyle){ 6 | return document.defaultView.getComputedStyle(el,null).getPropertyValue(styleProp); 7 | } 8 | return null; 9 | }; 10 | 11 | var getSourceLocation = function(){ 12 | var hash = window.location.hash; 13 | if(hash){ 14 | var colon = hash.indexOf(":"); 15 | if(colon){ 16 | return [ parseInt(hash.substr(1, colon)), 17 | parseInt(hash.substr(colon+1)) ]; 18 | } else { 19 | return [ parseInt(hash.substr(1)), 20 | 0 ]; 21 | } 22 | } 23 | return null; 24 | }; 25 | 26 | var scrollToLine = function(line, editor){ 27 | editor = editor || document.querySelector(".file"); 28 | var code = editor.querySelector("code.lisp"); 29 | var lineHeight = Length.toPx(code, getStyle(code, "line-height")); 30 | var pos = code.getBoundingClientRect().top + (line-1) * lineHeight; 31 | console.log(pos); 32 | window.scrollTo(0, pos); 33 | }; 34 | 35 | var highlightEditor = function(editor){ 36 | var code = editor.querySelector("code.lisp"); 37 | HighlightLisp.highlight_element(code); 38 | }; 39 | 40 | var highlightAllEditors = function(root){ 41 | root = root || document; 42 | [].forEach.call(root.querySelectorAll(".file"), highlightEditor); 43 | }; 44 | 45 | highlightAllEditors(); 46 | var location = getSourceLocation(); 47 | if(location) scrollToLine(location[0]); 48 | }); 49 | -------------------------------------------------------------------------------- /default/default.js: -------------------------------------------------------------------------------- 1 | window.addEventListener("DOMContentLoaded", function(){ 2 | var unmarkElement = function(el){ 3 | if(el.tagName === "mark" || el.tagName === "MARK"){ 4 | [].forEach.call(el.childNodes, function(child){ 5 | el.parentNode.insertBefore(child, el); 6 | }); 7 | el.parentNode.removeChild(el); 8 | }else if(el.parentNode.tagName === "mark"){ 9 | return unmarkElement(el.parentNode); 10 | } 11 | return null; 12 | } 13 | 14 | var unmarkAll = function(root){ 15 | root = root || document; 16 | [].forEach.call(root.querySelectorAll("mark"), unmarkElement); 17 | } 18 | 19 | var markElement = function(el){ 20 | if(el.parentNode.tagName === "mark" || el.parentNode.tagName === "MARK"){ 21 | return el.parentNode; 22 | } else { 23 | unmarkAll(); 24 | var marked = document.createElement("mark"); 25 | el.parentNode.insertBefore(marked, el); 26 | marked.appendChild(el); 27 | return marked; 28 | } 29 | } 30 | 31 | var markFragmented = function(){ 32 | if(window.location.hash){ 33 | var el = document.getElementById(decodeURIComponent(window.location.hash.substr(1))); 34 | if(el) markElement(el); 35 | } 36 | } 37 | 38 | var registerXrefLink = function(link){ 39 | var el = document.getElementById(decodeURIComponent(link.getAttribute("href").substr(1))); 40 | if(el){ 41 | link.addEventListener("click", function(){ 42 | markElement(el); 43 | }); 44 | } 45 | } 46 | 47 | var registerXrefLinks = function(root){ 48 | root = root || document; 49 | [].forEach.call(root.querySelectorAll("a.xref"), registerXrefLink); 50 | } 51 | 52 | markFragmented(); 53 | registerXrefLinks(); 54 | }); 55 | -------------------------------------------------------------------------------- /staple.ext.lisp: -------------------------------------------------------------------------------- 1 | (staple:load-system-quietly :staple-server) 2 | 3 | (defmethod staple:subsystems ((system (eql (asdf:find-system :staple)))) 4 | (list (asdf:find-system :staple-markdown) 5 | (asdf:find-system :staple-markless) 6 | (asdf:find-system :staple-code-parser) 7 | (asdf:find-system :staple-restructured-text) 8 | (asdf:find-system :staple-server))) 9 | 10 | (defmethod staple:packages ((system (eql (asdf:find-system :staple)))) 11 | (list (find-package :staple))) 12 | 13 | (defmethod staple:packages ((system (eql (asdf:find-system :staple-markdown)))) 14 | (list)) 15 | 16 | (defmethod staple:packages ((system (eql (asdf:find-system :staple-markless)))) 17 | (list)) 18 | 19 | (defmethod staple:packages ((system (eql (asdf:find-system :staple-restructured-text)))) 20 | (list)) 21 | 22 | (defmethod staple:packages ((system (eql (asdf:find-system :staple-package-recording)))) 23 | (list (find-package :staple-package-recording))) 24 | 25 | (defmethod staple:packages ((system (eql (asdf:find-system :staple-server)))) 26 | (list (find-package :staple-server))) 27 | 28 | (defmethod staple:packages ((system (eql (asdf:find-system :staple-code-parser)))) 29 | (list (find-package :staple-code-parser))) 30 | 31 | (defmethod staple:documents ((system (eql (asdf:find-system :staple-server)))) 32 | (list (asdf:system-relative-pathname system "README.md"))) 33 | 34 | (defmethod staple:documents ((system (eql (asdf:find-system :staple)))) 35 | (list (asdf:system-relative-pathname system "README.md"))) 36 | 37 | (defmethod staple:documents ((system (eql (asdf:find-system :staple-markdown)))) 38 | (list (asdf:system-relative-pathname system "README.markdown.md"))) 39 | 40 | (defmethod staple:documents ((system (eql (asdf:find-system :staple-markless)))) 41 | (list (asdf:system-relative-pathname system "README.markless.md"))) 42 | 43 | (defmethod staple:documents ((system (eql (asdf:find-system :staple-restructured-text)))) 44 | (list (asdf:system-relative-pathname system "README.restructured-text.md"))) 45 | -------------------------------------------------------------------------------- /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | on: [create, workflow_dispatch] 3 | permissions: 4 | contents: write 5 | jobs: 6 | build: 7 | strategy: 8 | matrix: 9 | platform: [ubuntu-latest, macOS-latest, windows-latest] 10 | fail-fast: false 11 | runs-on: ${{ matrix.platform }} 12 | defaults: 13 | run: 14 | shell: bash 15 | env: 16 | LISP: sbcl-bin 17 | steps: 18 | - name: Restore cache 19 | id: cache-ql 20 | uses: actions/cache@v3 21 | with: 22 | path: | 23 | ~/.roswell 24 | ~/.cache/common-lisp 25 | ~/AppData/Local/cache 26 | key: ${{ runner.os }}-ql 27 | - name: Install Lisp 28 | uses: 40ants/setup-lisp@v2 29 | - uses: actions/checkout@v1 30 | - name: Build the library 31 | shell: lispsh -eo pipefail {0} 32 | run: | 33 | ros run -- --noinform \ 34 | --eval "(push \"$GITHUB_WORKSPACE\" ql:*local-project-directories*)" \ 35 | --eval '(ql:quickload :staple/standalone)' \ 36 | --non-interactive 37 | - name: Build the binary 38 | shell: lispsh -eo pipefail {0} 39 | run: | 40 | ros run -- --noinform \ 41 | --eval "(push \"$GITHUB_WORKSPACE\" ql:*local-project-directories*)" \ 42 | --eval '(asdf:make :staple/standalone)' \ 43 | --non-interactive 44 | - name: Upload artifact 45 | uses: actions/upload-artifact@v4 46 | with: 47 | name: staple-${{ runner.os }} 48 | path: ${{ runner.os == 'Windows' && 'staple.exe' || (runner.os == 'Linux' && 'staple.run' || 'staple.o') }} 49 | - name: Create release 50 | id: create_release 51 | uses: ncipollo/release-action@v1 52 | continue-on-error: true 53 | with: 54 | allowUpdates: true 55 | name: Release ${{ github.ref_name }} 56 | artifacts: ${{ runner.os == 'Windows' && 'staple.exe' || (runner.os == 'Linux' && 'staple.run' || 'staple.o') }} 57 | -------------------------------------------------------------------------------- /parser/README.md: -------------------------------------------------------------------------------- 1 | ## About Staple-Parser 2 | This system implements a Lisp code parser to implement marking up definition references within code snippets. 3 | 4 | ## How To 5 | You can parse a lisp source snippets using `parse`: 6 | 7 | (staple-code-parser:parse "(defun foo (a) (+ 1 a))") 8 | 9 | This will return a list of "parse results". Parse results represent all information about the toplevel source form that was parsed. Typically you will want to pass this to `parse-result->definition-list`, which will return a list of definitions and their source locations that were found within the parse results. 10 | 11 | (staple-code-parser:parse-result->definition-list *) 12 | ; => ((# (16 . 17)) (# (1 . 6))) 13 | 14 | The definitions objects are from the [Definitions](https://shinmera.com/docs/definitions) library. Please see its documentation on how to handle these kinds of objects. This definition list is used in Staple to mark up the respective source parts with HTML links, but you could also use it for your own purposes. 15 | 16 | ## Extending Staple-Parser 17 | Since the parser does not compile or evaluate the code, it is missing a lot of information about what each symbol could be, hampering the quality of definition retrieval. You can help this out by implementing custom walkers for known forms that expand to parse results that are more easily understood. 18 | 19 | The way to do this is twofold. You can either use `define-walk-compound-form` an expand into known parse results, transforming the contents as appropriate, or you can use `define-walker-form` to define a new parse result type. In the latter case you will also need to add `define-sub-forms` and `define-definition-resolver` to handle the traversal and lookup. 20 | 21 | Have a look at the source files [special-forms](https://shinmera.com/project/staple/blob/master/parser/special-forms.lisp), [standard-forms](https://shinmera.com/project/staple/blob/master/parser/standard-forms.lisp), and [to-definitions](https://shinmera.com/project/staple/blob/master/parser/to-definitions.lisp) for examples on how to use these. 22 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:staple 3 | (:nicknames #:org.shirakumo.staple) 4 | (:use #:cl #:org.shirakumo.staple.recording) 5 | ;; code-format.lisp 6 | (:export 7 | #:markup-code-snippets-ignoring-errors 8 | #:markup-code-snippets 9 | #:skip-tag 10 | #:markup-code-block 11 | #:markup-code-reference) 12 | ;; inference.lisp 13 | (:export 14 | #:*document-patterns* 15 | #:*image-patterns* 16 | #:*default-template* 17 | #:extract-language 18 | #:simple-page 19 | #:document 20 | #:filename 21 | #:document-package 22 | #:simple-project 23 | #:logo 24 | #:documents 25 | #:images 26 | #:subsystems 27 | #:page-type 28 | #:template 29 | #:output-directory 30 | #:no-known-output-directory 31 | #:system) 32 | ;; page.lisp 33 | (:export 34 | #:*page* 35 | #:page 36 | #:title 37 | #:language 38 | #:output 39 | #:project 40 | #:page-variants 41 | #:page-siblings 42 | #:generate 43 | #:input-page 44 | #:input 45 | #:static-page 46 | #:compiled-page 47 | #:templated-page 48 | #:template-data 49 | #:definitions-index-page 50 | #:packages 51 | #:format-documentation 52 | #:resolve-source-link 53 | #:definition-wanted-p 54 | #:definitions 55 | #:system-page 56 | #:system 57 | #:current-commit) 58 | ;; project.lisp 59 | (:export 60 | #:*project* 61 | #:*load-prohibited-systems* 62 | #:project 63 | #:pages 64 | #:extension-file 65 | #:find-project 66 | #:load-extension 67 | #:infer-project 68 | #:generate) 69 | ;; recording.lisp 70 | (:export 71 | #:packages 72 | #:package-system) 73 | ;; transform.lisp 74 | (:export 75 | #:pathname-type->type 76 | #:compile-source 77 | #:define-source-compiler) 78 | ;; toolkit.lisp 79 | (:export 80 | #:find-files 81 | #:read-file 82 | #:definition-id 83 | #:definition-order 84 | #:sort-definitions 85 | #:definition-importance 86 | #:preferred-definition 87 | #:url-encode 88 | #:ensure-package-definition 89 | #:ensure-package 90 | #:absolute-source-location 91 | #:maybe-lang-docstring 92 | #:with-stream 93 | #:stream-designator 94 | #:relative-path 95 | #:load-system-quietly 96 | #:purify-arglist) 97 | ;; xref.lisp 98 | (:export 99 | #:xref-resolver 100 | #:remove-xref-resolver 101 | #:define-xref-resolver 102 | #:resolve-xref 103 | #:find-definitions-for-identifier 104 | #:xref)) 105 | -------------------------------------------------------------------------------- /recording.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:staple-package-recording 2 | (:nicknames #:org.shirakumo.staple.recording) 3 | (:use #:cl) 4 | (:export 5 | #:packages 6 | #:package-system)) 7 | 8 | (in-package #:org.shirakumo.staple.recording) 9 | 10 | (defvar *before-load-packages* (make-hash-table :test 'eql)) 11 | (defvar *system-packages* (make-hash-table :test 'eql)) 12 | 13 | (defun efind-package (name) 14 | (or (find-package name) 15 | (find-package (string-upcase name)) 16 | (error "No package with name ~s could be found." name))) 17 | 18 | (defmethod packages ((system asdf:system)) 19 | (let ((packages (gethash system *system-packages* :not-recorded))) 20 | (cond ((eql :not-recorded packages) 21 | ;; Heuristic, ech. 22 | (let ((pkg (find-package (asdf:component-name system)))) 23 | (when pkg (list pkg)))) 24 | (T 25 | packages)))) 26 | 27 | (defmethod packages ((system symbol)) 28 | (packages (asdf:find-system system T))) 29 | 30 | (defmethod (setf packages) (packages (system asdf:system)) 31 | (let ((packages (loop for package in packages 32 | collect (etypecase package 33 | (package package) 34 | ((or string symbol) (efind-package package)))))) 35 | (setf (gethash system *system-packages*) packages))) 36 | 37 | (defmethod (setf packages) (packages system-ish) 38 | (setf (packages (asdf:find-system system-ish T)) packages)) 39 | 40 | (defmethod package-system ((package package)) 41 | (loop for system being the hash-keys of *system-packages* 42 | for packages being the hash-values of *system-packages* 43 | when (find package packages) return system)) 44 | 45 | (defmethod package-system (thing) 46 | (package-system (or (find-package thing) 47 | (error "No such package ~s." thing)))) 48 | 49 | ;; Record all packages before system load 50 | (defmethod asdf:perform :after ((o asdf:prepare-op) (s asdf:system)) 51 | (when (eql :not-recorded (gethash s *before-load-packages* :not-recorded)) 52 | (setf (gethash s *before-load-packages*) (list-all-packages)))) 53 | 54 | ;; Difference recorded list against current list to get all packages defined. 55 | (defmethod asdf:perform :after ((o asdf:load-op) (s asdf:system)) 56 | (let ((old-packages (gethash s *before-load-packages* :not-recorded))) 57 | (when (and (not (eql :not-recorded old-packages)) 58 | (eql :not-recorded (gethash s *system-packages* :not-recorded))) 59 | (let ((new-packages (set-difference (list-all-packages) old-packages))) 60 | ;; Combine with previous ones to account for potential package addition 61 | ;; after later reloading of the system. 62 | (setf (packages s) 63 | (union (packages s) (reverse new-packages))))))) 64 | -------------------------------------------------------------------------------- /action.yml: -------------------------------------------------------------------------------- 1 | name: 'Compile Documentation' 2 | description: 'Compile documentation with Staple' 3 | branding: 4 | color: blue 5 | icon: file-text 6 | inputs: 7 | project: 8 | description: 'The project to compile documentation for' 9 | output: 10 | description: 'Where to put the documentation output' 11 | template: 12 | description: 'The Clip template to use for documentation pages' 13 | gh-pages: 14 | description: 'If set will publish the documentation to Github Pages' 15 | dist: 16 | descriptino: 'An extra dist to load for dependencies' 17 | outputs: 18 | output: 19 | description: 'The output directory into which the documentation was put' 20 | value: ${{ inputs.output }} 21 | 22 | runs: 23 | using: "composite" 24 | steps: 25 | - name: Restore cache 26 | uses: actions/cache@v3 27 | id: cache 28 | with: 29 | path: | 30 | ~/.quicklisp 31 | ~/.cache/common-lisp 32 | ~/AppData/Local/cache 33 | key: staple-${{ runner.os }} 34 | - name: Install Lisp 35 | shell: bash 36 | run: | 37 | sudo apt-get install -yy sbcl 38 | - name: Install env 39 | if: steps.cache.outputs.cache-hit != 'true' 40 | shell: bash 41 | run: | 42 | curl https://beta.quicklisp.org/quicklisp.lisp \ 43 | | cat - <(echo "(quicklisp-quickstart:install :path \"~/.quicklisp/\")" \ 44 | "(when (< 0 (length \"$DIST\")) (ql-dist:install-dist \"$DIST\" :prompt NIL))" \ 45 | "(ql:quickload :staple/standalone :silent T)") \ 46 | | sbcl --noinform 47 | env: 48 | DIST: ${{ inputs.dist }} 49 | - uses: actions/checkout@v4 50 | with: 51 | repository: shinmera/staple 52 | path: staple 53 | - name: Run staple 54 | shell: bash 55 | run: | 56 | sbcl --noinform \ 57 | --eval "(load \"~/.quicklisp/setup.lisp\")" \ 58 | --eval "(push \"$GITHUB_WORKSPACE\" ql:*local-project-directories*)" \ 59 | --eval "(ql:quickload :staple/standalone :silent T)" \ 60 | --eval "(staple::main)" \ 61 | --quit --end-toplevel-options \ 62 | "$PROJECT" \ 63 | --output "$OUTPUT" \ 64 | --template "$TEMPLATE" 65 | env: 66 | PROJECT: ${{ inputs.project || github.event.repository.name }} 67 | OUTPUT: ${{ inputs.output || format('{0}/staple-output/', runner.temp) }} 68 | TEMPLATE: ${{ inputs.template }} 69 | LISP: sbcl-bin 70 | - name: Upload Github Pages Artefact 71 | if: ${{ inputs.gh-pages }} 72 | uses: actions/upload-pages-artifact@v3.0.1 73 | with: 74 | path: ${{ inputs.output || format('{0}/staple-output/', runner.temp) }} 75 | - name: Write to Github Pages 76 | if: ${{ inputs.gh-pages }} 77 | id: deployment 78 | uses: actions/deploy-pages@v4 79 | -------------------------------------------------------------------------------- /code-format.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.staple) 2 | 3 | (defun markup-code-snippets-ignoring-errors (html) 4 | (handler-bind ((error (lambda (e) 5 | (format *debug-io* "~&WARN: Error during code markup: ~a" e) 6 | (when (find-restart 'skip-tag) 7 | (invoke-restart 'skip-tag))))) 8 | (markup-code-snippets html))) 9 | 10 | (defun markup-code-snippets (html) 11 | (let ((root (etypecase html 12 | (plump:node html) 13 | ((or string pathname) (plump:parse html))))) 14 | (flet ((markup (node) 15 | (restart-case 16 | (cond ((string= "pre" (plump:tag-name (plump:parent node))) 17 | (markup-code-block node)) 18 | ((and (plump:first-element node) 19 | (string= "pre" (plump:tag-name (plump:first-element node)))) 20 | (markup-code-block (plump:first-child node))) 21 | (T 22 | (markup-code-reference node))) 23 | (skip-tag () 24 | :report "Skip marking up the current tag.")) 25 | T)) 26 | (lquery:$ root "code" (each #'markup)) 27 | (etypecase html 28 | (plump:node root) 29 | ((or string pathname) (plump:serialize root NIL)))))) 30 | 31 | (defun make-xref-link (parent href content) 32 | (let ((link (plump:make-element parent "a"))) 33 | (setf (plump:attribute link "href") href) 34 | (setf (plump:attribute link "class") "xref") 35 | (plump:make-text-node link content) 36 | link)) 37 | 38 | ;; FIXME: this solves the issue of overlaps, but it's... not great for 39 | ;; obvious reasons. We should be able to handle nested definitions! 40 | (defun remove-overlaps (definitions) 41 | (let ((definitions (sort (copy-seq definitions) #'< :key #'caadr))) 42 | (loop for (definition . others) on definitions 43 | do (dolist (other others) 44 | (when (and (not (eq other definition)) 45 | (< (car (second other)) (cdr (second definition)))) 46 | (setf (cdr (second definition)) (car (second other))))) 47 | (when (<= (cdr (second definition)) (car (second definition))) 48 | (setf definitions (remove definition definitions)))) 49 | definitions)) 50 | 51 | (defun markup-code-block (node) 52 | (let* ((text (plump:text node)) 53 | (parse-result (staple-code-parser:parse text)) 54 | (definitions (remove-overlaps (staple-code-parser:parse-result->definition-list parse-result)))) 55 | (plump:clear node) 56 | (loop for prev = 0 then end 57 | for (def loc) in definitions 58 | for (start . end) = loc 59 | for xref = (xref def) 60 | do (cond (xref 61 | (plump:make-text-node node (subseq text prev start)) 62 | (make-xref-link node xref (subseq text start end))) 63 | (T 64 | (plump:make-text-node node (subseq text prev end)))) 65 | finally (plump:make-text-node node (subseq text prev))) 66 | node)) 67 | 68 | (defun markup-code-reference (node) 69 | (let* ((content (plump:text node)) 70 | (xref (xref content))) 71 | (when xref 72 | (plump:clear node) 73 | (make-xref-link node xref content)) 74 | node)) 75 | -------------------------------------------------------------------------------- /server/documentation.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.staple.server) 2 | 3 | (docs:define-docs 4 | (varaible *server-build* 5 | "Set to T around a generation that the server performs. 6 | 7 | Used to make sure that the xref resolver of the server doesn't 8 | interfere with generations that aren't for the server.") 9 | 10 | (variable *acceptor* 11 | "Holds the acceptor instance while the server is started. 12 | 13 | See START 14 | See STOP 15 | See ACCEPTOR") 16 | 17 | (variable *tmpdir* 18 | "Pathname to the temporary file directory the server uses to store documentation output. 19 | 20 | By default a subdirectory called \"staple-server\" in 21 | UIOP:TEMPORARY-DIRECTORY. 22 | 23 | See SYSTEM-PATH") 24 | 25 | (function all-systems 26 | "Returns a sorted list of all ASDF:SYSTEMs.") 27 | 28 | (function data-file 29 | "Returns the pathname to a file in the server's data dir.") 30 | 31 | (function system-link 32 | "Returns the relative URL to an ASDF:SYSTEM's documentation.") 33 | 34 | (function system-path 35 | "Returns the pathname to output directory for the documentation of the given ASDF:SYSTEM. 36 | 37 | See *TMPDIR*") 38 | 39 | (function find-system-in-path 40 | "Finds the matching ASDF:SYSTEM for the given URL path. 41 | 42 | For cases where a system's name might be a prefix of the given path, 43 | the system with the longest matching name is returned.") 44 | 45 | (function safe-prin1 46 | "PRIN1s the given thing to a string or returns a placeholder string if there is an error during printing.") 47 | 48 | (function or* 49 | "Same as CL:OR except that empty strings are treated as NIL.") 50 | 51 | (function cache-system 52 | "Creates the cache for the given system. 53 | 54 | Unless otherwise specified, the output is placed in the directory 55 | returned by SYSTEM-PATH. The system is generated normally otherwise, 56 | but supplying :if-exists :supersede. After generation, each HTML file 57 | in the output directory is modified such that links to file:// urls 58 | are replaced by ones that the server can handle, and each page gets 59 | the nav.ctml contents injected at the bottom of its body. 60 | 61 | This should ensure that the documentation can be customised heavily 62 | by the owner of the projects, but still work within a server setting. 63 | 64 | See SYSTEM-PATH 65 | See STAPLE:GENERATE") 66 | 67 | (function clear-cache 68 | "Clears the cache by deleting all files in *TMPDIR* 69 | 70 | See *TMPDIR*") 71 | 72 | (type acceptor 73 | "Hunchentoot acceptor to implement the Staple server. 74 | 75 | See HUNCHENTOOT:ACCEPTOR") 76 | 77 | (function start 78 | "Starts the Staple server. 79 | 80 | If *ACCEPTOR* is already set, an error is signalled. Otherwise, a new 81 | ACCEPTOR instance is created and started. 82 | 83 | See *ACCEPTOR* 84 | See ACCEPTOR") 85 | 86 | (function stop 87 | "Stops the Staple server. 88 | 89 | If *ACCEPTOR* is not set, an error is signalled. Otherwise the server 90 | is stopped and unbound. 91 | 92 | See *ACCEPTOR*") 93 | 94 | (function serve-system-list 95 | "Returns the HTML for the systems list page.") 96 | 97 | (function serve-system-docs 98 | "Returns the HTML for the given documentation path under the system.") 99 | 100 | (function serve-source 101 | "Returns the HTML for the file browser to the given path.") 102 | 103 | (function serve-error 104 | "Returns the HTML for the error display page.")) 105 | -------------------------------------------------------------------------------- /default/default.css: -------------------------------------------------------------------------------- 1 | html body{margin:0 auto 0 auto;padding:20px;max-width:1024px;font-family:sans-serif;font-size:14pt;overflow-y:scroll;}html body a{text-decoration:none;}html body a[href]{color:#0055AA;}html body a[href]:hover{color:#0088EE;}html body pre{background:#FAFAFA;border:1px solid #DDDDDD;padding:0.75em;overflow-x:auto;}html body pre >code a[href]{color:#223388;}article.project h1{font-size:1.7em;}article.project h1,article.project h2,article.project h3,article.project h4,article.project h5,article.project h6{margin:0.2em 0 0.1em 0;text-indent:1em;}article.project >header{text-align:center;}article.project >header img.logo{display:block;margin:auto;max-height:170px;}article.project >header h1{display:inline-block;text-indent:0;font-size:2.5em;}article.project >header .version{vertical-align:bottom;}article.project >header .languages{margin-top:-0.5em;text-transform:capitalize;}article.project >header .description{margin:0;}article.project >header .pages{margin-top:0.5em;font-size:1.2em;text-transform:capitalize;}article.project >header .pages a{display:inline-block;padding:0 0.2em;}article.project >section{margin:1em 0 1em 0;}article.project >section img{max-width:100%;}article.project #index >ul{list-style:none;margin:0;padding:0;}article.project .row label{display:inline-block;min-width:8em;}article.project #system .row{display:flex;}article.project #system #dependencies{display:inline;margin:0;padding:0;}article.project #system #dependencies li{display:inline;padding:0 0.2em;}article.project #system #author label{vertical-align:top;}article.project #system #author ul{display:inline-block;margin:0;padding:0;list-style:none;}article.project #toc nav>*{margin-left:1em;display:block;}article.definition{margin:1em 0 0 0;}article.definition >header h1,article.definition >header h2,article.definition >header h3,article.definition >header h4,article.definition >header h5,article.definition >header h6{text-indent:0;display:inline-block;}article.definition >header ul{display:inline-block;list-style:none;margin:0;padding:0;}article.definition >header ul li{display:inline-block;padding:0 0.2em 0 0;}article.definition >header .visibility{display:none;}article.definition >header .visibility,article.definition >header .type{text-transform:lowercase;}article.definition >header .source-link{visibility:hidden;float:right;}article.definition >header .source-link:after{visibility:visible;content:"[SRC]";}article.definition .docstring{margin:0 0 0 1em;}article.definition .docstring pre{font-size:0.8em;white-space:pre-wrap;}.definition.package >header ul.nicknames{display:inline-block;list-style:none;margin:0;padding:0 0 0 1em;}.definition.package >header ul.nicknames li{display:inline;}.definition.package >header ul.nicknames:before{content:"(";}.definition.package >header ul.nicknames:after{content:")";}.definition.package ul.definitions{margin:0;list-style:none;padding:0 0 0 0.5em;}.definition.callable >header .name:before,.definition.type >header .name:before{content:"(";font-weight:normal;}.definition.callable >header .arguments:after,.definition.type >header .arguments:after{content:")";}.definition.callable >header .arguments .arguments:before,.definition.type >header .arguments .arguments:before{content:"(";}.definition.callable >header .arguments .argument,.definition.type >header .arguments .argument{padding:0;}.definition.callable >header .arguments .argument.lambda-list-keyword,.definition.type >header .arguments .argument.lambda-list-keyword{color:#991155;}.definition li>mark{background:none;border-left:0.3em solid #0088EE;padding-left:0.3em;display:block;}@media (min-width: 1300px){html body{padding-left:16em;}article.project #toc{margin:0;position:fixed;left:0;top:0;bottom:0;width:15em;overflow-y:auto;background:#F0F0F0;border-right:1px solid #A0A0A0;}} -------------------------------------------------------------------------------- /project.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.staple) 2 | 3 | (defvar *load-prohibited-systems* 4 | (loop for name in '("asdf" "asdf-package-system" "asdf/defsystem" "asdf/driver" "asdf/prelude") 5 | for sys = (asdf:find-system name NIL) 6 | when sys collect sys)) 7 | (defvar *loaded-extensions*) 8 | 9 | (defclass project () 10 | ((output :initarg :output :accessor output))) 11 | 12 | (defgeneric pages (project)) 13 | 14 | (defmethod generate ((project project) &rest args) 15 | (let ((*current-commit-cache* (make-hash-table :test 'equal)) 16 | (results ())) 17 | (with-simple-restart (abort "Abort ~a" project) 18 | (dolist (page (pages project)) 19 | (with-simple-restart (continue "Ignore ~a" page) 20 | (push (apply #'generate page args) results)))) 21 | (values project (nreverse results)))) 22 | 23 | (defmethod relative-path ((to project) from) 24 | (relative-path (output to) from)) 25 | 26 | (defmethod relative-path (to (from project)) 27 | (relative-path (output from) to)) 28 | 29 | (defclass simple-project (project) 30 | ((pages :initarg :pages :accessor pages)) 31 | (:default-initargs 32 | :pages ())) 33 | 34 | (defgeneric extension-file (system)) 35 | 36 | (defmethod extension-file (system) 37 | (let ((source (asdf:system-source-directory system))) 38 | (when source (make-pathname :name "staple.ext" :type "lisp" :defaults source)))) 39 | 40 | (defgeneric find-project (project &key &allow-other-keys)) 41 | 42 | (defmethod find-project (name &rest args) 43 | (let ((system (asdf:find-system name NIL))) 44 | (when system 45 | (apply #'find-project system args)))) 46 | 47 | (defun make-extension-load-table () 48 | (let ((table (make-hash-table :test 'eq))) 49 | (dolist (sys *load-prohibited-systems* table) 50 | (setf (gethash sys table) T)))) 51 | 52 | (defun load-extension (system) 53 | (let ((*loaded-extensions* (if (boundp '*loaded-extensions*) 54 | *loaded-extensions* 55 | (make-extension-load-table))) 56 | (system (ensure-system system))) 57 | (unless (gethash system *loaded-extensions*) 58 | (setf (gethash system *loaded-extensions*) T) 59 | (load-system-quietly system) 60 | (loop for dependency in (asdf:system-depends-on system) 61 | for depsys = (asdf/find-component:resolve-dependency-spec system dependency) 62 | do (when (and depsys (not (eql depsys (asdf:find-system :staple)))) 63 | (load-extension depsys))) 64 | (let ((extension (extension-file system))) 65 | (when (and extension (probe-file extension)) 66 | (load extension))) 67 | system))) 68 | 69 | (defmethod find-project ((system asdf:system) &rest args) 70 | (load-extension system) 71 | ;; Now that the extension might have been loaded we can look 72 | ;; for new methods on this function specific to the system. 73 | (when (or (find-method #'find-project () `((eql ,system)) NIL) 74 | (find-method #'find-project () `((eql ,(system-name system))) NIL)) 75 | (apply #'find-project (system-name system) args))) 76 | 77 | (defgeneric infer-project (project &key &allow-other-keys)) 78 | 79 | (defmethod infer-project (name &rest args) 80 | (let ((system (asdf:find-system name NIL))) 81 | (when system 82 | (apply #'infer-project system args)))) 83 | 84 | (defmethod generate (project &rest args) 85 | (let ((project (or (when (typep project 'project) project) 86 | (apply #'find-project project args) 87 | (apply #'infer-project project args) 88 | (error "Cannot generate documentation for ~s: Could not find or infer a project." 89 | project)))) 90 | (apply #'generate project args))) 91 | -------------------------------------------------------------------------------- /default/default.lass: -------------------------------------------------------------------------------- 1 | (html 2 | (body 3 | :margin 0 auto 0 auto 4 | :padding 20px 5 | :max-width 1024px 6 | :font-family sans-serif 7 | :font-size 14pt 8 | :overflow-y scroll 9 | (a 10 | :text-decoration none) 11 | (a[href] 12 | :color (hex 0055AA)) 13 | ((:and a[href] :hover) 14 | :color (hex 0088EE)) 15 | (pre 16 | :background (hex FAFAFA) 17 | :border 1px solid (hex DDDDDD) 18 | :padding 0.75em 19 | :overflow-x auto 20 | (>code 21 | (a[href] 22 | :color (hex 223388)))))) 23 | 24 | (article.project 25 | (h1 26 | :font-size 1.7em) 27 | ((:or h1 h2 h3 h4 h5 h6) 28 | :margin 0.2em 0 0.1em 0 29 | :text-indent 1em) 30 | (>header 31 | :text-align center 32 | (img.logo 33 | :display block 34 | :margin auto 35 | :max-height 170px) 36 | (h1 37 | :display inline-block 38 | :text-indent 0 39 | :font-size 2.5em) 40 | (.version 41 | :vertical-align bottom) 42 | (.languages 43 | :margin-top -0.5em 44 | :text-transform capitalize) 45 | (.description 46 | :margin 0) 47 | (.pages 48 | :margin-top 0.5em 49 | :font-size 1.2em 50 | :text-transform capitalize 51 | (a :display inline-block 52 | :padding 0 0.2em))) 53 | (>section 54 | :margin 1em 0 1em 0 55 | (img :max-width 100%)) 56 | ("#index" 57 | (>ul 58 | :list-style none 59 | :margin 0 :padding 0)) 60 | (.row 61 | (label 62 | :display inline-block 63 | :min-width 8em)) 64 | ("#system" 65 | (.row 66 | :display flex) 67 | ("#dependencies" 68 | :display inline 69 | :margin 0 :padding 0 70 | (li :display inline 71 | :padding 0 0.2em)) 72 | ("#author" 73 | (label :vertical-align top) 74 | (ul :display inline-block 75 | :margin 0 :padding 0 76 | :list-style none))) 77 | ("#toc" 78 | (nav>* 79 | :margin-left 1em 80 | :display block))) 81 | 82 | (article.definition 83 | :margin 1em 0 0 0 84 | (>header 85 | ((:or h1 h2 h3 h4 h5 h6) 86 | :text-indent 0 87 | :display inline-block) 88 | (ul 89 | :display inline-block 90 | :list-style none 91 | :margin 0 :padding 0 92 | (li :display inline-block 93 | :padding 0 0.2em 0 0)) 94 | (.visibility 95 | :display none) 96 | ((:or .visibility .type) 97 | :text-transform lowercase) 98 | (.source-link 99 | :visibility hidden 100 | :float right) 101 | ((:and .source-link :after) 102 | :visibility visible 103 | :content "[SRC]")) 104 | (.docstring 105 | :margin 0 0 0 1em 106 | (pre :font-size 0.8em 107 | :white-space pre-wrap))) 108 | 109 | (.definition.package 110 | (>header 111 | (ul.nicknames 112 | :display inline-block 113 | :list-style none 114 | :margin 0 115 | :padding 0 0 0 1em 116 | (li :display inline)) 117 | ((:and ul.nicknames :before) :content "(") 118 | ((:and ul.nicknames :after) :content ")")) 119 | (ul.definitions 120 | :margin 0 121 | :list-style none 122 | :padding 0 0 0 0.5em)) 123 | 124 | ((:and .definition (:or .callable .type)) 125 | (>header 126 | ((:and .name :before) :content "(" :font-weight normal) 127 | ((:and .arguments :after) :content ")") 128 | (.arguments 129 | ((:and .arguments :before) :content "(") 130 | (.argument :padding 0) 131 | (.argument.lambda-list-keyword :color (hex 991155))))) 132 | 133 | (.definition 134 | (li>mark 135 | :background none 136 | :border-left 0.3em solid (hex 0088EE) 137 | :padding-left 0.3em 138 | :display block)) 139 | 140 | (:media "(min-width: 1300px)" 141 | ((html body) 142 | :padding-left 16em) 143 | (article.project 144 | ("#toc" 145 | :margin 0 146 | :position fixed 147 | :left 0 :top 0 :bottom 0 148 | :width 15em 149 | :overflow-y auto 150 | :background (hex F0F0F0) 151 | :border-right 1px solid (hex A0A0A0)))) 152 | -------------------------------------------------------------------------------- /main.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.staple) 2 | #+asdf (defun asdf:upgrade-asdf () NIL) 3 | 4 | (defun main () 5 | (destructuring-bind (&optional system &rest args) uiop:*command-line-arguments* 6 | (handler-bind ((error 7 | (lambda (e) 8 | (format *error-output* "[ERROR] ~a~%" e) 9 | (uiop:print-condition-backtrace e) 10 | (uiop:quit 1))) 11 | (sb-sys:interactive-interrupt 12 | (lambda (e) 13 | (declare (ignore e)) 14 | (uiop:quit 2)))) 15 | (cond (system 16 | (let ((here (uiop/os:getcwd))) 17 | #+quicklisp (setf ql:*local-project-directories* ()) 18 | #+asdf (asdf:clear-configuration) 19 | #+asdf (asdf:initialize-source-registry) 20 | #+asdf (asdf:initialize-source-registry `(:source-registry (:tree ,here) :inherit-configuration))) 21 | (let ((kargs ())) 22 | (loop for (key val) on args by #'cddr 23 | do (flet ((argp (short long) 24 | (or (and short (string-equal key (format NIL "-~a" short))) 25 | (and long (string-equal key (format NIL "--~a" long)))))) 26 | (when (and val (string/= "" val)) 27 | (cond ((argp "o" "output") 28 | (setf (getf kargs :output-directory) (pathname-utils:parse-native-namestring val))) 29 | ((argp "i" "image") 30 | (push (pathname-utils:parse-native-namestring val) (getf kargs :images))) 31 | ((argp "d" "document") 32 | (push (pathname-utils:parse-native-namestring val) (getf kargs :documents))) 33 | ((argp "p" "page-type") 34 | (setf (getf kargs :page-type) (read-from-string val))) 35 | ((argp "t" "template") 36 | (setf (getf kargs :template) (pathname-utils:parse-native-namestring val))) 37 | ((argp "k" "package") 38 | (push val (getf kargs :packages))) 39 | ((argp "s" "subsystem") 40 | (push val (getf kargs :subsystems))) 41 | (T 42 | (error "Unknown argument: ~a" key)))))) 43 | (apply #'staple:generate system :if-exists :supersede kargs))) 44 | (T 45 | (format *query-io* "~&Staple documentation generation tool 46 | 47 | Usage: staple system [arg...] 48 | 49 | system 50 | The name of the project/system to generate documentation for. 51 | 52 | -o --output 53 | The directory into which to output the documentation. 54 | 55 | -i --image 56 | An image to include in the inferred project. Can be specified 57 | multiple times. 58 | 59 | -d --document 60 | A document to include in the inferred project. Can be specified 61 | multiple times. 62 | 63 | -p --page-type 64 | The page type to use for inferred documents. 65 | 66 | -t --template 67 | The Clip template file to use for templated documents. 68 | 69 | -k --package 70 | A package to include in the symbol index. Can be specified 71 | multiple times. The name is READ to convert it to native case. 72 | 73 | -s --subsystem 74 | The name of a system to include as a subsystem. Can be 75 | specified multiple times. 76 | 77 | While you can specify the project inference properties right here on 78 | the command line, it is recommended to instead rely on a 79 | staple.ext.lisp file in your source directory to persist these 80 | preferences. For more information, please see the Staple 81 | documentation. 82 | 83 | Prior to invoking GENERATE, ASDF is updated to search for ASD files 84 | within the current working directory. Thus, for it to find your 85 | system, you should invoke staple from the project root in which all 86 | necessary systems are contained.~&")))))) 87 | -------------------------------------------------------------------------------- /xref.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.staple) 2 | 3 | (defvar *xref-resolvers* (make-hash-table :test 'eq)) 4 | 5 | (defun xref-resolver (name) 6 | (destructuring-bind (priority function) (gethash name *xref-resolvers*) 7 | (values function priority))) 8 | 9 | (defun (setf xref-resolver) (function name &optional (priority 0)) 10 | (setf (gethash name *xref-resolvers*) (list priority function))) 11 | 12 | (defun remove-xref-resolver (name) 13 | (remhash name *xref-resolvers*)) 14 | 15 | (defmacro define-xref-resolver (name args &body body) 16 | (destructuring-bind (name &optional (priority 0)) (if (listp name) name (list name)) 17 | `(progn (setf (xref-resolver ',name ,priority) 18 | (lambda ,args ,@body)) 19 | ',name))) 20 | 21 | (defun resolve-xref (definition) 22 | (loop for resolver in (sort (loop for v being the hash-values of *xref-resolvers* 23 | collect v) 24 | #'> :key #'first) 25 | for xref = (funcall (second resolver) definition) 26 | when xref do (return xref))) 27 | 28 | (define-xref-resolver (current-page 10) (definition) 29 | (when (find (definitions:package definition) (packages *page*)) 30 | (format NIL "#~a" (url-encode (definition-id definition))))) 31 | 32 | (define-xref-resolver (other-pages 0) (definition) 33 | (dolist (page (pages (project *page*))) 34 | (when (and (typep page 'definitions-index-page) 35 | (find (definitions:package definition) (packages page))) 36 | (return (format NIL "~a#~a" (relative-path page *page*) (url-encode (definition-id definition))))))) 37 | 38 | (define-xref-resolver common-lisp (definition) 39 | (when (eql (definitions:package definition) (find-package "CL")) 40 | (format NIL "http://l1sp.org/cl/~a" (url-encode (string-downcase (definitions:name definition)))))) 41 | 42 | (define-xref-resolver (other-projects -10) (definition) 43 | (let ((sys (package-system (definitions:package definition)))) 44 | (when (and sys (asdf:system-homepage sys)) 45 | (format NIL "~a#~a" (asdf:system-homepage sys) (url-encode (definition-id definition)))))) 46 | 47 | (defun parse-lisp-token (string) 48 | (with-output-to-string (out) 49 | (with-input-from-string (in string) 50 | (loop for char = (read-char in NIL) 51 | while char 52 | do (case char 53 | (#\\ (write-char (read-char in NIL) out)) 54 | (#\| (loop for char = (read-char in NIL) 55 | until (char= char #\|) 56 | do (write-char char out))) 57 | (T (write-char (char-upcase char) out))))))) 58 | 59 | (defun parse-symbol (identifier) 60 | (let (package (name identifier)) 61 | (loop with escaped = NIL 62 | for i from 0 below (length identifier) 63 | for char = (aref identifier i) 64 | do (case char 65 | (#\| (setf escaped (not escaped))) 66 | (#\\ (incf i)) 67 | (#\: 68 | (unless escaped 69 | (if (<= (length identifier) (1+ i)) 70 | (setf name "") 71 | (setf name (subseq identifier (+ i (if (eql #\: (aref identifier (1+ i))) 2 1))))) 72 | (setf package (cond ((= 0 i) 73 | "KEYWORD") 74 | ((and (= 1 i) (char= #\# (aref identifier 0))) 75 | :gensym) 76 | (T 77 | (subseq identifier 0 i)))))))) 78 | (values (parse-lisp-token name) 79 | (etypecase package 80 | (string (parse-lisp-token package)) 81 | ((eql :gensym) :gensym) 82 | (null NIL))))) 83 | 84 | (defun find-definitions-for-identifier (name &key package (type T)) 85 | (let ((packages (if package 86 | (list package) 87 | (append (packages *page*) (list "CL"))))) 88 | (loop for package in packages 89 | append (ignore-errors 90 | (let* ((package (ensure-package package)) 91 | (symbol (find-symbol name package))) 92 | (when symbol 93 | (definitions:find-definitions symbol :package package :type type))))))) 94 | 95 | (defgeneric xref (thing &optional type)) 96 | 97 | (defmethod xref ((definition definitions:definition) &optional (type T)) 98 | (declare (ignore type)) 99 | (resolve-xref definition)) 100 | 101 | (defmethod xref ((identifier string) &optional (type T)) 102 | (multiple-value-bind (name package) (parse-symbol identifier) 103 | (unless (eql package :gensym) 104 | (let ((defs (find-definitions-for-identifier name :package package :type type))) 105 | (loop for def in (preferred-definition defs) 106 | for xref = (resolve-xref def) 107 | do (when xref (return xref))))))) 108 | -------------------------------------------------------------------------------- /parser/to-definitions.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.staple.code-parser) 2 | 3 | (defmethod find-definitions (type source args)) 4 | 5 | (defmacro define-definition-resolver (type (source &rest args) &body body) 6 | (let ((argsg (gensym "ARGS"))) 7 | `(defmethod find-definitions ((,(gensym "TYPE") (eql ',type)) ,source ,argsg) 8 | (destructuring-bind ,args ,argsg 9 | ,@body)))) 10 | 11 | (defun tie-to-source (source defs) 12 | (loop for def in defs collect (list def source))) 13 | 14 | (define-definition-resolver :call (source name &rest arguments) 15 | (declare (ignore arguments)) 16 | (tie-to-source (second name) 17 | (definitions:find-definitions (third name) :type 'definitions:function))) 18 | 19 | (define-definition-resolver :macro (source name expansion) 20 | (declare (ignore expansion)) 21 | (tie-to-source (second name) 22 | (definitions:find-definitions (third name) :type 'definitions:macro))) 23 | 24 | (define-definition-resolver :variable (source name) 25 | (tie-to-source source 26 | (definitions:find-definitions name :type 'definitions:variable))) 27 | 28 | (define-definition-resolver :type (source name) 29 | (tie-to-source source 30 | (definitions:find-definitions name :type 'definitions:type))) 31 | 32 | (define-definition-resolver function (source name) 33 | (tie-to-source source 34 | (definitions:find-definitions name :type 'definitions:function))) 35 | 36 | (defmethod sub-results (type args)) 37 | 38 | (defmacro define-sub-results (type args &body body) 39 | (let ((argsg (gensym "ARGS"))) 40 | `(defmethod sub-results ((,(gensym "TYPE") (eql ',type)) ,argsg) 41 | (destructuring-bind ,args ,argsg 42 | ,@body)))) 43 | 44 | (define-sub-results block (name &rest forms) 45 | (list* name forms)) 46 | 47 | (define-sub-results catch (tag &rest forms) 48 | (list* tag forms)) 49 | 50 | (define-sub-results eval-when (&rest args) 51 | args) 52 | 53 | (define-sub-results flet (names definitions &rest forms) 54 | (append names definitions forms)) 55 | 56 | ;; function 57 | 58 | (define-sub-results lambda (variables &rest forms) 59 | (append (loop for var in variables append var) forms)) 60 | 61 | #+sbcl 62 | (define-sub-results sb-int:named-lambda (name variables &rest forms) 63 | (append (list name) (loop for var in variables append var) forms)) 64 | 65 | (define-sub-results go (label) 66 | (list label)) 67 | 68 | (define-sub-results if (test then &optional else) 69 | (if else 70 | (list test then else) 71 | (list test then))) 72 | 73 | (define-sub-results labels (names values &rest forms) 74 | (append names values forms)) 75 | 76 | (define-sub-results let (names values &rest forms) 77 | (append names values forms)) 78 | 79 | (define-sub-results let* (names values &rest forms) 80 | (append names values forms)) 81 | 82 | (define-sub-results load-time-value (form &optional (read-only-p NIL r-p)) 83 | (if r-p 84 | (list form read-only-p) 85 | (list form))) 86 | 87 | (define-sub-results locally (&rest forms) 88 | forms) 89 | 90 | (define-sub-results macrolet (names definitions &rest forms) 91 | (append names definitions forms)) 92 | 93 | (define-sub-results multiple-value-call (function &rest arguments) 94 | (list* function arguments)) 95 | 96 | (define-sub-results multiple-value-prog1 (form &rest body) 97 | (list* form body)) 98 | 99 | (define-sub-results progn (&rest forms) 100 | forms) 101 | 102 | (define-sub-results progv (symbols values &rest forms) 103 | (list* symbols values forms)) 104 | 105 | (define-sub-results return-from (name value) 106 | (list name value)) 107 | 108 | (define-sub-results setq (places values) 109 | (append places values)) 110 | 111 | (define-sub-results symbol-macrolet (names expansions &rest forms) 112 | (append names expansions forms)) 113 | 114 | (define-sub-results tagbody (labels abstractions) 115 | (append labels abstractions)) 116 | 117 | (define-sub-results the (type form) 118 | (list type form)) 119 | 120 | (define-sub-results throw (tag results) 121 | (list tag results)) 122 | 123 | (define-sub-results unwind-protect (protected &rest cleanup) 124 | (list* protected cleanup)) 125 | 126 | (define-sub-results :macro (name expansion) 127 | (list name expansion)) 128 | 129 | (define-sub-results :call (name &rest arguments) 130 | (list* name arguments)) 131 | 132 | (defun parse-result->definition-list (result) 133 | (let ((results ())) 134 | (labels ((traverse (type location &rest args) 135 | (when location 136 | (dolist (def (find-definitions type location args)) 137 | ;; Only keep results for different locations or different types. 138 | (unless (or (null (second def)) 139 | (loop for (pdef ploc) in results 140 | thereis (and (equal (second def) ploc) 141 | (eql (type-of (first def)) (type-of pdef))))) 142 | (pushnew def results :key #'second :test #'equal)))) 143 | (loop for form in (sub-results type args) 144 | do (apply #'traverse form)))) 145 | (loop for form in result 146 | do (apply #'traverse form)) 147 | results))) 148 | -------------------------------------------------------------------------------- /clip.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.staple) 2 | 3 | (defmethod clip:clip ((component asdf:component) field) 4 | (case* string-equal field 5 | (name (asdf:component-name component)) 6 | (parent (asdf:component-parent component)) 7 | (system (asdf:component-system component)) 8 | (version (asdf:component-version component)) 9 | (children (asdf:component-children component)) 10 | (encoding (asdf:component-encoding component)) 11 | (loaded-p (asdf:component-loaded-p component)) 12 | (pathname (asdf:component-pathname component)) 13 | (relative-pathname(asdf:component-relative-pathname component)) 14 | (find-path (asdf:component-find-path component)) 15 | (external-format (asdf:component-external-format component)) 16 | (children-by-name (asdf:component-children-by-name component)) 17 | (load-dependencies (asdf:component-sideway-dependencies component)) 18 | (sideway-dependencies (asdf:component-sideway-dependencies component)) 19 | (T (call-next-method)))) 20 | 21 | (defmethod clip:clip ((system asdf:system) field) 22 | (case* string-equal field 23 | (author (system-field 'author system)) 24 | (mailto (system-field 'mailto system)) 25 | (licence (system-field 'licence system)) 26 | (license (system-field 'licence system)) 27 | (homepage (system-field 'homepage system)) 28 | (long-name (system-field 'long-name system)) 29 | (maintainer (system-field 'maintainer system)) 30 | (bug-tracker (system-field 'bug-tracker system)) 31 | (description (system-field 'description system)) 32 | (source-file (system-field 'source-file system)) 33 | (source-control (if (listp (system-field 'source-control system)) 34 | (second (system-field 'source-control system)) 35 | (system-field 'source-control system))) 36 | (long-description (system-field 'long-description system)) 37 | (source-directory (system-field 'source-directory system)) 38 | (definition-pathname (system-field 'source-file system)) 39 | (defsystem-depends-on (system-field 'defsystem-depends-on system)) 40 | (depends-on (system-field 'depends-on system)) 41 | (weakly-depends-on (system-field 'weakly-depends-on system)) 42 | (dependencies (loop for entry in (append (system-field 'defsystem-depends-on system) 43 | (system-field 'depends-on system) 44 | (system-field 'weakly-depends-on system)) 45 | for system = (ensure-system entry) 46 | when system collect system)) 47 | (license-link 48 | (let ((in-output (find-files (output (project *page*)) '("LICENCE" "LICENSE") :max-depth 1)) 49 | (in-project (find-files (asdf:system-source-directory system) '("LICENCE" "LICENSE")))) 50 | (cond (in-output 51 | (relative-path (first in-output) *page*)) 52 | (in-project 53 | (resolve-source-link (list :file (first in-project)) *page*)) 54 | (T 55 | (format NIL "https://tldrlegal.com/search?q=~a" (system-field 'license system)))))) 56 | (T (call-next-method)))) 57 | 58 | (defmethod clip:clip ((package package) field) 59 | (case* string-equal field 60 | (name (package-name package)) 61 | (nicknames (package-nicknames package)) 62 | (shadowing-symbols (package-shadowing-symbols package)) 63 | (use-list (package-use-list package)) 64 | (used-by-list (package-used-by-list package)) 65 | (symbols 66 | (loop for symbol being the symbols of package 67 | collect symbol)) 68 | (external-symbols 69 | (loop for symbol being the external-symbols of package 70 | collect symbol)) 71 | (T (call-next-method)))) 72 | 73 | (defmethod clip:clip ((symbol symbol) field) 74 | (case* string-equal field 75 | (name (symbol-name symbol)) 76 | (package (symbol-package symbol)) 77 | (value (symbol-value symbol)) 78 | (function (symbol-function symbol)) 79 | (plist (symbol-plist symbol)) 80 | (T (call-next-method)))) 81 | 82 | (defmethod clip:clip ((definition definitions:definition) field) 83 | (case* string-equal field 84 | (xref (xref definition)) 85 | (id (definition-id definition)) 86 | (designator (definitions:designator definition)) 87 | (object (definitions:object definition)) 88 | (symbol (definitions:symbol definition)) 89 | (name (definitions:name definition)) 90 | (full-name (format NIL "~a:~a" 91 | (package-name (definitions:package definition)) 92 | (definitions:designator definition))) 93 | (package (definitions:package definition)) 94 | (type (type-of definition)) 95 | (kind (definitions:type definition)) 96 | (visibility (definitions:visibility definition)) 97 | (documentation (maybe-lang-docstring definition (language *page*))) 98 | (source-location (definitions:source-location definition)) 99 | (arguments ()) 100 | (qualifiers ()) 101 | (source-link (resolve-source-link definition *page*)) 102 | (formatted-documentation 103 | (or (format-documentation definition *page*) 104 | "No documentation provided.")) 105 | (T (call-next-method)))) 106 | 107 | (defmethod clip:clip ((definition definitions:callable) field) 108 | (case* string-equal field 109 | (arguments (definitions:arguments definition)) 110 | (T (call-next-method)))) 111 | 112 | (defmethod clip:clip ((definition definitions:method) field) 113 | (case* string-equal field 114 | (qualifiers (definitions:qualifiers definition)) 115 | (T (call-next-method)))) 116 | 117 | (defmethod clip:clip ((definition definitions:package) field) 118 | (case* string-equal field 119 | (nicknames (package-nicknames (definitions:object definition))) 120 | (definitions 121 | (definitions *page* (definitions:object definition))) 122 | (T (call-next-method)))) 123 | -------------------------------------------------------------------------------- /server/server.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.staple.server) 2 | 3 | (defvar *server-build* NIL) 4 | (defvar *acceptor* NIL) 5 | (defvar *tmpdir* (merge-pathnames "staple-server/" (uiop:temporary-directory))) 6 | 7 | (defun all-systems () 8 | (sort (asdf/system-registry:registered-systems*) #'string< :key #'asdf:component-name)) 9 | 10 | (defun data-file (path) 11 | (asdf:system-relative-pathname :staple-server (format NIL "data/~a" path))) 12 | 13 | (defun system-link (system) 14 | (format NIL "/~a/" (asdf:component-name system))) 15 | 16 | (defun system-path (system) 17 | (merge-pathnames (make-pathname :directory `(:relative ,(asdf:component-name system))) 18 | *tmpdir*)) 19 | 20 | (defun find-system-in-path (path) 21 | (let ((systems ())) 22 | (asdf:map-systems 23 | (lambda (sys) 24 | (when (staple::prefix-p (asdf:component-name sys) path) 25 | (push sys systems)))) 26 | (first (sort systems #'> :key (lambda (s) (length (asdf:component-name s))))))) 27 | 28 | (defun safe-prin1 (thing) 29 | (or (ignore-errors (prin1-to-string thing)) 30 | "")) 31 | 32 | (defmacro or* (&rest vals) 33 | (let ((arg (gensym "ARG"))) 34 | `(or ,@(loop for val in vals 35 | collect `(let ((,arg ,val)) 36 | (if (stringp ,arg) 37 | (unless (string= ,arg "") ,arg) 38 | ,arg)))))) 39 | 40 | (defun cache-system (system &optional dir) 41 | (unless (typep system 'asdf:system) (setf system (asdf:find-system system T))) 42 | (unless dir (setf dir (system-path system))) 43 | (format T "~& > Generating cache for ~a." (asdf:component-name system)) 44 | (ensure-directories-exist dir) 45 | (let ((*server-build* T)) 46 | (staple:generate system :if-exists :supersede 47 | :output-directory dir) 48 | ;; Modify HTML files to work better in the server environment. 49 | (staple::do-directory-tree (file dir) 50 | (when (find (pathname-type file) '("html" "htm" "xhtml") :test #'string-equal) 51 | (let ((document (plump:parse file))) 52 | (lquery:$ document "a[href^=file://]" 53 | (each (lambda (el) 54 | (setf (plump:attribute el "href") 55 | (format NIL "/source~a" (subseq (plump:attribute el "href") 56 | (length "file://"))))))) 57 | (lquery:$ document "[src^=file://]" 58 | (each (lambda (el) 59 | (setf (plump:attribute el "src") 60 | (format NIL "/file~a" (subseq (plump:attribute el "src") 61 | (length "file://"))))))) 62 | (lquery:$ document "body" (append (lquery:$ (initialize (data-file "nav.ctml")) "nav"))) 63 | (lquery:$ document (write-to-file file))))))) 64 | 65 | (defun clear-cache (&optional system) 66 | (uiop:delete-directory-tree 67 | (if system 68 | (system-path system) 69 | *tmpdir*) 70 | :validate (lambda (p) (uiop:subpathp p *tmpdir*)))) 71 | 72 | (defclass acceptor (hunchentoot:acceptor) 73 | () 74 | (:default-initargs 75 | :port 5123 76 | :message-log-destination NIL 77 | :access-log-destination NIL)) 78 | 79 | (defmethod hunchentoot:acceptor-dispatch-request ((acceptor acceptor) request) 80 | (let* ((path (subseq (hunchentoot:url-decode (hunchentoot:script-name request)) 1)) 81 | (system (find-system-in-path path))) 82 | (restart-case 83 | (handler-bind 84 | ((error (lambda (e) 85 | (dissect:with-capped-stack () 86 | (use-value (serve-error e) e))))) 87 | (cond 88 | ((string= path "") 89 | (serve-system-list)) 90 | ((staple::prefix-p "file/" path) 91 | (hunchentoot:handle-static-file (subseq path 4))) 92 | ((staple::prefix-p "source/" path) 93 | (serve-source (subseq path 6))) 94 | (system 95 | (serve-system-docs system (subseq path (length (asdf:component-name system))))) 96 | (T 97 | (hunchentoot:handle-static-file (data-file path))))) 98 | (use-value (value &optional error) 99 | (declare (ignore error)) 100 | value)))) 101 | 102 | (defun start (&key (port 5123)) 103 | (when *acceptor* 104 | (error "Server already running!")) 105 | (let ((acceptor (make-instance 'acceptor :port port))) 106 | (hunchentoot:start acceptor) 107 | (setf *acceptor* acceptor) 108 | (format T "~&Your documentation browser is now running on http://localhost:~a/~%" 109 | (hunchentoot:acceptor-port acceptor)))) 110 | 111 | (defun stop () 112 | (unless *acceptor* 113 | (error "Server is not running!")) 114 | (hunchentoot:stop *acceptor*) 115 | (setf *acceptor* NIL)) 116 | 117 | (defun serve-system-list () 118 | (plump:serialize 119 | (clip:process (data-file "list.ctml") 120 | :systems (all-systems)) 121 | NIL)) 122 | 123 | (defmacro with-error-unwind (form &body body) 124 | (let ((completed (gensym "COMPLETED"))) 125 | `(let ((,completed NIL)) 126 | (unwind-protect (multiple-value-prog1 ,form 127 | (setf ,completed T)) 128 | (unless ,completed 129 | ,@body))))) 130 | 131 | (defun serve-system-docs (system path) 132 | (let* ((dir (system-path system)) 133 | (path (if (string= "" path) "" (subseq path 1))) 134 | (path (if (string= "" path) "index.html" path)) 135 | (path (merge-pathnames dir path))) 136 | (when (or* (not (uiop:directory-exists-p dir)) 137 | (hunchentoot:get-parameter "rebuild")) 138 | (with-error-unwind (cache-system system dir) 139 | (clear-cache system))) 140 | (hunchentoot:handle-static-file path))) 141 | 142 | (defun serve-source (path) 143 | (plump:serialize 144 | (clip:process (data-file "file.ctml") 145 | :path path) 146 | NIL)) 147 | 148 | (defun serve-error (err) 149 | (plump:serialize 150 | (clip:process (data-file "error.ctml") 151 | :env (dissect:capture-environment err)) 152 | NIL)) 153 | 154 | (staple:define-xref-resolver server (definition) 155 | (when *server-build* 156 | (let ((sys (loop for sys in (all-systems) 157 | for packages = (staple:packages sys) 158 | do (when (find (definitions:package definition) packages) 159 | (return sys))))) 160 | (when sys 161 | (format NIL "/~a/#~a" 162 | (staple:url-encode (asdf:component-name sys)) 163 | (staple:url-encode (staple:definition-id definition))))))) 164 | -------------------------------------------------------------------------------- /parser/standard-forms.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.staple.code-parser) 2 | 3 | (define-walk-compound-form T (cst environment) 4 | (cst:db source (operator . arguments) cst 5 | (if (cst:atom operator) 6 | (if-let ((expander (ignore-errors (macro-function (cst:raw operator))))) 7 | (handler-case 8 | (let ((expansion (perform-and-record-macro-expansion expander cst))) 9 | `(:macro ,source 10 | ,(walk operator) 11 | ,(walk expansion))) 12 | (error () 13 | ;; Just.. bail. Not ideal, could try stuff like walking body forms 14 | ;; and skipping expansion. Maybe. 15 | `(:macro ,source 16 | ,(walk operator) 17 | ,(cst:raw cst)))) 18 | `(:call ,source 19 | ,(walk operator) 20 | ,@(mapcar #'walk (cst:listify arguments)))) 21 | (error "~@" cst)))) 22 | 23 | (defun perform-and-record-macro-expansion (expander cst) 24 | (let* ((expansion/raw (funcall expander (cst:raw cst) nil)) 25 | (reconstructed (cst:reconstruct T expansion/raw cst))) 26 | (labels ((record (node source-and-targets) 27 | (when (not (member node (cdr source-and-targets) :test #'eq)) 28 | (push node (cdr source-and-targets)) 29 | (when (cst:consp node) 30 | (record (cst:first node) source-and-targets) 31 | (record (cst:rest node) source-and-targets))))) 32 | (record reconstructed (cons cst '())) 33 | reconstructed))) 34 | 35 | ;; FIXME: Type walker required 36 | ;; (define-walk-compound-form typep (cst environment) 37 | ;; (cst:db source (operator form type . env) cst 38 | ;; (declare (ignore env)) 39 | ;; `(:call ,source 40 | ;; ,(walk operator) 41 | ;; ,(walk form) 42 | ;; ))) 43 | 44 | (defun maybe-unquote (thing) 45 | (if (and (consp thing) (eql 'quote (first thing))) 46 | (second thing) 47 | thing)) 48 | 49 | (define-walk-compound-form make-instance (cst environment) 50 | (cst:db source (operator type . args) cst 51 | `(progn ,source 52 | (:call ,(cons (car source) (cdr (cst:source operator))) 53 | (:function ,(cst:source operator) ,(cst:raw operator)) 54 | (:type ,(cst:source type) ,(maybe-unquote (cst:raw type))) 55 | ,@(mapcar #'walk (cst:listify args)))))) 56 | 57 | (define-walk-compound-form defclass (cst environment) 58 | (cst:db source (operator name superclasses slots . options) cst 59 | `(:macro ,source 60 | ,(walk operator) 61 | (progn ,source 62 | ,@(loop for class in (cst:listify superclasses) 63 | collect `(:type ,(cst:source class) ,(cst:raw class))))))) 64 | 65 | ;; Try handling defmethod directly to avoid lengthy macroexpansion and to 66 | ;; handle inference of class types. 67 | (define-walk-compound-form defmethod (cst environment) 68 | (cst:db source (operator name . args) cst 69 | (let ((qualifiers (loop for item = (cst:first args) 70 | while (and (cst:atom item) (not (cst:null item))) 71 | collect item 72 | do (setf args (cst:rest args)))) 73 | (lambda-list (cst:first args)) 74 | (body (cst:rest args))) 75 | (declare (ignore qualifiers)) 76 | (multiple-value-bind (declarations documentation forms) 77 | (cst:separate-function-body body) 78 | (declare (ignore declarations documentation)) 79 | `(:macro ,source 80 | ,(walk operator) 81 | (lambda ,source 82 | ,(walk (cst:parse-specialized-lambda-list T lambda-list) environment) 83 | (function ,(cst:source name) ,(cst:raw name)) 84 | ,@(walk-implicit-progn forms environment))))))) 85 | 86 | ;; Try handling the distinction between setf functions and setf-expanders. 87 | (define-walk-compound-form setf (cst environment) 88 | (cst:db source (operator . pairs) cst 89 | (flet ((handle-place (place value) 90 | (cond ((cst:atom place) 91 | `(setq ,source (,(walk place)) (,(walk value)))) 92 | ((fboundp `(setf ,(cst:raw (cst:first place)))) 93 | `(:call ,(cons (car source) (cdr (cst:source value))) 94 | (:function ,(cst:source (cst:first place)) 95 | (setf ,(cst:raw (cst:first place)))) 96 | ,(walk value) 97 | ,@(mapcar #'walk (cst:listify (cst:rest place))))) 98 | (T 99 | ;; Not sure how to check for setf-expanders or expand to 100 | ;; them, so we just do a basic macro expansion to at least 101 | ;; potentially get information about the arguments. 102 | (let ((expansion (perform-and-record-macro-expansion 103 | (macro-function 'setf) 104 | (cst:list operator place value)))) 105 | `(:macro ,source 106 | ,(walk operator) 107 | ,(walk expansion))))))) 108 | (let ((pairs (cst:listify pairs))) 109 | `(progn ,source 110 | ,@(loop for (place value) on pairs by #'cddr 111 | collect (handle-place place value))))))) 112 | 113 | (define-walk-compound-form loop (cst environment) 114 | (cst:db source (operator . args) cst 115 | `(:macro ,source 116 | ,(walk operator) 117 | (lambda ,source 118 | () 119 | ,@(walk-implicit-progn args environment))))) 120 | 121 | ;; Transform literals in funcalls' function arguments to functions. 122 | (flet ((walk-funcallish (cst environment) 123 | (cst:db source (operator function . arguments) cst 124 | (let ((function (walk function environment))) 125 | `(:call ,source 126 | ,(walk operator environment) 127 | ,(if (eql :literal (first function)) 128 | `(function ,@(rest function)) 129 | function) 130 | ,@(loop for argument in (cst:listify arguments) 131 | collect (walk argument environment))))))) 132 | (define-walk-compound-form funcall (cst environment) 133 | (walk-funcallish cst environment)) 134 | 135 | (define-walk-compound-form apply (cst environment) 136 | (walk-funcallish cst environment))) 137 | -------------------------------------------------------------------------------- /parser/documentation.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.staple.code-parser) 2 | 3 | ;; environment.lisp 4 | (docs:define-docs 5 | (type environment 6 | "Container for environment information used during walking. 7 | 8 | See PARENT 9 | See NAMESPACES 10 | See LOOKUP 11 | See AUGMENT-ENVIRONMENT! 12 | See AUGMENTED-ENVIRONMENT") 13 | 14 | (function parent 15 | "Returns the parent of the environment, if any. 16 | 17 | See ENVIRONMENT") 18 | 19 | (function namespaces 20 | "Returns the hash-table of namespaces in the environment. 21 | 22 | See ENVIRONMENT 23 | See NAMESPACE") 24 | 25 | (function namespace 26 | "Accesses the namespace of the given name from the environment. 27 | 28 | See NAMESPACES 29 | See ENVIRONMENT 30 | See LOOKUP") 31 | 32 | (function ensure-namespace 33 | "Makes sure the namespace of the given name exists in the environment. 34 | 35 | See ENVIRONMENT 36 | See NAMESPACES") 37 | 38 | (function lookup 39 | "Looks up the name in the namespace of the environment. 40 | 41 | This will traverse the environment chain upwards until no parent can 42 | be found anymore in case the current environment's namespace does not 43 | contain the value. 44 | 45 | When used as a setf place the value is always stored in the given 46 | environment's namespace. 47 | 48 | See NAMESPACE 49 | See ENVIRONMENT") 50 | 51 | (function augment-environment! 52 | "Augments the given environment with the new values for the given names. 53 | 54 | Returns the modified environment. 55 | 56 | See LOOKUP 57 | See ENVIRONMENT") 58 | 59 | (function augmented-environment 60 | "Returns a new environment with the changed values in place. 61 | 62 | The old environment is a parent to the new one. 63 | 64 | See AUGMENT-ENVIRONMENT! 65 | See ENVIRONMENT")) 66 | 67 | ;; to-definitions.lisp 68 | (docs:define-docs 69 | (function find-definitions 70 | "Returns any matching definitions for the given parse result. 71 | 72 | All parse results have the structure of (TYPE SOURCE . ARGS). 73 | Thus you can simply destructure it and pass the arguments to this 74 | function to retrieve its definitions. 75 | 76 | See DEFINE-DEFINITION-RESOLVER") 77 | 78 | (function define-definition-resolver 79 | "Shorthand to define a find-definitions method and destructure the arguments of the parse result. 80 | 81 | See FIND-DEFINITIONS") 82 | 83 | (function tie-to-source 84 | "Turns each def into a list of source and def.") 85 | 86 | (function sub-results 87 | "Returns all parse results that are sub-results of this parse result. 88 | 89 | All parse results have the structure of (TYPE SOURCE . ARGS). 90 | Thus you can simply destructure it and pass the arguments to this 91 | function to retrieve its definitions. 92 | 93 | See DEFINE-SUB-RESULTS") 94 | 95 | (function define-sub-results 96 | "Shorthand to define a sub-results method and destructure the arguments of the parse result. 97 | 98 | See SUB-RESULTS") 99 | 100 | (function parse-result->definition-list 101 | "Turn the parse-result into a list of definitions and source locations. 102 | 103 | For instance: 104 | ((:CALL (0 . 10) (:VARIABLE (1 . 5) NULL) (:LITERAL (6 . 9) NIL))) 105 | => ((# (1 . 5))) 106 | 107 | This uses FIND-DEFINITIONS to find suitable definitions for a parse 108 | result, as well as SUB-RESULTS to traverse the parse result tree. 109 | 110 | See FIND-DEFINITIONS 111 | See SUB-RESULTS")) 112 | 113 | ;; walker.lisp 114 | (docs:define-docs 115 | (type client 116 | "Our subclass of the eclector cst-client. 117 | 118 | Uses the host lisp's EVAL. 119 | 120 | See ECLECTOR.CONCRETE-SYNTAX-TREE::CST-CLIENT") 121 | 122 | (type placeholder 123 | "This class represents symbols that are not present in the host. 124 | 125 | They are emitted in parsed code snippets in place of symbols that 126 | cannot be read properly. 127 | 128 | See PLACEHOLDER-NAME 129 | See PLACEHOLDER-PACKAGE 130 | See PLACEHOLDER-INTERN") 131 | 132 | (function placeholder-name 133 | "Returns the symbol-name of the symbol this is a placeholder for. 134 | 135 | See PLACEHOLDER") 136 | 137 | (function placeholder-package 138 | "Returns the symbol-package name of the symbol this is a placeholder for. 139 | 140 | See PLACEHOLDER") 141 | 142 | (function placeholder-intern 143 | "Returns whether the symbol being read is an internal or external symbol. 144 | 145 | See PLACEHOLDER") 146 | 147 | (function walk 148 | "Walks the given CST in the environment. 149 | 150 | Should return a parse result structure. 151 | Parse results are lists of the following form: 152 | 153 | PARSE-RESULT ::= (TYPE SOURCE . ARGS) 154 | TYPE --- The type of the form we've walked. Typically this 155 | is a symbol of the form itself, like LAMBDA, or a 156 | keyword if a generic variant is encountered like 157 | for :CALLs and :MACROs. 158 | SOURCE ::= (START . END) 159 | ARGS --- Additional arguments for the parse result, 160 | including additional parse-results. 161 | 162 | Generally see the overall concrete-syntax-tree system for explanations 163 | on how to use this. 164 | 165 | Note that you probably want to define a method on WALK-FORM instead, 166 | as that is called automatically as appropriate for each CST:CONST-CST, 167 | and WALK-ATOM is called for each CST:ATOM-CST. 168 | 169 | See ENVIRONMENT") 170 | 171 | (function walk-bindings 172 | "Walk the set of LET bindings in the environment. 173 | 174 | Returns a list of cons cells where the CAR is the variable definition 175 | of the binding and the cdr is the parse result of the value. 176 | 177 | See WALK") 178 | 179 | (function walk-implicit-progn 180 | "Walks the CST as a list of forms and returns the list of parse-results for each form. 181 | 182 | See WALK") 183 | 184 | (function walk-body 185 | "Same as WALK-IMPLICIT-PROGN, but filters out declarations from the cst. 186 | 187 | See WALK-IMPLICIT-PROGN") 188 | 189 | (function walk-lambda-like 190 | "Walk a lambda-like structure. 191 | 192 | Parses the lambda-list and body forms appropriately and returns a 193 | parse-result for a lambda. The given parser is used to process the 194 | lambda-list. 195 | 196 | See WALK-IMPLICIT-PROGN") 197 | 198 | (function walk-atom 199 | "Walks an atom. 200 | 201 | If the atom is a symbol, it returns a parse result of a literal for 202 | keywords and booleans, or a variable for symbols. For everything else 203 | it returns a parse result for a literal.") 204 | 205 | (function walk-form 206 | "Walks a form. 207 | 208 | The form is identified by the car of the cons. The entirety of the 209 | form as a CST, including the operator, are passed along as well.") 210 | 211 | (function define-walk-compound-form 212 | "Shorthand to define a WALK-FORM method. 213 | 214 | Adds local functions for WALK and WALK-IMPLICIT-PROGN that 215 | automatically pass the environment along so you don't need to repeat 216 | it. 217 | 218 | See WALK-FORM") 219 | 220 | (function define-walker-form 221 | "Shorthand to define simple walker forms. 222 | 223 | The FORM should be a destructuring description of the kind of form to 224 | walk. The return value of the BODY should be the list of additional 225 | arguments for the parse result. The type and source of the parse 226 | result are automatically added for you. 227 | 228 | If you need control over the type or source, look at 229 | DEFINE-WALK-COMPOUND-FORM instead. 230 | 231 | See DEFINE-WALK-COMPOUND-FORM") 232 | 233 | (function read-toplevel 234 | "Reads the toplevel of an input. 235 | 236 | The INPUT may be a string, pathname, or a stream (by default). 237 | Returns a list of CSTs representing all toplevel forms that were read.") 238 | 239 | (function parse 240 | "Parses the input and returns a list of parse results, each for one toplevel. 241 | 242 | First uses READ-TOPLEVEL to read all toplevel forms, then uses WALK 243 | for each of the read CSTs to turn them into parse results. 244 | 245 | See READ-TOPLEVEL 246 | See WALK")) 247 | -------------------------------------------------------------------------------- /inference.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.staple) 2 | 3 | (defvar *document-patterns* 4 | '("README" "readme" "documentation")) 5 | 6 | (defvar *image-patterns* 7 | '("\\.svg$" "\\.png$" "\\.jpg$" "\\.jpeg$" "\\.gif$" "\\.bmp$")) 8 | 9 | (defvar *default-template* 10 | (asdf:system-relative-pathname :staple "default/default.ctml")) 11 | 12 | (defclass simple-page (system-page) 13 | ((document-package :initarg :document-package :accessor document-package) 14 | (document :initarg :document :accessor document) 15 | (images :initarg :images :accessor images)) 16 | (:default-initargs 17 | :document NIL 18 | :images () 19 | :document-package NIL 20 | :input *default-template*)) 21 | 22 | (defmethod initialize-instance :after ((page simple-page) &key document output language) 23 | (unless output 24 | (error "OUTPUT required.")) 25 | (unless language 26 | (setf (language page) (or (when document (extract-language (file-namestring document))) 27 | (when output (extract-language (file-namestring output))) 28 | :en))) 29 | (unless (or (pathname-name output) 30 | (pathname-type output)) 31 | (setf (output page) (merge-pathnames (filename page) (output page))))) 32 | 33 | (defmethod filename ((page simple-page)) 34 | (make-pathname :name (if (find (language page) '(:en :eng)) 35 | "index" 36 | (format NIL "index-~(~a~)" (language page))) 37 | :type "html")) 38 | 39 | (defmethod definition-wanted-p ((definition definitions:definition) (project simple-page)) 40 | (eql :external (definitions:visibility definition))) 41 | 42 | (defmethod definition-wanted-p ((definition definitions:method) (project simple-page)) 43 | NIL) 44 | 45 | (defmethod definition-wanted-p ((definition definitions:package) (project simple-page)) 46 | NIL) 47 | 48 | (defmethod definition-wanted-p ((definition definitions:compiler-macro) (project simple-page)) 49 | NIL) 50 | 51 | #+sbcl 52 | (defmethod definition-wanted-p ((definition definitions:declaration) (project simple-page)) 53 | NIL) 54 | 55 | (defmethod compile-source ((document pathname) (page simple-page)) 56 | (let ((*package* (or (document-package page) 57 | (first (packages page)) 58 | (find-package "CL-USER")))) 59 | (markup-code-snippets-ignoring-errors 60 | (compile-source document T)))) 61 | 62 | (defmethod template-data append ((page simple-page)) 63 | (list :documentation (when (document page) 64 | (compile-source (document page) page)) 65 | :images (loop for image in (images page) 66 | collect (file-namestring image)))) 67 | 68 | (defmethod documents ((system asdf:system)) 69 | (let ((source (asdf:system-source-directory system))) 70 | (when source 71 | (remove-if-not (lambda (path) (pathname-type->type (pathname-type path))) 72 | (find-files source *document-patterns*))))) 73 | 74 | (defmethod images ((system asdf:system)) 75 | (let ((source (asdf:system-source-directory system))) 76 | (when source 77 | (find-files source *image-patterns* :max-depth 1)))) 78 | 79 | (defmethod subsystems ((system asdf:system)) 80 | (let ((subsystems ())) 81 | (asdf:map-systems 82 | (lambda (subsystem) 83 | (when (and (not (eql subsystem system)) 84 | (prefix-p (asdf:component-name system) 85 | (asdf:component-name subsystem))) 86 | (push subsystem subsystems)))) 87 | subsystems)) 88 | 89 | (defmethod page-type ((system asdf:system)) 90 | 'simple-page) 91 | 92 | (defmethod template ((system asdf:system)) 93 | *default-template*) 94 | 95 | (defmethod output-directory ((system asdf:system)) 96 | (merge-pathnames "docs/" (asdf:system-source-directory system))) 97 | 98 | (define-condition no-known-output-directory (error) 99 | ((system :initarg :system :reader system)) 100 | (:report (lambda (c s) (format s "Cannot infer output directory for ~a." 101 | (asdf:component-name (system c)))))) 102 | 103 | (defmethod infer-project ((system asdf:system) &key output-directory (images NIL images-p) (documents NIL documents-p) page-type template (packages NIL packages-p) (subsystems NIL subsystems-p)) 104 | (load-extension system) 105 | (let* ((output-directory (or output-directory (output-directory system))) 106 | (documents (if documents-p documents (documents system))) 107 | (images (if images-p images (images system))) 108 | (page-type (or page-type (page-type system))) 109 | (template (or template (template system))) 110 | (packages (if packages-p packages (packages system))) 111 | (subsystems (if subsystems-p subsystems (subsystems system)))) 112 | (with-value-restart output-directory 113 | (unless (and (pathnamep output-directory) 114 | (pathname-utils:directory-p output-directory)) 115 | (error 'no-known-output-directory :system system))) 116 | (let ((project (make-instance 'simple-project :output output-directory))) 117 | (flet ((p (page) (push page (pages project)))) 118 | ;; Do subsystems first to filter documents list. 119 | (dolist (spec subsystems) 120 | (destructuring-bind (subsystem . args) (if (listp spec) spec (list spec)) 121 | (let ((sub-directory (or (getf args :output-directory) 122 | (pathname-utils:subdirectory output-directory (asdf:component-name subsystem)))) 123 | (subdocuments (or (getf args :documents) (documents subsystem) '(NIL))) 124 | (images (or (getf args :images) (images subsystem) images)) 125 | (page-type (or (getf args :page-type) (page-type subsystem) page-type)) 126 | (template (or (getf args :template) (template subsystem) template)) 127 | (packages (or (getf args :packages) (packages subsystem)))) 128 | ;; If we have the same source directory, and the documents are 129 | ;; automatically discovered, we'll set them to NIL here to avoid 130 | ;; documents intended for the primary system from being used for 131 | ;; a subsystem. 132 | (when (subsetp documents subdocuments) 133 | (setf subdocuments '(NIL))) 134 | ;; Otherwise, remove all documents from the primary system. 135 | (setf documents (set-difference documents subdocuments :test #'equal)) 136 | ;; And add pages for the subsystem. 137 | (dolist (document subdocuments) 138 | (p (make-instance page-type 139 | :project project 140 | :input template 141 | :output sub-directory 142 | :system subsystem 143 | :document document 144 | :images images 145 | :packages packages))) 146 | ;; Images! 147 | (dolist (image images) 148 | (p (make-instance 'static-page 149 | :project project 150 | :input image 151 | :output (pathname-utils:file-in sub-directory image))))))) 152 | ;; Pages for the primary documents. 153 | (dolist (document (or documents '(NIL))) 154 | (p (make-instance page-type 155 | :project project 156 | :input template 157 | :output output-directory 158 | :system system 159 | :document document 160 | :images images 161 | :packages packages))) 162 | ;; Images and stuff. 163 | (dolist (image images) 164 | (p (make-instance 'static-page 165 | :project project 166 | :input image 167 | :output (pathname-utils:file-in output-directory image))))) 168 | project))) 169 | -------------------------------------------------------------------------------- /docs/staple-markdown/index.html: -------------------------------------------------------------------------------- 1 | Staple Markdown
1.0.0

Markdown processing support for Staple

Table of Contents

About

This system adds support for Markdown syntax in both documents and docstrings. When this system is loaded, Staple will automatically scan for documents with the ending md to use as primary documents on inferred pages. It also adds the source-compiler :markdown that can be used to markup documentation source.

To use Markdown for docstrings as well, use a customisation like this on your page type:

(defmethod staple:format-documentation ((docstring string) (page my-page))
 2 |   (let ((*package* (first (staple:packages page))))
 3 |     (staple:markup-code-snippets-ignoring-errors
 4 |      (staple:compile-source docstring :markdown))))
 5 |

System Information

1.0.0
Yukari Hafner
zlib
https://Shinmera.github.io/staple/
https://github.com/Shinmera/staple/issues
https://github.com/Shinmera/staple.git
-------------------------------------------------------------------------------- /docs/staple-restructured-text/index.html: -------------------------------------------------------------------------------- 1 | Staple Restructured Text
1.0.0

Markdown processing support for Staple

Table of Contents

About

This system adds support for ReStructuredText syntax in both documents and docstrings. When this system is loaded, Staple will automatically scan for documents with the ending rst to use as primary documents on inferred pages. It also adds the source-compiler :restructured-text that can be used to markup documentation source.

To use ReStructuredText for docstrings as well, use a customisation like this on your page type:

(defmethod staple:format-documentation ((docstring string) (page my-page))
 2 |   (let ((*package* (first (staple:packages page))))
 3 |     (staple:markup-code-snippets-ignoring-errors
 4 |      (staple:compile-source docstring :restructured-text))))
 5 |

System Information

1.0.0
Yukari Hafner
zlib
https://Shinmera.github.io/staple/
https://github.com/Shinmera/staple/issues
https://github.com/Shinmera/staple.git
-------------------------------------------------------------------------------- /docs/staple-markless/index.html: -------------------------------------------------------------------------------- 1 | Staple Markless
1.0.0

Markdown processing support for Staple

Table of Contents

About

This system adds support for Markless syntax in both documents and docstrings. When this system is loaded, Staple will automatically scan for documents with the ending mess to use as primary documents on inferred pages. It also adds the source-compiler :markless that can be used to markup documentation source.

To use Markless for docstrings as well, use a customisation like this on your page type:

(defmethod staple:format-documentation ((docstring string) (page my-page))
 2 |   (let ((*package* (first (staple:packages page))))
 3 |     (staple:markup-code-snippets-ignoring-errors
 4 |      (staple:compile-source docstring :markless))))
 5 |

System Information

1.0.0
Yukari Hafner
zlib
https://Shinmera.github.io/staple/
https://github.com/Shinmera/staple/issues
https://github.com/Shinmera/staple.git
-------------------------------------------------------------------------------- /default/default.ctml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | Title 6 | 7 | 8 | 9 |
10 |
11 | 12 | 13 | 14 | 15 |

Name

16 | 17 | 18 | 1.0 19 | 20 | 21 | 24 | 25 | 26 |

27 | Some short description of the lib. 28 |

29 | 30 | 31 | 34 | 35 |
36 |
37 |

Table of Contents

38 | 54 |
55 | 56 |
57 |
58 | 59 | 60 | 61 |
62 |

System Information

63 | 64 |
65 | 66 | version 67 |
68 | 69 | 70 |
71 | 72 |
73 |
74 | 75 | 76 | 77 |
78 | 79 | author 80 |
81 | 82 | 83 |
84 | 85 | 89 |
90 | 91 | 92 | 93 |
94 | 95 | license 96 |
97 | 98 | 99 |
100 | 101 | http://example.com 102 |
103 | 104 | 105 |
106 | 107 | http://example.com 108 |
109 | 110 | 111 |
112 | 113 | http://example.com 114 |
115 | 116 |
117 | 118 | 119 | 120 |
121 |

Definition Index

122 |
    123 |
  • 124 |
    125 |
    126 |

    127 | FOO 128 |

    129 |
      130 |
    • CL-FOO
      • 131 |
    132 | 133 | Source 134 | 135 |
    136 |
    Docstring
    137 |
      138 |
    • 139 |
      140 |
      141 | visibility 142 | type 143 |

      144 | name 145 |

      146 |
        147 |
      • qualifier
        • 148 |
      149 |
        150 | 151 | 152 |
          153 |
        • argument
          • 154 |
        155 |         156 | 157 |
      • argument
        • 158 |         159 |         160 |
      161 | 162 | Source 163 | 164 |
      165 |
      Docstring
      166 |
      167 |
      • 168 |
    169 |
    170 |
    • 171 |
172 |
173 | 174 |
175 | 176 | 177 | 178 | -------------------------------------------------------------------------------- /logo.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 19 | 21 | 41 | 43 | 44 | 46 | image/svg+xml 47 | 49 | 50 | 51 | 52 | 53 | 58 | 73 | 77 | 81 | 85 | 89 | 93 | 94 | 99 | 104 | 109 | 110 | 111 | -------------------------------------------------------------------------------- /docs/logo.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 19 | 21 | 41 | 43 | 44 | 46 | image/svg+xml 47 | 49 | 50 | 51 | 52 | 53 | 58 | 73 | 77 | 81 | 85 | 89 | 93 | 94 | 99 | 104 | 109 | 110 | 111 | -------------------------------------------------------------------------------- /docs/staple-server/logo.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 19 | 21 | 41 | 43 | 44 | 46 | image/svg+xml 47 | 49 | 50 | 51 | 52 | 53 | 58 | 73 | 77 | 81 | 85 | 89 | 93 | 94 | 99 | 104 | 109 | 110 | 111 | -------------------------------------------------------------------------------- /docs/staple-code-parser/logo.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 19 | 21 | 41 | 43 | 44 | 46 | image/svg+xml 47 | 49 | 50 | 51 | 52 | 53 | 58 | 73 | 77 | 81 | 85 | 89 | 93 | 94 | 99 | 104 | 109 | 110 | 111 | -------------------------------------------------------------------------------- /docs/staple-markdown/logo.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 19 | 21 | 41 | 43 | 44 | 46 | image/svg+xml 47 | 49 | 50 | 51 | 52 | 53 | 58 | 73 | 77 | 81 | 85 | 89 | 93 | 94 | 99 | 104 | 109 | 110 | 111 | -------------------------------------------------------------------------------- /docs/staple-markless/logo.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 19 | 21 | 41 | 43 | 44 | 46 | image/svg+xml 47 | 49 | 50 | 51 | 52 | 53 | 58 | 73 | 77 | 81 | 85 | 89 | 93 | 94 | 99 | 104 | 109 | 110 | 111 | -------------------------------------------------------------------------------- /docs/staple-package-recording/logo.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 19 | 21 | 41 | 43 | 44 | 46 | image/svg+xml 47 | 49 | 50 | 51 | 52 | 53 | 58 | 73 | 77 | 81 | 85 | 89 | 93 | 94 | 99 | 104 | 109 | 110 | 111 | -------------------------------------------------------------------------------- /docs/staple-restructured-text/logo.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 19 | 21 | 41 | 43 | 44 | 46 | image/svg+xml 47 | 49 | 50 | 51 | 52 | 53 | 58 | 73 | 77 | 81 | 85 | 89 | 93 | 94 | 99 | 104 | 109 | 110 | 111 | --------------------------------------------------------------------------------