Repository: atlas-engineer/nyxt Branch: master Commit: aeb6c72cf1ef Files: 205 Total size: 1.2 MB Directory structure: gitextract_qdmfzfut/ ├── .dir-locals.el ├── .github/ │ ├── ISSUE_TEMPLATE/ │ │ ├── bug_report.md │ │ ├── feature_request.md │ │ └── ui_request.md │ ├── SECURITY.md │ └── pull_request_template.md ├── .gitignore ├── .gitmodules ├── INSTALL ├── README.org ├── _build/ │ └── README.org ├── assets/ │ ├── Info.plist │ ├── nyxt.appimage.desktop │ ├── nyxt.desktop │ ├── nyxt.icns │ └── nyxt.metainfo.xml ├── developer-manual.org ├── libraries/ │ ├── analysis/ │ │ ├── README.org │ │ ├── analysis.lisp │ │ ├── composite-sequence.lisp │ │ ├── data.lisp │ │ ├── dbscan.lisp │ │ ├── document-vector.lisp │ │ ├── package.lisp │ │ ├── section.lisp │ │ ├── stem.lisp │ │ ├── tests/ │ │ │ └── tests.lisp │ │ ├── text-rank.lisp │ │ └── tokenize.lisp │ ├── download-manager/ │ │ ├── engine.lisp │ │ ├── native.lisp │ │ └── package.lisp │ ├── nasdf/ │ │ ├── install.lisp │ │ ├── log.lisp │ │ ├── nasdf.asd │ │ ├── nasdf.lisp │ │ ├── package.lisp │ │ ├── readme.org │ │ ├── systems.lisp │ │ └── tests.lisp │ ├── password-manager/ │ │ ├── package.lisp │ │ ├── password-keepassxc.lisp │ │ ├── password-pass.lisp │ │ ├── password-security.lisp │ │ └── password.lisp │ ├── text-buffer/ │ │ ├── package.lisp │ │ └── text-buffer.lisp │ ├── theme/ │ │ ├── README.org │ │ ├── package.lisp │ │ ├── tests/ │ │ │ └── tests.lisp │ │ ├── theme.lisp │ │ └── utilities.lisp │ └── user-interface/ │ ├── package.lisp │ └── user-interface.lisp ├── licenses/ │ ├── ASSET-LICENSE │ ├── DejaVu Fonts License.txt │ └── SOURCE-LICENSE ├── makefile ├── nyxt.asd ├── source/ │ ├── about.lisp │ ├── browser.lisp │ ├── buffer.lisp │ ├── clipboard.lisp │ ├── color.lisp │ ├── command-commands.lisp │ ├── command.lisp │ ├── concurrency.lisp │ ├── conditions.lisp │ ├── configuration-commands.lisp │ ├── configuration.lisp │ ├── describe.lisp │ ├── dom.lisp │ ├── external-editor.lisp │ ├── foreign-interface.lisp │ ├── global.lisp │ ├── help.lisp │ ├── history.lisp │ ├── input.lisp │ ├── inspector.lisp │ ├── keyscheme.lisp │ ├── manual.lisp │ ├── message.lisp │ ├── mode/ │ │ ├── annotate.lisp │ │ ├── autofill.lisp │ │ ├── base.lisp │ │ ├── blocker.lisp │ │ ├── bookmark.lisp │ │ ├── bookmarklets.lisp │ │ ├── buffer-listing.lisp │ │ ├── certificate-exception.lisp │ │ ├── cruise-control.lisp │ │ ├── document.lisp │ │ ├── download.lisp │ │ ├── emacs.lisp │ │ ├── expedition.lisp │ │ ├── file-manager.lisp │ │ ├── force-https.lisp │ │ ├── help.lisp │ │ ├── hint-prompt-buffer.lisp │ │ ├── hint.lisp │ │ ├── history-migration.lisp │ │ ├── history.lisp │ │ ├── input-edit.lisp │ │ ├── keyscheme.lisp │ │ ├── macro-edit.lisp │ │ ├── message.lisp │ │ ├── no-image.lisp │ │ ├── no-script.lisp │ │ ├── no-sound.lisp │ │ ├── no-webgl.lisp │ │ ├── passthrough.lisp │ │ ├── password.lisp │ │ ├── process.lisp │ │ ├── prompt-buffer.lisp │ │ ├── proxy.lisp │ │ ├── reading-line.lisp │ │ ├── repeat.lisp │ │ ├── search-buffer.lisp │ │ ├── small-web.lisp │ │ ├── spell-check.lisp │ │ ├── style.lisp │ │ ├── user-script.lisp │ │ ├── vi.lisp │ │ ├── visual.lisp │ │ └── watch.lisp │ ├── mode.lisp │ ├── package.lisp │ ├── parenscript-macro.lisp │ ├── prompt-buffer.lisp │ ├── recent-buffers.lisp │ ├── renderer/ │ │ ├── electron.lisp │ │ ├── gi-gtk.lisp │ │ └── gtk.lisp │ ├── renderer-script.lisp │ ├── renderer.lisp │ ├── search-engine.lisp │ ├── spinneret-tags.lisp │ ├── start.lisp │ ├── status.lisp │ ├── time.lisp │ ├── tutorial.lisp │ ├── types.lisp │ ├── urls.lisp │ ├── user-classes.lisp │ ├── user-files.lisp │ ├── user-interface.lisp │ ├── utilities.lisp │ └── window.lisp └── tests/ ├── benchmarks/ │ ├── package.lisp │ └── prompter.lisp ├── define-configuration.lisp ├── mode/ │ ├── annotate.lisp │ ├── autofill.lisp │ ├── base.lisp │ ├── blocker.lisp │ ├── bookmark.lisp │ ├── bookmarklets.lisp │ ├── buffer-listing.lisp │ ├── certificate-exception.lisp │ ├── cruise-control.lisp │ ├── document.lisp │ ├── download.lisp │ ├── emacs.lisp │ ├── expedition.lisp │ ├── file-manager.lisp │ ├── force-https.lisp │ ├── help.lisp │ ├── hint-prompt-buffer.lisp │ ├── hint.lisp │ ├── history.lisp │ ├── input-edit.lisp │ ├── keyscheme.lisp │ ├── macro-edit.lisp │ ├── message.lisp │ ├── no-image.lisp │ ├── no-script.lisp │ ├── no-sound.lisp │ ├── no-webgl.lisp │ ├── passthrough.lisp │ ├── password.lisp │ ├── process.lisp │ ├── prompt-buffer.lisp │ ├── proxy.lisp │ ├── reading-line.lisp │ ├── reduce-tracking.lisp │ ├── repeat.lisp │ ├── search-buffer.lisp │ ├── small-web.lisp │ ├── spell-check.lisp │ ├── style.lisp │ ├── user-script.lisp │ ├── vi.lisp │ ├── visual.lisp │ └── watch.lisp ├── mode.lisp ├── package.lisp ├── prompt-buffer.lisp ├── renderer/ │ ├── custom-schemes.lisp │ ├── package.lisp │ ├── search-buffer.lisp │ └── set-url.lisp ├── test-data/ │ ├── hint-mode-html-document.html │ └── history.lisp ├── urls.lisp └── user-script-parsing.lisp ================================================ FILE CONTENTS ================================================ ================================================ FILE: .dir-locals.el ================================================ ((nil . ((fill-column . 80) (project-vc-ignores . ("./_build")) (require-final-newline . t) (eval . (add-hook 'before-save-hook 'delete-trailing-whitespace nil t)))) (org-mode . ((org-edit-src-content-indentation 0))) (lisp-mode . ((eval . (cl-flet ((enhance-imenu-lisp (&rest keywords) (dolist (keyword keywords) (let ((prefix (when (listp keyword) (cl-second keyword))) (keyword (if (listp keyword) (cl-first keyword) keyword))) (add-to-list 'lisp-imenu-generic-expression (list (purecopy (concat (capitalize keyword) (if (string= (substring-no-properties keyword -1) "s") "es" "s"))) (purecopy (concat "^\\s-*(" (regexp-opt (list (if prefix (concat prefix "-" keyword) keyword) (concat prefix "-" keyword)) t) "\\s-+\\(" lisp-mode-symbol-regexp "\\)")) 2)))))) ;; This adds the argument to the list of imenu known keywords. (enhance-imenu-lisp '("bookmarklet-command" "define") '("class" "define") '("command" "define") '("ffi-method" "define") '("ffi-generic" "define") '("function" "define") '("internal-page-command" "define") '("internal-page-command-global" "define") '("mode" "define") '("parenscript" "define") "defpsmacro")))))) ================================================ FILE: .github/ISSUE_TEMPLATE/bug_report.md ================================================ --- name: Bug report about: Bug report title: '' labels: '' assignees: '' --- **Describe the bug** **Steps to reproduce the issue** **Information** - OS Name+Version: - Installation method (Flatpak, Guix, package manager, build from source): - Output of Nyxt command `show-system-information`: ================================================ FILE: .github/ISSUE_TEMPLATE/feature_request.md ================================================ --- name: Feature request about: Suggest an idea for this project title: '' labels: feature assignees: '' --- **Is your feature request related to a problem? Please describe.** **Describe the solution you'd like** **Describe alternatives you've considered** **Additional context** ================================================ FILE: .github/ISSUE_TEMPLATE/ui_request.md ================================================ --- name: UI request about: Suggest a UI change for this project title: '' labels: ui/ux assignees: '' --- **Please describe the UI issue:** **Describe the solution you'd like** **Describe alternatives you've considered** **Additional context:** **Screenshots/Mock ups:** ================================================ FILE: .github/SECURITY.md ================================================ # Security Policy ## Supported Versions Only the latest stable version is currently supported with security updates. ## Reporting a Vulnerability hello@atlas.engineer ================================================ FILE: .github/pull_request_template.md ================================================ # Description - Please include a summary of the change. Fixes # (issue) # Checklist: - [ ] Git branch state is mergable. - [ ] Changelog is up to date (via a separate commit). - [ ] New dependencies are accounted for. - [ ] Documentation is up to date. - [ ] Compilation and tests (`(asdf:test-system :nyxt/)`) - No new compilation warnings. - Tests are sufficient. ================================================ FILE: .gitignore ================================================ # Ignore build artifacts nyxt build/ node_modules/ package.json package-lock.json # Ignore compiled lisp files *.FASL *.fasl *.fas *.lisp-temp *.dfsl *.pfsl *.d64fsl *.p64fsl *.lx64fsl *.lx32fsl *.dx64fsl *.dx32fsl *.fx64fsl *.fx32fsl *.sx64fsl *.sx32fsl *.wx64fsl *.wx32fsl # Ignore PNG and XCF *.xcf *.png # Generated documentation manual.html # Ignore etags/ctags TAGS # Ignore C object files and libraries *.o *.so ================================================ FILE: .gitmodules ================================================ [submodule "_build/alexandria"] path = _build/alexandria url = https://gitlab.common-lisp.net/alexandria/alexandria.git shallow = true [submodule "_build/bordeaux-threads"] path = _build/bordeaux-threads url = https://github.com/sionescu/bordeaux-threads shallow = true [submodule "_build/calispel"] path = _build/calispel url = https://github.com/hawkir/calispel shallow = true [submodule "_build/cl-jpl-util"] path = _build/cl-jpl-util url = https://github.com/hawkir/cl-jpl-util shallow = true [submodule "_build/trivial-garbage"] path = _build/trivial-garbage url = https://github.com/trivial-garbage/trivial-garbage shallow = true [submodule "_build/cl-containers"] path = _build/cl-containers url = https://github.com/gwkkwg/cl-containers shallow = true [submodule "_build/metatilities-base"] path = _build/metatilities-base url = https://github.com/gwkkwg/metatilities-base shallow = true [submodule "_build/cl-custom-hash-table"] path = _build/cl-custom-hash-table url = https://github.com/metawilm/cl-custom-hash-table shallow = true [submodule "_build/cl-ppcre"] path = _build/cl-ppcre url = https://github.com/edicl/cl-ppcre shallow = true [submodule "_build/flexi-streams"] path = _build/flexi-streams url = https://github.com/edicl/flexi-streams shallow = true [submodule "_build/trivial-gray-streams"] path = _build/trivial-gray-streams url = https://github.com/trivial-gray-streams/trivial-gray-streams shallow = true [submodule "_build/cl-prevalence"] path = _build/cl-prevalence url = https://github.com/40ants/cl-prevalence shallow = true [submodule "_build/s-sysdeps"] path = _build/s-sysdeps url = https://github.com/svenvc/s-sysdeps shallow = true [submodule "_build/usocket"] path = _build/usocket url = https://github.com/usocket/usocket/ shallow = true [submodule "_build/split-sequence"] path = _build/split-sequence url = https://github.com/sharplispers/split-sequence shallow = true [submodule "_build/closer-mop"] path = _build/closer-mop url = https://github.com/pcostanza/closer-mop shallow = true [submodule "_build/cluffer"] path = _build/cluffer url = https://github.com/robert-strandh/cluffer shallow = true [submodule "_build/Acclimation"] path = _build/Acclimation url = https://github.com/robert-strandh/Acclimation shallow = true [submodule "_build/Clump"] path = _build/Clump url = https://github.com/robert-strandh/Clump shallow = true [submodule "_build/dexador"] path = _build/dexador url = https://github.com/fukamachi/dexador shallow = true [submodule "_build/babel"] path = _build/babel url = https://github.com/cl-babel/babel shallow = true [submodule "_build/trivial-features"] path = _build/trivial-features url = https://github.com/trivial-features/trivial-features shallow = true [submodule "_build/fast-http"] path = _build/fast-http url = https://github.com/fukamachi/fast-http shallow = true [submodule "_build/proc-parse"] path = _build/proc-parse url = https://github.com/fukamachi/proc-parse shallow = true [submodule "_build/anaphora"] path = _build/anaphora url = https://github.com/tokenrove/anaphora shallow = true [submodule "_build/xsubseq"] path = _build/xsubseq url = https://github.com/fukamachi/xsubseq shallow = true [submodule "_build/smart-buffer"] path = _build/smart-buffer url = https://github.com/fukamachi/smart-buffer shallow = true [submodule "_build/cl-unicode"] path = _build/cl-unicode url = https://github.com/edicl/cl-unicode shallow = true [submodule "_build/named-readtables"] path = _build/named-readtables url = https://github.com/melisgl/named-readtables shallow = true [submodule "_build/trivial-types"] path = _build/trivial-types url = https://github.com/m2ym/trivial-types shallow = true [submodule "_build/quri"] path = _build/quri url = https://github.com/fukamachi/quri shallow = true [submodule "_build/fast-io"] path = _build/fast-io url = https://github.com/rpav/fast-io shallow = true [submodule "_build/static-vectors"] path = _build/static-vectors url = https://github.com/sionescu/static-vectors shallow = true [submodule "_build/cffi"] path = _build/cffi url = https://github.com/cffi/cffi shallow = true [submodule "_build/chunga"] path = _build/chunga url = https://github.com/edicl/chunga shallow = true [submodule "_build/cl-cookie"] path = _build/cl-cookie url = https://github.com/fukamachi/cl-cookie shallow = true [submodule "_build/local-time"] path = _build/local-time url = https://github.com/dlowe-net/local-time shallow = true [submodule "_build/trivial-mimes"] path = _build/trivial-mimes url = https://github.com/Shinmera/trivial-mimes shallow = true [submodule "_build/cl-base64"] path = _build/cl-base64 url = https://gitlab.common-lisp.net/nyxt/cl-base64.git shallow = true [submodule "_build/cl-plus-ssl"] path = _build/cl-plus-ssl url = https://github.com/cl-plus-ssl/cl-plus-ssl shallow = true [submodule "_build/drakma"] path = _build/drakma url = https://github.com/edicl/drakma shallow = true [submodule "_build/puri"] path = _build/puri url = https://gitlab.common-lisp.net/nyxt/puri.git shallow = true [submodule "_build/cl-enchant"] path = _build/cl-enchant url = https://github.com/tlikonen/cl-enchant shallow = true [submodule "_build/fset"] path = _build/fset url = https://github.com/slburson/fset shallow = true [submodule "_build/misc-extensions"] path = _build/misc-extensions url = https://gitlab.common-lisp.net/misc-extensions/misc-extensions.git shallow = true [submodule "_build/iolib"] path = _build/iolib url = https://github.com/sionescu/iolib shallow = true [submodule "_build/idna"] path = _build/idna url = https://github.com/antifuchs/idna shallow = true [submodule "_build/swap-bytes"] path = _build/swap-bytes url = https://github.com/sionescu/swap-bytes shallow = true [submodule "_build/log4cl"] path = _build/log4cl url = https://github.com/sharplispers/log4cl shallow = true [submodule "_build/moptilities"] path = _build/moptilities url = https://github.com/gwkkwg/moptilities/ shallow = true [submodule "_build/parenscript"] path = _build/parenscript url = https://gitlab.common-lisp.net/parenscript/parenscript shallow = true [submodule "_build/plump"] path = _build/plump url = https://github.com/Shinmera/plump shallow = true [submodule "_build/array-utils"] path = _build/array-utils url = https://github.com/Shinmera/array-utils shallow = true [submodule "_build/documentation-utils"] path = _build/documentation-utils url = https://github.com/Shinmera/documentation-utils shallow = true [submodule "_build/trivial-indent"] path = _build/trivial-indent url = https://github.com/Shinmera/trivial-indent shallow = true [submodule "_build/serapeum"] path = _build/serapeum url = https://github.com/ruricolist/serapeum shallow = true [submodule "_build/nhooks"] path = _build/nhooks url = https://github.com/atlas-engineer/nhooks shallow = true [submodule "_build/trivia"] path = _build/trivia url = https://github.com/guicho271828/trivia shallow = true [submodule "_build/optima"] path = _build/optima url = https://github.com/m2ym/optima shallow = true [submodule "_build/lisp-namespace"] path = _build/lisp-namespace url = https://github.com/guicho271828/lisp-namespace shallow = true [submodule "_build/trivial-cltl2"] path = _build/trivial-cltl2 url = https://github.com/Zulu-Inuoe/trivial-cltl2 shallow = true [submodule "_build/type-i"] path = _build/type-i url = https://github.com/guicho271828/type-i shallow = true [submodule "_build/introspect-environment"] path = _build/introspect-environment url = https://github.com/Bike/introspect-environment shallow = true [submodule "_build/string-case"] path = _build/string-case url = https://github.com/pkhuong/string-case shallow = true [submodule "_build/parse-number"] path = _build/parse-number url = https://github.com/sharplispers/parse-number/ shallow = true [submodule "_build/parse-declarations"] path = _build/parse-declarations url = https://gitlab.common-lisp.net/parse-declarations/parse-declarations.git shallow = true [submodule "_build/global-vars"] path = _build/global-vars url = https://github.com/lmj/global-vars shallow = true [submodule "_build/trivial-file-size"] path = _build/trivial-file-size url = https://github.com/ruricolist/trivial-file-size shallow = true [submodule "_build/trivial-macroexpand-all"] path = _build/trivial-macroexpand-all url = https://github.com/cbaggers/trivial-macroexpand-all shallow = true [submodule "_build/cl-str"] path = _build/cl-str url = https://github.com/vindarel/cl-str shallow = true [submodule "_build/cl-change-case"] path = _build/cl-change-case url = https://github.com/rudolfochrist/cl-change-case shallow = true [submodule "_build/trivial-clipboard"] path = _build/trivial-clipboard url = https://github.com/snmsts/trivial-clipboard shallow = true [submodule "_build/trivial-package-local-nicknames"] path = _build/trivial-package-local-nicknames url = https://github.com/phoe/trivial-package-local-nicknames shallow = true [submodule "_build/unix-opts"] path = _build/unix-opts url = https://github.com/atlas-engineer/unix-opts shallow = true [submodule "_build/cl-webkit"] path = _build/cl-webkit url = https://github.com/joachifm/cl-webkit shallow = true [submodule "_build/cl-gobject-introspection"] path = _build/cl-gobject-introspection url = https://github.com/andy128k/cl-gobject-introspection shallow = true [submodule "_build/lparallel"] path = _build/lparallel url = https://github.com/lmj/lparallel/ shallow = true [submodule "_build/jpl-queues"] path = _build/jpl-queues url = https://gitlab.common-lisp.net/nyxt/jpl-queues.git shallow = true [submodule "_build/mt19937"] path = _build/mt19937 url = https://gitlab.common-lisp.net/nyxt/mt19937 shallow = true [submodule "_build/s-xml"] path = _build/s-xml url = https://gitlab.common-lisp.net/s-xml/s-xml shallow = true [submodule "_build/cl-utilities"] path = _build/cl-utilities url = https://gitlab.common-lisp.net/cl-utilities/cl-utilities shallow = true [submodule "_build/cl-qrencode"] path = _build/cl-qrencode url = https://github.com/jnjcc/cl-qrencode shallow = true [submodule "_build/clss"] path = _build/clss url = https://github.com/Shinmera/clss shallow = true [submodule "_build/spinneret"] path = _build/spinneret url = https://github.com/ruricolist/spinneret/ shallow = true [submodule "_build/salza2"] path = _build/salza2 url = https://github.com/xach/salza2 shallow = true [submodule "_build/zpng"] path = _build/zpng url = https://github.com/xach/zpng shallow = true [submodule "_build/iterate"] path = _build/iterate url = https://gitlab.common-lisp.net/iterate/iterate.git shallow = true [submodule "_build/cl-gopher"] path = _build/cl-gopher url = https://github.com/knusbaum/cl-gopher shallow = true [submodule "_build/phos"] path = _build/phos url = https://github.com/omar-polo/phos shallow = true [submodule "_build/cl-tld"] path = _build/cl-tld url = https://github.com/lu4nx/cl-tld shallow = true [submodule "_build/nfiles"] path = _build/nfiles url = https://github.com/atlas-engineer/nfiles shallow = true [submodule "_build/nkeymaps"] path = _build/nkeymaps url = https://github.com/atlas-engineer/nkeymaps shallow = true [submodule "_build/py-configparser"] path = _build/py-configparser url = https://gitlab.common-lisp.net/nyxt/py-configparser shallow = true [submodule "_build/trivial-custom-debugger"] path = _build/trivial-custom-debugger url = https://github.com/phoe/trivial-custom-debugger shallow = true [submodule "_build/lisp-unit2"] path = _build/lisp-unit2 url = https://github.com/AccelerationNet/lisp-unit2 shallow = true [submodule "_build/nsymbols"] path = _build/nsymbols url = https://github.com/atlas-engineer/nsymbols shallow = true [submodule "_build/LASS"] path = _build/LASS url = https://github.com/Shinmera/LASS shallow = true [submodule "_build/njson"] path = _build/njson url = https://github.com/atlas-engineer/njson shallow = true [submodule "_build/nclasses"] path = _build/nclasses url = https://github.com/atlas-engineer/nclasses/ shallow = true [submodule "_build/prompter"] path = _build/prompter url = https://github.com/atlas-engineer/prompter shallow = true [submodule "_build/chipz"] path = _build/chipz url = https://github.com/sharplispers/chipz shallow = true [submodule "_build/cl-cffi-gtk"] path = _build/cl-cffi-gtk url = https://github.com/sharplispers/cl-cffi-gtk shallow = true [submodule "_build/cl-json"] path = _build/cl-json url = https://github.com/sharplispers/cl-json shallow = true [submodule "_build/cl-sqlite"] path = _build/cl-sqlite url = https://github.com/TeMPOraL/cl-sqlite shallow = true [submodule "_build/cl-electron"] path = _build/cl-electron url = https://github.com/atlas-engineer/cl-electron/ shallow = true [submodule "_build/cl-colors-ng"] path = _build/cl-colors-ng url = https://codeberg.org/cage/cl-colors-ng.git shallow = true [submodule "_build/cl-interpol"] path = _build/cl-interpol url = https://github.com/edicl/cl-interpol shallow = true [submodule "_build/symbol-munger"] path = _build/symbol-munger url = https://github.com/AccelerationNet/symbol-munger shallow = true [submodule "_build/in-nomine"] path = _build/in-nomine url = https://github.com/phoe/in-nomine shallow = true [submodule "_build/trivial-arguments"] path = _build/trivial-arguments url = https://github.com/Shinmera/trivial-arguments.git shallow = true ================================================ FILE: INSTALL ================================================ Usage: make all # Generate Nyxt binary at $PWD. make install # Install Nyxt. make doc # Generate Nyxt static documentation. DESTDIR and PREFIX set the target destination. Both must be absolute paths. When unbound, DESTDIR is set to / and PREFIX is set to $DESTDIR/usr/local/. NASDF_SOURCE_PATH sets where the source files will be installed. When unbound, it is set to $PREFIX/share/. When NYXT_SUBMODULES is "true" (the default), all Lisp dependencies are searched at ./_build. Otherwise, they need to be made visible to ASDF by other means. In case you have received an archive that includes the source of these Lisp dependencies, then it all should work out of the box. NYXT_RENDERER sets the renderer, by default "electron". NYXT_VERSION forces the version number, in the rare eventuality that it can't be fetched in another way. The static documentation is particularly useful when it can't be consulted from Nyxt itself (where it is dynamically generated at runtime). ================================================ FILE: README.org ================================================ * Nyxt browser #+html: *Nyxt* [nýkst] is a keyboard-driven web browser designed for hackers. Inspired by Emacs and Vim, it has familiar keybindings ([[https://en.wikipedia.org/wiki/Emacs][Emacs]], [[https://en.wikipedia.org/wiki/Vim_(text_editor)][vi]], [[https://en.wikipedia.org/wiki/IBM_Common_User_Access][CUA]]), and is infinitely extensible in Lisp. *Attention:* Nyxt is under active development. Please feel free to [[https://github.com/atlas-engineer/nyxt/issues][report]] bugs, instabilities or feature wishes. ----- * Features For an exhaustive description of all of the features, please refer to the manual. ** Fast tab switching Switch easily between your open tabs via fuzzy search. If you are looking for ~https://www.example.com~, you could type in ~ele~, ~exa~, ~epl~, or any other matching series of letters. #+html: ** Multiple marking Commands can accept multiple inputs, allowing you to quickly perform an operation against multiple objects. In the example below we simultaneously open several bookmarks. #+html: ** Powerful bookmarks Bookmark a page with tags. Search bookmarks with compound queries. Capture more data about your bookmarks, and group and wrangle them in any way you like. #+html: ** Multi tab search Search multiple tabs at the same time, and view all the results in a single window. Jump quickly through your open tabs to find what you need. #+html: ** History as a tree History is represented as a tree that you can traverse. Smarter than the "forwards-backwards" abstraction found in other browsers, the tree makes sure you never lose track of where you've been. #+html: * Installation Supported platforms: - GNU/Linux - macOS (in development) - Windows (in development) - FreeBSD (unofficial) ** GNU/Linux The Nyxt team maintains the following distribution means: - [[https://flathub.org/apps/engineer.atlas.Nyxt][Nyxt on Flathub]] [[https://repology.org/project/nyxt/versions][Non-official distribution means are supported by the community as well]]. We're not accountable for their quality, so we kindly ask to report issues to the maintainers of those packaging efforts. * Contributing Please refer to the [[file:developer-manual.org][developer's documentation]]. ================================================ FILE: _build/README.org ================================================ This directory contains all Common Lisp dependencies. They are fetched via Git submodules. This gives us good reproducibility and control, unlike with Quicklisp which might not have the right versions. We store these in a directory that's excluded from recursion by ASDF. as per =asdf/source-registry:*source-registry-exclusions*=. This way we won't conflict with user or system libraries. ================================================ FILE: assets/Info.plist ================================================ NSPrincipalClass Nyxt CFBundleIconFile nyxt.icns CFBundlePackageType APPL CFBundleGetInfoString Nyxt CFBundleSignature ???? CFBundleExecutable nyxt CFBundleIdentifier engineer.Atlas.Nyxt NSAppTransportSecurity NSAllowsLocalNetworking CFBundleURLTypes CFBundleURLName http URL CFBundleURLSchemes http CFBundleURLName https URL CFBundleURLSchemes https CFBundleURLName gopher URL CFBundleURLSchemes gopher CFBundleURLName gemini URL CFBundleURLSchemes gemini CFBundleDocumentTypes CFBundleTypeExtensions html xhtml ================================================ FILE: assets/nyxt.appimage.desktop ================================================ [Desktop Entry] Name=Nyxt Comment=Web Browser for Hackers GenericName=Web Browser Keywords=Internet;WWW;Browser;Web;Explorer Exec="~a" Terminal=false X-MultipleArgs=false Type=Application Icon=nyxt Categories=Network;WebBrowser; MimeType=text/html;text/xml;application/xhtml+xml;application/xml;application/rss+xml;application/rdf+xml;image/gif;image/jpeg;image/png;x-scheme-handler/http;x-scheme-handler/https;x-scheme-handler/ftp;x-scheme-handler/chrome;video/webm;application/x-xpinstall; StartupNotify=true StartupWMClass=nyxt ================================================ FILE: assets/nyxt.desktop ================================================ [Desktop Entry] Name=Nyxt Comment=Web Browser for Hackers GenericName=Web Browser Keywords=Internet;WWW;Browser;Web;Explorer Exec=nyxt %u Terminal=false X-MultipleArgs=false Type=Application Icon=nyxt Categories=Network;WebBrowser; MimeType=text/html;text/xml;application/xhtml+xml;application/xml;application/rss+xml;application/rdf+xml;image/gif;image/jpeg;image/png;x-scheme-handler/http;x-scheme-handler/https;x-scheme-handler/ftp;x-scheme-handler/chrome;video/webm;application/x-xpinstall; StartupNotify=true StartupWMClass=nyxt ================================================ FILE: assets/nyxt.metainfo.xml ================================================ engineer.atlas.Nyxt CC-BY-SA-3.0 BSD-3-Clause Atlas Engineer Nyxt The hacker's browser

Quickly analyze, navigate, and extract information from the Internet. Nyxt is fully hackable — all of its source code can be introspected, modified, and tweaked to your exact specification.

 Network https://nyxt-browser.com/ https://github.com/atlas-engineer/nyxt https://github.com/atlas-engineer/nyxt/issues https://nyxt-browser.com/faq https://discourse.atlas.engineer/ https://nyxt-browser.com/purchase https://atlas.engineer/contact https://github.com/atlas-engineer/nyxt/blob/master/developer-manual.org nyxt.desktop nyxt https://nyxt-browser.com/static/image/switch-buffer.png Fast tab switching https://nyxt-browser.com/static/image/multi-select.png Multiple marking https://nyxt-browser.com/static/image/bookmark.png Powerful bookmarks https://nyxt-browser.com/static/image/multi-search.png Multi tab search https://nyxt-browser.com/static/image/history.png History as a tree https://nyxt-browser.com/article/release-3.11.8.org https://nyxt-browser.com/article/release-3.11.7.org https://nyxt-browser.com/article/release-3.11.6.org https://nyxt-browser.com/article/release-3.11.5.org https://nyxt-browser.com/article/release-3.11.4.org https://nyxt-browser.com/article/release-3.11.3.org https://nyxt-browser.com/article/release-3.11.2.org https://nyxt-browser.com/article/release-3.11.1.org https://nyxt-browser.com/article/release-3.11.0.org https://nyxt-browser.com/article/release-3.10.0.org https://nyxt-browser.com/article/release-3.9.2.org https://nyxt-browser.com/article/release-3.9.1.org https://nyxt-browser.com/article/release-3.9.0.org https://nyxt-browser.com/article/release-3.8.0.org https://nyxt-browser.com/article/release-3.7.0.org https://nyxt-browser.com/article/release-3.6.1.org ================================================ FILE: developer-manual.org ================================================ #+TITLE: Nyxt Developer's Manual # Install org-make-toc so the TOC below will be automatically generated. # https://github.com/alphapapa/org-make-toc * Table of contents :TOC: :PROPERTIES: :TOC: :include all :ignore this :END: :CONTENTS: - [[#bill-of-materials][Bill of Materials]] - [[#source][Source]] - [[#common-lisp][Common Lisp]] - [[#web-renderers][Web renderers]] - [[#webkitgtk][WebKitGTK]] - [[#electron][Electron]] - [[#other][Other]] - [[#development-environment][Development environment]] - [[#tests][Tests]] - [[#installation][Installation]] - [[#contributing][Contributing]] - [[#help][Help]] - [[#commit-style][Commit style]] - [[#branch-management][Branch management]] - [[#programming-conventions][Programming conventions]] :END: * Bill of Materials ** Source Either get a tarball (=nyxt--source-with-submodules.tar.xz=) from a [[https://github.com/atlas-engineer/nyxt/releases][tagged release]], or clone as a git repository: #+begin_src sh mkdir -p ~/common-lisp git clone --recurse-submodules https://github.com/atlas-engineer/nyxt ~/common-lisp/nyxt #+end_src ** Common Lisp Nyxt is written in Common Lisp. Currently, we only target one of its implementations - [[http://www.sbcl.org/][SBCL]]. Nyxt also depends on Common Lisp libraries. These are bundled in the tarball mentioned above or fetched as Git submodules (under =./_build=). Note for advanced users: the single source of truth for CL libraries is dictated by the Git submodules. Any Nyxt build that deviates from it is considered unofficial. See environment variable =NYXT_SUBMODULES= defined in the makefile to override the default behavior. ** Web renderers Nyxt is designed to be web engine agnostic so its dependencies vary. *** WebKitGTK Using the latest [[https://webkitgtk.org][WebKitGTK]] version is advised for security concerns. The oldest version that supports all features is 2.36. The packages that provide the following shared objects are required: - libwebkit2gtk-4.1.so - libgobject-2.0.so - libgirepository-1.0.so - libglib-2.0.so - libgthread-2.0.so - libgio-2.0.so - libcairo.so - libpango-1.0.so - libpangocairo-1.0.so - libgdk_pixbuf-2.0.so - libgdk-3.so - libgtk-3.so To improve media stream it is recommended to install =gst-libav= and the following plugins: - gst-plugins-bad - gst-plugins-base - gst-plugins-good - gst-plugins-ugly *** Electron Experimental support for [[https://www.electronjs.org/][Electron]]. Further documentation soon. ** Other The packages that provide the following shared objects are required: - libssl.so.3 - libcrypto.so.3 - libfixposix.so.3 - libsqlite3.so Additionally, the following packages: - xclip :: when using X system; - wl-clipboard :: when using Wayland; - enchant :: spellchecking (optional). * Development environment Lisp favors incremental program development meaning that you make some changes and compile them. In other words, there's no need to compile the whole codebase or even restart the program. The typical Common Lisp IDE is [[https://github.com/slime/slime][SLIME]] (or its fork [[https://github.com/joaotavora/sly][SLY]]), which requires being comfortable with Emacs. Add the snippet below to Emacs' init file. #+begin_src emacs-lisp (setq slime-lisp-implementations '((nyxt ("sbcl" "--dynamic-space-size 3072") :env ("CL_SOURCE_REGISTRY=~/common-lisp//:~/common-lisp/nyxt/_build//")))) #+end_src Start the REPL by issuing =M-- M-x sly RET nyxt RET= and evaluate: #+begin_src lisp (asdf:load-system :nyxt/gi-gtk) (nyxt:start) #+end_src Note that: - [[https://asdf.common-lisp.dev/asdf/Configuring-ASDF-to-find-your-systems.html][ASDF must be configured to find the required systems]]; - =cffi= must be configured to find the required shared objects by setting env var =LD_LIBRARY_PATH= or =cffi:*foreign-library-directories*=. ** Tests It is recommended to restart the Lisp image before and after running the tests since some of them are stateful: #+begin_src lisp (asdf:test-system :nyxt/gi-gtk) #+end_src * Installation Nyxt uses the =Make= build system. Run =make= to display the documentation or see the [[../makefile][Makefile]] for more details. * Contributing Nyxt is a joint effort and we welcome contributors! You can find tasks [[https://github.com/atlas-engineer/nyxt/issues?q=is%3Aissue+is%3Aopen+label%3Agood-first-issue][on our issue tracker]] to suit your interests and skills. Please fork the project and open a pull request (PR) on GitHub to undergo the reviewing process. Refer to the [[*Branch management][branch management section]] for more detailed information. Please resist the temptation of discussing changes without drafting its implementation. Currently, we value pragmatism over creativity. ** Help Feel free to contact us at any point if you need guidance. - To learn Common Lisp, see [[https://nyxt-browser.com/learn-lisp]]; - [[https://github.com/atlas-engineer/nyxt/issues][Open up an issue on GitHub]]; - Find Nyxt on Libera IRC: =#nyxt= - [[https://discord.gg/YXCk7gDKgJ][Nyxt's Discord]]; ** Commit style Ensure to isolate commits containing whitespace changes (including indentation) or code movements as to avoid noise in the diffs. Regarding commit messages, we follow the convention of prefixing the title with the basename when there's a single modified file. For instance, for changes in =source/mode/blocker.lisp= the commit message would look as per below: #+begin_example mode/blocker: Short description of the change Further explanation. #+end_example ** Branch management Nyxt uses the following branches: - =master= for development; - == for working on particular features; - =-series= to backport commits corresponding to specific major versions. Branch off from the target branch and rebase onto it right before merging as to avoid merge conflicts. A commit is said to be atomic when it builds and starts Nyxt successfully. At times, for the sake of readability, it is wise to break the changes down to smaller non-atomic commits. In that case, a merge commit is required (use merge option =no-ff=). This guarantees that running =git bisect= with option =--first-parent= only picks atomic commits, which streamlines the process. Those with commit access may push trivial changes directly to the target branch. ** Programming conventions The usual style guides by [[https://www.cs.umd.edu/~nau/cmsc421/norvig-lisp-style.pdf][Norvig & Pitman's Tutorial on Good Lisp Programming Style]] and [[https://google.github.io/styleguide/lispguide.xml][Google Common Lisp Style Guide]] are advised. For symbol naming conventions, see https://www.cliki.net/Naming+conventions. Some of our conventions include: - Prefer =first= and =rest= over =car= and =cdr=, respectively. - Use =define-class= instead of =defclass=. - Use =nyxt:define-package= for Nyxt-related pacakges. Notice that it features default imports (e.g. =export-always=) and package nicknames (e.g. =alex=, =sera=, etc.). Prefer =uiop:define-package= for general purpose packages. - Export using =export-always= next to the symbol definition. This helps prevent exports to go out-of-sync, or catch typos. Unlike =export=, =export-always= saves you from surprises upon recompilation. - When sensible, declaim the function types using =->=. Note that there is then no need to mention the type of the arguments and the return value in the docstring. - Use the =maybe= and =maybe*= types instead of =(or null ...)= and =(or null (array * (0)) ...)=, respectively. - Use the =list-of= type for typed lists. - Use =funcall*= to not error when function does not exist. - Prefer classes over structs. - Classes should be usable with just a =make-instance=. - Slots classes should be formatted in the following way: #+begin_src lisp (slot-name slot-value ... :documentation "Foo.") #+end_src When =slot-value= is the only parameter specified then: #+begin_src lisp (slot-name slot-value) #+end_src - =customize-instance= is reserved for end users. Use =initialize-instance :after= or =slot-unbound= to initialize the slots. Set up the rest of the class in =customize-instance :after=. Bear in mind that anything in this last method won't be customizable for the end user. - Almost all files should be handled via the =nfiles= library. - =(setf SLOT-WRITER) :after= is reserved for "watchers", i.e. handlers that are run whenever the slot is set. The =:around= method is not used by watchers, and thus the watcher may be overridden. - We use the =%foo%= naming convention for special local variables. - We suffix predicates with =-p=. Unlike the usual convention, we always use a dash (i.e. =foo-p= over =foop=). - Prefer the term =url= over =uri=. - URLs should be of type =quri:uri=. If you need to manipulate a URL string, call it =url-string=. In case the value contains a URL, but is not =quri:url=, use =url-designator= and its =url= method to normalize into =quri:uri=. - Paths should be of type =cl:pathname=. Use =uiop:native-namestring= to "send" to OS-facing functions, =uiop:ensure-pathname= to "receive" from OS-facing functions or to "trunamize". - Prefer =handler-bind= over =handler-case=: when running from the REPL, this triggers the debugger with a full stacktrace; when running the Nyxt binary, all conditions are caught anyway. - Do not handle the =T= condition, this may break everything. Handle =error=, =serious-condition=, or exceptionally =condition= (for instance if you do not control the called code, and some libraries subclass =condition= instead of =error=). - Dummy variables are called =_=. - Prefer American spelling. - Construct =define-command= requires a short one-line docstring without newlines. - Name keyword function parameters as follows =&key (var default-value var-supplied-p)=. # - Conversion functions =FROM->TO= or =->TO= for generic functions. The # only one that comes to mind is =url= which does not follow this convention... # - Blocking function should be prefixed with =wait-on-=. # Local Variables: # eval: (add-hook 'before-save-hook # (lambda nil (if (fboundp 'org-make-toc) # (org-make-toc) # (message-box "Please install org-make-toc."))) # nil # t) # End: ================================================ FILE: libraries/analysis/README.org ================================================ * Analysis Analysis is a library that provides facilities to help analyze and understand data. Listed below are the classes: ** Document The document class represents a document. After creating a document, you can perform several operations on it, some examples: + term count: how many times does a term appear in a document? + term frequency: how many times does a term appear divided by the total number of words in the document? ** Document Collection The document collection class represents a collection of documents. As with a document, there are several operations available, some examples: + dictionary: which words appear in the document collection? + keywords: what are the important keywords in this document collection? ** Document Vertex The document vertex class represents a document that is part of a graph. The edges slot of the document vertex class is used to store edges of that particular vertex. The keys in the edges slot hash table are the actual vertexes, and the values are the edge weights. ** Document Cluster The document cluster class represents a document that is part of a graph which will be clustered. It extends the document-vertex class and adds support for a cluster tag and a list of neighbors. These slots are useful for clustering algorithms. ================================================ FILE: libraries/analysis/analysis.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :analysis) (export-always 'document) (defclass document () ((source :accessor source :initarg :source :documentation "The source object for the document.") (string-contents :initarg :string-contents :accessor string-contents) (term-count-table :initform (make-hash-table :test #'equal) :documentation "Contains a mapping of term -> amount of times word appears in the document.") (vector-data :accessor vector-data :documentation "Vector representation of the document.") (rank :accessor rank :documentation "Rank used for sorting.") (tokens :accessor tokens) (token-count :accessor token-count)) (:documentation "The document class represents a document. After creating a document, you can perform several operations on it, some examples: + term count: how many times does a term appear in a document? + term frequency: how many times does a term appear divided by the total number of words in the document?")) (defclass document-collection () ((documents :initform () :initarg :documents :accessor documents)) (:documentation "The document collection class represents a collection of documents. As with a document, there are several operations available, some examples: + dictionary: which words appear in the document collection? + keywords: what are the important keywords in this document collection?")) (defmethod initialize-instance :after ((document document) &key) (setf (tokens document) (word-tokenize (string-contents document))) (setf (token-count document) (length (tokens document))) (loop for token in (tokens document) do (incf (gethash token (slot-value document 'term-count-table) 0)))) (defmethod term-count ((document document) term) (gethash term (slot-value document 'term-count-table) 0)) (defmethod term-frequency ((document document) term) "How often does the word exist in the document?" (/ (term-count document term) ;; prevent division by zero for malformed documents (max 1 (token-count document)))) (defmethod termp ((document document) term) "Does the term exist in the document?" (> (term-count document term) 0)) (defmethod add-document ((document-collection document-collection) document) "Add a document to the document collection." (push document (documents document-collection))) (defun match-term (term) (lambda (document) (termp document term))) (defmethod document-frequency ((document-collection document-collection) term) (/ (count-if (match-term term) (documents document-collection)) (length (documents document-collection)))) (defmethod inverse-document-frequency ((document-collection document-collection) term) (log (/ (length (documents document-collection)) (count-if (match-term term) (documents document-collection))))) (defmethod term-frequency-inverse-document-frequency ((document document) (document-collection document-collection) term) (* (term-frequency document term) (inverse-document-frequency document-collection term))) (defmethod dictionary ((document document)) "Return a list of all of the words that appear in a document." (loop for key being the hash-keys of (slot-value document 'term-count-table) collect key)) (defmethod dictionary ((document-collection document-collection)) "Return a list of all of the words that appear in a document collection." (let ((words (list))) (loop for document in (documents document-collection) do (alexandria:appendf words (tokens document))) (remove-duplicates words :test #'equalp))) (export-always 'keywords) (defmethod keywords ((document document) &optional document-collection) (if document-collection (sort (loop for word in (dictionary document) collect (cons word (term-frequency-inverse-document-frequency document document-collection word))) #'> :key #'rest) (sort (loop for word in (dictionary document) collect (cons word (term-frequency document word))) #'> :key #'rest))) (export-always 'extract-keywords) (defun extract-keywords (text &key (limit 5)) "Extract keywords from a string of text." (serapeum:take limit (keywords (make-instance 'analysis:document :string-contents text)))) ================================================ FILE: libraries/analysis/composite-sequence.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause ;; Given the following sequence: ;; 1 2 3 4 5 ;; ;; We would record the following sequences/outcomes. ;; ;; Chain length of 1: ;; 1 -> 2 ;; 2 -> 3 ;; 3 -> 4 ;; 4 -> 5 ;; ;; Chain length of 2: ;; 1 2 -> 3 ;; 2 3 -> 4 ;; 3 4 -> 5 ;; ;; Chain length of 3: ;; 1 2 3 -> 4 ;; 2 3 4 -> 5 ;; ;; As can be seen above, the amount of subsequences within a given sequence is ;; equal to (- (length sequence) chain length). (in-package :analysis) (export-always 'sequence-model) (defclass sequence-model (node) () (:documentation "The sequence-model class represents the root of a directed graph. The edges represent possible sequences of events. It may help to envision the graph as a finite state machine.")) (defclass node () ((edges :accessor edges :initform (make-hash-table :test #'equal)))) (export-always 'element) (defclass element-node (node) ((element :accessor element :initarg :element) (occurrences :accessor occurrences :initform 0 :documentation "Number of times this element has appeared at the end of a sequence."))) (defmethod add-edge ((from-node node) (to-node node)) (alexandria:ensure-gethash (element to-node) (edges from-node) to-node)) (defmethod list-edge-elements ((node node)) (mapcar #'element (alexandria:hash-table-values (edges node)))) (defmethod increment ((node node)) (incf (occurrences node))) (export-always 'add-record) (defmethod add-record ((model sequence-model) sequence) (multiple-value-bind (list-but-last-element last-element) (serapeum:halves sequence) (let ((leaf (alexandria:ensure-gethash list-but-last-element (edges model) (make-instance 'node)))) (increment (add-edge leaf (make-instance 'element-node :element (first last-element))))))) (defmethod add-record-subsequence ((model sequence-model) sequence) "Add a record for all subsequences. E.g. transform '(3 2 1)' into: '(3 2 1), '(2 1), '(1)" (loop while (> (length sequence) 1) collect (add-record model sequence) do (setf sequence (rest sequence)))) (export-always 'predict) (defmethod predict ((model sequence-model) sequence) (serapeum:and-let* ((leaf (gethash sequence (edges model))) (edges (alexandria:hash-table-values (edges leaf)))) (first (sort edges #'> :key #'occurrences)))) (defmethod predict-subsequence-simple ((model sequence-model) sequence) "Predict a sequence's next value based on all subsequence predictions. This is a naive implementation which simply considers the amount of occurences without regard to the weight of different chain lengths." (let* ((subsequence-results (loop while (> (length sequence) 1) collect (let* ((leaf (gethash sequence (edges model))) (edges (alexandria:hash-table-values (edges leaf)))) (first (sort edges #'> :key #'occurrences))) do (setf sequence (rest sequence))))) (first (sort subsequence-results #'> :key #'occurrences)))) ================================================ FILE: libraries/analysis/data.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :analysis) (defclass language-data () ((stop-words :initarg :stop-words :accessor stop-words :initform (list "a" "able" "about" "above" "according" "accordingly" "across" "actually" "after" "afterwards" "again" "against" "ain't" "all" "allow" "allows" "almost" "alone" "along" "already" "also" "although" "always" "am" "among" "amongst" "an" "and" "another" "any" "anybody" "anyhow" "anyone" "anything" "anyway" "anyways" "anywhere" "apart" "appear" "appreciate" "appropriate" "are" "aren't" "around" "as" "a's" "aside" "ask" "asking" "associated" "at" "available" "away" "awfully" "be" "became" "because" "become" "becomes" "becoming" "been" "before" "beforehand" "behind" "being" "believe" "below" "beside" "besides" "best" "better" "between" "beyond" "both" "brief" "but" "by" "came" "can" "cannot" "cant" "can't" "cause" "causes" "certain" "certainly" "changes" "clearly" "c'mon" "co" "com" "come" "comes" "concerning" "consequently" "consider" "considering" "contain" "containing" "contains" "corresponding" "could" "couldn't" "course" "c's" "currently" "definitely" "described" "despite" "did" "didn't" "different" "do" "does" "doesn't" "doing" "don" "done" "don't" "down" "downwards" "during" "each" "edu" "eg" "eight" "either" "else" "elsewhere" "enough" "entirely" "especially" "et" "etc" "even" "ever" "every" "everybody" "everyone" "everything" "everywhere" "ex" "exactly" "example" "except" "far" "few" "fifth" "first" "five" "followed" "following" "follows" "for" "former" "formerly" "forth" "four" "from" "further" "furthermore" "get" "gets" "getting" "given" "gives" "go" "goes" "going" "gone" "got" "gotten" "greetings" "had" "hadn't" "happens" "hardly" "has" "hasn't" "have" "haven't" "having" "he" "he'd" "he'll" "hello" "help" "hence" "her" "here" "hereafter" "hereby" "herein" "here's" "hereupon" "hers" "herself" "he's" "hi" "him" "himself" "his" "hither" "hopefully" "how" "howbeit" "however" "how's" "i" "i'd" "ie" "if" "ignored" "i'll" "i'm" "immediate" "in" "inasmuch" "inc" "indeed" "indicate" "indicated" "indicates" "inner" "insofar" "instead" "into" "inward" "is" "isn't" "it" "it'd" "it'll" "its" "it's" "itself" "i've" "just" "keep" "keeps" "kept" "know" "known" "knows" "last" "lately" "later" "latter" "latterly" "least" "less" "lest" "let" "let's" "like" "liked" "likely" "little" "look" "looking" "looks" "ltd" "mainly" "many" "may" "maybe" "me" "mean" "meanwhile" "merely" "might" "more" "moreover" "most" "mostly" "much" "must" "mustn't" "my" "myself" "name" "namely" "nd" "near" "nearly" "necessary" "need" "needs" "neither" "never" "nevertheless" "new" "next" "nine" "no" "nobody" "non" "none" "noone" "nor" "normally" "not" "nothing" "novel" "now" "nowhere" "obviously" "of" "off" "often" "oh" "ok" "okay" "old" "on" "once" "one" "ones" "only" "onto" "or" "other" "others" "otherwise" "ought" "our" "ours" "ourselves" "out" "outside" "over" "overall" "own" "particular" "particularly" "per" "perhaps" "placed" "please" "plus" "possible" "presumably" "probably" "provides" "que" "quite" "qv" "rather" "rd" "re" "really" "reasonably" "regarding" "regardless" "regards" "relatively" "respectively" "right" "s" "said" "same" "saw" "say" "saying" "says" "second" "secondly" "see" "seeing" "seem" "seemed" "seeming" "seems" "seen" "self" "selves" "sensible" "sent" "serious" "seriously" "seven" "several" "shall" "shan't" "she" "she'd" "she'll" "she's" "should" "shouldn't" "since" "six" "so" "some" "somebody" "somehow" "someone" "something" "sometime" "sometimes" "somewhat" "somewhere" "soon" "sorry" "specified" "specify" "specifying" "still" "sub" "such" "sup" "sure" "t" "take" "taken" "tell" "tends" "th" "than" "thank" "thanks" "thanx" "that" "thats" "that's" "the" "their" "theirs" "them" "themselves" "then" "thence" "there" "thereafter" "thereby" "therefore" "therein" "theres" "there's" "thereupon" "these" "they" "they'd" "they'll" "they're" "they've" "think" "third" "this" "thorough" "thoroughly" "those" "though" "three" "through" "throughout" "thru" "thus" "to" "together" "too" "took" "toward" "towards" "tried" "tries" "truly" "try" "trying" "t's" "twice" "two" "un" "under" "unfortunately" "unless" "unlikely" "until" "unto" "up" "upon" "us" "use" "used" "useful" "uses" "using" "usually" "value" "various" "very" "via" "viz" "vs" "want" "wants" "was" "wasn't" "way" "we" "we'd" "welcome" "well" "we'll" "went" "were" "we're" "weren't" "we've" "what" "whatever" "what's" "when" "whence" "whenever" "when's" "where" "whereafter" "whereas" "whereby" "wherein" "where's" "whereupon" "wherever" "whether" "which" "while" "whither" "who" "whoever" "whole" "whom" "who's" "whose" "why" "why's" "will" "willing" "wish" "with" "within" "without" "wonder" "won't" "would" "wouldn't" "yes" "yet" "you" "you'd" "you'll" "your" "you're" "yours" "yourself" "yourselves" "you've" "zero")) (stop-words-lookup :accessor stop-words-lookup))) (defmethod initialize-instance :after ((data language-data) &key) (setf (stop-words-lookup data) (loop with ht = (make-hash-table :test #'equal) for stop in (stop-words data) do (setf (gethash stop ht) t) finally (return ht)))) (defparameter *language-data* (make-instance 'language-data)) ================================================ FILE: libraries/analysis/dbscan.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :analysis) ;;; dbscan.lisp -- implementation of Density-based spatial clustering ;;; of applications with noise (DBSCAN) algorithm (defclass document-cluster (document-vertex) ((cluster :accessor cluster :initform :noise) (neighbors :accessor neighbors)) (:documentation "The document cluster class represents a document that is part of a graph which will be clustered. It extends the documenet-vertex class and adds support for a cluster tag and a list of neighbors. These slots are useful for clustering algorithms.")) (defmethod clusters ((collection document-collection)) "Return a list of clusters. Each hash key represents a cluster, and the hash value is the list of elements in that cluster. Please note: this function is not responsible for computing the clusters, only for returning the list of pre-tagged documents in cluster lists." (let ((result (make-hash-table))) (loop for document in (documents collection) do (push document (gethash (cluster document) result (list)))) result)) (defun get-cluster (cluster-label points) "Return all matching points for a given cluster label." (remove-if-not (lambda (i) (eq (cluster i) cluster-label)) points)) (defmethod distance ((vector-1 t) (vector-2 t)) "Return the Euclidean distance between two vectors." (sqrt (loop for i across vector-1 for j across vector-2 sum (expt (- i j) 2)))) (defmethod distance ((document-a document-cluster) (document-b document-cluster)) (distance (vector-data document-a) (vector-data document-b))) (defmethod generate-document-distance-vectors ((collection document-collection)) "Set the edge weights for all document neighbors (graph is fully connected)." (with-accessors ((documents documents)) collection (loop for document-a in documents do (loop for document-b in documents do (setf (gethash document-b (edges document-a)) (distance document-a document-b)))))) (defmethod dbscan ((collection document-collection) &key (minimum-points 3) (epsilon 0.5)) "Minimum points refers to the minimum amount of points that must exist in the neighborhood of a point for it to be considered a core-point in a cluster. Epsilon refers to the distance between two points for them to be considered neighbors." (labels ((range-query (document) "Return all points that have a distance less than epsilon." (loop for vertex being the hash-keys of (edges document) when (and (<= (gethash vertex (edges document)) epsilon) (not (eq vertex document))) collect vertex)) (core-point-p (point) "Is a point a core-point?" (<= minimum-points (length (range-query point)))) (cluster-match-p (point cluster) "Check if a core point belongs to a cluster." (intersection cluster (range-query point)))) ;;; identify core points (let* ((core-points (remove-if-not #'core-point-p (documents collection))) (non-core-points (set-difference (documents collection) core-points))) ;;; assign labels to core points (loop for point in core-points with cluster-count = 0 do (loop named cluster-set for i from 0 to cluster-count ;; point found cluster match, setf and break when (cluster-match-p point (get-cluster i core-points)) do (setf (cluster point) i) (return-from cluster-set) ;; point found no cluster-match, create new cluster finally (setf (cluster point) (incf cluster-count)))) ;;; assign labels to non-core points (loop for point in non-core-points for intersection = (intersection core-points (range-query point)) when intersection do (setf (cluster point) (cluster (first intersection))))))) ================================================ FILE: libraries/analysis/document-vector.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :analysis) ;;; document-vector.lisp: transform a document into a vector (defmethod word-count-vectorize ((document document) dictionary) "Transform a document into a vector using word counts." (let ((vector-data (make-array (length dictionary) :initial-element 0))) (loop for word in dictionary for index from 0 below (length vector-data) do (setf (aref vector-data index) (term-count document word))) (setf (vector-data document) vector-data))) (defmethod tf-idf-vectorize ((document document) (collection document-collection) dictionary) "Transform a document into a vector using tf-idf. Definition: tf-idf: term frequency, inverse document frequency. How often does a term a appear in a document as compared to all other documents?" (let ((vector-data (make-array (length dictionary) :initial-element 0))) (loop for word in dictionary for index from 0 below (length vector-data) do (setf (aref vector-data index) (term-frequency-inverse-document-frequency document collection word))) (setf (vector-data document) vector-data))) (defmethod tf-vectorize ((document document) dictionary) "Transform a document into a vector using tf. Definition: tf: term frequency. How often does a term appear in a document?" (let ((vector-data (make-array (length dictionary) :initial-element 0))) (loop for word in dictionary for index from 0 below (length vector-data) do (setf (aref vector-data index) (term-frequency document word))) (setf (vector-data document) vector-data))) (defmethod vectorize-documents ((document-collection document-collection) operation) (let ((dictionary (dictionary document-collection))) (loop for document in (documents document-collection) do (funcall operation document dictionary)))) (defmethod word-count-vectorize-documents ((document-collection document-collection)) (vectorize-documents document-collection #'word-count-vectorize)) (defmethod tf-vectorize-documents ((document-collection document-collection)) "Definition: tf: term frequency. How often does a term appear in a document?" (vectorize-documents document-collection #'tf-vectorize)) (defmethod tf-idf-vectorize-documents ((document-collection document-collection)) "Definition: tf-idf: term frequency, inverse document frequency. How often does a term appear in a document as compared to all other documents?" (vectorize-documents document-collection (lambda (document dictionary) (tf-idf-vectorize document document-collection dictionary)))) ================================================ FILE: libraries/analysis/package.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (uiop:define-package :analysis (:use :cl) (:import-from :serapeum #:export-always)) ================================================ FILE: libraries/analysis/section.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :analysis) ;;; section.lisp -- given a document, automatically generate sections (export-always 'extract-sections) (defun extract-sections (text &key (epsilon 0.5)) "Extract the sections from a string of text. Epsilon refers to the distance between two points for them to be considered related." (labels ((average-distance (point points) (/ (reduce #'+ points :key (lambda (i) (distance (vector-data i) (vector-data point)))) (length points)))) (let ((collection (make-instance 'document-collection))) (loop for sentence in (sentence-tokenize text) do (add-document collection (make-instance 'document-cluster :string-contents sentence))) (tf-vectorize-documents collection) (loop for document in (documents collection) with cluster-index = 0 for cluster = (get-cluster cluster-index (documents collection)) do (if (and cluster (>= epsilon (average-distance document cluster))) (setf (cluster document) cluster-index) (setf (cluster document) (incf cluster-index)))) collection))) ================================================ FILE: libraries/analysis/stem.lisp ================================================ (in-package :analysis) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; The software is completely free for any purpose, unless notes at ;; the head of the program text indicates otherwise (which is ;; rare). In any case, the notes about licensing are never more ;; restrictive than the BSD License. ; ;; In every case where the software is not written by me (Martin ;; Porter), this licensing arrangement has been endorsed by the ;; contributor, and it is therefore unnecessary to ask the contributor ;; again to confirm it. ; ;; The Porter Stemming Algorithm, somewhat mechanically hand translated to Common Lisp by ;; Steven M. Haflich smh@franz.com Feb 2002. Most of the inline comments refer to the ;; original C code. At the time of this translation the code passes the associated Porter ;; test files. See the function test at the end of this file. ;; This port is intended to be portable ANSI Common Lisp. However, it has only been ;; compiled and tested with Allegro Common Lisp. This code is offered in the hope it will ;; be useful, but with no warranty of correctness, suitability, usability, or anything ;; else. The C implementation from which this code was derived was not reentrant, relying ;; on global variables. This implementation corrects that. It is intended that a word to ;; be stemmed will be in a string with fill-pointer, as this is a natural result when ;; parsing user input, web scraping, whatever. If not, a string with fill-pointer is ;; created, but this is an efficiency hit and is here intended only for lightweight use or ;; testing. Using some resource mechanism on these strings would be a useful improvement, ;; whether here or in the calling code. ;; Postscript: When I contacted Martin Porter about this anachronism, he decided to fix ;; the C version to implement proper reentrancy. The CL version is now also served from ;; his central site. It should be functionally identical to this one, modulo the current ;; comment and a couple harmless formatting and comment changes. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; This is the Porter stemming algorithm, coded up in ANSI C by the ;; author. It may be regarded as canonical, in that it follows the ;; algorithm presented in ;; Porter, 1980, An algorithm for suffix stripping, Program, Vol. 14, ;; no. 3, pp 130-137, ;; only differing from it at the points maked --DEPARTURE-- below. ;; See also http://www.tartarus.org/~martin/PorterStemmer ;; The algorithm as described in the paper could be exactly replicated ;; by adjusting the points of DEPARTURE, but this is barely necessary, ;; because (a) the points of DEPARTURE are definitely improvements, and ;; (b) no encoding of the Porter stemmer I have seen is anything like ;; as exact as this version, even with the points of DEPARTURE! ;; You can compile it on Unix with 'gcc -O3 -o stem stem.c' after which ;; 'stem' takes a list of inputs and sends the stemmed equivalent to ;; stdout. ;; The algorithm as encoded here is particularly fast. ;; Release 1 ;; The main part of the stemming algorithm starts here. b is a buffer ;; holding a word to be stemmed. The letters are in b[k0], b[k0+1] ... ;; ending at b[k]. In fact k0 = 0 in this demo program. k is readjusted ;; downwards as the stemming progresses. Zero termination is not in fact ;; used in the algorithm. ;; Note that only lower case sequences are stemmed. Forcing to lower case ;; should be done before stem(...) is called. ;; cons(i) is TRUE <=> b[i] is a consonant. ;;; Common Lisp port Version 1.01 ;;; ;;; Common Lisp port Version history ;;; ;;; 1.0 -- smh@franz.com Feb 2002 ;;; initial release ;;; ;;; 1.01 -- smh@franz.com 25 Apr 2004 ;;; step4 signalled error for "ion" "ions". Thanks to Jeff Heard ;;; for detecting this and suggesting the fix. (defun consonantp (str i) (let ((char (char str i))) (cond ((member char '(#\a #\e #\i #\o #\u)) nil) ((eql char #\y) (if (= i 0) t (not (consonantp str (1- i))))) (t t)))) ;; m() measures the number of consonant sequences between k0 and j. if c is ;; a consonant sequence and v a vowel sequence, and <..> indicates arbitrary ;; presence, ;; gives 0 ;; vc gives 1 ;; vcvc gives 2 ;; vcvcvc gives 3 ;; .... (defun m (str lim) (let ((n 0) (i 0)) (loop (when (>= i lim) (return-from m n)) (if (not (consonantp str i)) (return nil)) (incf i)) (incf i) (loop (loop (if (>= i lim) (return-from m n)) (if (consonantp str i) (return nil)) (incf i)) (incf i) (incf n) (loop (if (>= i lim) (return-from m n)) (if (not (consonantp str i)) (return nil)) (incf i)) (incf i)))) ;; vowelinstem() is TRUE <=> k0,...j contains a vowel (defun vowelinstem (str) (loop for i from 0 below (fill-pointer str) unless (consonantp str i) return t)) ;; doublec(j) is TRUE <=> j,(j-1) contain a double consonant. (defun doublec (str i) (cond ((< i 1) nil) ((not (eql (char str i) (char str (1- i)))) nil) (t (consonantp str i)))) ;; cvc(i) is TRUE <=> i-2,i-1,i has the form consonant - vowel - consonant ;; and also if the second c is not w,x or y. this is used when trying to ;; restore an e at the end of a short word. e.g. ;; cav(e), lov(e), hop(e), crim(e), but ;; snow, box, tray. (defun cvc (str lim) (decf lim) (if (or (< lim 2) (not (consonantp str lim)) (consonantp str (1- lim)) (not (consonantp str (- lim 2)))) (return-from cvc nil)) (if (member (char str lim) '(#\w #\x #\y)) (return-from cvc nil)) t) ;; ends(s) is TRUE <=> k0,...k ends with the string s. (defun ends (str ending) (declare (string str) (simple-string ending)) (let ((len1 (length str)) (len2 (length ending))) (loop for pa downfrom (1- len1) to 0 and pb downfrom (1- len2) to 0 unless (eql (char str pa) (char ending pb)) return nil finally (return (when (< pb 0) (decf (fill-pointer str) len2) t))))) ;; setto(s) sets (j+1),...k to the characters in the string s, readjusting k. (defun setto (str suffix) (declare (string str) (simple-string suffix)) (loop for char across suffix do (vector-push-extend char str))) ;; r(s) is used further down. (defun r (str s sfp) (if (> (m str (fill-pointer str)) 0) (setto str s) (setf (fill-pointer str) sfp))) ;; step1ab() gets rid of plurals and -ed or -ing. e.g. ;; caresses -> caress ;; ponies -> poni ;; ties -> ti ;; caress -> caress ;; cats -> cat ;; feed -> feed ;; agreed -> agree ;; disabled -> disable ;; matting -> mat ;; mating -> mate ;; meeting -> meet ;; milling -> mill ;; messing -> mess ;; meetings -> meet (defun step1ab (str) (when (eql (char str (1- (fill-pointer str))) #\s) (cond ((ends str "sses") (incf (fill-pointer str) 2)) ((ends str "ies") (setto str "i")) ((not (eql (char str (- (fill-pointer str) 2)) #\s)) (decf (fill-pointer str))))) (cond ((ends str "eed") (if (> (m str (fill-pointer str)) 0) (incf (fill-pointer str) 2) (incf (fill-pointer str) 3))) ((let ((sfp (fill-pointer str))) (if (or (ends str "ed") (ends str "ing")) (if (vowelinstem str) t (progn (setf (fill-pointer str) sfp) nil)))) (cond ((ends str "at") (setto str "ate")) ((ends str "bl") (setto str "ble")) ((ends str "iz") (setto str "ize")) ((doublec str (1- (fill-pointer str))) (unless (member (char str (1- (fill-pointer str))) '(#\l #\s #\z)) (decf (fill-pointer str)))) (t (if (and (= (m str (fill-pointer str)) 1) (cvc str (fill-pointer str))) (setto str "e")))))) str) ;; step1c() turns terminal y to i when there is another vowel in the stem. (defun step1c (str) (let ((saved-fill-pointer (fill-pointer str))) (when (and (ends str "y") (vowelinstem str)) (setf (char str (fill-pointer str)) #\i)) (setf (fill-pointer str) saved-fill-pointer)) str) ;; step2() maps double suffices to single ones. so -ization ( = -ize plus ;; -ation) maps to -ize etc. note that the string before the suffix must give ;; m() > 0. (defun step2 (str) (let ((sfp (fill-pointer str))) (when (> sfp 2) (block nil (case (char str (- (length str) 2)) (#\a (when (ends str "ational") (r str "ate" sfp) (return)) (when (ends str "tional") (r str "tion" sfp) (return))) (#\c (when (ends str "enci") (r str "ence" sfp) (return)) (when (ends str "anci") (r str "ance" sfp) (return))) (#\e (when (ends str "izer") (r str "ize" sfp) (return))) (#\l (when (ends str "bli") (r str "ble" sfp) (return)) ;; -DEPARTURE- ;; To match the published algorithm, replace prev line with ;; ((when (ends str "abli") (r str "able" sfp) (return)) (when (ends str "alli") (r str "al" sfp) (return)) (when (ends str "entli") (r str "ent" sfp) (return)) (when (ends str "eli") (r str "e" sfp) (return)) (when (ends str "ousli") (r str "ous" sfp) (return))) (#\o (when (ends str "ization") (r str "ize" sfp) (return)) (when (ends str "ation") (r str "ate" sfp) (return)) (when (ends str "ator") (r str "ate" sfp) (return))) (#\s (when (ends str "alism") (r str "al" sfp) (return)) (when (ends str "iveness") (r str "ive" sfp) (return)) (when (ends str "fulness") (r str "ful" sfp) (return)) (when (ends str "ousness") (r str "ous" sfp) (return))) (#\t (when (ends str "aliti") (r str "al" sfp) (return)) (when (ends str "iviti") (r str "ive" sfp) (return)) (when (ends str "biliti") (r str "ble" sfp) (return))) ;; -DEPARTURE- ;; To match the published algorithm, delete next line. (#\g (when (ends str "logi") (r str "log" sfp) (return))))))) str) ;; step3() deals with -ic-, -full, -ness etc. similar strategy to step2. (defun step3 (str) (let ((sfp (fill-pointer str))) (block nil (case (char str (1- (length str))) (#\e (when (ends str "icate") (r str "ic" sfp) (return)) (when (ends str "ative") (r str "" sfp) (return)) ; huh? (when (ends str "alize") (r str "al" sfp) (return))) (#\i (when (ends str "iciti") (r str "ic" sfp) (return))) (#\l (when (ends str "ical") (r str "ic" sfp) (return)) (when (ends str "ful") (r str "" sfp) (return))) ; huh? (#\s (when (ends str "ness") (r str "" sfp) (return))) ; huh? ))) str) ;; step4() takes off -ant, -ence etc., in context vcvc. (defun step4 (str) (let ((sfp (fill-pointer str))) (when (> sfp 2) ; Unnecessary? (block nil (case (char str (- sfp 2)) (#\a (if (ends str "al") (return))) (#\c (if (ends str "ance") (return)) (if (ends str "ence") (return))) (#\e (if (ends str "er") (return))) (#\i (if (ends str "ic") (return))) (#\l (if (ends str "able") (return)) (if (ends str "ible") (return))) (#\n (if (ends str "ant") (return)) (if (ends str "ement") (return)) (if (ends str "ment") (return)) (if (ends str "ent") (return))) (#\o (if (ends str "ion") (let ((len (length str))) (if (and (> len 0) (let ((c (char str (1- len)))) (or (eql c #\s) (eql c #\t)))) (return) (setf (fill-pointer str) sfp)))) (if (ends str "ou") (return))) ; takes care of -ous (#\s (if (ends str "ism") (return))) (#\t (if (ends str "ate") (return)) (if (ends str "iti") (return))) (#\u (if (ends str "ous") (return))) (#\v (if (ends str "ive") (return))) (#\z (if (ends str "ize") (return)))) (return-from step4 str)) (unless (> (m str (fill-pointer str)) 1) (setf (fill-pointer str) sfp))) str)) ;; step5() removes a final -e if m() > 1, and changes -ll to -l if m() > 1. (defun step5 (str) (let ((len (fill-pointer str))) (if (eql (char str (1- len)) #\e) (let ((a (m str len))) (if (or (> a 1) (and (= a 1) (not (cvc str (1- len))))) (decf (fill-pointer str)))))) (let ((len (fill-pointer str))) (if (and (eql (char str (1- len)) #\l) (doublec str (1- len)) (> (m str len) 1)) (decf (fill-pointer str)))) str) ;; In stem(p,i,j), p is a char pointer, and the string to be stemmed is from p[i] to p[j] ;; inclusive. Typically i is zero and j is the offset to the last character of a string, ;; (p[j+1] == '\0'). The stemmer adjusts the characters p[i] ... p[j] and returns the new ;; end-point of the string, k. Stemming never increases word length, so i <= k <= j. To ;; turn the stemmer into a module, declare 'stem' as extern, and delete the remainder of ;; this file. (defun stem (str) (let ((len (length str))) ;; With this line, strings of length 1 or 2 don't go through the ;; stemming process, although no mention is made of this in the ;; published algorithm. Remove the line to match the published ;; algorithm. (if (<= len 2) (return-from stem str)) ; /*-DEPARTURE-*/ (if (typep str 'simple-string) ; Primarily for testing. (setf str (make-array len :element-type 'character :fill-pointer len :initial-contents str))) (step1ab str) (step1c str) (step2 str) (step3 str) (step4 str) (step5 str) str)) #+never (trace step1ab step1c step2 step3 step4 step5) #+never (defun test () ; Run against the distributed test files. (with-open-file (f1 "voc.txt") (with-open-file (f2 "output.txt") (loop as w1 = (read-line f1 nil nil) while w1 as w2 = (read-line f2 nil nil) as w3 = (stem w1) if (equal w2 w3) count t into successes else count t into failures and do (format t "(stem ~s) => ~s wanted ~s~%" w1 w3 w2) finally (progn (format t "sucesses ~d failures ~d~%" successes failures) (return failures)))))) ================================================ FILE: libraries/analysis/tests/tests.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (uiop:define-package :analysis/tests (:use :cl :lisp-unit2) (:import-from :analysis)) (in-package :analysis/tests) (define-test test-single-length () (let ((model (make-instance 'analysis::sequence-model))) (analysis::add-record model '(1 2)) (assert-equal (analysis::element (analysis::predict model '(1))) 2)) (let ((model (make-instance 'analysis::sequence-model))) (analysis::add-record model '(1 2)) (analysis::add-record model '(2 3)) (analysis::add-record model '(2 3)) (assert-equal (analysis::element (analysis::predict model '(1))) 2)) (let ((model (make-instance 'analysis::sequence-model))) (analysis::add-record model '(1 2)) (analysis::add-record model '(1 2)) (analysis::add-record model '(1 2)) (analysis::add-record model '(1 3)) (analysis::add-record model '(1 3)) (assert-equal (analysis::element (analysis::predict model '(1))) 2)) (let ((model (make-instance 'analysis::sequence-model))) (analysis::add-record model '(1 2)) (analysis::add-record model '(1 2)) (analysis::add-record model '(1 3)) (analysis::add-record model '(1 3)) (analysis::add-record model '(1 3)) (assert-equal (analysis::element (analysis::predict model '(1))) 3)) (let ((model (make-instance 'analysis::sequence-model))) (analysis::add-record model '(1 2)) (analysis::add-record model '(1 3)) (analysis::add-record model '(1 2)) (assert-equal (analysis::element (analysis::predict model '(1))) 2))) (define-test test-multiple-length () (let ((model (make-instance 'analysis::sequence-model))) (analysis::add-record model '(1 2 3)) (assert-equal (analysis::element (analysis::predict model '(1 2))) 3)) ;; Make sure the most temporally recent element is used ;; Fails in CCL. (let ((model (make-instance 'analysis::sequence-model))) (analysis::add-record model '(1 2 4)) (analysis::add-record model '(1 2 3)) (assert-equal (analysis::element (analysis::predict model '(1 2))) 3)) (let ((model (make-instance 'analysis::sequence-model))) (analysis::add-record model '(1 2 3)) (analysis::add-record model '(1 2 4)) (analysis::add-record model '(1 2 4)) (analysis::add-record model '(1 2 4)) (assert-equal (analysis::element (analysis::predict model '(1 2))) 4)) (let ((model (make-instance 'analysis::sequence-model))) (analysis::add-record model '(1 2 3)) (analysis::add-record model '(1 2 4)) (analysis::add-record model '(1 2 4)) (analysis::add-record model '(1 2 4)) (analysis::add-record model '(1 2 3)) (analysis::add-record model '(1 2 3)) (analysis::add-record model '(1 2 3)) (analysis::add-record model '(1 2 3)) (assert-equal (analysis::element (analysis::predict model '(1 2))) 3))) (define-test test-variable-length () (let ((model (make-instance 'analysis::sequence-model))) (analysis::add-record model '(1 2 3)) (analysis::add-record model '(1 2 4)) (analysis::add-record model '(1 2 4)) (analysis::add-record model '(1 2 4)) (analysis::add-record model '(1 2)) (analysis::add-record model '(1 2)) (analysis::add-record model '(1 2)) (analysis::add-record model '(1 2 3)) (analysis::add-record model '(1 2 3)) (analysis::add-record model '(1 2 3)) (analysis::add-record model '(1 2 3)) (assert-equal (analysis::element (analysis::predict model '(1 2))) 3)) (let ((model (make-instance 'analysis::sequence-model))) (analysis::add-record model '(1 2 3)) (analysis::add-record model '(1 2 4)) (analysis::add-record model '(1 2 4)) (analysis::add-record model '(1 2 4)) (analysis::add-record model '(1 2)) (analysis::add-record model '(1 2)) (analysis::add-record model '(1 3)) (analysis::add-record model '(1 3)) (analysis::add-record model '(1 3)) (analysis::add-record model '(1 2 3)) (analysis::add-record model '(1 2 3)) (analysis::add-record model '(1 2 3)) (analysis::add-record model '(1 2 3)) (assert-equal (analysis::element (analysis::predict model '(1))) 3) (assert-equal (analysis::element (analysis::predict model '(1 2))) 3))) ================================================ FILE: libraries/analysis/text-rank.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :analysis) ;;; text-rank.lisp -- implementation of textrank algorithm (defclass document-vertex (document) ((edges :accessor edges :initform (make-hash-table) :documentation "The keys of the hash table represent the edges, the values of the hash table represent the edge weights.")) (:documentation "The document vertex class represents a document that is part of a graph. The edges slot of the document vertex class is used to store edges of that particular vertex. The keys in the edges slot hash table are the actual vertexes, and the values are the edge weights.")) (defmethod cosine-similarity ((document-a document) (document-b document)) "Calculate the cosine similarity between two vectors." (flet ((vector-product (document-a document-b) (loop for a across (vector-data document-a) for b across (vector-data document-b) sum (* a b))) (vector-sum-root (document) (sqrt (loop for i across (vector-data document) sum (* i i)))) (vector-zero-p (document) (every #'zerop (vector-data document)))) (if (or (vector-zero-p document-a) (vector-zero-p document-b)) 0 ; if either vector is completely zero, they are dissimilar (/ (vector-product document-a document-b) (* (vector-sum-root document-a) (vector-sum-root document-b)))))) (defmethod generate-document-similarity-vectors ((collection document-collection)) "Set the edge weights for all document neighbors (graph is fully connected)." (with-accessors ((documents documents)) collection (loop for document-a in documents do (loop for document-b in documents do (setf (gethash document-b (edges document-a)) (cosine-similarity document-a document-b)))))) (defmethod text-rank ((collection document-collection) &key (epsilon 0.001) (damping 0.85) (initial-rank) (iteration-limit 100)) "This method is used to calculate the text rankings for a document collection. The `epsilon' is the maximum delta for a given node rank change during an iteration to be considered convergent. The `damping' is a factor utilized to normalize the data. The `initial-rank' is the rank given to nodes before any iterations. The `iteration-limit' is the amount of times the algorithm may traverse the graph before giving up (if the algorithm does not converge)." (with-accessors ((documents documents)) collection (unless (zerop (length documents)) (labels ((set-initial-rank () "Set the initial rank of all documents to a supplied value OR 1/length of the documents." (let ((initial-rank (or initial-rank (/ 1 (length documents))))) (mapcar (lambda (document) (setf (rank document) initial-rank)) documents))) (graph-neighbors (document) "Return a list of neighbors. In a fully connected graph, all nodes are a neighbor except for the node itself." (remove document documents)) (graph-neighbor-edge-sum (document) "Add up the edges of all neighbors of a given node." (let ((sum (- (reduce #'+ (alexandria:hash-table-values (edges document))) 1))) (if (> sum 0) sum 1))) (document-similarity (document-a document-b) (gethash document-b (edges document-a) 0)) (convergedp (previous-score current-score) "Check if a delta qualifies for convergence." (<= (abs (- previous-score current-score)) epsilon)) (calculate-rank (document) "Calculate the rank of a document." (loop for neighbor in (graph-neighbors document) sum (/ (* damping (rank neighbor) (document-similarity document neighbor)) (graph-neighbor-edge-sum neighbor))))) (set-initial-rank) (loop with converged = nil for iteration from 0 to iteration-limit until converged do (setf converged t) (loop for document in documents for old-rank = (rank document) for new-rank = (calculate-rank document) do (setf (rank document) new-rank) unless (convergedp old-rank new-rank) do (setf converged nil))))))) (export-always 'summarize-text) (defun summarize-text (text &key (summary-length 3) (show-rank-p nil)) (let ((collection (make-instance 'document-collection))) (loop for sentence in (sentence-tokenize text) do (add-document collection (make-instance 'document-vertex :string-contents sentence))) (tf-idf-vectorize-documents collection) (generate-document-similarity-vectors collection) (text-rank collection :iteration-limit 100) (serapeum:take summary-length (mapcar (if show-rank-p (lambda (i) (cons (rank i) (string-contents i))) #'string-contents) (sort (documents collection) #'> :key #'rank))))) ================================================ FILE: libraries/analysis/tokenize.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :analysis) (defun word-tokenize (string &key (remove-stop-words t) (stem nil) (down-case t) (alphabetic t)) "Split a string into a list of words." (let* ((alpha-scanner (cl-ppcre:create-scanner "^[A-Za-z]*$")) (tokens (str:split " " (str:collapse-whitespaces string))) (tokens (if remove-stop-words (delete-if (lambda (x) (gethash (string-downcase x) (stop-words-lookup *language-data*))) tokens) tokens)) (tokens (if stem (mapcar #'stem tokens) tokens)) (tokens (if down-case (mapcar #'string-downcase tokens) tokens)) (tokens (if alphabetic (delete-if-not (lambda (x) (cl-ppcre:scan alpha-scanner x)) tokens) tokens))) tokens)) (defun sentence-tokenize (string) "Split a string into a list of sentences." ;; TODO: Use "\\p{Terminal_Punctuation}" regexp instead to catch all terminal ;; punctuation marks, including "," and ";"? (remove "" (mapcar #'str:trim (cl-ppcre:split "[.!?]" string)) :test #'equal)) ================================================ FILE: libraries/download-manager/engine.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :download-manager) (defvar *default-download-directory* #p"~/Downloads/") (defun default-download-directory () (let ((dir (ignore-errors (uiop:run-program '("xdg-user-dir" "DOWNLOAD") :output '(:string :stripped t))))) (when (or (null dir) (string= dir (uiop:getenv "HOME"))) (setf dir (uiop:getenv "XDG_DOWNLOAD_DIR"))) (unless dir (setf dir *default-download-directory*)) dir)) (defun download-directory (&optional (directory (default-download-directory))) "Return path to download directory. Create it if it does not exist." (unless directory (setf directory (default-download-directory))) (unless (string= "" (file-namestring directory)) (setf directory (format nil "~a/" (namestring directory)))) (truename (ensure-directories-exist directory))) (defun ensure-unique-file (file) "Return FILE if unique or suffix it with a number otherwise." (loop with original-name = file with suffix = 1 while (uiop:file-exists-p file) do (setf file (make-pathname :defaults original-name :name (format nil "~a.~d" (pathname-name (pathname original-name)) suffix))) do (incf suffix)) (namestring (pathname file))) (defvar *notifications* nil "A channel which can be queried for download notifications. The channel return value is a `download'.") (defclass download () ((requested-url :accessor requested-url :initarg :requested-url :initform (quri:uri "") :type quri:uri :documentation "The URL that the user requested. This may be different from the actual location of the download, e.g. in case of automatic redirection. See RESOLVED-URL.") (resolved-url :accessor resolved-url :initarg :resolved-url :initform (quri:uri "") :type quri:uri :documentation "The actual source of the download. This may be different from the URL the user requested, see REQUESTED-URL.") (file :accessor file :initarg :file :initform "" :documentation "Path pointing to the local storage location of the downloaded file.") (downstream :accessor downstream :initarg :downstream :initform nil :documentation "The stream which can be read from to do the actual download.") (status :accessor status :initarg :status ;; TODO: String? :initform nil) (header :accessor header :initarg :header :initform "") (update-interval :type alexandria:non-negative-real :accessor update-interval :initarg :update-interval :initform 1.0 :documentation "Time in seconds after which a notification is sent to the `*notifications*' channel.") (last-update :type alexandria:non-negative-real :accessor last-update :initarg :last-update :initform 0.0 :documentation "Time in seconds when the last notification was sent.") (finished-p :accessor finished-p :initform nil :documentation "Non-nil if it has finished downloading.") (bytes-fetched :accessor bytes-fetched :initform 0) (bytes-last-update :accessor bytes-last-update :initform 0 :documentation "Bytes fetched when last `update' was called.") (last-update-speed :accessor last-update-speed :initform 0 :documentation "Download speed in B/s when last `update' was called."))) (defmethod filename ((download download)) "Return the full name of this downloaded file, as a string." (format nil "~a" (file download))) (defmethod temp-file ((download download)) "Return a file name suitable for unfinished downloads." (ensure-unique-file (format nil "~a.part" (namestring (file download))))) (defmethod bytes-total ((download download)) (let ((bytes (gethash "content-length" (header download) 0))) (if (stringp bytes) (parse-integer bytes) bytes))) (defmethod progress ((download download)) "Return progress ratio. When download is completed, return 1.0. When progress cannot be computer (because bytes-total is unknown), return (values 0 'unknown)." (cond ((finished-p download) 1) ((if (> (bytes-total download) 0) (/ (float (bytes-fetched download)) (float (bytes-total download))) (values 0 'unknown))))) (defmethod update ((download download)) "Send DOWNLOAD to the `notifications' channel. Only send if last update was more than `update-interval' seconds ago." (let* ((new-time (/ (get-internal-real-time) (float internal-time-units-per-second))) (time-diff (- new-time (last-update download)))) (when (or (< (update-interval download) time-diff) (finished-p download)) (calispel:! *notifications* download) (setf (last-update-speed download) (if (= 0 time-diff) 0 (round (/ (float (- (bytes-fetched download) (bytes-last-update download))) time-diff)))) (setf (bytes-last-update download) (bytes-fetched download)) (setf (last-update download) new-time)))) (declaim (ftype (function (quri:uri &key (:directory (or string pathname)) (:proxy (or quri:uri null)) (:cookies (or string null)))) resolve)) (defun resolve (url &key (directory (default-download-directory)) proxy cookies) "Start downloading URL concurrently and return a corresponding `download' object. If DIRECTORY is nil, `default-download-directory' will be used. COOKIES can specify a cookie jar as a string, which is useful for authenticated downloads. PROXY is the full proxy address, e.g. \"socks5://127.0.0.1:9050\"." (unless *notifications* (setf *notifications* (make-instance 'calispel:channel))) (let ((download (cache :url url :directory (download-directory directory) :cookies cookies :proxy proxy))) ;; TODO: We just use bt:make-thread, no need for a channel... Unless need to ;; watch for unfinished downloads and warn the user before closing. (bt:make-thread (lambda () (fetch download)) :name "download-manager") download)) ================================================ FILE: libraries/download-manager/native.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause ;;; Native Common Lisp download manager backend. (in-package :download-manager) (defmethod cache ((type (eql :url)) url &rest args) (log:debug url args) (apply #'locally-cache url args)) (defun parse-cookie-jar-string (cookie-jar-string host path) "Host is for instance \"example.org\" and path is \"/foo/bar\"." (cl-cookie:make-cookie-jar :cookies (mapcar (lambda (c) (cl-cookie:parse-set-cookie-header c host path)) (cl-ppcre:split " *; *" cookie-jar-string)))) (defun locally-cache (requested-url &key (directory (download-directory)) cookies proxy) (let* ((cookies-jar (unless (str:emptyp cookies) (parse-cookie-jar-string cookies (quri:uri-host requested-url) (quri:uri-path requested-url))))) (handler-case (multiple-value-bind (stream status response-headers resolved-url) (dex:get (quri:render-uri requested-url) :want-stream t :force-binary t :keep-alive nil :proxy (and proxy (quri:render-uri proxy)) :cookie-jar cookies-jar) ;; TODO: Allow caller to set the target filename? (let* ((file (merge-pathnames directory (extract-filename requested-url response-headers)))) ;; TODO: Touch file now to ensure uniqueness when actually downloading? (make-instance 'download :requested-url requested-url :resolved-url (quri:uri resolved-url) :header response-headers :file file :status status :downstream stream))) (error (c) (error c))))) (defmethod fetch ((download download) &key (buffer-size 16)) ; Small for testing. "Return the number of bytes fetched." (let* ((buffer (make-array buffer-size :element-type '(unsigned-byte 8))) ;; Without `uiop:parse-native-namestring' `with-open-file' would fail ;; if `temp-file' had a wildcard. (temp-file (uiop:parse-native-namestring (temp-file download)))) (with-open-file (output temp-file :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) (log:info "Downloading ~s~% to ~s." (or (ignore-errors (quri:url-decode (quri:render-uri (resolved-url download)))) (quri:render-uri (resolved-url download))) (namestring (file download))) (loop :for byte-position = (read-sequence buffer (downstream download)) :do (update download) :when (plusp byte-position) :do (incf (bytes-fetched download) byte-position) :if (plusp byte-position) :do (write-sequence buffer output :end byte-position) :else :return nil)) ;; TODO: Report something if bytes-fetched is not the same as bytes-total. (setf (finished-p download) t) (uiop:rename-file-overwriting-target temp-file (ensure-unique-file ;; Same as above for `parse-native-namestring'. (uiop:parse-native-namestring (namestring (file download))))) (update download) (bytes-fetched download))) (defun parse-http-header (header-entry) "Return the alist of key-value paris in HEADER-ENTRY." (mapcar (lambda (key-value) (cl-ppcre:split "=" key-value)) ;; TODO: Don't split at escaped or quoted semicolons? (cl-ppcre:split " *; *" header-entry))) (defun normalize-filename (filename) "Remove surrounding quotes and return the basename as a string. Return NIL if filename is not a string or a pathname." (when (pathnamep filename) (setf filename (namestring filename))) (when (stringp filename) (file-namestring (string-trim "\"" filename)))) (defun extract-filename (url &optional headers) "Extract a filename to save the contents of a URL under." ;; See https://en.wikipedia.org/wiki/List_of_HTTP_header_fields. (or (normalize-filename (second (assoc "filename" (parse-http-header (gethash "content-disposition" headers)) :test #'string=))) (let ((basename (ignore-errors (file-namestring (quri:uri-path url))))) (if (or (null basename) (string= "" basename)) "index.html" basename)))) ================================================ FILE: libraries/download-manager/package.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (uiop:define-package :download-manager (:use :cl) (:export #:init #:*notifications* #:default-download-directory #:download #:resolved-url #:requested-url #:header #:file #:filename #:bytes-fetched #:bytes-total #:progress #:finished-p #:last-update-speed #:cache #:resolve)) ================================================ FILE: libraries/nasdf/install.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :nasdf) (export-always 'nasdf-file) (defclass nasdf-file (static-file) ((if-does-not-exist :initform :error :initarg :if-does-not-exist :type (member :error nil) :documentation "What to do when input file is missing: - `:error': Signal an error. - `nil': Skip it.")) (:documentation "Component type for files to install.")) (import 'nasdf-file :asdf-user) (export-always 'nasdf-binary-file) (defclass nasdf-binary-file (nasdf-file) () (:documentation "Component type for executables to install.")) (import 'nasdf-binary-file :asdf-user) (export-always 'nasdf-library-file) (defclass nasdf-library-file (nasdf-binary-file) () (:documentation "Component type for libraries (shared objects) to install.")) (import 'nasdf-library-file :asdf-user) (export-always 'nasdf-desktop-file) (defclass nasdf-desktop-file (nasdf-file) () (:documentation "Component type for XDG .desktop files to install.")) (import 'nasdf-desktop-file :asdf-user) (export-always 'nasdf-appdata-file) (defclass nasdf-appdata-file (nasdf-file) () (:documentation "Component type for Appdata files to install.")) (import 'nasdf-appdata-file :asdf-user) (export-always 'nasdf-icon-scalable-file) (defclass nasdf-icon-scalable-file (nasdf-file) () (:documentation "Component type for the SVG icon.")) (import 'nasdf-icon-scalable-file :asdf-user) (export-always 'nasdf-icon-directory) (defclass nasdf-icon-directory (nasdf-file) ((asdf/interface::type :initform "png")) ; TODO: Is there a standard way to access the type? (:documentation "Component type for directory containing icon files to install. File of type `type' are looked for. The last number found in the file name is used to install the icon in the right directory.")) (import 'nasdf-icon-directory :asdf-user) ;; TODO: Is it possible to list all files targetted by an ASDF system? (export-always 'nasdf-source-directory) (defclass nasdf-source-directory (nasdf-file) ((exclude-subpath :initform '() :type (or null (cons string *)) :accessor exclude-subpath :initarg :exclude-subpath :documentation "Subpath to exclude from installation. Subpaths are relative to the component, so (:nasdf-source-directory \"foo\" :exclude-subpath (\"bar\")) means that foo/bar is excluded, but foo/baz is not. If subpath is a directory, then all its subpaths are excluded as well.") (exclude-types :initform '("fasl") :type (or null (cons string *)) :accessor exclude-types :initarg :exclude-types :documentation "Pattern of files to exclude when not using Git.")) (:documentation "Directory of Common Lisp source files. Subdirectory is included. Git is used to list the tracked files -- untracked files will be ignored. If Git is not found, fall back to copying everything except files of type in `exclude-types'. Destination directory is given by the `dest-source-dir' generic function.")) (import 'nasdf-source-directory :asdf-user) (defun nil-pathname-p (pathname) "Return non-nil if PATHNAME is `*nil-pathname*' or nil." (the (values boolean &optional) (or (null pathname) (pathname-equal pathname *nil-pathname*)))) (defun basename (pathname) ; From nfiles. "Return the basename, that is: - if it's a directory, the name of the directory, - if it's a file, the name of the file including its type (extension), - nil if it's a nil-pathname (#p\"\")." (if (nil-pathname-p pathname) nil ; TODO: Shouldn't we return #p"" instead? (first (last (pathname-directory ;; Ensure directory _after_ truenamizing, otherwise if ;; non-directory file exists it may not yield a directory. (ensure-directory-pathname (ensure-pathname pathname :truenamize t))))))) (defun path-from-env (environment-variable default) (let ((env (getenv environment-variable))) (if env (ensure-directory-pathname env) default))) (defun relative-path-from-env (environment-variable default) (let ((env (getenv environment-variable))) (if env (relativize-pathname-directory (ensure-directory-pathname env)) default))) ;; We use `defparameter' so that paths are re-computed on system reload. (export-always '*destdir*) (defparameter *destdir* (if (getenv "DESTDIR") (ensure-directory-pathname (getenv "DESTDIR")) #p"/")) (export-always '*prefix*) (defparameter *prefix* (merge-pathnames* (relative-path-from-env "PREFIX" #p"usr/local/") *destdir*)) (export-always '*datadir*) (defparameter *datadir* (path-from-env "DATADIR" (merge-pathnames* "share/" *prefix*))) (export-always '*bindir*) (defparameter *bindir* (path-from-env "BINDIR" (merge-pathnames* "bin/" *prefix*))) (export-always '*libdir*) (defparameter *libdir* (path-from-env "LIBDIR" (merge-pathnames* "lib/" *prefix*))) (export-always 'libdir) (defmethod libdir ((component nasdf-library-file)) (let ((name (primary-system-name (component-system component)))) (ensure-directory-pathname (merge-pathnames* name *libdir*)))) (export-always '*dest-source-dir*) (defvar *dest-source-dir* (path-from-env "NASDF_SOURCE_PATH" *datadir*) "Root of where the source will be installed. Final path is resolved in `dest-source-dir'.") (export-always 'dest-source-dir) (defmethod dest-source-dir ((component nasdf-source-directory)) "The directory into which the source is installed." (let ((name (primary-system-name (component-system component)))) (ensure-directory-pathname (merge-pathnames* name *dest-source-dir*)))) (export-always '*chmod-program*) (defvar *chmod-program* "chmod") (export-always '*chmod-executable-arg*) (defvar *chmod-executable-arg* "+x") (export-always 'make-executable) (defun make-executable (file) "Does nothing if files does not exist." ;; TODO: Use iolib/os:file-permissions instead of chmod? Too verbose? (when (file-exists-p file) (run-program (list *chmod-program* *chmod-executable-arg* (native-namestring file))))) (export-always 'install-file) (defun install-file (file dest) "Like `copy-file' but ensures all parent directories are created if necessary." (ensure-all-directories-exist (list (directory-namestring dest))) (copy-file file dest)) (defmethod perform ((op compile-op) (c nasdf-file)) ; REVIEW: load-op? (loop for input in (input-files op c) for output in (output-files op c) do (if (or (file-exists-p input) (slot-value c 'if-does-not-exist)) (progn (install-file input output) ;; (format *error-output* "~&; installing file~%; ~s~%; to~%; ~s~%" source dest) ; Too verbose? (logger "installed ~s" output)) (logger "skipped ~s" output))) nil) (defmethod output-files ((op compile-op) (c nasdf-file)) (values (list (merge-pathnames* (pathname-name (component-name c)) *prefix*)) t)) (defmethod output-files ((op compile-op) (c nasdf-binary-file)) (values (list (merge-pathnames* (basename (component-name c)) *bindir*)) t)) (defmethod perform ((op compile-op) (c nasdf-binary-file)) (call-next-method) (mapc #'make-executable (output-files op c)) nil) (defmethod output-files ((op compile-op) (c nasdf-library-file)) (values (list (merge-pathnames* (basename (component-name c)) (libdir c))) t)) (defmethod output-files ((op compile-op) (c nasdf-desktop-file)) (values (list (merge-pathnames* (merge-pathnames* (basename (component-name c)) "applications/") *datadir*)) t)) (defmethod output-files ((op compile-op) (c nasdf-appdata-file)) (values (list (merge-pathnames* (merge-pathnames* (basename (component-name c)) "metainfo/") *datadir*)) t)) (defmethod output-files ((op compile-op) (c nasdf-icon-scalable-file)) (values (list (merge-pathnames* (merge-pathnames* (basename (component-name c)) "icons/hicolor/scalable/apps/") *datadir*)) t)) ;; TODO Moving png icons to assets/icons would simplify their handling. (defun scan-last-number (path) "Return the last number found in PATH. Return NIL is there is none." (let ((result (block red (reduce (lambda (&optional next-char result) (if (parse-integer (string next-char) :junk-allowed t) (cons next-char result) (if result (return-from red result) result))) (native-namestring path) :initial-value '() :from-end t)))) (when result (coerce result 'string)))) (defmethod input-files ((op compile-op) (c nasdf-icon-directory)) "Return all files of NASDF-ICON-DIRECTORY `type' in its directory. File must contain a number in their path." (let ((result (remove-if (complement #'scan-last-number) (directory-files (component-pathname c) (strcat "*." (file-type c)))))) (let* ((dimensions (mapcar #'scan-last-number result)) (dups (set-difference dimensions (remove-duplicates dimensions) :test 'string=))) (if (= 0 (length dups)) result (error "Directory contains icons with duplicate dimensions: ~a" dups))))) (defmethod output-files ((op compile-op) (c nasdf-icon-directory)) (let ((name (primary-system-name (component-system c)))) (values (mapcar (lambda (path) (let ((icon-size (scan-last-number path)) ) (format nil "~a/icons/hicolor/~ax~a/apps/~a.png" *datadir* icon-size icon-size name))) (input-files op c)) t))) (defun file-excluded-type (file exclude-types) (member (pathname-type file) exclude-types :test 'equalp)) (defun list-directory (directory &key exclude-subpath (exclude-types '("fasl"))) (let ((result '())) (collect-sub*directories (ensure-directory-pathname directory) (constantly t) (lambda (dir) (notany (lambda (exclusion) (string-suffix-p (basename dir) exclusion)) (mapcar #'basename exclude-subpath))) (lambda (subdirectory) (setf result (append result (remove-if (lambda (file) (file-excluded-type file exclude-types)) (directory-files subdirectory)))))) result)) (export-always 'copy-directory) (defun copy-directory (source destination &key exclude-subpath (exclude-types '("fasl")) verbose-p) ; REVIEW: Unused, but seem quite useful. "Copy the content (the file tree) of SOURCE to DESTINATION." (when verbose-p (logger "copy ~s/* inside ~s." source destination)) (mapc (lambda (file) (unless (member (pathname-type file) exclude-types :test 'equalp) (let ((destination-file (merge-pathnames* (subpathp file (ensure-directory-pathname source)) (ensure-pathname destination :truenamize t :ensure-directory t)))) (install-file file destination-file)))) (list-directory source :exclude-subpath exclude-subpath :exclude-types exclude-types))) (defmethod input-files ((op compile-op) (component nasdf-source-directory)) "Return all files of NASDF-SOURCE-DIRECTORY." (with-current-directory ((system-source-directory (component-system component))) (list-directory (component-pathname component) :exclude-subpath (exclude-subpath component) :exclude-types (exclude-types component)))) (defmethod output-files ((op compile-op) (component nasdf-source-directory)) (let ((root (system-source-directory (component-system component)))) (values (mapcar (lambda (path) (merge-pathnames* (subpathp path root) (dest-source-dir component))) (input-files op component)) t))) (export-always 'nasdf-source-file) (defclass nasdf-source-file (nasdf-file) () (:documentation "Common Lisp source files. Destination directory is given by the `dest-source-dir' generic function.")) (import 'nasdf-source-file :asdf-user) (defmethod dest-source-dir ((component nasdf-source-file)) ; TODO: Factor with other method? "The directory into which the source is installed." (let ((name (primary-system-name (component-system component)))) (ensure-directory-pathname (merge-pathnames* name *dest-source-dir*)))) (defmethod output-files ((op compile-op) (c nasdf-source-file)) (values (list (merge-pathnames* (basename (component-name c)) (dest-source-dir c))) t)) ================================================ FILE: libraries/nasdf/log.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :nasdf) ;; TODO: Use full-fledged logging facility? ;; Maybe we want to keep this dependency-free though... (defvar *log-prefix* "; ") (defun logger (control-string &rest format-arguments) "Like `format' but assumes `*error-output*' as a stream and ensures fresh lines." (let ((*standard-output* *error-output*)) (fresh-line) (princ *log-prefix*) (apply #'format t control-string format-arguments) (fresh-line))) ================================================ FILE: libraries/nasdf/nasdf.asd ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (defsystem "nasdf" :version "0.1.8" :author "Atlas Engineer LLC" :description "ASDF helpers for system setup, testing and installation." :license "BSD 3-Clause" :components ((:file "package") (:file "log") (:file "nasdf") (:file "install") (:file "systems") (:file "tests"))) ================================================ FILE: libraries/nasdf/nasdf.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :nasdf) (defmacro export-always (symbols &optional (package nil package-supplied?)) "Like `export', but also evaluated at compile time." `(eval-when (:compile-toplevel :load-toplevel :execute) (export ,symbols ,@(and package-supplied? (list package))))) (defun env-true-p (env-variable) (let ((value (getenv env-variable))) (or (string-equal "true" value) (string-equal "yes" value) (string-equal "on" value) (string-equal "1" value)))) ================================================ FILE: libraries/nasdf/package.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause #+sb-package-locks (eval-when (:compile-toplevel :load-toplevel :execute) (when (find-package :nasdf) (sb-ext:unlock-package :nasdf))) (uiop:define-package :nasdf (:use #:cl #:uiop #:asdf) (:documentation "ASDF helpers for system setup, testing and installation. A system that installs files: (defsystem \"my-project/install\" :defsystem-depends-on (\"nasdf\") :depends-on (alexandria) :components ((:nasdf-desktop-file \"assets/my-project.desktop\") (:nasdf-icon-directory \"assets/\") (:nasdf-binary-file \"my-project\") (:nasdf-library-file \"libraries/web-extensions/libmy.so\" :if-does-not-exist nil) (:nasdf-source-directory \"source\") (:nasdf-source-directory \"nasdf\") (:nasdf-source-directory \"libraries\" :exclude-subpath (\"web-extensions\") ; Do not install this non-Lisp source. :exclude-types (\"o\" \"c\" \"h\" ; C code and artifacts. \"fasl\")))) A test system: (defsystem \"my-project/tests\" :defsystem-depends-on (\"nasdf\") :class :nasdf-test-system :depends-on (alexandria lisp-unit2) :components ((:file \"tests\")) :test-suite-args (:package :my-project/tests))")) #+sb-package-locks (sb-ext:lock-package :nasdf) ================================================ FILE: libraries/nasdf/readme.org ================================================ #+TITLE: NASDF NASDF is an ASDF extension providing utilities to ease system setup, testing and installation. * Features - Test suite helpers. - Installation helpers such as handling of icons or desktop files. See [[file:package.lisp]] for more details. * Environment variables NASDF exposes the following environment variables for convenience: - =NASDF_SOURCE_PATH= :: See =nasdf:*dest-source-dir*=. - =NASDF_USE_LOGICAL_PATHS= :: Allow non-expanded logical pathnames in system pathnames. This is particularly useful when shipping the source. Disable it if your tooling (e.g. SLIME) encounters issues to find the definition of symbols. See =asdf:nasdf-file=. All boolean environment variables try to be smart enough to understand what you mean; for instance both =on= and =true= are valid values to enable the feature. ================================================ FILE: libraries/nasdf/systems.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :nasdf) (export-always 'nasdf-system) (defclass nasdf-system (system) () (:documentation "Extended ASDF system. It enables features such as: - Togglable logical-pathnames depending on NASDF_USE_LOGICAL_PATHS. - Executable dependencies are made immutable for ASDF to prevent accidental reloads.")) (import 'nasdf-system :asdf-user) (defmethod perform :before ((o image-op) (c nasdf-system)) "Perform some last minute tweaks to the final image. - Register immutable systems to prevent compiled images from trying to recompile the application and its dependencies. See `:*immutable-systems*'. - If on SBCL, include `sb-sprof', the statistical profiler, since it's one of the few modules that's not automatically included in the image." #+sbcl (require :sb-sprof) (map () 'register-immutable-system (already-loaded-systems))) (defun set-new-translation (host logical-directory root-directory &optional (translated-directory (string-downcase (substitute #\/ #\; logical-directory)))) "Add default translations for LOGICAL-DIRECTORY (e.g. \"foo;bar;\") in HOST. Default translations: - FASL files are expanded as usual with `apply-output-translations' (should default to the ASDF cache). - Other files are expanded to their absolute location. This effectively makes the logical pathname behave as if it had been a physical pathname." (let* ((logical-directory (if (string-suffix-p logical-directory ";") logical-directory (strcat logical-directory ";"))) (logical-path (strcat host ":" logical-directory "**;*.*.*")) (logical-fasl-path (strcat host ":" logical-directory "**;*.fasl.*")) (path-translation (ensure-pathname (subpathname* root-directory translated-directory) :ensure-directory t :wilden t)) (fasl-translation (ensure-pathname (apply-output-translations (subpathname* root-directory translated-directory)) :wilden t))) (if (ignore-errors (logical-pathname-translations host)) (flet ((set-alist (key value) (let ((pair (assoc key (logical-pathname-translations host) :key #'namestring :test #'string-equal))) (if pair (setf (rest pair) (list value)) (push (list key value) (logical-pathname-translations host)))))) (set-alist logical-path path-translation) (set-alist logical-fasl-path fasl-translation) ;; Return this for consistency: (list (list logical-fasl-path fasl-translation) (list logical-path path-translation))) (setf (logical-pathname-translations host) ;; WARNING: fasl path must come first as it's more specific. (list (list logical-fasl-path fasl-translation) (list logical-path path-translation)))))) (defun logical-word-or-lose (word) ; From `sb-impl::logical-word-or-lose'. (declare (string word)) (when (string= word "") (error 'namestring-parse-error :complaint "Attempted to treat invalid logical hostname ~ as a logical host:~% ~S" :args (list word) :namestring word :offset 0)) (let ((word (string-upcase word))) (dotimes (i (length word)) (let ((ch (schar word i))) (unless (and (typep ch 'standard-char) (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-))) (error 'namestring-parse-error :complaint "logical namestring character which ~ is not alphanumeric or hyphen:~% ~S" :args (list ch) :namestring word :offset i)))) (coerce word 'string))) (defun parse-logical-pathname (pathname) "Return two values: - the host; - the directory." (let* ((name (namestring pathname)) (pos (position #\: name))) (when pos (let ((host (subseq name 0 (position #\: name)))) (when (ignore-errors (logical-word-or-lose host)) (values host (subseq name (1+ (position #\: name))))))))) (defmethod component-pathname ((system nasdf-system)) "If NASDF_USE_LOGICAL_PATHS environment variable is set, use logical path source location, otherwise use the translated path. Tools such as Emacs (SLIME and SLY) may fail to make use of logical paths, say, to go to the compilation error location." (let ((path (call-next-method))) (when path (let ((final-path (let ((host (parse-logical-pathname path))) (if host (progn (set-new-translation host (subseq (namestring path) (1+ (length host))) (system-source-directory system)) ;; The #p reader macro expands to logical ;; pathnames only if the host is already ;; defined, which may not be the case at this ;; point, so we remake the pathname. (make-pathname :defaults path)) path)))) (if (env-true-p "NASDF_USE_LOGICAL_PATHS") final-path (translate-logical-pathname final-path)))))) (defclass nyxt-renderer-system (system) () (:documentation "Specialized systems for Nyxt with renderer dependency. The renderer is configured from NYXT_RENDERER or `*nyxt-renderer*'.")) (import 'nyxt-renderer-system :asdf-user) (export '*nyxt-renderer*) (defvar *nyxt-renderer* (or (getenv "NYXT_RENDERER") "gi-gtk")) (defmethod component-depends-on ((o prepare-op) (c nyxt-renderer-system)) `((load-op ,(format nil "nyxt/~a-application" *nyxt-renderer*)) ,@(call-next-method))) ================================================ FILE: libraries/nasdf/tests.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :nasdf) (export-always 'nasdf-test-system) (defclass nasdf-test-system (nasdf-system) ((test-suite-args :initform nil :initarg :test-suite-args :reader test-suite-args :documentation "Arguments passed to `lisp-unit2:run-tests'.")) (:documentation "Specialized system that runs `lisp-unit2' test suites, whose parameters are specified by the `test-suite-args' slot.")) (import 'nasdf-test-system :asdf-user) (defmethod perform ((op test-op) (c nasdf-test-system)) (destructuring-bind (&key package tags exclude-tags &allow-other-keys) (test-suite-args c) (let ((output (symbol-call :lisp-unit2 :run-tests :package package :tags tags :run-contexts (find-symbol* :with-summary-context :lisp-unit2))))))) (export-always 'print-benchmark) (defun print-benchmark (benchmark-results) (labels ((rat->float (num) (if (integerp num) num (float num))) (print-times (entry) (let ((title (first entry)) (attr (rest entry))) (unless (or (member (symbol-name title) '("RUN-TIME" "SYSTEM-RUN-TIME")) (and (member (symbol-name title) '("PAGE-FAULTS" "EVAL-CALLS") :test #'string=) (zerop (getf attr :average)))) (format t " ~a: ~,9t~a" (string-downcase title) (rat->float (getf attr :average))) (format t "~32,8t[~a, ~a]" (rat->float (getf attr :minimum)) (rat->float (getf attr :maximum))) (format t "~56,8t(median ~a, deviation ~a, total ~a)" (rat->float (getf attr :median)) (rat->float (getf attr :deviation)) (rat->float (getf attr :total))) (format t "~%"))))) (dolist (mark benchmark-results) (format t "~a (~a sample~:p):~%" (first mark) (getf (rest (second mark)) :samples)) (mapc #'print-times (rest mark))))) ================================================ FILE: libraries/password-manager/package.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (uiop:define-package :password (:use :cl) (:import-from :nclasses #:define-class) (:import-from :serapeum #:export-always)) (eval-when (:compile-toplevel :load-toplevel :execute) (trivial-package-local-nicknames:add-package-local-nickname :sera :serapeum :password)) ================================================ FILE: libraries/password-manager/password-keepassxc.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :password) (define-class keepassxc-interface (password-interface) ((executable (pathname->string (sera:resolve-executable "keepassxc-cli"))) (password-file :documentation "The path to the KeePass password database.") (key-file nil :type (or null string pathname) :documentation "The key file for `password-file'.") (master-password "" :type string :documentation "The password to the `password-file'.") (yubikey-slot nil :documentation "Yubikey slot to unlock the `password-file'.") (entries-cache nil :type list :export nil :documentation "The cache to speed the entry listing up.")) (:export-class-name-p t) (:export-accessor-names-p t)) (push 'keepassxc-interface *interfaces*) (defmethod list-passwords ((password-interface keepassxc-interface)) (or (entries-cache password-interface) (let* ((st (make-string-input-stream (master-password password-interface))) (output (execute password-interface (append (list "ls" "-Rf") ; Recursive flattened. (when (key-file password-interface) (list "-k" (uiop:native-namestring (key-file password-interface)))) (when (yubikey-slot password-interface) (list "-y" (yubikey-slot password-interface))) (list (password-file password-interface))) :input st :output '(:string :stripped t)))) (setf (entries-cache password-interface) (remove-if (alexandria:curry #'str:ends-with-p "/") (sera:lines output)))))) (defmethod clip-password ((password-interface keepassxc-interface) &key password-name service) (declare (ignore service)) (with-input-from-string (st (master-password password-interface)) (execute password-interface (append (list "clip") (when (key-file password-interface) (list "-k" (uiop:native-namestring (key-file password-interface)))) (when (yubikey-slot password-interface) (list "-y" (yubikey-slot password-interface))) (list (password-file password-interface) password-name)) :input st :wait-p nil))) (defmethod clip-username ((password-interface keepassxc-interface) &key password-name service) (declare (ignore service)) (with-input-from-string (st (master-password password-interface)) (execute password-interface (append (list "clip" "--attribute" "username") (when (key-file password-interface) (list "-k" (uiop:native-namestring (key-file password-interface)))) (when (yubikey-slot password-interface) (list "-y" (yubikey-slot password-interface))) (list (password-file password-interface) password-name)) :input st :wait-p nil))) (defmethod save-password ((password-interface keepassxc-interface) &key password-name username password service) (declare (ignore service)) ;; This is to force entries re-fetching the next time we need passwords. (setf (entries-cache password-interface) nil) (with-input-from-string (st (format nil "~a~C~a" (master-password password-interface) #\newline password)) (execute password-interface (append (list "add" "--username" username "--password-prompt" (password-file password-interface)) (when (key-file password-interface) (list "-k" (uiop:native-namestring (key-file password-interface)))) (when (yubikey-slot password-interface) (list "-y" (yubikey-slot password-interface))) (list (if (str:emptyp password-name) "--generate" password-name))) :input st))) (defmethod password-correct-p ((password-interface keepassxc-interface)) (handler-case (list-passwords password-interface) (uiop/run-program:subprocess-error () nil))) ================================================ FILE: libraries/password-manager/password-pass.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :password) (define-class password-store-interface (password-interface) ((executable (pathname->string (sera:resolve-executable "pass"))) (sleep-timer (or (uiop:getenv "PASSWORD_STORE_CLIP_TIME") 45)) (password-directory (or (uiop:getenv "PASSWORD_STORE_DIR") (format nil "~a/.password-store" (uiop:getenv "HOME"))) :type string :reader password-directory)) (:export-class-name-p t) (:export-accessor-names-p t)) (push 'password-store-interface *interfaces*) (defmethod list-passwords ((password-interface password-store-interface)) (let ((directory (uiop:truename* (uiop:parse-native-namestring (password-directory password-interface))))) (when directory ;; Special care must be taken for symlinks. Say `~/.password-store/work` ;; points to `~/work/pass`, would we follow symlinks, we would not be able to ;; truncate `~/.password-store/` in `~/work/pass/some/password.gpg`. Because ;; of this, we don't follow symlinks. (let* ((raw-list (uiop:directory* ;; We truncate the root directory so that the password list ;; resembles the output from `pass list`. To do so, we ;; truncate `~/.password-store/` in the pathname strings of ;; the passwords. (format nil "~a/**/*.gpg" directory))) (dir-length (length (namestring directory)))) (mapcar (lambda (x) (subseq (namestring x) dir-length (- (length (namestring x)) (length ".gpg")))) raw-list))))) (defmethod clip-password ((password-interface password-store-interface) &key password-name service) (declare (ignore service)) (execute password-interface (list "show" "--clip" password-name) ;; Outputting to string blocks `pass'. :output 'nil)) (defvar *multiline-separator* ": *" "A regular expression to separate keys from values in the `pass' multiline format.") (defun parse-multiline (content) "Return an alist of the multiple entries. An entry is a sequence of - a key string, - a colon, - optional spaces, - a value string. This is meant to handle the organization suggestion from http://www.passwordstore.org/#organization. Lines that don't match the format are ignored. The first line (the password) is skipped." (unless (uiop:emptyp content) (let ((lines (str:split (string #\newline) content))) (delete nil (mapcar (lambda (line) (let ((entry (ppcre:split *multiline-separator* line :limit 2))) (when (= 2 (length entry)) entry))) ;; Skip first line to ignore password: (rest lines)))))) (defvar *username-keys* '("login" "user" "username") "A list of string keys used to find the `pass' username in `clip-username'.") (defmethod clip-username ((password-interface password-store-interface) &key password-name service) "Save the multiline entry that's prefixed with on of the `*username-keys*' to clipboard. Case is ignored. The prefix is discarded from the result and returned." (declare (ignore service)) (when password-name (let* ((content (execute password-interface (list "show" password-name) :output '(:string :stripped t))) (entries (parse-multiline content)) (username-entry (when entries (some (lambda (key) (find key entries :test #'string-equal :key #'first)) *username-keys*)))) (when username-entry (trivial-clipboard:text (second username-entry)) (second username-entry))))) (defmethod save-password ((password-interface password-store-interface) &key password-name username password service) (declare (ignore service)) (with-open-stream (st (make-string-input-stream (format nil "~a~%username:~a" password username))) (execute password-interface (list "insert" "--multiline" password-name) :input st)) (when (str:emptyp password) (execute password-interface (list "generate" password-name)))) (defmethod password-correct-p ((password-interface password-store-interface)) t) ================================================ FILE: libraries/password-manager/password-security.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :password) ;;; Provide an interface to the command line "security" program used ;;; on BSD and Darwin systems to interface with the system keychain (define-class security-interface (password-interface) ((executable (pathname->string (sera:resolve-executable "security")))) (:export-class-name-p t) (:export-accessor-names-p t)) (push 'security-interface *interfaces*) (defmethod list-passwords ((password-interface security-interface)) (error "Listing passwords not supported by the 'security' interface.")) (defmethod clip-password ((password-interface security-interface) &key password-name service) (clip-password-string password-interface (str:replace-all "\"" "" (str:replace-first "password: " "" (nth-value 1 (execute password-interface (list "find-internet-password" "-a" password-name "-s" service "-g") :error-output '(:string :stripped t))))))) (defmethod clip-username ((password-interface security-interface) &key password-name service) (declare (ignore password-name service)) (error "Username clipping is not supported by security interface.")) (defmethod password-correct-p ((password-interface security-interface)) t) ================================================ FILE: libraries/password-manager/password.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :password) (define-class password-interface () ((executable nil :type (or null string) :documentation "The program to query for password information.") (sleep-timer 15 :type alexandria:non-negative-real :documentation "The amount of time to sleep, in seconds.")) (:export-class-name-p t) (:export-accessor-names-p t)) (export-always 'list-passwords) (defgeneric list-passwords (password-interface) (:documentation "Retrieve all available passwords.")) (export-always 'clip-password) (defgeneric clip-password (password-interface &key password-name service) (:documentation "Retrieve specific password by name.")) (export-always 'clip-username) (defgeneric clip-username (password-interface &key password-name service) (:documentation "Retrieve specific login by name of the password entry.")) (export-always 'save-password) (defgeneric save-password (password-interface &key password-name username password service) (:documentation "Save password to database. If PASSWORD-NAME is empty, then generate a new password.")) (export-always 'password-correct-p) (defgeneric password-correct-p (password-interface) (:documentation "Return T if set password is correct, NIL otherwise.")) (export-always 'complete-interface) (defgeneric complete-interface (password-interface) (:method ((password-interface password-interface)) password-interface) (:documentation "Return the PASSWORD-INTERFACE with all the misfilled fields corrected.")) (defgeneric execute (interface arguments &rest run-program-args &key wait-p &allow-other-keys) (:method ((interface password-interface) (arguments list) &rest run-program-args &key (wait-p t) &allow-other-keys) (apply (if wait-p #'uiop:run-program #'uiop:launch-program) (append (uiop:ensure-list (executable interface)) arguments) (alexandria:remove-from-plist run-program-args :wait-p))) (:documentation "Execute the command matching the INTERFACE, with ARGS. `uiop:run-program' is used underneath, with RUN-PROGRAM-ARGS being its arguments. When the WAIT-P is NIL, `uiop:launch-program' is used instead of `uiop:run-program'.")) (defun safe-clipboard-text () "Return clipboard content, or \"\" if the content is not textual." ;; xclip errors out when the clipboard contains non-text: ;; https://github.com/astrand/xclip/issues/38#issuecomment-466625564. (ignore-errors (trivial-clipboard:text))) ;;; Prerequisite Functions (defmethod clip-password-string ((password-interface password-interface) pass) (trivial-clipboard:text pass) (bt:make-thread (lambda () (sleep (sleep-timer password-interface)) (when (string= (safe-clipboard-text) pass) ;; Reset the clipboard so that the user does not accidentally paste ;; something else. (trivial-clipboard:text ""))))) ;;; Commands to wrap together. (defun pathname->string (pathname) "Like `namestring' but return NIL if PATHNAME is NIL." (when pathname (namestring pathname))) (export-always '*interfaces*) (defvar *interfaces* '()) ================================================ FILE: libraries/text-buffer/package.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (uiop:define-package :text-buffer (:use :cl) (:export #:text-buffer #:cursor)) ================================================ FILE: libraries/text-buffer/text-buffer.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :text-buffer) (defclass text-buffer (cluffer-simple-line:line) ()) (defclass cursor (cluffer-simple-line::right-sticky-cursor) ((word-separation-characters :accessor word-separation-characters :initform '(":" "/" "." " " " ")))) (defmethod string-representation ((buffer text-buffer)) (with-output-to-string (out) (map nil (lambda (string) (write-string string out)) (cluffer:items buffer)))) (defmethod invisible-string-representation ((buffer text-buffer)) (make-string (cluffer:item-count buffer) :initial-element #\*)) (defmethod safe-forward ((cursor cursor)) (unless (cluffer:end-of-line-p cursor) (cluffer:forward-item cursor) (cluffer:item-before-cursor cursor))) (defmethod safe-backward ((cursor cursor)) (unless (cluffer:beginning-of-line-p cursor) (cluffer:backward-item cursor) (cluffer:item-after-cursor cursor))) (defmethod delete-item-forward ((cursor cursor)) (unless (cluffer:end-of-line-p cursor) (cluffer:delete-item cursor) t)) (defmethod delete-item-backward ((cursor cursor)) (unless (cluffer:beginning-of-line-p cursor) (cluffer:erase-item cursor) t)) (defmethod word-separation-chars-at-cursor-p ((cursor cursor) &key direction) "Return non-nil when `word-separation-characters' are found before/after the cursor position. You can specify to look before or after the cursor by supplying :backward or :forward for the direction value." (find (cond ((and (not (cluffer:beginning-of-line-p cursor)) (eq direction :backward)) (cluffer:item-before-cursor cursor)) ((and (not (cluffer:end-of-line-p cursor)) (eq direction :forward)) (cluffer:item-after-cursor cursor))) (word-separation-characters cursor) :test #'equal)) (defmethod move-to-word ((cursor cursor) &key direction conservative-word-move) "Move the cursor to the boundary of a word and return its position. A word is a string bounded by `word-separation-characters'. Specify a `direction' of :forward or :backward to change the movement." (labels ((move-to-boundary (&key over-non-word-chars) "Move the cursor while it finds `word-separation-characters' adjacent to it. When `over-non-word-chars' is `t' move the cursor otherwise." (loop named movement while (if over-non-word-chars (word-separation-chars-at-cursor-p cursor :direction direction) (not (word-separation-chars-at-cursor-p cursor :direction direction))) unless (if (eq direction :backward) (safe-backward cursor) (safe-forward cursor)) do (return-from movement)))) (if (word-separation-chars-at-cursor-p cursor :direction direction) (progn (move-to-boundary :over-non-word-chars t) (when conservative-word-move (move-to-boundary))) (move-to-boundary))) (cluffer:cursor-position cursor)) (defmethod move-forward-word ((cursor cursor) &key conservative-word-move) (move-to-word cursor :direction :forward :conservative-word-move conservative-word-move)) (defmethod move-backward-word ((cursor cursor) &key conservative-word-move) (move-to-word cursor :direction :backward :conservative-word-move conservative-word-move)) (defmethod delete-word ((cursor cursor) &key direction) "Delete characters until encountering the boundary of a word. Specify a `direction' as :forward or :backward." (let ((start-cursor-position (cluffer:cursor-position cursor)) (end-cursor-position (if (eq direction :backward) (move-backward-word cursor :conservative-word-move t) (move-forward-word cursor :conservative-word-move t)))) (dotimes (i (abs (- start-cursor-position end-cursor-position))) (if (eq direction :backward) (cluffer:delete-item cursor) (cluffer:erase-item cursor))))) (defmethod delete-forward-word ((cursor cursor)) "Delete characters forward until encountering the end of a word." (delete-word cursor :direction :forward)) (defmethod delete-backward-word ((cursor cursor)) "Delete characters backward until encountering the end of a word." (delete-word cursor :direction :backward)) (defmethod kill-forward-line ((cursor cursor)) (loop while (delete-item-forward cursor))) (defmethod insert-string ((cursor cursor) string) (loop for char across string do (cluffer:insert-item cursor (string char)))) (defmethod word-at-cursor ((cursor cursor)) "Return word at cursor. If cursor is between two words, return the first one." (let ((original-cursor-position (cluffer:cursor-position cursor))) (move-backward-word cursor) (let* ((delta (abs (- (cluffer:cursor-position cursor) (move-forward-word cursor)))) (word-at-cursor (reverse (apply #'concatenate 'string (loop repeat delta collect (safe-backward cursor)))))) (setf (cluffer:cursor-position cursor) original-cursor-position) word-at-cursor))) (defmethod replace-word-at-cursor ((cursor cursor) string) (unless (uiop:emptyp (word-at-cursor cursor)) (move-backward-word cursor) (delete-forward-word cursor)) (insert-string cursor string)) (defmethod kill-line ((cursor cursor)) "Kill the complete line." (cluffer:beginning-of-line cursor) (kill-forward-line cursor)) (defun word-start (s position &optional (white-spaces '(#\space #\no-break_space))) "Return the index of the beginning word at POSITION in string S." (apply #'max (mapcar (lambda (char) (let ((pos (position char s :end position :from-end t))) (if pos (1+ pos) 0))) white-spaces))) (defun word-end (s position &optional (white-spaces '(#\space #\no-break_space))) "Return the index of the end of the word at POSITION in string S." (apply #'min (mapcar (lambda (char) (or (position char s :start position) (length s))) white-spaces))) ================================================ FILE: libraries/theme/README.org ================================================ #+TITLE: Theme library for Nyxt #+PROPERTY: :results silent * Overview This general purpose theme library provides the means to customize the colors and fonts of Nyxt's UI. Besides exposing the set of tweakable options, opinionated defaults are provided. Owing to its flexibility, it can be used to theme other projects. ** Palette's rationale The following semantic color groups are defined: - ~background~ :: large surfaces. - ~primary~ :: primary interface elements. - ~secondary~ :: secondary or decorative interface elements. - ~action~ :: focus or call to action. - ~success~ :: successful completion, download, or evaluation. - ~warning~ :: errors, invalid operations, or consequential actions. - ~highlight~ :: eye-catching text highlighting. For each group, 2 variation colors with more and less contrast are defined. These are intended for cases of complex and overlapping interfaces. E.g. ~background+~ and ~background-~. Additionally, a foreground color is defined. E.g. ~on-background~. This rationale is loosely based on [[https://m2.material.io/design/material-theming/implementing-your-theme.html][Google Material Design Guidelines]]. ** Example #+begin_src lisp (defvar my-theme (make-instance 'theme:theme :background-color "#F0F0F0" :primary-color "#595959" :secondary-color "#E6E6E6" :action-color "#5FCFFF" :highlight-color "#FAC090" :success-color "#AEE5BE" :warning-color "#F3B5AF" :font-family "Iosevka" :monospace-font-family "Iosevka") "Example theme. When the values for on-colors are omitted, they're automatically set to either black or white, according to what achieves a better contrast. When the values for color+ and color- are omitted, they fallback on regular color values. Note that not all semantic color groups need to be defined.") ;; Set the theme in Nyxt's config file (define-configuration browser ((theme my-theme))) #+end_src * Defaults We suggest following the WCAG (Web Content Accessibility Guidelines) with respect to contrast ratios. The lowest standard (Level AA) requires a ratio of 4.5:1, while a higher standard (Level AAA) requires 7:1. The target contrast ratios for the default palette are summarized below. - Minus colors (e.g. ~background-~) :: >= 4.5:1 - Regular colors (e.g. ~background~) :: >= 6.5:1 - Plus colors (e.g. ~background+~) :: >= 8.5:1 ** Light theme | Color Name | Value | ~on-*~ Value | Contrast | |---------------+---------+--------------+----------| | ~background+~ | #FFFFFF | #000000 | 21.00 | | ~background~ | #F8F8F8 | #000000 | 19.77 | | ~background-~ | #ECECEC | #000000 | 17.78 | |---------------+---------+--------------+----------| | ~primary+~ | #474747 | #FFFFFF | 9.29 | | ~primary~ | #555555 | #FFFFFF | 7.46 | | ~primary-~ | #686868 | #FFFFFF | 5.57 | |---------------+---------+--------------+----------| | ~secondary+~ | #BFBFBF | #000000 | 11.42 | | ~secondary~ | #A6A6A6 | #000000 | 8.63 | | ~secondary-~ | #909090 | #000000 | 6.58 | |---------------+---------+--------------+----------| | ~action+~ | #72CDFE | #000000 | 11.88 | | ~action~ | #37A8E4 | #000000 | 7.88 | | ~action-~ | #178DCC | #000000 | 5.72 | |---------------+---------+--------------+----------| | ~highlight+~ | #FFFA66 | #000000 | 19.12 | | ~highlight~ | #FCE304 | #000000 | 16.13 | | ~highlight-~ | #FCBA04 | #000000 | 12.16 | |---------------+---------+--------------+----------| | ~success+~ | #71FE7D | #000000 | 16.18 | | ~success~ | #8AEA92 | #000000 | 14.26 | | ~success-~ | #86D58E | #000000 | 11.92 | |---------------+---------+--------------+----------| | ~warning+~ | #88040D | #FFFFFF | 10.14 | | ~warning~ | #AF1923 | #FFFFFF | 7.03 | | ~warning-~ | #D2232E | #FFFFFF | 5.22 | |---------------+---------+--------------+----------| #+TBLFM: $4='(contrast $2 $3);%.2f ** Dark theme | Color Name | Value | ~on-*~ Value | Contrast | |---------------+---------+--------------+----------| | ~background+~ | #000000 | #FFFFFF | 21.00 | | ~background~ | #121212 | #FFFFFF | 18.73 | | ~background-~ | #333333 | #FFFFFF | 12.63 | |---------------+---------+--------------+----------| | ~primary+~ | #EFA671 | #000000 | 10.36 | | ~primary~ | #E48D4E | #000000 | 8.22 | | ~primary-~ | #D7752F | #000000 | 6.47 | |---------------+---------+--------------+----------| | ~secondary+~ | #683008 | #FFFFFF | 10.42 | | ~secondary~ | #844115 | #FFFFFF | 7.64 | | ~secondary-~ | #9F592D | #FFFFFF | 5.33 | |---------------+---------+--------------+----------| | ~action+~ | #481FA2 | #FFFFFF | 10.54 | | ~action~ | #571FD2 | #FFFFFF | 8.29 | | ~action-~ | #763DF2 | #FFFFFF | 5.65 | |---------------+---------+--------------+----------| | ~highlight+~ | #FC83F2 | #000000 | 9.67 | | ~highlight~ | #F46DE8 | #000000 | 8.20 | | ~highlight-~ | #EA43DD | #000000 | 6.35 | |---------------+---------+--------------+----------| | ~success+~ | #87FCDF | #000000 | 17.02 | | ~success~ | #4CFBCF | #000000 | 16.01 | | ~success-~ | #05F4CD | #000000 | 14.83 | |---------------+---------+--------------+----------| | ~warning+~ | #FFD152 | #000000 | 14.49 | | ~warning~ | #FCBA04 | #000000 | 12.16 | | ~warning-~ | #FCA904 | #000000 | 10.82 | |---------------+---------+--------------+----------| #+TBLFM: $4='(contrast $2 $3);%.2f ** Remarks The minus and plus colors, when omitted, are set to the corresponding regular color. ~on-colors~, when omitted, are set to either black or white, depending on which results in a higher contrast ratio with its corresponding ~color~. One might be tempted to think that ~on-colors~ are meant to be used solely for text, but the principle holds more generality, when placing tiny elements over huge surfaces. Take blue and yellow, colors that have a poor contrast ratio. Consider that, (1) you inscribe a blue circle that covers most of the yellow square's surface, and (2) you were to draw a tiny blue cross on the same yellow background. In situation (1), you still properly discern the circle, whereas in (2) you'd struggle to see it. * COMMENT TBLFM Code Auxiliary code to update contrast ratios on the tables shown in this document. Instructions: - Evaluate the cell below; - Run command =org-table-recalculate-buffer-tables=. #+begin_src emacs-lisp (defun contrast (c1 c2) "Measure WCAG contrast ratio between C1 and C2. C1 and C2 are color values written in hexadecimal RGB." (cl-flet ((wcag-formula (hex) (cl-loop for k in '(0.2126 0.7152 0.0722) for x in (color-name-to-rgb hex) sum (* k (if (<= x 0.03928) (/ x 12.92) (expt (/ (+ x 0.055) 1.055) 2.4)))))) (let ((ct (/ (+ (wcag-formula c1) 0.05) (+ (wcag-formula c2) 0.05)))) (max ct (/ ct))))) #+end_src ================================================ FILE: libraries/theme/package.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (uiop:define-package :theme (:use :cl) (:shadow #:warning) (:import-from :serapeum #:export-always) (:import-from :nclasses #:define-class)) ================================================ FILE: libraries/theme/tests/tests.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package cl-user) (uiop:define-package :theme/tests (:use :cl :lisp-unit2) (:import-from :theme)) (in-package :theme/tests) (defvar *theme* (make-instance 'theme:theme :background-color "white" :action-color "#37A8E4") "Dummy theme for testing.") (define-test fallback-colors () (assert-string= "white" (theme:background-color- *theme*)) (assert-string= "white" (theme:background-color+ *theme*)) (assert-string= "black" (theme:on-background-color *theme*)) (assert-false (theme:primary-color+ *theme*)) (assert-false (theme:primary-color *theme*)) (assert-false (theme:primary-color- *theme*)) (assert-false (theme:on-primary-color *theme*))) (define-test css-substitution () (assert-string= "a{background-color:white;color:black;}h1{color:#37A8E4 !important;}" (let ((lass:*pretty* nil)) (theme:themed-css *theme* `(a :background-color ,theme:background-color :color ,theme:on-background-color) `(h1 :color ,theme:action-color "!important"))))) (defmethod assert-contrast ((theme theme:theme) &key (min-color+-contrast 8.5) (min-color-contrast 6.5) (min-color--contrast 4.5)) (macrolet ((assert-contrast-ratio (color1 color2 min-contrast) `(assert-true (>= (theme:contrast-ratio ,color1 ,color2) ,min-contrast)))) (multiple-value-bind (on-colors regular-colors minus-colors plus-colors) (values-list (theme:filter-palette (list (alexandria:curry #'uiop:string-prefix-p "ON-") (alexandria:rcurry #'uiop:string-suffix-p "COLOR") (alexandria:rcurry #'uiop:string-suffix-p "COLOR-") (alexandria:rcurry #'uiop:string-suffix-p "COLOR+")) (theme:palette theme))) (loop for on-color in on-colors for regular-color in regular-colors for minus-color in minus-colors for plus-color in plus-colors do (assert-contrast-ratio (funcall regular-color theme) (funcall on-color theme) min-color-contrast) do (assert-contrast-ratio (funcall plus-color theme) (funcall on-color theme) min-color+-contrast) do (assert-contrast-ratio (funcall minus-color theme) (funcall on-color theme) min-color--contrast))))) (define-test default-light-theme-contrast () (assert-contrast theme:+light-theme+)) (define-test default-dark-theme-contrast () (assert-contrast theme:+dark-theme+)) ================================================ FILE: libraries/theme/theme.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :theme) (define-class theme () ((background-color+ :documentation "More contrasting variation of `background-color'.") (background-color :documentation "The background color of the theme.") (background-color- :documentation "Less contrasting variation of `background-color'.") (on-background-color :documentation "The color for elements/text in front of `background-color'.") (primary-color+ :documentation "More contrasting variation of `primary-color'.") (primary-color :documentation "Primary UI element color.") (primary-color- :documentation "Less contrasting variation of `primary-color'.") (on-primary-color :documentation "The color for elements/text in front of `primary-color'.") (secondary-color+ :documentation "More contrasting variation of `secondary-color'.") (secondary-color :documentation "Secondary UI element color.") (secondary-color- :documentation "Less contrasting variation of `secondary-color'.") (on-secondary-color :documentation "The color for elements/text in front of `secondary-color'.") (action-color+ :documentation "More contrasting variation of `action-color'.") (action-color :documentation "Color for focused and important elements.") (action-color- :documentation "Less contrasting variation of `action-color'.") (on-action-color :documentation "The color for elements/text in front of `action-color'.") (highlight-color+ :documentation "More contrasting variation of `highlight-color'.") (highlight-color :documentation "The color for elements requiring attention.") (highlight-color- :documentation "Less contrasting variation of `highlight-color'.") (on-highlight-color :documentation "The color for elements/text in front of `highlight-color'.") (success-color+ :documentation "More contrasting variation of `success-color'.") (success-color :documentation "The color to express success.") (success-color- :documentation "Less contrasting variation of `success-color'.") (on-success-color :documentation "The color for elements/text in front of `success-color'.") (warning-color+ :documentation "More contrasting variation of `warning-color'.") (warning-color :documentation "The color to express errors.") (warning-color- :documentation "Less contrasting variation of `warning-color'.") (on-warning-color :documentation "The color for elements/text in front of `warning-color'.") (font-family "Public Sans" :documentation "The font family to use by default.") (monospace-font-family "DejaVu Sans Mono" :documentation "The monospace font family to use by default.")) (:export-class-name-p t) (:export-accessor-names-p t) (:export-predicate-name-p t)) (defmethod initialize-instance :after ((theme theme) &key) (multiple-value-bind (on-colors regular-colors minus-colors plus-colors) (values-list (filter-palette (list (alexandria:curry #'uiop:string-prefix-p "ON-") (alexandria:rcurry #'uiop:string-suffix-p "COLOR") (alexandria:rcurry #'uiop:string-suffix-p "COLOR-") (alexandria:rcurry #'uiop:string-suffix-p "COLOR+")) (palette theme))) (loop for on-color in on-colors for regular-color in regular-colors for minus-color in minus-colors for plus-color in plus-colors do (when (and (not (slot-value theme on-color)) (slot-value theme regular-color)) (setf (slot-value theme on-color) (contrasting-color (slot-value theme regular-color)))) do (when (and (not (slot-value theme minus-color)) (slot-value theme regular-color)) (setf (slot-value theme minus-color) (slot-value theme regular-color))) do (when (and (not (slot-value theme plus-color)) (slot-value theme regular-color)) (setf (slot-value theme plus-color) (slot-value theme regular-color)))))) (export-always 'dark-p) (defmethod dark-p ((theme theme)) "Whether the theme is dark." (when (string= "white" (contrasting-color (background-color theme))) t)) (export-always 'palette) (defmethod palette ((theme theme)) "Return color slots of THEME. Example that returns the palette's color values: (mapcar (alexandria:rcurry #'funcall +light-theme+) (palette +light-theme+))" (serapeum:filter (alexandria:curry #'serapeum:string-contains-p "COLOR") (mopu:direct-slot-names theme) :key #'string)) (export-always 'filter-palette) (defun filter-palette (preds palette) "Partition PALETTE according to PREDS." (serapeum:partitions preds palette :key #'string)) (export-always 'with-theme) (defmacro with-theme (theme-instance &body body) "Evaluate BODY with THEME and THEME's slots let-bound." `(let ((theme ,theme-instance)) (with-slots ,(mopu:direct-slot-names 'theme) theme ,@body))) (export-always 'themed-css) (defmacro themed-css (theme &body forms) "Generate CSS via lass FORMS styled according to THEME. Example: (themed-css (make-instance 'theme :background-color \"white\") `(|h1,h2,h3,h4,h5,h6| :border-style \"solid\" :border-color ,theme:on-background-color) `(p :color ,(if (theme:dark-p theme:theme) \"yellow\" \"green\")))" `(with-theme ,theme (lass:compile-and-write ,@forms))) (export-always '+light-theme+) (defvar +light-theme+ (make-instance 'theme :background-color+ "#FFFFFF" :background-color "#F8F8F8" :background-color- "#ECECEC" :primary-color+ "#999999" :primary-color "#686868" :primary-color- "#555555" :secondary-color+ "#BFBFBF" :secondary-color "#A6A6A6" :secondary-color- "#909090" :action-color+ "#72CDFE" :action-color "#37A8E4" :action-color- "#178DCC" :highlight-color+ "#FFFA66" :highlight-color "#FCE304" :highlight-color- "#FCBA04" :success-color+ "#71FE7D" :success-color "#8AEA92" :success-color- "#86D58E" :warning-color+ "#88040D" :warning-color "#AF1923" :warning-color- "#D2232E")) (export-always '+dark-theme+) (defvar +dark-theme+ (make-instance 'theme:theme :background-color- "#3B4252" :background-color "#2E3440" :background-color+ "#434C5E" :on-background-color "#E5E9F0" :primary-color- "#5E81AC" :primary-color "#5E81AC" :primary-color+ "#81A1C1" :on-primary-color "#ECEFF4" :secondary-color- "#4C566A" :secondary-color "#4C566A" :secondary-color+ "#5E81AC" :on-secondary-color "#E5E9F0" :action-color- "#88C0D0" :action-color "#88C0D0" :action-color+ "#81A1C1" :on-action-color "#2E3440" :success-color- "#8FBCBB" :success-color "#8FBCBB" :success-color+ "#81A1C1" :on-success-color "#2E3440" :highlight-color- "#B48EAD" :highlight-color "#B48EAD" :highlight-color+ "#D8DEE9" :on-highlight-color "#2E3440" :warning-color- "#EBCB8B" :warning-color "#EBCB8B" :warning-color+ "#D08770" :on-warning-color "#2E3440")) ================================================ FILE: libraries/theme/utilities.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :theme) (serapeum:-> relative-luminance ((or string integer cl-colors-ng:rgb cl-colors-ng:hsv)) real) (defun relative-luminance (color) "Compute relative luminance of COLOR." ;; See https://www.w3.org/WAI/GL/wiki/Relative_luminance (loop for const in '(0.2126 0.7152 0.0722) for rgb-component in (list (cl-colors-ng:rgb-red (cl-colors-ng:as-rgb color)) (cl-colors-ng:rgb-green (cl-colors-ng:as-rgb color)) (cl-colors-ng:rgb-blue (cl-colors-ng:as-rgb color))) sum (* const (if (<= rgb-component 0.04045) (/ rgb-component 12.92) (expt (/ (+ rgb-component 0.055) 1.055) 2.4))))) (serapeum:-> contrast-ratio ((or string integer cl-colors-ng:rgb cl-colors-ng:hsv) (or string integer cl-colors-ng:rgb cl-colors-ng:hsv)) (real 0 21)) ; Ratio between black and white. (export-always 'contrast-ratio) (defun contrast-ratio (color1 color2) "Compute contrast ratio between COLOR1 and COLOR2." ;; See https://www.w3.org/WAI/GL/wiki/Contrast_ratio (let ((ratio (/ (+ (relative-luminance color1) 0.05) (+ (relative-luminance color2) 0.05)))) (max ratio (/ ratio)))) (serapeum:-> contrasting-color ((or string integer cl-colors-ng:rgb cl-colors-ng:hsv)) string) (export-always 'contrasting-color) (defun contrasting-color (color) "Determine whether black or white best contrasts with COLOR." (if (>= (contrast-ratio color "white") (contrast-ratio color "black")) "white" "black")) ================================================ FILE: libraries/user-interface/package.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (uiop:define-package :user-interface (:use :cl)) ================================================ FILE: libraries/user-interface/user-interface.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :user-interface) ;; Taken from serapeum (defmacro export-always (symbols &optional (package nil package-supplied?)) "Like `export', but also evaluated at compile time." `(eval-when (:compile-toplevel :load-toplevel :execute) (export ,symbols ,@(and package-supplied? (list package))))) (export-always 'id) (defvar *id* 0 "Counter used to generate a unique ID.") (defun unique-id () (format nil "ui-element-~d" (incf *id*))) (defgeneric to-html (object) (:documentation "The HTML representation of OBJECT. A form suitable to be compiled by Spinneret.")) (export-always 'buffer) (defclass ui-element () ((id :accessor id) (buffer :accessor buffer :initarg :buffer :documentation "Buffer where element is drawn."))) (defmethod initialize-instance :after ((element ui-element) &key) (setf (id element) (unique-id))) (export-always 'connect) (defmethod connect ((element ui-element) buffer) (setf (buffer element) buffer)) (export-always 'update) (defgeneric update (ui-element) (:documentation "Propagate changes to the buffer.")) (export-always 'button) (export-always 'text) (export-always 'action) (defclass button (ui-element) ((text :initform "" :initarg :text :accessor text) (alt-text :initform "" :initarg :alt-text :accessor alt-text) (action :initform "" :initarg :action :accessor action))) (defmethod (setf text) :after (text (button button)) (declare (ignorable text)) (when (slot-boundp button 'buffer) (update button))) (defmethod (setf action) :after (action (button button)) (declare (ignorable action)) (when (slot-boundp button 'buffer) (update button))) (defmethod (setf alt-text) :after (text (button button)) (declare (ignorable text)) (when (slot-boundp button 'buffer) (update button))) (export-always 'to-html) (defmethod to-html ((button button)) (spinneret:with-html (:button :id (id button) :class "button" :title (alt-text button) :onclick (action button) (text button)))) (export-always 'paragraph) (defclass paragraph (ui-element) ((text :initform "" :initarg :text :accessor text))) (defmethod (setf text) :after (text (paragraph paragraph)) (declare (ignorable text)) (when (slot-boundp paragraph 'buffer) (update paragraph))) (defmethod to-html ((paragraph paragraph)) (spinneret:with-html (:p :id (id paragraph) (text paragraph)))) (export-always 'progress-bar) (export-always 'percentage) (defclass progress-bar (ui-element) ((percentage :initform 0 :initarg :percentage :accessor percentage :documentation "The percentage the progress bar is filled up, use a number between 0 and 100."))) (defmethod to-html ((progress-bar progress-bar)) (spinneret:with-html (:div :class "progress-bar-base" (:div :class "progress-bar-fill" :id (id progress-bar) ;; empty string to force markup to make closing :div tag "")))) (defmethod (setf percentage) :after (percentage (progress-bar progress-bar)) (declare (ignorable percentage)) (when (slot-boundp progress-bar 'buffer) (update progress-bar))) ================================================ FILE: licenses/ASSET-LICENSE ================================================ All non-source code assets are licensed as CC BY-SA. Creative Commons Deed This is a human-readable summary of the full license below. You are free: to Share— to copy, distribute and transmit the work, and to Remix— to adapt the work for any purpose, even commercially. Under the following conditions: Attribution— You must attribute the work in the manner specified by the author or licensor (but not in any way that suggests that they endorse you or your use of the work.) Share Alike—If you alter, transform, or build upon this work, you may distribute the resulting work only under the same, similar or a compatible license. With the understanding that: Waiver— Any of the above conditions can be waived if you get permission from the copyright holder. Other Rights—In no way are any of the following rights affected by the license: your fair dealing or fair use rights; the author's moral rights; and rights other persons may have either in the work itself or in how the work is used, such as publicity or privacy rights. Notice—For any reuse or distribution, you must make clear to others the license terms of this work. The best way to do that is with a link to https://creativecommons.org/licenses/by-sa/3.0/ ================================================ FILE: licenses/DejaVu Fonts License.txt ================================================ Fonts are (c) Bitstream (see below). DejaVu changes are in public domain. Glyphs imported from Arev fonts are (c) Tavmjong Bah (see below) Bitstream Vera Fonts Copyright ------------------------------ Copyright (c) 2003 by Bitstream, Inc. All Rights Reserved. Bitstream Vera is a trademark of Bitstream, Inc. Permission is hereby granted, free of charge, to any person obtaining a copy of the fonts accompanying this license ("Fonts") and associated documentation files (the "Font Software"), to reproduce and distribute the Font Software, including without limitation the rights to use, copy, merge, publish, distribute, and/or sell copies of the Font Software, and to permit persons to whom the Font Software is furnished to do so, subject to the following conditions: The above copyright and trademark notices and this permission notice shall be included in all copies of one or more of the Font Software typefaces. The Font Software may be modified, altered, or added to, and in particular the designs of glyphs or characters in the Fonts may be modified and additional glyphs or characters may be added to the Fonts, only if the fonts are renamed to names not containing either the words "Bitstream" or the word "Vera". This License becomes null and void to the extent applicable to Fonts or Font Software that has been modified and is distributed under the "Bitstream Vera" names. The Font Software may be sold as part of a larger software package but no copy of one or more of the Font Software typefaces may be sold by itself. THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL BITSTREAM OR THE GNOME FOUNDATION BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM OTHER DEALINGS IN THE FONT SOFTWARE. Except as contained in this notice, the names of Gnome, the Gnome Foundation, and Bitstream Inc., shall not be used in advertising or otherwise to promote the sale, use or other dealings in this Font Software without prior written authorization from the Gnome Foundation or Bitstream Inc., respectively. For further information, contact: fonts at gnome dot org. Arev Fonts Copyright ------------------------------ Copyright (c) 2006 by Tavmjong Bah. All Rights Reserved. Permission is hereby granted, free of charge, to any person obtaining a copy of the fonts accompanying this license ("Fonts") and associated documentation files (the "Font Software"), to reproduce and distribute the modifications to the Bitstream Vera Font Software, including without limitation the rights to use, copy, merge, publish, distribute, and/or sell copies of the Font Software, and to permit persons to whom the Font Software is furnished to do so, subject to the following conditions: The above copyright and trademark notices and this permission notice shall be included in all copies of one or more of the Font Software typefaces. The Font Software may be modified, altered, or added to, and in particular the designs of glyphs or characters in the Fonts may be modified and additional glyphs or characters may be added to the Fonts, only if the fonts are renamed to names not containing either the words "Tavmjong Bah" or the word "Arev". This License becomes null and void to the extent applicable to Fonts or Font Software that has been modified and is distributed under the "Tavmjong Bah Arev" names. The Font Software may be sold as part of a larger software package but no copy of one or more of the Font Software typefaces may be sold by itself. THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL TAVMJONG BAH BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM OTHER DEALINGS IN THE FONT SOFTWARE. Except as contained in this notice, the name of Tavmjong Bah shall not be used in advertising or otherwise to promote the sale, use or other dealings in this Font Software without prior written authorization from Tavmjong Bah. For further information, contact: tavmjong @ free . fr. ================================================ FILE: licenses/SOURCE-LICENSE ================================================ BSD 3-Clause License Copyright (c) 2017-2025, Atlas Engineer LLC. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: makefile ================================================ # SPDX-FileCopyrightText: Atlas Engineer LLC # SPDX-License-Identifier: BSD-3-Clause ## Use Bourne shell syntax. SHELL = /bin/sh UNAME := $(shell uname) LISP ?= sbcl SBCL_FLAGS = ifeq ($(LISP), sbcl) SBCL_FLAGS=--dynamic-space-size $(shell sbcl --noinform --no-userinit --non-interactive --eval '(prin1 (max 3072 (/ (sb-ext:dynamic-space-size) 1024 1024)))' --quit | tail -1) endif LISP_FLAGS ?= $(SBCL_FLAGS) --no-userinit --non-interactive NYXT_SUBMODULES ?= true NYXT_RENDERER ?= electron NASDF_USE_LOGICAL_PATHS ?= true NODE_SETUP ?= true export NYXT_SUBMODULES export NYXT_RENDERER export NASDF_USE_LOGICAL_PATHS export NODE_SETUP .PHONY: help help: @cat INSTALL makefile_dir := $(dir $(abspath $(lastword $(MAKEFILE_LIST)))) ifeq ($(NYXT_SUBMODULES),true) CL_SOURCE_REGISTRY = $(makefile_dir)_build// export CL_SOURCE_REGISTRY endif lisp_eval:=$(LISP) $(LISP_FLAGS) \ --eval '(require "asdf")' \ --eval '(asdf:load-asd "$(makefile_dir)/libraries/nasdf/nasdf.asd")' \ --eval '(asdf:load-asd "$(makefile_dir)/nyxt.asd")' \ --eval lisp_quit:=--eval '(uiop:quit 0 \#+bsd nil)' ## asdf:load-system is a bit slow on :nyxt/$(NYXT_RENDERER)-application, so we ## keep a Make dependency on the Lisp files. lisp_files := nyxt.asd $(shell find . -type f -name '*.lisp') nyxt: $(lisp_files) if [ "$(NYXT_RENDERER)" = "electron" ] && \ [ "$(NODE_SETUP)" = "true" ] && \ [ "$(NYXT_SUBMODULES)" = "true" ]; then \ $(MAKE) -C $(makefile_dir)_build/cl-electron install; \ fi $(lisp_eval) '(asdf:load-system :nyxt/$(NYXT_RENDERER)-application)' \ --eval '(asdf:make :nyxt/$(NYXT_RENDERER)-application)' \ $(lisp_quit) || (printf "\n%s\n%s\n" "Compilation failed, see the above stacktrace." && exit 1) .PHONY: all all: nyxt .PHONY: doc doc: $(lisp_eval) '(asdf:load-system :nyxt)' \ --eval '(asdf:load-system :nyxt/documentation)' $(lisp_quit) .PHONY: check check: $(lisp_eval) '(asdf:test-system :nyxt)' .PHONY: clean clean: rm nyxt ================================================ FILE: nyxt.asd ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause #-asdf3.1 (error "Nyxt requires ASDF 3.1.2") ;; WARNING: We _must_ declare the translation host or else ASDF won't recognize ;; the pathnames as logical-pathnames, thus returning the system directory ;; instead. (setf (logical-pathname-translations "NYXT") nil) (defsystem "nyxt" :defsystem-depends-on ("nasdf") :class :nasdf-system :version "4" ; 4.0.0-pre-release-3 :author "Atlas Engineer LLC" :homepage "https://nyxt-browser.com" :description "Extensible web browser in Common Lisp" :license "BSD 3-Clause" :depends-on (alexandria bordeaux-threads calispel cl-base64 cl-colors-ng cl-gopher cl-json cl-ppcre cl-ppcre-unicode cl-prevalence cl-qrencode cl-tld closer-mop clss dexador enchant flexi-streams iolib iolib/os lass local-time log4cl lparallel nclasses nfiles nhooks njson/cl-json nkeymaps nsymbols/star parenscript phos plump prompter py-configparser quri serapeum spinneret sqlite str trivia trivial-arguments trivial-clipboard trivial-package-local-nicknames trivial-types unix-opts ;; Local systems: nyxt/analysis nyxt/download-manager nyxt/password-manager nyxt/text-buffer nyxt/theme nyxt/user-interface) :pathname #p"NYXT:source;" :components ((:file "utilities") (:file "types") (:file "package" :depends-on ("utilities" "types")) (:module "Utilities" :pathname "" :depends-on ("package") :components ((:file "time") (:file "keyscheme") (:file "conditions") (:file "user-interface"))) (:module "Core" :pathname "" :depends-on ("Utilities") :serial t :components ((:file "renderer") (:file "global") (:file "concurrency") (:file "user-files") (:file "user-classes") (:file "configuration") (:file "parenscript-macro") (:file "message") (:file "command") (:file "renderer-script") (:file "urls") (:file "inspector") (:file "dom") (:file "search-engine") (:file "buffer") (:file "window") (:file "mode") (:file "history") (:file "spinneret-tags") (:file "browser") (:file "foreign-interface") (:file "clipboard") (:file "color") (:file "input") (:file "prompt-buffer") (:file "command-commands") (:file "recent-buffers") (:file "external-editor"))) (:module "Core modes" :pathname "mode" :depends-on ("Core") :components ((:file "input-edit") (:file "buffer-listing") (:file "message") (:file "passthrough") (:file "document" :depends-on ("passthrough")) (:file "hint" :depends-on ("document")) (:file "search-buffer") (:file "spell-check" :depends-on ("document")) (:file "help" :depends-on ("document" "search-buffer")) (:file "history") (:file "keyscheme") (:file "process"))) (:file "describe" :depends-on ("Core modes")) (:module "Prompter modes" :pathname "mode" :depends-on ("describe" "Core modes") :components ((:file "prompt-buffer") (:file "hint-prompt-buffer" :depends-on ("prompt-buffer")) (:file "file-manager" :depends-on ("prompt-buffer")) (:file "download" :depends-on ("file-manager")))) (:file "mode/base" :depends-on ("Core modes")) (:file "status" :depends-on ("Core")) (:module "Help" :pathname "" :depends-on ("Core modes" "Modes") :components ((:file "help") (:file "about") (:file "tutorial"))) (:file "configuration-commands" :depends-on ("Help")) (:file "start" :depends-on ("configuration-commands")) (:file "manual" :depends-on ("configuration-commands")) (:module "Modes" :pathname "mode" :depends-on ("Core modes") :components ((:file "annotate") (:file "autofill") (:file "bookmark") (:file "bookmarklets") (:file "cruise-control" :depends-on ("repeat")) (:file "emacs") (:file "expedition") (:file "history-migration") (:file "macro-edit") (:file "no-sound") (:file "password") (:file "reading-line") (:file "repeat") (:file "small-web") (:file "style" :depends-on ("bookmarklets")) (:file "visual") (:file "vi") (:file "watch")))) :in-order-to ((test-op (test-op "nyxt/tests") ;; Dumping the manual may catch errors. (compile-op "nyxt/documentation") ;; Subsystems: (test-op "nyxt/analysis") (test-op "nyxt/theme")))) (defsystem "nyxt/tests" :defsystem-depends-on ("nasdf") :class :nasdf-test-system :depends-on (nyxt lisp-unit2) :pathname #p"NYXT:tests;" :components ((:file "package") (:file "define-configuration") (:file "prompt-buffer") (:file "urls") (:file "user-script-parsing") (:file "mode") (:module "Modes" :pathname "mode" :components ((:file "autofill") (:file "annotate") (:file "base") (:file "blocker") (:file "bookmark") (:file "bookmarklets") (:file "buffer-listing") (:file "certificate-exception") (:file "cruise-control") (:file "document") (:file "download") (:file "emacs") (:file "expedition") (:file "file-manager") (:file "force-https") (:file "help") (:file "hint-prompt-buffer") (:file "hint") (:file "history") (:file "input-edit") (:file "keyscheme") (:file "macro-edit") (:file "message") (:file "no-image") (:file "no-script") (:file "no-sound") (:file "no-webgl") (:file "passthrough") (:file "password") (:file "process") (:file "prompt-buffer") (:file "proxy") (:file "reading-line") ;; TODO Fix repeat-mode architecture. Visit the file below for ;; more information. ;; (:file "repeat") (:file "search-buffer") (:file "small-web") (:file "spell-check") (:file "style") (:file "vi") ;; TODO Fix visual-mode architecture. Visit the file below for ;; more information. ;; (:file "visual") (:file "user-script") (:file "watch")))) :test-suite-args (:package :nyxt/tests)) (defsystem "nyxt/benchmarks" :defsystem-depends-on ("nasdf") :class :nasdf-system :depends-on (nyxt alexandria trivial-benchmark) :pathname #p"NYXT:tests;benchmarks;" :components ((:file "package") (:file "prompter")) :perform (test-op (op c) (eval-input "(nasdf:print-benchmark (alexandria:hash-table-alist (benchmark:run-package-benchmarks :package :nyxt/benchmarks :verbose t)))"))) (defsystem "nyxt/documentation" :depends-on (nyxt) :perform (compile-op (o c) (with-open-file (out "manual.html" :direction :output :if-exists :supersede) (write-string (symbol-call :nyxt :manual-html) out) (format *error-output* "Manual dumped to ~s.~&" "manual.html")))) (defsystem "nyxt/gtk" :defsystem-depends-on ("nasdf") :class :nasdf-system :depends-on (nyxt cl-webkit2) :pathname #p"NYXT:source;" :components ((:file "renderer/gtk") ;; TODO: Port to other renderers. (:file "mode/blocker") (:file "mode/certificate-exception") (:file "mode/force-https") (:file "mode/user-script") (:file "mode/no-image") (:file "mode/no-script") (:file "mode/no-webgl") (:file "mode/proxy"))) (defsystem "nyxt/gi-gtk" :defsystem-depends-on ("nasdf") :class :nasdf-system :depends-on (nyxt/gtk cl-gobject-introspection) :pathname #p"NYXT:source;renderer;" :components ((:file "gi-gtk")) :in-order-to ((test-op (test-op "nyxt/gi-gtk/tests") (test-op "nyxt/tests") ;; Dumping the manual may catch errors. (compile-op "nyxt/documentation") ;; Subsystems: (test-op "nyxt/analysis") (test-op "nyxt/theme")))) (defsystem "nyxt/gi-gtk/tests" :defsystem-depends-on ("nasdf") :class :nasdf-test-system :depends-on (nyxt/gi-gtk lisp-unit2) :pathname #p"NYXT:tests;renderer;" :serial t :components ((:file "package") (:file "set-url") (:file "custom-schemes") (:file "search-buffer")) :test-suite-args (:package :nyxt/tests/renderer)) (defsystem "nyxt/electron" :depends-on (nyxt cl-electron) :pathname #p"NYXT:source;renderer;" :components ((:file "electron"))) ;; We should not set the build-pathname in systems that have a component. ;; Indeed, when an external program (like Guix) builds components, it needs to ;; know the name of the output. But ASDF/SYSTEM::COMPONENT-BUILD-PATHNAME is ;; non-exported so the only reliable way to know the build pathname is to use ;; the default. ;; ;; The workaround is to set a new dummy system of which the sole purpose is to ;; produce the desired binary. (defsystem "nyxt/gtk-application" :defsystem-depends-on ("nasdf") :class :nasdf-system :depends-on (nyxt/gtk) :build-operation "program-op" :build-pathname "nyxt" :entry-point "nyxt:entry-point") (defsystem "nyxt/gi-gtk-application" :defsystem-depends-on ("nasdf") :class :nasdf-system :depends-on (nyxt/gi-gtk) :build-operation "program-op" :build-pathname "nyxt" :entry-point "nyxt:entry-point") (defsystem "nyxt/electron-application" :defsystem-depends-on ("nasdf") :class :nasdf-system :depends-on (nyxt/electron) :build-operation "program-op" :build-pathname "nyxt" :entry-point "nyxt:entry-point") (defsystem "nyxt/install" :defsystem-depends-on ("nasdf") :class :nyxt-renderer-system :components ((:nasdf-desktop-file "assets/nyxt.desktop") (:nasdf-appdata-file "assets/nyxt.metainfo.xml") (:nasdf-icon-scalable-file "assets/glyphs/nyxt.svg") (:nasdf-icon-directory "assets/") (:nasdf-binary-file "nyxt") (:nasdf-source-file "nyxt.asd") (:nasdf-source-directory "source") (:nasdf-source-directory "nasdf") (:nasdf-source-directory "libraries" :exclude-types ("o" "c" "h" ; C code and artifacts. "fasl")))) ;; Library subsystems: (defsystem "nyxt/download-manager" :defsystem-depends-on ("nasdf") :class :nasdf-system :depends-on (calispel cl-ppcre dexador log4cl quri str) :pathname #p"NYXT:libraries;download-manager;" :components ((:file "package") (:file "engine") (:file "native"))) (defsystem "nyxt/analysis" :defsystem-depends-on ("nasdf") :class :nasdf-system :depends-on (alexandria cl-ppcre serapeum str) :pathname #p"NYXT:libraries;analysis;" :components ((:file "package") (:file "composite-sequence") (:file "data") (:file "stem") (:file "tokenize") (:file "analysis") (:file "document-vector") (:file "text-rank") (:file "dbscan") (:file "section")) :in-order-to ((test-op (test-op "nyxt/analysis/tests")))) (defsystem "nyxt/analysis/tests" :defsystem-depends-on ("nasdf") :class :nasdf-test-system :depends-on (nyxt/analysis lisp-unit2) :pathname #p"NYXT:libraries;analysis;tests;" :components ((:file "tests")) :test-suite-args (:package :analysis/tests)) (defsystem "nyxt/user-interface" :defsystem-depends-on ("nasdf") :class :nasdf-system :depends-on (spinneret) :pathname #p"NYXT:libraries;user-interface;" :components ((:file "package") (:file "user-interface"))) (defsystem "nyxt/text-buffer" :defsystem-depends-on ("nasdf") :class :nasdf-system :depends-on (cluffer) :pathname #p"NYXT:libraries;text-buffer;" :components ((:file "package") (:file "text-buffer"))) (defsystem "nyxt/password-manager" :defsystem-depends-on ("nasdf") :class :nasdf-system :depends-on (bordeaux-threads cl-ppcre nclasses serapeum str trivial-clipboard uiop) :pathname #p"NYXT:libraries;password-manager;" :components ((:file "package") (:file "password") (:file "password-keepassxc") (:file "password-security") ;; Keep password-pass as to ensure higher priority. (:file "password-pass"))) (defsystem "nyxt/theme" :defsystem-depends-on ("nasdf") :class :nasdf-system :depends-on (alexandria cl-colors-ng lass nclasses serapeum) :pathname #p"NYXT:libraries;theme;" :components ((:file "package") (:file "utilities") (:file "theme")) :in-order-to ((test-op (test-op "nyxt/theme/tests")))) (defsystem "nyxt/theme/tests" :defsystem-depends-on ("nasdf") :class :nasdf-test-system :depends-on (nyxt/theme lisp-unit2) :pathname #p"NYXT:libraries;theme;tests;" :components ((:file "tests")) :test-suite-args (:package :theme/tests)) ================================================ FILE: source/about.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :nyxt) (define-internal-page-command-global about () (buffer "*About*") "Show the list of contributors." (spinneret:with-html-string (:nstyle (style buffer)) (:h1 "Contributors") (:ul (:li "Adom Hartell (@4t0m)") (:li "André A. Gomes (@aadcg)") (:li "Artyom Bologov (@aartaka)") (:li "John Mercouris (@jmercouris)") (:li "@hendursaga") (:li "@kssytsrk") (:li "Pedro Delfino (@pdelfino)") (:li "Pierre Neidhardt (@ambrevar)") (:li "Solomon Bloch (@noogie13)") (:li "Vincent Dardel (@vindarel)")) (:h1 "Supporters") (:p "Many thanks to all of our backers who've supported Nyxt development.") (:p "Thank you to NLnet for supporting Nyxt!") (:h1 "Crowdfunding backers") (:p "Thank you to all who have supported and made Nyxt possible!") (:h2 "2018-11 campaign: *NIX Support") (:h3 "Digital Omnipresence") (:ul (:li "Alexander.Shendi") (:li "Ashish SHUKLA") (:li "Christopher Nascone") (:li "dan.girsh") (:li "Eric Monson") (:li "Jack Randall") (:li "James Anderson") (:li "liweitian") (:li "Marco Heisig") (:li "Oluwafemi Agbabiaka") (:li "pjb") (:li "Robert Krahn") (:li "Robert Uhl") (:li "1 anonymous")) (:h3 "Digital Magma") (:ul (:li "Daniel V") (:li "Jason Hamilton") (:li "Magnus Nyberg") (:li "Marek Kochanowicz") (:li "Rich Smith") (:li "Robert Uhl") (:li "simon") (:li "slade") (:li "Steve Last") (:li "ulf.makestad") (:li "1 anonymous")) (:h3 "Digital Immortality") (:ul (:li "Alexey Abramov") (:li "Are Jensen") (:li "Joseph Mingrone") (:li "Nikita Poliakov") (:li "pjb") (:li "Sainath Adapa") (:li "Spencer Heywood") (:li "Sungjin Chun") (:li "Tom Delord") (:li "2 anonymous")) (:h3 "Others") (:ul (:li "Nicholas Zivkovic") (:li "Pierre Neidhardt") (:li "Simon Zugmeyer") (:li "vindarel") (:li "5 anonymous")) (:h2 "2019-10 campaign: v1.4.0") (:h3 "Digital Immortality") (:ul (:li "Tim Johann") (:li "Julien Rousé") (:li "ebababi") (:li "Emil Oppeln-Bronikowski") (:li "Fox Kiester") (:li "Stefan Husmann") (:li "Nils Grunwald") (:li "Florian Adamsky") (:li "Valentin Atanasov") (:li "Pranav Vats") (:li "Jörn Gersdorf") (:li "Matt Skinner") (:li "Jelle Dirk Licht") (:li "Minori Yamashita") (:li "Hugh Daschbach") (:li "Niklas Carlsson") (:li "mestelan") (:li "Camille Troillard") (:li "mace nicolas") (:li "dan.girsh") (:li "Michael Bruderer") (:li "Patrice Rault") (:li "Cees de Groot") (:li "Sam Hedin") (:li "rbarzic") (:li "Jake Waksbaum") (:li "Lukas Jenks") (:li "Rodrigo Lazo") (:li "Lucas Sifoni") (:li "Calle Helmertz") (:li "Kristian Nygaard Jensen") (:li "Robert Uhl") (:li "Francis Burstall") (:li "Arnaud BEAUD'HUIN") (:li "Daniel V") (:li "Albin Heimerson") (:li "Alexander ter Weele") (:li "Jeremy Firth") (:li "aim") (:li "liweitian") (:li "Philipe Dallaire") (:li "Travis Brown") (:li "Divan Santana") (:li "John C Haprian") (:li "Pierrick Maillard") (:li "Dardel Renaud") (:li "Dardel Renaud") (:li "Nils Grunwald") (:li "hector") (:li "Jean Morel") (:li "Jos van Bakel") (:li "slade") (:li "dietrich ayala") (:li "bacon totem") (:li "Pierre Neidhardt") (:li "18 anonymous")))) ================================================ FILE: source/browser.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :nyxt) (hooks:define-hook-type prompt-buffer (function (prompt-buffer)) "Hook acting on `prompt-buffer'.") (hooks:define-hook-type resource (function (request-data) (or request-data null)) "Hook acting on `request-data' resource. Returns: - Possibly modified `request-data'---redirect/block request. - NIL---block request.") (hooks:define-hook-type browser (function (browser)) "Hook acting on `browser' (likely `*browser*').") (export-always '(hook-resource)) (define-class proxy () ((url (quri:uri "socks5://127.0.0.1:9050") :documentation "The address of the proxy server. It's made of three components: protocol, host and port. Example: \"http://192.168.1.254:8080\".") (allowlist '("localhost" "localhost:8080") :type (list-of string) :documentation "A list of URIs not to forward to the proxy.") (proxied-downloads-p t :documentation "Non-nil if downloads should also use the proxy.")) (:export-class-name-p t) (:export-accessor-names-p t) (:documentation "Enable forwarding of all network requests to a specific host. This can apply to specific buffer.")) (export-always 'combine-composed-hook-until-nil) (defmethod combine-composed-hook-until-nil ((hook hooks:hook) &optional arg) "Return the composition of the HOOK handlers on ARG, from oldest to youngest. Stop processing when a handler returns nil. Without handlers, return ARG. This is an acceptable `hooks:combination' for `hooks:hook'." (labels ((compose-handlers (handlers result) (if handlers (let ((new-result (funcall (first handlers) result))) (log:debug "Handler (~a ~a): ~a" (first handlers) result new-result) (when new-result (compose-handlers (rest handlers) new-result))) result))) (compose-handlers (mapcar #'hooks:fn (hooks:handlers hook)) arg))) (export-always 'renderer-browser) (defclass renderer-browser () () (:metaclass interface-class) (:documentation "Renderer-specific representation for the global browser. Should be redefined by the renderer.")) (define-class browser (renderer-browser) ((search-engines (mapcar #'make-instance '(ddg-search-engine wikipedia-search-engine)) :type (cons search-engine *) :documentation "A list of `search-engine' objects. The first one is the default, as per `default-search-engine'.") (search-engine-suggestions-p t :type boolean :documentation "Whether search suggestions are displayed.") (remote-execution-p nil :type boolean :documentation "Whether code sent to the socket gets executed. You must understand the risks before enabling this: a privileged user with access to your system can then take control of the browser and execute arbitrary code under your user profile.") (exit-code 0 :type alex:non-negative-integer :reader t :export t :documentation "The exit code return to the operating system. 0 means success. Non-zero means failure.") (socket-thread nil :type t :documentation "Thread that listens on socket. See `*socket-file*'. This slot is mostly meant to clean up the thread if necessary.") (messages-content '() :export t :reader messages-content :documentation "A list of all echoed messages. Most recent messages are first.") (clipboard-ring (make-ring) :documentation "The ring with all the clipboard contents Nyxt could cache. Note that it may be incomplete.") (command-model (make-instance 'analysis:sequence-model) :documentation "This model is used to generate predictions for what the user will do. Which commands will they invoke next?") (last-command nil :type (maybe function) :documentation "The last command invoked by the user.") (command-dispatcher #'dispatch-command :type (or sym:function-symbol function) :documentation "Function to process the command processed in `dispatch-input-event'. Takes the function/command as the only argument.") (prompt-buffer-generic-history (make-ring) :documentation "The default history of all prompt buffer entries. This history is used if no history is specified for a given prompt buffer.") (default-new-buffer-url (quri:uri (nyxt-url 'new)) :type url-designator :documentation "The URL set to a new blank buffer opened by Nyxt.") (set-url-history (make-ring) :documentation "A ring that keeps track of all URLs set by `set-url'.") (recent-buffers (make-ring :size 50) :export nil :documentation "A ring that keeps track of deleted buffers.") (windows (make-hash-table) :export nil :documentation "Table of all windows, indexed by their `id'.") (last-active-window nil :type (or window null) :export nil :documentation "Records the last active window. This is useful when no Nyxt window is focused and we still want `ffi-window-active' to return something. See `current-window' for the user-facing function.") (buffers :initform (make-hash-table) :documentation "Table of all live buffers, indexed by their `id'. See `buffer-list', `buffer-get', `buffer-set' and `buffer-delete'.") (startup-error-reporter-function nil :type (or function null) :export nil :documentation "When supplied, upon startup, if there are errors, they will be reported by this function.") (open-external-link-in-new-window-p nil :documentation "Whether to open links issued by an external program or issued by Control+ in a new window.") (downloads :documentation "List of downloads. Used for rendering by the download manager.") (startup-timestamp (time:now) :export nil :documentation "`time:timestamp' of when Nyxt was started.") (startup-promise (lpara:promise) :export nil :accessor nil :documentation "Promise used to make `start-browser' synchronous. Without it, `start-browser' would return before the `*browser*' is effectively usable. Implementation detail.") (init-time 0.0 :type alex:non-negative-real :export nil :documentation "Initialization time in seconds.") (ready-p nil :reader ready-p :documentation "If non-nil, the browser is ready for operation (make buffers, load data files, open prompt buffer, etc).") (native-dialogs t :type boolean :documentation "Whether to replace renderer specific dialog boxes with the prompt buffer.") (theme theme:+light-theme+ :type theme:theme :documentation "The theme to use for all the browser interface elements.") (glyph-logo (gethash "nyxt.svg" *static-data*) :documentation "The logo of Nyxt as an SVG.") (history-file (make-instance 'history-file) :type history-file :documentation "A file to persist history data across sessions.") (history-vector (make-array 0 :fill-pointer t :adjustable t) :type vector :documentation "A vector holding `history-entry' objects.") (default-cookie-policy :no-third-party :type cookie-policy :documentation "Cookie policy of new buffers. Valid values are `:accept', `:never' and `:no-third-party'.") ;; Hooks follow: (after-init-hook (make-instance 'hook-browser) :documentation "The entry-point hook to configure everything in Nyxt. The hook takes browser as the argument. This hook is run after the `*browser*' is instantiated and before the `startup' is run. A handler can be added with: \(define-configuration browser (after-init-hook (hooks:add-hook %slot-value% 'my-init-handler)))") (after-startup-hook (make-instance 'hook-browser) :documentation "Hook run when the browser is started and ready for interaction. The handlers take browser as the argument. A handler can be added with: \(define-configuration browser (after-startup-hook (hooks:add-hook %slot-value% 'my-startup-handler)))") (before-exit-hook (make-instance 'hooks:hook-void) :type hooks:hook-void :documentation "Hook run before both `*browser*' and the renderer get terminated. The handlers take no argument.") (window-make-hook (make-instance 'hook-window) :type hook-window :documentation "Hook run after `window-make'. The handlers take the window as argument.") (buffer-make-hook (make-instance 'hook-buffer) :type hook-buffer :documentation "Hook run after `buffer' initialization and before the URL is loaded. It is run before mode initialization so that the default mode list can still be altered from the hooks. The handlers take the buffer as argument.") (buffer-before-make-hook (make-instance 'hook-buffer) :type hook-buffer :documentation "Hook run at the beginning of `buffer' initialization. The buffer web view is not allocated, so it's not possible to run arbitrary parenscript from this hook. See `buffer-make-hook' and `buffer-after-make-hook' for other hook options. The handlers take the buffer as argument.") (buffer-after-make-hook (make-instance 'hook-buffer) :type hook-buffer :documentation "Hook run after `buffer' initialization and before the URL is loaded. It is run as the very last step of buffer initialization, when everything else is ready. See also `buffer-make-hook' and `buffer-before-make-hook'. The handlers take the buffer as argument.") (prompt-buffer-make-hook (make-instance 'hook-prompt-buffer) :type hook-prompt-buffer :documentation "Hook run after the `prompt-buffer' class is instantiated and before initializing the `prompt-buffer' modes. The handlers take the `prompt-buffer' as argument.") (prompt-buffer-ready-hook (make-instance 'hook-prompt-buffer) :type hook-prompt-buffer :documentation "Hook run while waiting for the prompt buffer to be available. The handlers take the `prompt-buffer' as argument.") (external-editor-program (or (uiop:getenvp "VISUAL") (uiop:getenvp "EDITOR") (when (sera:resolve-executable "gio") "gio open")) :type (or string null) :reader nil :writer t :export t :documentation "The external editor to use for editing files. The full command, including its arguments, may be specified as list of strings or as a single string.")) (:export-class-name-p t) (:export-accessor-names-p t) (:documentation "The browser class defines the overall behavior of Nyxt, in the sense that it manages the display of buffers. For instance, it abstracts the renderer, and lays the foundations to track and manipulate buffers and windows. A typical Nyxt session encompasses a single instance of this class, but nothing prevents otherwise.") (:metaclass user-class)) (export-always 'recent-history-entries) (defmethod recent-history-entries (n (browser browser) &key deduplicate-p) "Return the N most recent browsing history entries as a list. When DEDUPLICATE-P is non-nil, remove duplicated entries." (nreverse (coerce (let ((recent-entries (sera:slice (history-vector browser) (- n)))) (if deduplicate-p (remove-duplicates recent-entries :test #'equals) recent-entries)) 'list))) (defmethod theme ((ignored (eql nil))) "Fallback theme in case `*browser*' is NIL." (declare (ignore ignored)) theme:+light-theme+) (defmethod external-editor-program ((browser browser)) "Specialized reader for `external-editor-program' slot. A list of strings is returned, as to comply with `uiop:launch-program' or `uiop:run-program'." (with-slots ((cmd external-editor-program)) browser (if (str:blank? cmd) (progn (echo-warning "Invalid value of `external-editor-program' browser slot.") nil) (str:split " " cmd :omit-nulls t)))) (defmethod default-search-engine ((browser browser)) (first (search-engines browser))) (defmacro on-renderer-ready (thread-name &body body) "Run BODY from a new thread when renderer is ready. `ffi-within-renderer-thread' runs its body on the renderer thread when it's idle, so it should do the job." `(ffi-within-renderer-thread (lambda () (run-thread ,thread-name ,@body)))) (defmethod finalize-startup ((browser browser) urls startup-timestamp) "Run `after-init-hook' then BROWSER's `startup'." ;; `messages-appender' requires `*browser*' to be initialized. (unless (find-if (sera:eqs 'messages-appender) (log4cl:all-appenders) :key #'sera:class-name-of) (log4cl:add-appender log4cl:*root-logger* (make-instance 'messages-appender))) (ignore-errors (handler-bind ((error (lambda (c) (log:error "In after-init-hook: ~a" c)))) (hooks:run-hook (after-init-hook browser) browser))) ; TODO: Run outside the main loop? ;; `startup' must be run _after_ this function returns; It's not enough since ;; the `startup' may invoke the prompt buffer, which cannot be invoked from ;; the renderer thread: this is why we run the `startup' in a new thread from ;; there. (on-renderer-ready "finalize-startup" (window-make browser) (let ((history-file-contents (files:content (history-file browser)))) (setf (history-vector browser) (make-array (length history-file-contents) :fill-pointer t :adjustable t :initial-contents history-file-contents))) (open-urls (or urls (list (default-new-buffer-url browser)))) (lpara:fulfill (slot-value browser 'startup-promise)) (hooks:run-hook (after-startup-hook browser) browser) (funcall* (startup-error-reporter-function browser))) ;; Set `init-time' at the end of finalize to take the complete startup time ;; into account. (setf (slot-value *browser* 'init-time) (time:timestamp-difference (time:now) startup-timestamp)) (setf (slot-value *browser* 'ready-p) t)) ;; Catch a common case for a better error message. (defmethod buffers :before ((browser t)) (when (null browser) (error "There is no current *browser*. Is Nyxt started?"))) (-> set-window-title (&optional window) *) (export-always 'set-window-title) (defun set-window-title (&optional (window (current-window))) "Set WINDOW title." (setf (ffi-window-title window) (titler window))) (-> open-urls ((maybe (cons quri:uri *))) *) (defun open-urls (urls) "Create new buffers and load URLS. The buffer corresponding to the first URL is focused." (with-protect ("Could not make buffer to open ~a: ~a" urls :condition) (let ((first-buffer (first (mapcar (lambda (url) (make-buffer :url url)) urls)))) (when first-buffer (if (open-external-link-in-new-window-p *browser*) (ffi-window-set-buffer (window-make *browser*) first-buffer) (set-current-buffer first-buffer)))))) (defun get-keymap (buffer buffer-keyscheme-map) "Return the keymap in BUFFER-KEYSCHEME-MAP corresponding to BUFFER's `keyscheme'. If none is found, fall back to `keyscheme:cua'." (keymaps:get-keymap (or (keyscheme buffer) keyscheme:cua) buffer-keyscheme-map)) (defun request-resource-open-url (&key url &allow-other-keys) (make-buffer :url url)) (defun request-resource-open-url-focus (&key url &allow-other-keys) (make-buffer-focus :url url)) (export-always 'renderer-request-data) (defclass renderer-request-data () () (:metaclass interface-class) (:documentation "Renderer-specific request object. Should be redefined by the renderer.")) (define-class request-data (renderer-request-data) ((buffer (current-buffer) :type buffer :documentation "Buffer targeted by the request.") (url (quri:uri "") :documentation "URL of the request") (event-type :other :accessor nil ; TODO: No public accessor for now, we first need a use case. :export nil :documentation "The type of request, e.g. `:link-click'.") (new-window-p nil :documentation "Whether the request takes place in a new window.") (http-method nil :type (maybe string) :documentation "The HTTP method (GET, POST and friends) of the request.") (request-headers nil :type trivial-types:association-list :documentation "Dotted alist of headers for the request.") (response-headers nil :type trivial-types:association-list :documentation "Dotted alist of headers for the response to the given request.") (toplevel-p nil :documentation "Whether the request happens in a toplevel frame.") (resource-p nil :documentation "Whether the request is a resource request. Resource requests cannot be redirected or blocked.") (mime-type nil :type (maybe string) :documentation "The MIME type of the resource at the other end of the request.") (known-type-p nil :documentation "Whether the request is for content with supported MIME-type, such as a picture that can be displayed in the web view.") (file-name nil :type (maybe string) :documentation "The name this file will be saved on disk with, if downloaded.") (keys '() :type list :documentation "The key sequence that generated the request.")) (:export-class-name-p t) (:export-accessor-names-p t) (:documentation "Representation of HTTP(S) request. Most important slots are: - `buffer' request belongs to. - `url' requested. - `request-headers'/`response-headers' for headers it's requested with. - and `toplevel-p'/`resource-p' for whether it's a new page or resource request (respectively).")) (export-always 'url-dispatching-handler) (-> url-dispatching-handler (symbol (function (quri:uri) boolean) (or string (function (quri:uri) (or quri:uri null)))) *) (defun url-dispatching-handler (name test action) "Return a `hook-request' handler apply its ACTION on the URLs conforming to TEST. Fit for `request-resource-hook'. TEST should be function of one argument, the requested URL. ACTION can be either - a shell command as a string, - or a function taking a URL as argument. In case ACTION returns nil (always the case for shell command), URL request is aborted. If ACTION returns a URL, it's loaded. `match-host', `match-scheme', `match-domain' and `match-file-extension' can be used to create TEST-functions, but any other function of one argument would fit the TEST slot as well. The following example does a few things: - Forward DOI links to the doi.org website. - Open magnet links with Transmission. - Open local files (file:// URIs) with Emacs. \(define-configuration web-buffer (request-resource-hook (hooks:add-hook %slot-value% (url-dispatching-handler 'doi-link-dispatcher (match-scheme \"doi\") (lambda (url) (quri:uri (format nil \"https://doi.org/~a\" (quri:uri-path url)))))))) \(defmethod customize-instance ((buffer web-buffer)) (hooks:add-hook (request-resource-hook buffer) (url-dispatching-handler 'transmission-magnet-links (match-scheme \"magnet\") \"transmission-remote --add ~a\")) (hooks:add-hook (request-resource-hook buffer) (url-dispatching-handler 'emacs-file (match-scheme \"file\") (lambda (url) (uiop:launch-program `(\"emacs\" ,(quri:uri-path url))) nil))))" (make-instance 'hooks:handler :fn (lambda (request-data) (let ((url (url request-data))) (if (funcall test url) (etypecase action (function (let* ((new-url (funcall action url))) (log:info "Applied ~s URL-dispatcher on ~s and got ~s" (symbol-name name) (render-url url) (when new-url (render-url new-url))) (when new-url (setf (url request-data) new-url) request-data))) (string (let ((action (lambda (url) (uiop:launch-program (format nil action (render-url url))) nil))) (funcall action url) (log:info "Applied ~s shell-command URL-dispatcher on ~s" (symbol-name name) (render-url url))))) request-data))) :name name)) (defun javascript-error-handler (condition) (echo-warning "JavaScript error: ~a" condition)) (defun print-message (html-body &optional (window (current-window))) (ffi-print-message (message-buffer window) html-body)) (export-always 'current-window) (defun current-window (&optional no-rescan) "Return the current window. If NO-RESCAN is non-nil, fetch the window from the `last-active-window' cache instead of asking the renderer for the active window. It is faster but may yield the wrong result." (when *browser* (if (and no-rescan (slot-value *browser* 'last-active-window)) (slot-value *browser* 'last-active-window) ;; No window when browser is not started. (ignore-errors (ffi-window-active *browser*))))) (export-always 'set-current-buffer) (defmethod set-current-buffer ((buffer modable-buffer) &key (focus t)) "Set the active BUFFER for the active window. Return BUFFER." (cond ((not (current-window)) (make-window buffer)) ((and (active-buffer-p buffer) (not (eq (current-window) (window buffer)))) (ffi-window-set-buffer (window buffer) (get-inactive-buffer) :focus nil) (ffi-window-set-buffer (current-window) buffer :focus focus)) ((and (not (active-buffer-p buffer)) (not (eq (current-window) (window buffer)))) (ffi-window-set-buffer (current-window) buffer :focus focus)) (t nil)) buffer) (export-always 'current-prompt-buffer) (defun current-prompt-buffer () "Return the current prompt-buffer." (first (active-prompt-buffers (current-window)))) (export-always 'focused-buffer) (defun focused-buffer (&optional (window (current-window)) ) "Return the currently focused buffer." (find-if #'ffi-focused-p (list (first (active-prompt-buffers window)) (active-buffer window) (status-buffer window) (message-buffer window)))) (define-internal-page-command-global reduce-to-buffer (&key (delete t)) (reduced-buffer "*Reduced Buffers*") "Query the buffer(s) to \"reduce \" by copying their titles/URLs to a single buffer, optionally delete them. This function is useful for archiving a set of useful URLs or preparing a list to send to a someone else." (let ((buffers (prompt :prompt "Reduce buffer(s)" :sources (make-instance 'buffer-source :constructor (remove-if #'internal-url-p (buffer-list) :key #'url) :actions-on-return #'identity :enable-marks-p t)))) (unwind-protect (spinneret:with-html-string (:h1 "Reduced Buffers:") (:div (if buffers (loop for buffer in buffers collect (with-current-buffer buffer (:div (:p (:b "Title: ") (title buffer)) (:p (:b "URL: ") (:a :href (render-url (url buffer)) (render-url (url buffer)))) (:p (:b "Automatically generated summary: ") (:ul (loop for summary-bullet in (analysis:summarize-text (document-get-paragraph-contents :limit 10000)) collect (:li (str:collapse-whitespaces summary-bullet))))) (:hr "")))) (:p "None chosen.")))) (when delete (mapcar #'buffer-delete buffers))))) (export-always 'render-menu) (defun render-menu (mode-symbol &optional (buffer (current-buffer))) "Render a menu for a given mode symbol." (spinneret:with-html (:div :class "mode-menu" (loop for command in (list-mode-commands mode-symbol) collect (let ((name (string-downcase (closer-mop:generic-function-name command))) (bindings (keymaps:pretty-binding-keys (name command) (current-keymaps buffer) :print-style (keymaps:name (keyscheme buffer))))) (:nbutton :class "button binding" :text (if bindings (first bindings) "⏎") `(nyxt::run-async ,command)) (:nbutton :class "button command" :text name `(nyxt::run-async ,command))))))) ================================================ FILE: source/buffer.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :nyxt) (hooks:define-hook-type keymaps-buffer (function ((list-of keymaps:keymap) buffer) (values &optional (list-of keymaps:keymap) buffer)) "Hook to modify keymaps. Get a list of `nkeymaps:keymap's and `buffer' and return a new list and buffer.") (export-always '(hook-keymaps-buffer)) (hooks:define-hook-type url->url (function (quri:uri) quri:uri) "Hook getting a `quri:uri' and returning same/another one. ") (export-always 'renderer-buffer) (defclass renderer-buffer () () (:metaclass interface-class) (:documentation "Renderer-specific buffer objects. Should be redefined by the renderer.")) (defvar %default-modes '(base-mode) "The default modes for unspecialized buffers. This is useful when there is no current buffer.") (define-class buffer (renderer-buffer) ((default-modes %default-modes :accessor nil :type (list-of symbol) :documentation "The symbols of the modes to instantiate on buffer creation. The mode instances are stored in the `modes' BUFFER slot. The default modes returned by this method are appended to the default modes inherited from the superclasses.") (id (new-id) :type unsigned-byte :documentation "Unique identifier for a buffer.") (key-stack '() :documentation "A stack of the key chords a user has pressed.") (last-access (time:now) :export nil :documentation "Timestamp when the buffer was last switched to.") (last-key nil :export nil :type (or null keymaps:key) :documentation "Last pressed key.") (url (quri:uri "")) (url-at-point (quri:uri "")) (title "") (style (theme:themed-css (theme *browser*) '(:font-face :font-family "public sans" :font-style "normal" :font-weight "400" :src "url('nyxt-resource:PublicSans-Regular.woff')" "format('woff')") '(:font-face :font-family "public sans" :font-style "italic" :font-weight "400" :src "url('nyxt-resource:PublicSans-Italic.woff')" "format('woff')") '(:font-face :font-family "public sans" :font-style "normal" :font-weight "100" :src "url('nyxt-resource:PublicSans-Thin.woff')" "format('woff')") '(:font-face :font-family "public sans" :font-style "italic" :font-weight "100" :src "url('nyxt-resource:PublicSans-ThinItalic.woff')" "format('woff')") '(:font-face :font-family "public sans" :font-style "normal" :font-weight "200" :src "url('nyxt-resource:PublicSans-ExtraLight.woff')" "format('woff')") '(:font-face :font-family "public sans" :font-style "italic" :font-weight "200" :src "url('nyxt-resource:PublicSans-ExtraLightItalic.woff')" "format('woff')") '(:font-face :font-family "public sans" :font-style "normal" :font-weight "300" :src "url('nyxt-resource:PublicSans-Light.woff')" "format('woff')") '(:font-face :font-family "public sans" :font-style "italic" :font-weight "300" :src "url('nyxt-resource:PublicSans-LightItalic.woff')" "format('woff')") '(:font-face :font-family "public sans" :font-style "normal" :font-weight "500" :src "url('nyxt-resource:PublicSans-Medium.woff')" "format('woff')") '(:font-face :font-family "public sans" :font-style "italic" :font-weight "500" :src "url('nyxt-resource:PublicSans-MediumItalic.woff')" "format('woff')") '(:font-face :font-family "public sans" :font-style "normal" :font-weight "600" :src "url('nyxt-resource:PublicSans-SemiBold.woff')" "format('woff')") '(:font-face :font-family "public sans" :font-style "italic" :font-weight "600" :src "url('nyxt-resource:PublicSans-SemiBoldItalic.woff')" "format('woff')") '(:font-face :font-family "public sans" :font-style "normal" :font-weight "700" :src "url('nyxt-resource:PublicSans-Bold.woff')" "format('woff')") '(:font-face :font-family "public sans" :font-style "italic" :font-weight "700" :src "url('nyxt-resource:PublicSans-BoldItalic.woff')" "format('woff')") '(:font-face :font-family "public sans" :font-style "normal" :font-weight "800" :src "url('nyxt-resource:PublicSans-ExtraBold.woff')" "format('woff')") '(:font-face :font-family "public sans" :font-style "italic" :font-weight "800" :src "url('nyxt-resource:PublicSans-ExtraBoldItalic.woff')" "format('woff')") '(:font-face :font-family "public sans" :font-style "normal" :font-weight "900" :src "url('nyxt-resource:PublicSans-Black.woff')" "format('woff')") '(:font-face :font-family "public sans" :font-style "italic" :font-weight "900" :src "url('nyxt-resource:PublicSans-BlackItalic.woff')" "format('woff')") '(:font-face :font-family "dejavu sans mono" :src "url('nyxt-resource:DejaVuSansMono.ttf')" "format('ttf')") '(* :box-sizing border-box) `(body :background-color ,theme:background-color :color ,theme:on-background-color :font-family ,theme:font-family :margin-left "20px" :margin-top "20px") '(ul :margin-top "0" :margin-bottom "0") '("details > *" :margin-left "18px") '("details > ul" :margin-left "inherit") '("details summary" :margin-left "inherit" :margin-bottom "8px" :cursor "pointer") '("summary::-webkit-details-marker" :padding-bottom "4px") '("details > summary" :list-style-type "none") '("details > summary::-webkit-details-marker" :display "none") '("details > summary::before" :font-weight "bold" :content "+" :margin-right "5px" :display "inline-block") '("details[open] > summary::before" :content "−") '(.section :margin-top "2em") `("h1,h2,h3,h4,h5,h6" :color ,theme:primary-color) `(hr :background-color ,theme:secondary-color :color ,theme:on-secondary-color :height "2px" :border-radius "2px" :border-width "0") '(button :background "transparent" :color "inherit" :border "none" :padding 0 :font "inherit" :outline "inherit") `(.button :appearance "menulist-button" :background-color ,theme:primary-color :color ,theme:on-primary-color :display "inline-block" :text-decoration "none" :border-radius "4px" :border-color ,theme:primary-color :border-style "solid" :border-width "0.2em" :padding "0.2em" :margin "0.2em") `(select.button :appearance auto :background-color ,theme:primary-color :color ,theme:on-primary-color) `(code :font-family ,theme:monospace-font-family :font-size "0.9rem") `(.code-select :position "absolute" :top "0" :right "0" :padding-right "8px !important" :direction "rtl" :appearance "none !important" :border "none" :background-color "transparent !important" :color "black !important") `(".code-select:hover" :color ,theme:action-color !important) '((:and .button :hover) :cursor "pointer" :opacity 0.8) `((:and .button (:or :visited :active)) :color ,theme:background-color) `(.link :appearance none :text-decoration "underline" :display "inline" :color ,theme:primary-color) '(".link:hover" :opacity 0.8) `(.action :color ,theme:action-color) `(.button.action :background-color ,theme:action-color :color ,theme:on-action-color :border-color ,theme:action-color+) `(.warning :color ,theme:warning-color) `(.button.warning :background-color ,theme:warning-color :color ,theme:on-warning-color :border-color ,theme:warning-color+) `(.success :color ,theme:success-color) `(.button.success :background-color ,theme:success-color :color ,theme:on-success-color :border-color ,theme:success-color+) `(.highlight :color ,theme:highlight-color) `(.button.highlight :background-color ,theme:highlight-color :color ,theme:on-highlight-color :border-color ,theme:highlight-color+) `(.plain :color ,theme:on-background-color :background-color ,theme:background-color) `(.input :appearance "textfield" :display "inline-block" :color "black" :background-color "white" :border "0.2em" solid ,theme:secondary-color :border-radius "4px" :outline "none" :padding "0.2em" :margin "0.2em") `(a :color ,theme:primary-color) `("a:hover" :opacity 0.8) `(pre :font-family ,theme:monospace-font-family :font-size "0.9rem" :border-radius "2px" :overflow "auto" :padding "5px") '("table" :border-radius "2px" :border-spacing "0" :width "100%") `("pre, p code" :color ,theme:on-background-color :background-color ,theme:background-color-) '("a code" :text-decoration underline) `("table, th, td" :border-color ,theme:primary-color :border-width "1px" :border-style "solid" :background-color ,theme:background-color :color ,theme:on-background-color) '("td, th" :padding "6px") `(th :background-color ,theme:primary-color :color ,theme:on-primary-color :text-align "left") '("th:first-of-type" :border-top-left-radius "1px") '("th:last-of-type" :border-top-right-radius "1px") '("tr:last-of-type td:first-of-type" :border-bottom-left-radius "2px") '("tr:last-of-type td:last-of-type" :border-bottom-right-radius "2px") '("table.resizable-table th" :resize "horizontal" :overflow "auto") `("::selection" :color ,theme:on-action-color :background-color ,theme:action-color) `(".mode-menu" :overflow-x "scroll" :white-space "nowrap" :background-color ,theme:background-color- :position "sticky" :margin-top "-20px" :top 0 :width "100%" :height "32px") `(".mode-menu > button" :color ,theme:on-secondary-color :padding-left "8px" :padding-right "8px" :font-size "14px" :border-radius "2px" :margin "0" :margin-right "12px" :border "none" :height "32px") `(".mode-menu > .binding" :background-color ,theme:secondary-color) `(".mode-menu > .command" :background-color ,theme:background-color-) '(".mode-menu::-webkit-scrollbar" :display "none") '("dl" :display "grid" :grid-template-columns "max-content auto" :row-gap "10px" :column-gap "10px") `("dt" :grid-column-start 1 :padding "4px" :padding-left "8px" :padding-right "8px" :border-radius "2px" :font-weight "bold" :background-color ,theme:background-color-) '("dd" :margin-inline-start "0" :grid-column-start 2) '("dd pre" :margin-top "0" :margin-bottom "0") '(".nsection-anchor" :display "none") '(".nsection-summary:hover .nsection-anchor" :display "inline-block"))) (buffer-delete-hook (make-instance 'hook-buffer) :type hook-buffer :documentation "Hook run before `buffer-delete'. The handlers take the buffer as argument.")) (:export-class-name-p t) (:export-accessor-names-p t) (:export-predicate-name-p t) (:metaclass user-class) (:documentation "A buffer is the fundamental unit of displayed content. Buffers result from the computations of a web renderer, which generates a visual representation of HTML documents. Rendered URLs or the Nyxt's manual qualify as examples. Buffers are fully separated from one another, so that each has its own behavior and settings.")) (defmethod request-resource-hook ((buffer buffer)) "A method to not error out if the buffer has no `request-resource-hook'. Useful in FFI functions where we usually specialize things against `renderer-buffer', not knowing the exact class of those." nil) (defmethod initialize-instance :after ((buffer buffer) &key &allow-other-keys) "Dummy method to allow forwarding other key arguments." buffer) (define-class modable-buffer (buffer) ((modes '() :documentation "The list of mode instances. Modes are instantiated over the result of the `default-modes' method, with `customize-instance' and not in the initform so that the instantiation form can access the initialized buffer.") (page-mode nil :documentation "A single mode enabled for internal pages. This slot stores the mode enabled by internal pages. When the user navigates away from the internal page, this mode is disabled.") (enable-mode-hook (make-instance 'hook-mode) :type hook-mode :documentation "Hook run on mode enabling, after the mode-specific hook.") (disable-mode-hook (make-instance 'hook-mode) :type hook-mode :documentation "Hook run on mode disabling, after the mode-specific hook.")) (:export-class-name-p t) (:export-accessor-names-p t) (:export-predicate-name-p t) (:metaclass user-class) (:documentation "A buffer whose behavior can be modified with `mode's.")) (defmethod enable-page-mode ((modable-buffer modable-buffer) mode) (enable-modes* mode modable-buffer) (setf (page-mode modable-buffer) mode)) (defmethod disable-page-mode ((modable-buffer modable-buffer)) (when (page-mode modable-buffer) (disable-modes* (page-mode modable-buffer) modable-buffer) (setf (page-mode modable-buffer) nil))) (defmethod modes ((buffer buffer)) "Return the modes active in BUFFER. Non-`modable-buffer's never have modes. The default specialization on `buffer' is useful to be able to call the method regardless of the buffer, with a meaningful result." '()) (export-always 'enabled-modes) (defmethod enabled-modes ((buffer modable-buffer)) "Only return enabled modes." (sera:filter #'enabled-p (modes buffer))) (defmethod enabled-modes ((buffer buffer)) "Unless a modable buffer, return NIL for modes." nil) (define-class input-buffer (buffer) ((keyscheme keyscheme:cua :documentation "The keyscheme that will be used for all modes.") (current-keymaps-hook (make-instance 'hook-keymaps-buffer :combination #'hooks:combine-composed-hook) :type hook-keymaps-buffer :documentation "Hook run as a return value of `current-keymaps'.") (conservative-word-move t :documentation "If non-nil, the cursor moves to the end (resp. beginning) of the word when `move-forward-word' (resp. `move-backward-word') is called.") (forward-input-events-p nil :documentation "When non-nil, keyboard events are forwarded to the renderer when no binding is found. Pointer events (e.g. mouse events) are not affected by this, they are always forwarded when no binding is found.") (last-event nil :type t :export nil ;; TODO: Store multiple events? Maybe when implementing keyboard macros. :documentation "The last event received in the current buffer.") (lisp-url-callbacks (sera:dict) :type hash-table :export nil :documentation "The index of callbacks for `lisp://' URLs. They are populated by the `nyxt/ps:lisp-eval' Parenscript macro. It's part of `input-buffer' since any (even offline) buffer that can be clicked on may want to have dynamic interactions.")) (:export-class-name-p t) (:export-accessor-names-p t) (:export-predicate-name-p t) (:metaclass user-class) (:documentation "A buffer in which the user can input.")) (define-class document-buffer (buffer) ((document-model-delta-threshold 10 :documentation "The `document-model' is updated when the changed elements exceed this amount." :export nil) (document-model nil :reader nil ; We use a custom reader. :writer t :export t :type (or null plump:node) :documentation "A parsed representation of the rendered buffer. Computed by `plump:parse', see `update-document-model' for details.") (keep-search-marks-p t :type boolean :documentation "Whether to keep search marks after exiting the prompt buffer.") (scroll-distance 32 :type integer :documentation "The distance in pixels for `scroll-down' or `scroll-up'.") (smooth-scrolling nil :documentation "Whether to scroll smoothly.") (horizontal-scroll-distance 50 :type integer :documentation "The distance in pixels for `scroll-left' or `scroll-right'.") (zoom-ratio nil :type (or null float) :reader t :export t :documentation "The current zoom ratio as per `ffi-buffer-zoom-ratio'. It is an implementation detail and must not be set by the user. For the user-facing slot, see `zoom-ratio-default'.") (zoom-ratio-step 0.1 :type float :documentation "The step size for zooming in and out.") (zoom-ratio-default 1.0 :type float :documentation "The default zoom ratio.") (page-scroll-ratio 0.90 :type float :documentation "The ratio of the page to scroll. A value of 0.95 means that the bottom 5% will be the top 5% when scrolling down.")) (:export-class-name-p t) (:export-accessor-names-p t) (:export-predicate-name-p t) (:metaclass user-class) (:documentation "Buffers holding structured documents.")) (define-class context-buffer (buffer) ((download-directory (make-instance 'download-directory) :type download-directory :documentation "Directory where downloads will be stored.") (download-engine :initform :renderer :type symbol :documentation "Select a download engine to use, such as `:lisp' or `:renderer'.")) (:export-class-name-p t) (:export-accessor-names-p t) (:export-predicate-name-p t) (:metaclass user-class) (:documentation "A buffer that holds buffer-specific settings (see its slots). Global settings should be stored in `browser' instead. Conceptually, it's similar to \"private windows\" in popular browsers but the scope is that of buffers.")) (defmethod print-object ((buffer buffer) stream) (print-unreadable-object (buffer stream :type t) (format stream "~a ~a" (id buffer) (url buffer)))) (defmethod (setf url) :around (value (buffer document-buffer)) (declare (ignore value)) (call-next-method) (set-window-title)) (defmethod (setf title) :around (value (buffer document-buffer)) (declare (ignore value)) (call-next-method) (set-window-title)) (export-always 'default-modes) (defgeneric default-modes (buffer) (:method-combination append) ;; TODO: Add a warning method when passing NIL to guard the current buffer not ;; bound errors? (:method append ((buffer t)) %default-modes) (:method append ((buffer buffer)) (slot-value buffer 'default-modes)) (:method :around ((buffer buffer)) "Remove the duplicates from the `default-modes' and normalize them. This allows setting modes as :DARK-MODE or 'EMACS-MODE in whatever package, and Nsymbols will find the proper symbol, unless duplicate." (mapcar (alex:rcurry #'resolve-user-symbol :mode (list-all-packages)) (remove-duplicates (call-next-method) ;; Modes at the beginning of the list have higher ;; priority. :from-end t))) (:documentation "BUFFER's default modes. `append's all the methods applicable to BUFFER to get the full list of modes.")) (define-class network-buffer (buffer) ((status :unloaded :type (member :loading :finished :unloaded :failed) :export nil :documentation "The status of the buffer. - `:loading' when loading a web resource. - `:finished' when done loading a web resource. - `:unloaded' for buffers that have not been loaded yet, like session-restored buffers, dead buffers or new buffers that haven't started the loading process yet.") (buffer-load-hook (make-instance 'hook-url->url :combination #'hooks:combine-composed-hook) :type hook-url->url :accessor nil :export nil :documentation "Hook run in `buffer-load' before loading. The handlers take the URL going to be loaded as argument and must return a (possibly new) URL.") (buffer-loaded-hook (make-instance 'hook-buffer) :type hook-buffer :documentation "Hook run on `on-signal-load-finished'. The handlers take the buffer as argument.") (request-resource-keyscheme-map (define-keyscheme-map "request-resource" () keyscheme:default (list "C-button1" 'request-resource-open-url "button2" 'request-resource-open-url "C-shift-button1" 'request-resource-open-url-focus "shift-button2" 'request-resource-open-url-focus)) :documentation "Looked up when `request-resource-hook' handlers run. The keymap takes functions whose key arguments are `:url' and `:buffer'.") (request-resource-hook (make-instance 'hook-resource :combination #'combine-composed-hook-until-nil) :type hook-resource :documentation "Hook run on every resource load. The handlers are composed, passing a `request-data' until one of them returns nil or all handlers apply successfully. Newest hook is run first. If a `request-data' object is returned, it gets passed to other handlers or right to the renderer if there are no more handlers. If nil is returned, stop the hook and cancel the resource load. The current buffer URL should not be relied upon. With WebKitGTK, it is the same as (url REQUEST-DATA). If you need to access the URL before this request, inspect the document-mode history. Example: \(defmethod configure-instance ((buffer buffer)) (reduce #'hooks:add-hook '(old-reddit-handler auto-proxy-handler) :initial-value (request-resource-hook buffer)))") (proxy nil :accessor nil :type (or proxy null) :documentation "Proxy for buffer.") (certificate-exceptions '() :type (list-of string) :documentation "A list of hostnames for ignoring certificate errors.")) (:export-class-name-p t) (:export-accessor-names-p t) (:export-predicate-name-p t) (:metaclass user-class) (:documentation "Buffers that must interact with resources over the network.")) (define-class web-buffer (context-buffer network-buffer modable-buffer document-buffer input-buffer) ((keywords nil :reader nil :writer t :documentation "The keywords parsed from the current web buffer.")) (:export-class-name-p t) (:export-accessor-names-p t) (:export-predicate-name-p t) (:metaclass user-class) (:documentation "Buffer for browsing the web.")) (defmethod customize-instance :after ((buffer buffer) &key (browser *browser*) no-hook-p &allow-other-keys) "Finalize buffer. Return the created buffer." (unless (or no-hook-p (not browser)) (hooks:run-hook (buffer-before-make-hook browser) buffer)) buffer) (defmethod customize-instance :after ((buffer modable-buffer) &key (browser *browser*) no-hook-p extra-modes &allow-other-keys) "Finalize instantiation of modable BUFFER. In particular, - Run `buffer-make-hook'; - `enable' the modes from the `modes' slot, `default-modes', and the EXTRA-MODES - Run `buffer-after-make-hook'." (unless no-hook-p (hooks:run-hook (buffer-make-hook browser) buffer)) (mapc #'enable (modes buffer)) (enable-modes* (append (reverse (default-modes buffer)) (uiop:ensure-list extra-modes)) buffer) (unless no-hook-p (hooks:run-hook (buffer-after-make-hook browser) buffer)) buffer) (defmethod customize-instance :after ((buffer context-buffer) &key &allow-other-keys) "Finalize buffer. Return the created buffer." (buffer-set (id buffer) buffer) buffer) (export-always 'update-document-model) (defun update-document-model (&key (buffer (current-buffer))) "Update BUFFER's `document-model' as to include Nyxt identifiers." (ps-eval :buffer buffer (defvar nyxt-identifier-counter 0) (defun add-nyxt-identifiers (node) (unless (ps:chain node (has-attribute "nyxt-identifier")) (ps:chain node (set-attribute "nyxt-identifier" (ps:stringify nyxt-identifier-counter)))) (incf nyxt-identifier-counter) (dolist (child (if (ps:chain node shadow-root) (ps:chain *array (from (ps:@ node shadow-root children)) (concat (ps:chain *array (from (ps:@ node children))))) (ps:chain node children))) (add-nyxt-identifiers child)) (when (ps:@ node shadow-root) (ps:chain node (set-attribute "nyxt-shadow-root" ""))) nyxt-identifier-counter) (setf nyxt-identifier-counter (add-nyxt-identifiers (ps:chain document body)))) (when-let ((body-json (with-current-buffer buffer (nyxt/dom::get-document-body-json)))) (let ((dom (nyxt/dom::named-json-parse body-json))) (unless (uiop:emptyp (plump:text dom)) (when (slot-boundp buffer 'keywords) (setf (keywords buffer) nil)) (setf (document-model buffer) dom))))) (defun dead-buffer-p (buffer) (not (buffer-get (id buffer)))) (defmethod document-model ((buffer buffer) &key use-cached-p) "A wraparound accessor to BUFFER's `document-model'. In case the page changed more than `document-model-delta-threshold', runs `update-document-model'." (if use-cached-p (slot-value buffer 'document-model) (ps-labels :buffer buffer ((%count-dom-elements () (defvar dom-counter 0) (defun count-dom-elements (node) (incf dom-counter) (dolist (child (ps:chain node children)) (count-dom-elements child)) dom-counter) (setf dom-counter 0) (count-dom-elements (nyxt/ps:qs document "html")))) (if (dead-buffer-p buffer) (slot-value buffer 'document-model) (let ((value (slot-value buffer 'document-model)) (element-count (%count-dom-elements))) (if (and value element-count ;; Check the difference in element count. (< (abs (- (length (clss:select "*" value)) (truncate element-count))) (document-model-delta-threshold buffer))) value (progn (update-document-model :buffer buffer) (slot-value buffer 'document-model)))))))) (defmethod proxy ((buffer buffer)) (slot-value buffer 'proxy)) (defmethod (setf proxy) (proxy (buffer buffer)) (setf (slot-value buffer 'proxy) proxy) (if proxy (setf (ffi-buffer-proxy buffer) (list (url proxy) (allowlist proxy))) (setf (ffi-buffer-proxy buffer) (quri:uri "")))) (defmethod keywords ((buffer web-buffer)) "Return the terms that best describe the contents of BUFFER." (or (slot-value buffer 'keywords) (when-let ((document (document-model buffer))) (setf (slot-value buffer 'keywords) (analysis:extract-keywords (str:join " " (map 'list #'plump:text (clss:select "p" document)))))))) (define-class keyword-source (prompter:source) ((prompter:name "Keywords") (buffer (current-buffer) :type buffer) (prompter:enable-marks-p t) (prompter:constructor (lambda (source) (mapcar #'first (nyxt::keywords (buffer source)))))) (:export-class-name-p t) (:documentation "Source listing the keywords for source `buffer'.")) (-> proxy-url (buffer &key (:downloads-only boolean)) *) (defun proxy-url (buffer &key (downloads-only nil)) "Return the proxy address, nil if not set. If DOWNLOADS-ONLY is non-nil, then it only returns the proxy address (if any) when `proxied-downloads-p' is true." (let* ((proxy (and buffer (proxy buffer))) (proxied-downloads (and proxy (proxied-downloads-p proxy)))) (when (or (and (not downloads-only) proxy) proxied-downloads) (url proxy)))) (defun load-failed-p (buffer) "Only `network-buffer' loads can fail." (and (network-buffer-p buffer) (eq (slot-value buffer 'status) :failed))) (hooks:define-hook-type buffer (function (buffer)) "Hook acting on `buffer's.") (define-command make-buffer (&rest args &key (title "") modes (url (if *browser* (default-new-buffer-url *browser*) (quri:uri (nyxt-url 'new)))) (load-url-p t) (buffer-class 'web-buffer) &allow-other-keys) "Create a new buffer. MODES is a list of mode symbols. If URL is empty, the `default-new-buffer-url' browser slot is used instead. To load nothing, set it to 'about:blank'. LOAD-URL-P controls whether to load URL right at buffer creation." (let* ((url (url url)) (buffer (apply #'make-instance buffer-class :title title :extra-modes modes (append (unless (url-empty-p url) (list :url url)) (uiop:remove-plist-keys '(:title :modes :url) args))))) (when load-url-p (ffi-buffer-load buffer url)) buffer)) (define-command make-buffer-focus (&key (url (default-new-buffer-url *browser*))) "Switch to a new buffer. See `make-buffer'." (let ((buffer (make-buffer :url url))) (set-current-buffer buffer) buffer)) (-> add-to-recent-buffers (buffer) *) (defun add-to-recent-buffers (buffer) "Push BUFFER to the front of `recent-buffers'. The notion of first element is dictated by `containers:first-item'." (when (web-buffer-p buffer) (containers:delete-item (recent-buffers *browser*) buffer) (containers:insert-item (recent-buffers *browser*) buffer))) (export-always 'buffer-list) (defun buffer-list () "Order is stable." (sort (alex:hash-table-values (buffers *browser*)) #'> :key #'id)) (export-always 'internal-buffers) (defun internal-buffer-list (&key (all nil)) ;; Note that the `buffers' slot only keeps track of "main" buffers. (append (sera:filter #'internal-url-p (buffer-list)) (when all (alex:flatten (loop for window in (window-list) collect (active-prompt-buffers window) collect (status-buffer window) collect (message-buffer window)))))) (defun buffer-get (id) "Get the `buffer' with the corresponding ID." (or (gethash id (slot-value *browser* 'buffers)) (find-if (lambda (prompt-buffer) (eql (id prompt-buffer) id)) (mapcan #'active-prompt-buffers (alexandria:hash-table-values (windows *browser*)))))) (defun buffer-set (id buffer) "Ensure that entry ID->BUFFER belongs to `buffers' hash table." (when *browser* ;; Mutate state of the hash table. (setf (gethash id (slot-value *browser* 'buffers)) buffer) ;; Notify `buffers' of the new hash table state. Useful, for example, to ;; update the status buffer. (setf (buffers *browser*) (buffers *browser*)))) (defun buffer-delete (id) "Remove `buffers' hash table entry matching key ID. This is a low-level function. See `buffer-delete' and `delete-buffer'." ;; Mutate state of the hash table. (when *browser* (remhash id (slot-value *browser* 'buffers)) ;; Notify `buffers' of the new hash table state. Useful, for example, to ;; update the status buffer. (setf (buffers *browser*) (buffers *browser*)))) (export-always 'window-list) (defun window-list () "Return a list of all the open `windows'." (when *browser* (alex:hash-table-values (windows *browser*)))) (defmethod window ((buffer buffer)) "Get the window containing a buffer." (find buffer (alex:hash-table-values (windows *browser*)) :key #'active-buffer)) (defun last-active-buffer () "Return buffer with most recent `last-access'." (first (sort-by-time (buffer-list)))) (defmethod active-buffer-p ((buffer buffer)) (find buffer (mapcar #'active-buffer (window-list)))) (defun get-inactive-buffer () "Return inactive buffers sorted by `last-access', when applicable. If none exist, make a new inactive buffer." (if-let ((inactive (set-difference (buffer-list) (mapcar #'active-buffer (window-list))))) (first (sort-by-time inactive)) (make-buffer))) (define-command copy-url () "Save current URL to clipboard." (echo "~s copied to clipboard." (copy-to-clipboard (render-url (url (current-buffer)))))) (define-command copy-title () "Save current page title to clipboard." (echo "~a copied to clipboard." (copy-to-clipboard (title (current-buffer))))) (define-class buffer-source (prompter:source) ((prompter:name "Buffer list") (prompter:constructor (append (list (active-buffer (current-window))) (remove (active-buffer (current-window)) (buffer-list)))) (prompter:filter-preprocessor #'prompter:filter-exact-matches) (prompter:enable-marks-p t) (prompter:actions-on-return (list (lambda-unmapped-command set-current-buffer) (lambda-mapped-command ffi-buffer-delete) 'reload-buffers)) (prompter:actions-on-current-suggestion-enabled-p t) (prompter:actions-on-current-suggestion (lambda-command set-current-buffer* (buffer) "Set current BUFFER for the active window." (set-current-buffer buffer :focus nil))) (prompter:destructor (let ((buffer (current-buffer))) (lambda (prompter source) (declare (ignore source)) (unless (or (prompter:returned-p prompter) (eq buffer (current-buffer))) (set-current-buffer buffer))))) (prompter:active-attributes-keys '("Title" "URL" "Keywords") :accessor nil)) (:export-class-name-p t) (:metaclass user-class) (:documentation "Source for choosing one (or several) of the open buffers. The `prompter:actions-on-current-suggestion' are set up to preview/switch to the buffer currently chosen as suggestion.")) (defmethod prompter:object-attributes ((buffer buffer) (source prompter:source)) (declare (ignore source)) `(("Title" ,(title buffer) (:width 3)) ("URL" ,(render-url (url buffer)) (:width 2)) ,(when (web-buffer-p buffer) `("Keywords" ,(format nil "~:{~a~^ ~}" (keywords buffer)) (:width 2))) ("ID" ,(id buffer) (:width 1)))) (define-command switch-buffer () "Switch buffer using fuzzy completion." (prompt :prompt "Switch to buffer" :sources (make-instance 'buffer-source))) (define-command switch-buffer-domain (&key domain (buffer (current-buffer))) "Switch to buffer sharing the same domain as the current one." (let ((domain (or domain (quri:uri-domain (url buffer))))) (prompt :prompt "Switch to buffer in current domain" :sources (make-instance 'buffer-source :constructor (sera:filter (match-domain domain) (sort-by-time (buffer-list))))))) (define-command toggle-prompt-buffer-focus () "Toggle the focus between the current buffer and the current prompt buffer." (let ((prompt-buffer (current-prompt-buffer))) (if (ffi-focused-p prompt-buffer) (prog1 (ffi-focus-buffer (current-buffer)) (ps-eval :buffer prompt-buffer (setf (ps:@ (nyxt/ps:qs document "*") style opacity) "0.5"))) (prog1 (ffi-focus-buffer prompt-buffer) (ps-eval :buffer prompt-buffer (setf (ps:@ (nyxt/ps:qs document "*") style opacity) "1")))))) (flet ((delete-all (buffers &optional predicate) (mapcar #'ffi-buffer-delete (sera:filter (or predicate #'identity) buffers)))) (define-command delete-buffer (&key (buffers (prompt :prompt "Delete buffer(s)" :sources (make-instance 'buffer-source :enable-marks-p t :actions-on-return (list (lambda-mapped-command ffi-buffer-delete) (lambda-command buffer-delete-duplicates* (buffers) "Delete all buffers with same URLs, except selected." (delete-all (set-difference (buffer-list) buffers) (lambda (buffer) (member (url buffer) buffers :key #'url :test #'quri:uri-equal)))) (lambda-command buffer-delete-same-host* (buffers) "Delete all the buffers with the same website open." (delete-all (buffer-list) (lambda (buffer) (member (quri:uri-host (url buffer)) (mapcar #'url buffers) :key #'quri:uri-host :test #'string-equal)))) (lambda-command buffer-delete-same-url* (buffers) "Delete all the buffers with the same page open." (delete-all (buffer-list) (lambda (buffer) (member (url buffer) buffers :key #'url :test #'quri:uri-equal))))))) buffers-supplied-p)) "Query the buffer(s) to delete. BUFFERS should be a list of `buffer's." (when buffers-supplied-p (delete-all (uiop:ensure-list buffers))))) (define-command delete-all-buffers () "Delete all buffers, with confirmation." (if-confirm ((format nil "Delete ~a buffer(s)?" (length (buffer-list)))) (mapcar #'ffi-buffer-delete (buffer-list)))) (define-command delete-current-buffer () "Delete the current buffer and switch to the last visited one. If no other buffers exist, load the start page." (ffi-buffer-delete (current-buffer))) (define-command delete-other-buffers (&optional (buffer (current-buffer))) "Delete all buffers except BUFFER. When BUFFER is omitted, it defaults to the current one." (let ((buffers-to-delete (remove buffer (buffer-list)))) (if-confirm ((format nil "Delete ~a buffer(s)?" (length buffers-to-delete))) (mapcar #'ffi-buffer-delete buffers-to-delete)))) ;; Useful to be used by prompt buffer actions, since they take a list as ;; argument. (export-always 'buffer-load*) (defun buffer-load* (url-list) "Load first element of URL-LIST in current buffer and the rest in new buffers." (mapc (lambda (url) (make-buffer :url (url url))) (rest url-list)) (ffi-buffer-load (current-buffer) (url (first url-list)))) (define-class global-history-source (prompter:source) ((prompter:name "Global history") (prompter:constructor (recent-history-entries 200 *browser* :deduplicate-p t)) (prompter:enable-marks-p t) (prompter:filter-preprocessor #'prompter:filter-exact-matches) (prompter:actions-on-return #'buffer-load*)) (:export-class-name-p t) (:metaclass user-class) (:documentation "Source listing all the entries in history. Loads the entry with default `prompter:actions-on-return'.")) (define-class url-or-query () ((data "" :type string :documentation "A string to be resolved to a URL via `url'.") (kind :initarg nil :type (maybe keyword) :documentation "A keyword that classifies `data' based on its content. One of `:url' or `:search-query'.") (search-engine :type (maybe search-engine) :documentation "Applicable when `kind' is `:search-query'.") (search-query :initarg nil :type (maybe string) :documentation "Applicable when `kind' is `:search-query'.")) (:export-class-name-p t) (:export-accessor-names-p t) (:documentation "Helper structure that resolves user input to a URL. Determine whether a valid https URL, local file or a search engine query is requested. When the first word of `data' matches the `shortcut' of a `search-engine', then it is interpreted as a search engine query.")) (defmethod print-object ((query url-or-query) stream) (print-unreadable-object (query stream :type t) (format stream "~a" (data query)))) (defmethod initialize-instance :after ((query url-or-query) &key &allow-other-keys) (with-slots (data kind search-engine search-query) query (setf data (str:trim data)) (cond ((str:blankp data) t) ((valid-url-p data :check-tld-p nil) (setf kind :url)) ((ignore-errors (valid-url-p (str:concat "https://" data) :check-tld-p t)) (setf kind :url data (str:concat "https://" data))) ((uiop:file-exists-p data) (setf kind :url data (str:concat "file://" (uiop:native-namestring data)))) (t (let* ((terms (sera:tokens data)) (explicit-engine (find (first terms) (search-engines *browser*) :key #'shortcut :test #'string-equal)) (engine (or explicit-engine (default-search-engine *browser*)))) (setf kind :search-query search-engine engine) (if explicit-engine (setf search-query (str:join " " (rest terms))) (setf search-query data data (format-query data engine)))))))) (export-always 'search-suggestions) (defmethod search-suggestions ((query url-or-query)) (with-slots (search-engine search-query) query (when search-engine (let ((suggestions (suggestions search-query search-engine))) (mapcar (lambda (suggestion) (make-instance 'url-or-query :data (format-query suggestion search-engine))) ;; Ensure that search-query is the first suggestion. (if (string-equal search-query (first suggestions)) suggestions (append (list search-query) suggestions))))))) (defmethod url ((query url-or-query)) (with-slots (data kind search-engine search-query) query (quri:uri (if (eq :search-query kind) (format-url search-query search-engine) data)))) (define-class url-or-query-source (prompter:source) ((prompter:name "URL or search query") (prompter:filter-preprocessor (lambda (suggestions source input) (declare (ignore suggestions source)) (list (make-instance 'url-or-query :data input)))) (prompter:filter-postprocessor (lambda (prompt-suggestions source input) (declare (ignore source input)) (sleep 0.15) ; Delay search suggestions while typing. (if-let ((_ (search-engine-suggestions-p *browser*)) (completion (search-suggestions (prompter:value (first prompt-suggestions))))) completion prompt-suggestions))) (prompter:filter nil) (prompter:actions-on-return #'buffer-load*)) (:export-class-name-p t) (:metaclass user-class) (:documentation "Source listing URL queries from user input in a DWIM fashion. See `url-or-query'.")) (defmethod prompter:object-attributes ((query url-or-query) (source url-or-query-source)) (declare (ignore source)) (with-slots (data kind search-engine search-query) query `(("Input" ,(or search-query data) (:width 5)) ("Type" ,(cond ((null kind) "") ((eq kind :search-query) (name search-engine)) (t kind)) (:width 2))))) (export-always 'url-sources) (defmethod url-sources ((buffer buffer) actions-on-return) "Return list of `set-url' sources. The returned sources should have `url' or `prompter:actions-on-return' methods specified for their contents." (let ((actions-on-return (uiop:ensure-list actions-on-return))) (append (list (make-instance 'url-or-query-source :actions-on-return actions-on-return) (make-instance 'global-history-source :actions-on-return actions-on-return)) (mappend (rcurry #'url-sources (uiop:ensure-list actions-on-return)) (enabled-modes buffer))))) (define-command set-url (&key (default-action #'buffer-load*)) "Set the URL for the current buffer, completing with history." (let* ((history (set-url-history *browser*)) (actions-on-return (list #'buffer-load* (lambda-command copy-url* (suggestions) "Copy the URL of the chosen suggestion." (trivial-clipboard:text (render-url (url (first suggestions)))))))) (pushnew default-action actions-on-return) (prompt :prompt "Open URL" :input (render-url (url (current-buffer))) :history history :sources (url-sources (current-buffer) actions-on-return)) (current-buffer))) (define-command set-url-new-buffer () (set-url :default-action (lambda-command new-buffer-load* (suggestion-values) "Load URL(s) in new buffer(s)." (mapc (lambda (suggestion) (make-buffer :url (url suggestion))) (rest suggestion-values)) (make-buffer-focus :url (url (first suggestion-values)))))) (define-command reload-current-buffer () "Reload current buffer. Return it." (ffi-buffer-reload (current-buffer))) (define-command reload-buffers (&optional (buffers (prompt :prompt "Reload buffer(s)" :sources (make-instance 'buffer-source :enable-marks-p t)))) "Prompt for BUFFERS to be reloaded. Return BUFFERS." (mapcar #'ffi-buffer-reload (alex:ensure-list buffers)) buffers) (define-command switch-buffer-previous (&key (offset 1) (buffer (current-buffer))) "Switch to the previous buffer." (let ((buffer-list (buffer-list))) (set-current-buffer (nth (mod (+ offset (position buffer buffer-list)) (length buffer-list)) buffer-list)))) (define-command switch-buffer-next (&key (offset 1) (buffer (current-buffer))) "Switch to the next buffer." (switch-buffer-previous :offset (- offset) :buffer buffer)) (define-command switch-buffer-last () "Switch to the last visited buffer. The buffer with the most recent access time is returned." (when-let ((buffer (second (sort-by-time (buffer-list))))) (set-current-buffer buffer))) (define-command open-inspector () "Open the inspector, a graphical tool to inspect the buffer." (ffi-inspector-show (current-buffer)) (current-buffer)) ================================================ FILE: source/clipboard.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :nyxt) (-> ring-insert-clipboard (containers:ring-buffer-reverse) (maybe string)) (export-always 'ring-insert-clipboard) (defun ring-insert-clipboard (ring) "Check if clipboard-content is most recent entry in RING. If not, insert clipboard-content into RING. Return most recent entry in RING." (let ((clipboard-content (handler-case (trivial-clipboard:text) (uiop:subprocess-error () nil)))) (when clipboard-content (unless (string= clipboard-content (unless (containers:empty-p ring) (containers:first-item ring))) (containers:insert-item ring clipboard-content))) (unless (containers:empty-p ring) (string (containers:first-item ring))))) (export-always 'copy-to-clipboard) (defun copy-to-clipboard (input) "Save INPUT text to clipboard, and ring." (containers:insert-item (clipboard-ring *browser*) (trivial-clipboard:text input))) ================================================ FILE: source/color.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :nyxt) (defvar *css-colors* '("AliceBlue" "AntiqueWhite" "Aqua" "Aquamarine" "Azure" "Beige" "Bisque" "Black" "BlanchedAlmond" "Blue" "BlueViolet" "Brown" "BurlyWood" "CadetBlue" "Chartreuse" "Chocolate" "Coral" "CornflowerBlue" "Cornsilk" "Crimson" "Cyan" "DarkBlue" "DarkCyan" "DarkGoldenRod" "DarkGray" "DarkGrey" "DarkGreen" "DarkKhaki" "DarkMagenta" "DarkOliveGreen" "DarkOrange" "DarkOrchid" "DarkRed" "DarkSalmon" "DarkSeaGreen" "DarkSlateBlue" "DarkSlateGray" "DarkSlateGrey" "DarkTurquoise" "DarkViolet" "DeepPink" "DeepSkyBlue" "DimGray" "DimGrey" "DodgerBlue" "FireBrick" "FloralWhite" "ForestGreen" "Fuchsia" "Gainsboro" "GhostWhite" "Gold" "GoldenRod" "Gray" "Grey" "Green" "GreenYellow" "HoneyDew" "HotPink" "IndianRed" "Indigo" "Ivory" "Khaki" "Lavender" "LavenderBlush" "LawnGreen" "LemonChiffon" "LightBlue" "LightCoral" "LightCyan" "LightGoldenRodYellow" "LightGray" "LightGrey" "LightGreen" "LightPink" "LightSalmon" "LightSeaGreen" "LightSkyBlue" "LightSlateGray" "LightSlateGrey" "LightSteelBlue" "LightYellow" "Lime" "LimeGreen" "Linen" "Magenta" "Maroon" "MediumAquaMarine" "MediumBlue" "MediumOrchid" "MediumPurple" "MediumSeaGreen" "MediumSlateBlue" "MediumSpringGreen" "MediumTurquoise" "MediumVioletRed" "MidnightBlue" "MintCream" "MistyRose" "Moccasin" "NavajoWhite" "Navy" "OldLace" "Olive" "OliveDrab" "Orange" "OrangeRed" "Orchid" "PaleGoldenRod" "PaleGreen" "PaleTurquoise" "PaleVioletRed" "PapayaWhip" "PeachPuff" "Peru" "Pink" "Plum" "PowderBlue" "Purple" "RebeccaPurple" "Red" "RosyBrown" "RoyalBlue" "SaddleBrown" "Salmon" "SandyBrown" "SeaGreen" "SeaShell" "Sienna" "Silver" "SkyBlue" "SlateBlue" "SlateGray" "SlateGrey" "Snow" "SpringGreen" "SteelBlue" "Tan" "Teal" "Thistle" "Tomato" "Turquoise" "Violet" "Wheat" "White" "WhiteSmoke" "Yellow" "YellowGreen") "All the named CSS colors to construct `color-source' from.") (defvar copy-actions (list (lambda-command copy-as-hex* (colors) "Copy the color as hex #XXXXXX string." (let ((hex (cl-colors-ng:print-hex (first colors)))) (ffi-buffer-copy (current-buffer) hex) (echo "~s copied to clipboard." hex))) (lambda-command copy-as-rgb* (colors) "Copy the color as CSS rgb() function string." (let ((rgb (cl-colors-ng:print-css-rgb/a (first colors)))) (ffi-buffer-copy (current-buffer) rgb) (echo "Copied ~a to clipboard!" rgb))) (lambda-command copy-as-hsl* (colors) "Copy the color as CSS hsl() function string." (let ((hsl (cl-colors-ng:print-css-hsl (first colors)))) (ffi-buffer-copy (current-buffer) hsl) (echo "Copied ~a to clipboard!" hsl))))) (export-always 'color-source) (define-class color-source (prompter:source) ((prompter:name "Color") (prompter:constructor *css-colors*) (prompter:filter-preprocessor #'prompter:filter-exact-matches) (prompter:filter-postprocessor (lambda (suggestions source input-color) (unless (str:empty? input-color) (sleep 0.2)) (append (when (ignore-errors (cl-colors-ng:as-rgb input-color)) (list (make-instance 'prompter:suggestion :value input-color :attributes (prompter:object-attributes input-color source)))) suggestions))) (prompter:actions-on-current-suggestion-enabled-p t) (prompter:actions-on-return (cons #'identity copy-actions))) (:documentation "A source for color search and copying. Allows looking through the colors based on their names, HEX values, and rgb()/hsl() CSS functions representing them.")) (defmethod prompter:object-attributes ((color string) (source color-source)) `(("Color" ,color) ("HEX" ,(cl-colors-ng:print-hex color)) ("RGB" ,(cl-colors-ng:print-css-rgb/a color)))) (define-command-global pick-color () "Pick a color and copy it to clipboard. The current color is previewed in the prompt buffer's input area. Color can be entered as: - CSS color name: \"PapayaWhip\" (capitalization is optional.) - HEX code: \"#37A8E4\". - HSL and RGB functions inspired by CSS." (prompt :prompt "Color" :sources (make-instance 'color-source :actions-on-return copy-actions))) ================================================ FILE: source/command-commands.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :nyxt) (define-class hook-description () ((name "" :documentation "The hook name.") (value nil :documentation "The hook value."))) (defun command-attributes (command &optional (buffer (active-buffer (current-window :no-rescan)))) (let ((command-name (name command))) `(("Name" ,(string-downcase command-name) (:width 1)) ("Bindings" ,(format nil "~{~a~^, ~}" (keymaps:pretty-binding-keys command-name (current-keymaps buffer) :print-style (keymaps:name (keyscheme buffer)))) (:width 1)) ("Docstring" ,(documentation-line command 'function "") (:width 4)) ("Mode" ,(let ((package-name (uiop:symbol-package-name command-name))) (if (str:starts-with-p "NYXT/MODE/" package-name) (string-downcase (str:replace-first "NYXT/MODE/" "" package-name)) "")) (:width 1))))) (define-class command-source (prompter:source) ((prompter:name "Commands") (global-p t :type boolean :documentation "Whether global commands are included in the suggestions.") (buffer (current-buffer) :type buffer) (prompter:constructor (lambda (source) (sort-by-time (list-commands :global-p (global-p source) :mode-symbols (mapcar #'sera:class-name-of (sera:filter #'enabled-p (enabled-modes (buffer source)))))))) (prompter:active-attributes-keys '("Name" "Bindings" "Docstring") :accessor nil) (prompter:filter-preprocessor #'prompter:filter-exact-matches)) (:export-class-name-p t) (:documentation "Prompter source to execute commands. Global commands are listed if `global-p' is non-nil. Mode commands of enabled modes are also listed. While disabled-mode commands are not listed, it's still possible to call them from a key binding.") (:metaclass user-class)) (defmethod predict-next-command ((browser browser)) (when-let ((prediction (analysis:predict (command-model browser) (list (last-command browser))))) (analysis:element prediction))) (define-class predicted-command-source (prompter:source) ((prompter:name "Predicted Command") (prompter:constructor (lambda (source) (declare (ignore source)) (list (predict-next-command *browser*)))) (prompter:filter-preprocessor #'prompter:filter-exact-matches)) (:export-class-name-p t) (:documentation "Prompter source to predict commands.") (:metaclass user-class)) (define-command execute-predicted-command () "Execute the predicted next command." (run-async (predict-next-command *browser*))) (defmethod prompter:object-attributes ((command command) (source prompter:source)) (declare (ignore source)) (command-attributes command)) (define-command execute-command () "Execute a command by name. Also accepts arbitrary Lisp expressions (even without the outermost level of parentheses), and lists the possible completions for the incomplete symbols, together with the arglists and documentations of the functions typed in." (unless (active-prompt-buffers (current-window)) (prompt :prompt "Execute command" :sources (list (make-instance 'command-source :actions-on-return (list (lambda-command run-command* (commands) "Run the chosen command." (let ((command (first commands))) (setf (last-access command) (local-time:now)) (run-async command))) (lambda-command describe-command* (commands) "Show the documentation and properties of this command." (describe-command :command (name (first commands)))))) (make-instance 'predicted-command-source :actions-on-return (lambda-command run-command* (commands) "Run the chosen command." (when-let ((command (first commands))) (setf (last-access command) (time:now)) (run-async command))))) :hide-suggestion-count-p t))) (defun get-hooks () (flet ((list-hooks (object) (mapcar (lambda (hook) (make-instance 'hook-description :name (str:downcase (closer-mop:slot-definition-name hook)) :value (funcall (symbol-function (closer-mop:slot-definition-name hook)) object))) (remove-if-not (lambda (s) (let ((name (closer-mop:slot-definition-name s))) (and (str:ends-with-p "-hook" (string name) :ignore-case t) (fboundp name)))) (closer-mop:class-slots (class-of object)))))) (let ((window-hooks (list-hooks (current-window))) (buffer-hooks (list-hooks (current-buffer))) (browser-hooks (list-hooks *browser*))) (append window-hooks buffer-hooks browser-hooks)))) (define-class hook-source (prompter:source) ((prompter:name "Hooks") (prompter:constructor (get-hooks)) (prompter:actions-on-return (lambda-mapped-command value)))) (defmethod prompter:object-attributes ((hook-description hook-description) (source hook-source)) (declare (ignore source)) `(("Name" ,(name hook-description)))) (define-class handler-source (prompter:source) ((prompter:name "Handlers") (hook nil :documentation "The hook for which to retrieve handlers for.") (prompter:constructor (lambda (source) (hooks:handlers (hook source)))))) (defmethod prompter:object-attributes ((handler symbol) (source handler-source)) (declare (ignore source)) `(("Name" ,(str:downcase (hooks:name handler))))) (define-class disabled-handler-source (handler-source) ((prompter:constructor (lambda (source) (hooks:disabled-handlers (hook source)))))) (defun manage-hook-handler (action) (let ((hook (prompt1 :prompt "Hook" :sources 'hook-source))) (funcall (case action (:enable #'hooks:enable-hook) (:disable #'hooks:disable-hook)) hook (prompt1 :prompt "Handler" :sources (make-instance (case action (:enable 'disabled-handler-source) (:disable 'handler-source)) :hook hook))))) (define-command-global disable-hook-handler () "Remove handler of a hook." (manage-hook-handler :disable)) (define-command-global enable-hook-handler () "Add handler of a hook." (manage-hook-handler :enable)) ================================================ FILE: source/command.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :nyxt) (defvar *command-list* '() "The list of known commands, for internal use only.") (define-class command (standard-generic-function) ((visibility :mode :type (member :global :mode :anonymous) :reader t :writer nil :documentation "Sets whether command is listed in `command-source'. - `:global' always lists it. This is mostly useful for third-party packages to define globally-accessible commands without polluting the official Nyxt packages. - `:mode' lists it when the corresponding mode is active. - `:anonymous' never lists it.") (last-access (time:now) :type time:timestamp :documentation "Last time this command was called from prompt buffer. Useful to sort the commands by most recent use.")) (:metaclass closer-mop:funcallable-standard-class) (:export-class-name-p t) (:export-accessor-names-p t) (:export-predicate-name-p t) (:documentation "Commands are interactive functions. (As in Emacs.) Commands are funcallable. We need a `command' class for multiple reasons: - Identify commands uniquely. - Customize prompt buffer display value with properties. - Last access: This is useful to sort command by the time they were last called. The only way to do this is to persist the command instances. Since they are generic functions, they can be specialize with `:before', `:after' and `:around' qualifiers, effectively acting as hooks. These specializations are reserved to the user.")) (defmethod name ((command command)) "A useful shortcut." (closer-mop:generic-function-name command)) (defun initialize-command (command lambda-expression) (when (uiop:emptyp (closer-mop:generic-function-name command)) (alex:required-argument 'name)) (when lambda-expression ;; `closer-mop:ensure-method' calls `add-method' which reinitializes the ;; command / generic function, thus running `initialize-command' twice each ;; time. TODO: Can we avoid this? (closer-mop:ensure-method command lambda-expression) (when (uiop:emptyp (documentation command t)) (let ((doc (nth-value 2 (alex:parse-body (rest (rest lambda-expression)) :documentation t)))) (if (and (uiop:emptyp doc) (not (eq :anonymous (visibility command)))) (error "Command ~a requires documentation." (name command)) (setf (documentation command 'function) doc))))) (unless (eq :anonymous (visibility command)) ;; Overwrite previous command: (setf *command-list* (delete (closer-mop:generic-function-name command) *command-list* :key #'closer-mop:generic-function-name)) (push command *command-list*))) (defmethod initialize-instance :after ((command command) &key lambda-expression &allow-other-keys) (initialize-command command lambda-expression)) (defmethod reinitialize-instance :after ((command command) &key lambda-expression &allow-other-keys) (initialize-command command lambda-expression)) (defun find-command (name) (find name *command-list* :key #'name)) ;; TODO: Can we use `alex:named-lambda'? How do we get the name then? (export-always 'make-command) (defun make-command (name lambda-expression &optional (visibility :anonymous)) "Return an non-globally defined command named NAME." (make-instance 'command :name name :lambda-expression lambda-expression :visibility visibility)) (export-always 'lambda-command) (defmacro lambda-command (name args &body body) "ARGS may only be a list of required arguments (optional and keyword argument not allowed). Example: \(let ((source (make-my-source))) (lambda-command open-file* (files) \"Open files in some way.\" ;; Note that `source' is captured in the closure. (mapc (opener source) files)))" (let ((doc (nth-value 2 (alex:parse-body body :documentation t)))) (alex:with-gensyms (closed-over-body) ;; Warning: `make-command' takes a lambda-expression as an unevaluated list, ;; thus the BODY environment is not that of the lexical environment ;; (closures would thus fail to close over). To avoid this problem, we capture ;; the lexical environment in a lambda. ;; ;; Note that this relies on the assumption that ARGS is just a list of ;; _required arguments_, which is a same assumption for prompt buffer actions. ;; We could remove this limitation with some argument parsing. `(let ((,closed-over-body (lambda ,args ,@body))) (make-command ',name (list 'lambda ',args ,doc (list 'apply ,closed-over-body '(list ,@args)))))))) (export-always 'lambda-mapped-command) (defmacro lambda-mapped-command (function-symbol) "Define a command which `mapcar's FUNCTION-SYMBOL over a list of arguments." (let ((name (intern (str:concat (string function-symbol) "-*")))) `(lambda-command ,name (arg-list) ,(documentation function-symbol 'function) (mapcar ',function-symbol arg-list)))) (export-always 'lambda-unmapped-command) (defmacro lambda-unmapped-command (function-symbol) "Define a command which calls FUNCTION-SYMBOL over the first element of a list of arguments." (let ((name (intern (str:concat (string function-symbol) "-1")))) `(lambda-command ,name (arg-list) ,(documentation function-symbol 'function) (,function-symbol (first arg-list))))) (eval-always (defun generalize-lambda-list (lambda-list) "Return a lambda-list compatible with generic-function definitions. Generic function lambda lists differ from ordinary lambda list in some ways; see HyperSpec '3.4.2 Generic Function Lambda Lists'." (multiple-value-bind (required optional rest keywords aok? aux key?) (alex:parse-ordinary-lambda-list lambda-list) (declare (ignore aux)) (sera:unparse-ordinary-lambda-list required (mapcar #'first optional) rest (mapcar #'cadar keywords) aok? nil key?)))) (export-always 'define-command) (defmacro define-command (name (&rest arglist) &body body) "Define new command NAME. `define-command' syntax is similar to `defmethod'. Example: \(define-command play-video-in-current-page (&optional (buffer (current-buffer))) \"Play video in the currently open buffer.\" (uiop:run-program (list \"mpv\" (render-url (url buffer)))))" (let ((doc (or (nth-value 2 (alex:parse-body body :documentation t)) ""))) `(progn (export-always ',name (symbol-package ',name)) ;; Warning: We use `defgeneric' instead of `make-instance' (or even ;; `ensure-generic-function') so that the compiler stores source location ;; information (for "go to definition" to work). (sera:lret ((gf (defgeneric ,name (,@(generalize-lambda-list arglist)) (:documentation ,doc) (:method (,@arglist) ,@body) (:generic-function-class command)))) (setf (slot-value gf 'visibility) :mode))))) (export-always 'define-command-global) (defmacro define-command-global (name (&rest arglist) &body body) "Like `define-command' but mark the command as global. This means it will be listed in `command-source' when the global option is on. This is mostly useful for third-party packages to define globally-accessible commands without polluting Nyxt packages." `(sera:lret ((cmd (define-command ,name (,@arglist) ,@body))) (setf (slot-value cmd 'visibility) :global))) (export-always 'delete-command) (defun delete-command (name) "Remove command NAME, if any. Any function or macro definition of NAME is also removed, regardless of whether NAME is defined as a command." (setf *command-list* (delete name *command-list* :key #'name)) (fmakunbound name)) (-> list-all-maybe-subpackages () (list-of types:package-designator)) (defun list-all-maybe-subpackages () (remove-if-not (lambda (pkg) (find #\/ (package-name pkg))) (list-all-packages))) (export-always 'subpackage-p) (-> subpackage-p (types:package-designator types:package-designator) (values boolean &optional)) (defun subpackage-p (subpackage package) "Return non-nil if SUBPACKAGE is a subpackage of PACKAGE or is PACKAGE itself. A subpackage has a name that starts with that of PACKAGE followed by a '/' separator." (or (eq (find-package subpackage) (find-package package)) (uiop:string-prefix-p (uiop:strcat (package-name package) "/") (package-name subpackage)))) (export-always 'subpackages) (-> subpackages (types:package-designator) (list-of types:package-designator)) (defun subpackages (package) "Return all subpackages of PACKAGE, including itself." (append (list package) (remove-if-not (lambda (p) (subpackage-p p package)) (list-all-maybe-subpackages)))) (-> nyxt-subpackage-p (types:package-designator) boolean) (defun nyxt-subpackage-p (package) "Return non-nil if PACKAGE is a sub-package of `nyxt'." (subpackage-p package :nyxt)) (-> nyxt-user-subpackage-p (types:package-designator) boolean) (defun nyxt-user-subpackage-p (package) "Return non-nil if PACKAGE is a sub-package of `nyxt' or `nyxt-user'." (subpackage-p package :nyxt-user)) (defun nyxt-packages () "Return all Nyxt packages. See also `nyxt-user-packages', `nyxt-extension-packages' and `non-nyxt-packages'." (sera:filter #'nyxt-subpackage-p (list-all-packages))) (defun nyxt-user-packages () "Return all Nyxt user packages." (sera:filter #'nyxt-user-subpackage-p (list-all-packages))) (defun nyxt-extension-packages () "Return all the Nyxt extension packages. A package is considered an extension one if its name is \"nx-\"-prefixed." (remove-if-not (curry #'str:starts-with-p "NX-") (list-all-packages) :key #'package-name)) (defun non-nyxt-packages () "Return the packages that are not related to Nyxt. It's the complement of `nyxt-packages' and `nyxt-user-packages'." (set-difference (list-all-packages) (append (nyxt-packages) (nyxt-user-packages)))) (define-class slot () ((name nil :type (or symbol null)) (class-sym nil :type (or symbol null)))) (defun class-slots (class-sym &key (visibility :any)) "Return the list of slots with VISIBILITY." (sym:filter-symbols visibility (mopu:slot-names class-sym))) (defmethod prompter:object-attributes ((slot slot) (source prompter:source)) (declare (ignore source)) `(("Name" ,(string (name slot))) ("Class" ,(string (class-sym slot))))) (defun package-slots (packages &optional (visibility :any)) "Return the list of all slot symbols in PACKAGES. See `sym:package-symbols'." (mappend (lambda (class-sym) (mapcar (lambda (slot) (make-instance 'slot :name slot :class-sym class-sym)) (class-slots class-sym :visibility visibility))) (sym:package-classes packages))) (sym:define-symbol-type command (function) (command-p (ignore-errors (symbol-function sym:%symbol%)))) (defun list-commands (&key global-p mode-symbols) "List commands. Commands are instances of the `command' class. When MODE-SYMBOLS are provided, list only the commands that belong to the corresponding mode packages or of a parent mode packages. Otherwise list all commands. Additionally, list all commands within the Nyxt package. With MODE-SYMBOLS and GLOBAL-P, include global commands." ;; TODO: Make sure we list commands of inherited modes. (if mode-symbols (lpara:premove-if (lambda (command) (and (or (not global-p) (not (eq :global (visibility command)))) (notany (lambda (mode-symbol) (or (eq (symbol-package (name command)) (symbol-package mode-symbol)) (member (symbol-package (name command)) (mapcar #'symbol-package (sera:filter (symbol-function (uiop:safe-read-from-string "sym:mode-symbol-p" :package :nyxt)) (mapcar #'class-name (mopu:superclasses mode-symbol))))))) mode-symbols))) *command-list*) *command-list*)) (defun list-mode-commands (mode-symbol) "List commands. Commands are instances of the `command' class. Only commands defined within the context of a mode are listed." (remove-if-not (lambda (command) (eq (symbol-package (name command)) (symbol-package mode-symbol))) *command-list*)) (defun run-command (command &optional args) ;; Bind current buffer for the duration of the command. This ;; way, if the user switches buffer after running a command ;; but before command termination, `current-buffer' will ;; return the buffer from which the command was invoked. (with-current-buffer (current-buffer) (handler-case (apply #'funcall command args) (prompt-buffer-canceled () (log:debug "Prompt buffer interrupted") nil)))) (defun run (command &optional args) "Run COMMAND over ARGS and return its result. This is blocking, see `run-async' for an asynchronous way to run commands." (let ((channel (make-channel 1)) (error-channel (make-channel 1))) (run-thread "run command" ;; TODO: This `handler-case' overlaps with `with-protect' from `run-thread'. Factor them! (handler-case (calispel:! channel (run-command command args)) (condition (c) (calispel:! error-channel c)))) (calispel:fair-alt ((calispel:? channel result) result) ((calispel:? error-channel c) (echo-warning "Error when running ~a: ~a" command c))))) (defun run-async (command &optional args) "Run COMMAND over ARGS asynchronously. See `run' for a way to run commands in a synchronous fashion and return the result." (run-thread "run-async command" (run-command command args))) (define-command nothing () ; TODO: Replace with ESCAPE special command that allows dispatched to cancel current key stack. "A command that does nothing. This is useful to override bindings to do nothing." (values)) ================================================ FILE: source/concurrency.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :nyxt) (defun initialize-lparallel-kernel (&key (worker-count (sera:count-cpus))) "Initialize the lparallel kernel with WORKER-COUNT, if not supplied set it to the amount of CPU cores." (unless lpara:*kernel* (setf lpara:*kernel* (lpara:make-kernel worker-count)))) (defun restart-browser (c) "Restart browser reporting condition C." (funcall 'restart-with-message ; Not defined yet. :condition c :backtrace (with-output-to-string (stream) (uiop:print-backtrace :stream stream :condition c)))) (export-always 'with-protect) (defmacro with-protect ((format-string &rest args) &body body) "Run body with muffled conditions when `*run-from-repl-p*' is nil, run normally otherwise. When the condition is muffled, a warning is reported to the user as per FORMAT-STRING and ARGS. As a special case, the first `:condition' keyword in ARGS is replaced with the raised condition." (alex:with-gensyms (c sub-c) `(if (or *run-from-repl-p*) (handler-case (progn ,@body) (prompt-buffer-canceled () (log:debug "Prompt buffer interrupted"))) (ignore-errors (handler-bind ((error (lambda (,c) (declare (ignorable ,c)) (if *restart-on-error* (restart-browser ,c) ,(let ((condition-index (position :condition args))) (flet ((new-args (condition condition-index &optional escaped-p) (if condition-index (append (subseq args 0 condition-index) (list (if escaped-p `(plump:encode-entities (princ-to-string ,condition)) `,condition)) (subseq args (1+ condition-index))) 'args))) `(handler-bind ((t (lambda (,sub-c) (declare (ignore ,sub-c)) (log:error ,format-string ,@(new-args c condition-index)) (invoke-restart 'continue)))) (echo-warning ,format-string ,@(new-args c condition-index :escaped-p))))))))) ,@body))))) (defun make-channel (&optional size) "Return a channel of capacity SIZE. If SIZE is NIL, capacity is infinite." (cond ((null size) (make-instance 'calispel:channel :buffer (make-instance 'jpl-queues:unbounded-fifo-queue))) ((zerop size) (make-instance 'calispel:channel)) ((plusp size) (make-instance 'calispel:channel :buffer (make-instance 'jpl-queues:bounded-fifo-queue :capacity size))))) (defun drain-channel (channel &optional timeout) "Listen to CHANNEL until a value is available, then return all CHANNEL values as a list. TIMEOUT specifies how long to wait for a value after the first one. This is a blocking operation." (labels ((fetch () (multiple-value-bind (value received?) (calispel:? channel timeout) (if received? (cons value (fetch)) nil)))) (cons (calispel:? channel) (nreverse (fetch))))) (export-always 'run-thread) (defmacro run-thread (name &body body) "Run body in a new protected thread. This supersedes `bt:make-thread' in Nyxt. Don't use the latter unless you know what you are doing!" `(lparallel.thread-util:with-thread (:name ,(str:concat "Nyxt " name) :bindings (append '((*run-from-repl-p* . *run-from-repl-p*) (*headless-p* . *headless-p*)) bt:*default-special-bindings*)) (with-protect ("Error on separate thread: ~a" :condition) ,@body))) (defun evaluate (string) "Evaluate all expressions in STRING and return the last result as a list of values. The list of values is useful when the last result is multi-valued, e.g. (values 'a 'b). You need not wrap multiple values in a PROGN, all top-level expressions are evaluated in order." (let ((channel (make-channel 2))) (run-thread "evaluator" (let ((*standard-output* (make-string-output-stream))) (calispel:! channel (with-input-from-string (input string) (first (last (mapcar (lambda (s-exp) (multiple-value-list (with-protect ("Error in s-exp evaluation: ~a" :condition) (eval s-exp)))) (safe-slurp-stream-forms input)))))) (calispel:! channel (get-output-stream-string *standard-output*)))) (values (calispel:? channel) (calispel:? channel)))) (defun evaluate-async (string) "Like `evaluate' but does not block and does not return the result." (run-thread "async evaluator" (with-input-from-string (input string) (dolist (s-exp (safe-slurp-stream-forms input)) (funcall (lambda () (with-protect ("Error in s-exp evaluation: ~a" :condition) (eval s-exp)))))))) ================================================ FILE: source/conditions.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :nyxt) (export-always 'nyxt-error) (define-condition nyxt-error (error) ((message :initarg :message :accessor message)) (:report (lambda (c stream) (format stream "~a" (slot-value c 'message)))) (:documentation "An error internal to Nyxt. It should abort the ongoing command, but not the whole process.")) (export-always 'browser-already-started) (define-condition browser-already-started (nyxt-error) () (:documentation "An existing instance of Nyxt is already running.")) (export-always 'prompt-buffer-canceled) (define-condition prompt-buffer-canceled (error) () (:documentation "Signaled when prompt buffer is exited abnormally (via ESC key, for example).")) ================================================ FILE: source/configuration-commands.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :nyxt) (defun error-in-new-window (title condition-string backtrace) (sera:lret* ((window (window-make *browser*)) (error-buffer (make-instance 'document-buffer))) (with-current-buffer error-buffer (html-set (values (spinneret:with-html-string (:head (:title title) (:nstyle (style (current-buffer)))) (:body (:h1 title) (:h2 "Condition") (:pre condition-string) (:h2 "Backtrace") (:pre backtrace))) "text/html;charset=utf8") error-buffer)) (ffi-window-set-buffer window error-buffer))) (-> load-lisp ((or null types:pathname-designator) &key (:package (or null package))) *) (defun load-lisp (file &key package) "Load the Lisp FILE (can also be a stream). Return T on success. On error, return the condition as a first value and the backtrace as second value." (unless (files:nil-pathname-p file) (let ((*package* (or (find-package package) *package*))) (flet ((unsafe-load () (cond ((streamp file) (load file)) ((uiop:file-exists-p file) (log:info "Loading Lisp file ~s." file) (load file)) (t (log:debug "Lisp file ~s does not exist." file))) nil)) (if *run-from-repl-p* (tagbody loop (restart-case (unsafe-load) (load-lisp-retry () :report "Retry loading Lisp file." (go loop)))) (catch 'lisp-file-error (handler-bind ((error (lambda (c) (let ((backtrace (with-output-to-string (stream) (uiop:print-backtrace :stream stream :condition c)))) (throw 'lisp-file-error (if *browser* (error-in-new-window "*Config file errors*" (princ-to-string c) backtrace) (values c backtrace))))))) (unsafe-load)))))))) (define-command load-file () "Load the prompted Lisp file." (prompt :prompt "Load file" :input (uiop:native-namestring (let ((config-path (files:expand *config-file*))) (if (uiop:file-exists-p config-path) (uiop:pathname-directory-pathname config-path) (uiop:getcwd)))) :extra-modes 'nyxt/mode/file-manager:file-manager-mode :sources (make-instance 'nyxt/mode/file-manager:file-source :extensions '("lisp") :actions-on-return (lambda-command load-file* (files) (dolist (file files) (load-lisp file)))))) (export-always 'clean-configuration) (defun clean-configuration () "Undo user configuration set by `define-configuration' or `customize-instance'." (dolist (class (sera:filter #'user-class-p (sym:package-classes* (nyxt-packages)))) (setf (hooks:handlers-alist (slot-value class 'customize-hook)) nil)) (dolist (method (mopu:generic-function-methods #'customize-instance)) (unless (or (equal (list (find-class t)) ; Don't remove default method. (mopu:method-specializers method)) ;; We only preserve :after methods for ourselves. (equal (list :after) (method-qualifiers method)))))) (define-command load-config-file (&key (config-file (files:expand *config-file*))) "Load or reload the CONFIG-FILE." (if (files:nil-pathname-p config-file) (echo "No config file.") (progn (clean-configuration) (load-lisp config-file :package (find-package :nyxt-user)) (echo "~a loaded." config-file)))) #+(and unix (not darwin)) (define-command add-desktop-entry () "Install the running AppImage to the system menu via a `.desktop' entry. The path installed to is `~/.local/share/applications/'." (let* ((appimage-path (uiop:getenv "APPIMAGE_PATH")) (desktop-entry-dir "~/.local/share/applications/") (icons-dir "~/.local/share/icons/hicolor/") (desktop-entry-path (uiop:merge-pathnames* (make-pathname :name "nyxt.desktop") desktop-entry-dir))) (ensure-directories-exist desktop-entry-dir) (uiop:with-output-file (stream desktop-entry-path :if-exists :supersede) (format stream (gethash "nyxt.desktop" *static-data*) appimage-path)) (loop for resolution in '("16x16" "32x32" "128x128" "256x256") do (let* ((icon (gethash (format nil "nyxt_~a.png" resolution) *static-data*)) (icon-dir (uiop:merge-pathnames* (format nil "~a/apps/" resolution) icons-dir)) (icon-path (uiop:merge-pathnames* "nyxt.png" icon-dir))) (ensure-directories-exist icon-dir) (uiop:with-output-file (stream icon-path :element-type '(unsigned-byte 8) :if-exists :supersede) (write-sequence icon stream)))) (uiop:launch-program "update-desktop-database") (echo "Added Nyxt to the system menu.~%"))) ================================================ FILE: source/configuration.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :nyxt) (define-class config-directory-file (files:config-file nyxt-file) ((files:base-path #p"")) (:export-class-name-p t) (:documentation "Nyxt directory for config files.")) (define-class config-special-file (config-directory-file) ((files:base-path #p"") (command-line-option :config :accessor nil :type keyword)) (:export-class-name-p t) (:documentation "Like `config-directory-file' but can be controlled from command line options.")) (define-class config-file (config-special-file nyxt-lisp-file) ((files:base-path #p"config") (command-line-option :config :accessor nil :type keyword)) (:export-class-name-p t) (:documentation "Lisp configuration file which path can be controlled from command line options. Unlike `auto-config-file', it can only be loaded with `cl:load', it is not meant to be read with `nfiles:read-file' or `nfiles:content'.")) (defmethod files:read-file ((profile nyxt-profile) (file config-file) &key) "Don't load anything for `config-file's since they are Lisp file to be loaded with `cl:load'." nil) (define-class auto-config-file (config-special-file nyxt-lisp-file) ((files:base-path (files:join #p"auto-config." (princ-to-string (version)))) (command-line-option :auto-config :accessor nil :type keyword)) (:export-class-name-p t) (:documentation "Lisp configuration file which path can be controlled from command line options. Unlike `config-file', it can both loaded with `cl:load' and read with `nfiles:read-file'. The latter should return a structured reification of the configuration.")) (defmethod files:resolve ((profile nyxt-profile) (config-file config-special-file)) (let* ((option (slot-value config-file 'command-line-option)) (no-option (alex:make-keyword (uiop:strcat "NO-" (symbol-name option))))) (if (getf *options* no-option) #p"" (let ((path (or (uiop:ensure-pathname (getf *options* option)) (call-next-method)))) (unless (uiop:emptyp path) (when (and (getf *options* option) (not (uiop:file-exists-p path))) (log:warn "File ~s does not exist." path)) path))))) (export-always '*auto-config-file*) (defvar *auto-config-file* (make-instance 'auto-config-file) "The generated configuration file.") (export-always '*config-file*) (defvar *config-file* (make-instance 'config-file) "The configuration file entry point.") (define-class log-file (files:data-file nyxt-file) ((files:base-path #p"nyxt.log") (files:name "log-file")) (:export-class-name-p t) (:documentation "Data file for Nyxt logs.")) (export-always '*log-file*) (defvar *log-file* (make-instance 'log-file) "Path to the file where log is saved. This is global because logging starts before the `*browser*' is even initialized.") (defvar *log-pattern* "<%p> [%D{%H:%M:%S}] %m%n" "Non-verbose log pattern.") (define-class nyxt-source-directory (nyxt-file) ((files:name "source")) (:export-class-name-p t) (:documentation "Directory with Nyxt sources.")) (defmethod files:resolve ((profile nyxt-profile) (directory nyxt-source-directory)) "Try hard to find Nyxt source on disk. Return #p\"\" if not found." (let ((asd-path (ignore-errors (asdf:system-source-directory :nyxt)))) (if (uiop:directory-exists-p asd-path) asd-path (or ;; XDG / FHS: (find-if (lambda (d) (uiop:file-exists-p (uiop:merge-pathnames* "nyxt.asd" d))) (uiop:xdg-data-dirs "nyxt")) ;; Location relative to the binary: (let ((relative-dir (uiop:merge-pathnames* "share/nyxt/" (files:parent (files:parent (uiop:ensure-pathname (first (uiop:raw-command-line-arguments)) :truenamize t)))))) (when (uiop:file-exists-p (uiop:merge-pathnames* "nyxt.asd" relative-dir)) relative-dir)) ;; Not found: #p"")))) (export-always '*source-directory*) (defvar *source-directory* (make-instance 'nyxt-source-directory) "The directory where the source code is stored. This is set globally so that it can be looked up if there is no `*browser*' instance.") (define-class extensions-directory (files:data-file nyxt-file) ((files:base-path #p"extensions/") (files:name "extensions")) (:export-class-name-p t) (:documentation "Nyxt data subdirectory for Lisp extensions.")) (export-always '*extensions-directory*) (defvar *extensions-directory* (make-instance 'extensions-directory) "The directory where extensions are stored. This is set globally so that extensions can be loaded even if there is no `*browser*' instance.") (export-always 'nyxt-source-registry) (defun nyxt-source-registry () "Return Nyxt-specific ASDF registry, with source and extension directories." (let ((source-dir (files:expand *source-directory*))) `(:source-registry (:tree ,(files:expand *extensions-directory*)) ,@(unless (uiop:absolute-pathname-p source-dir) `((:tree ,source-dir))) ; Probably useless since systems are immutable. :inherit-configuration))) (defun set-nyxt-source-location (pathname) ; From `sb-ext:set-sbcl-source-location'. "Initialize the NYXT logical host based on PATHNAME, which should be the top-level directory of the Nyxt sources. This will replace any existing translations for \"NYXT:source;\" and \"NYXT:libraries;\". Other \"NYXT:\" translations are preserved." (let ((truename (truename pathname)) (current-translations (remove-if (lambda (translation) (or (pathname-match-p "NYXT:source;" translation) (pathname-match-p "NYXT:libraries;" translation))) (logical-pathname-translations "NYXT") :key #'first))) (flet ((physical-target (component) (merge-pathnames (make-pathname :directory (list :relative component :wild-inferiors) :name :wild :type :wild) truename))) (setf (logical-pathname-translations "NYXT") `(("NYXT:source;**;*.*.*" ,(physical-target "source")) ("NYXT:libraries;**;*.*.*" ,(physical-target "libraries")) ,@current-translations))))) (define-class slot-form () ((name nil :type symbol) (value nil :type t)) (:export-class-name-p t) (:documentation "A form to set slot with `name' to `value'.")) (define-class class-form () ((class-name nil :type symbol) (forms '() :type (maybe (cons (or cons slot-form) *)))) (:export-class-name-p t) (:documentation "A set of `forms' for class configuration.")) (defun read-init-form-slot (class-name sexp) "Return 2 values: - the slot name; - the slot value. Return NIL if not a slot setting." (when (and (= 3 (length sexp)) (eq (first sexp) 'setf) (eq (first (second sexp)) 'slot-value) (eq (second (second sexp)) class-name)) (let ((slot-name (second (third (second sexp)))) (slot-value (third sexp))) (values slot-name slot-value)))) (defun write-init-form-slot (class-name slot-form) `(setf (slot-value ,class-name ',(name slot-form)) ,(value slot-form))) (defun read-init-form-class (form) "Return: - the class name - the list of forms, either `slot-form' or a raw s-exp. Return NIL if not a class form." (when-let ((class-name (when (and (eq (first form) 'defmethod) (eq (second form) 'customize-instance)) (second (first (find-if #'consp form)))))) (let ((body (alex:parse-body (sera:nlet lp ((sexp form)) (if (consp (first sexp)) (rest sexp) (lp (rest sexp)))) :documentation t))) (values class-name (mapcar (lambda (sexp) (multiple-value-bind (name value) (read-init-form-slot class-name sexp) (if name (make-instance 'slot-form :name name :value value) sexp))) body))))) (defun write-init-form-class (class-form) `(defmethod customize-instance ((,(class-name class-form) ,(class-name class-form)) &key) ,@(mapcar (lambda (form) (if (slot-form-p form) (write-init-form-slot (class-name class-form) form) form)) (forms class-form)))) ;; TODO: Instantiate directly in read-init-*? (defmethod files:deserialize ((profile nyxt-profile) (file auto-config-file) raw-content &key) (flet ((make-init-form (form) (multiple-value-bind (name forms) (read-init-form-class form) (if name (make-instance 'class-form :class-name name :forms forms) form)))) (mapcar #'make-init-form (uiop:slurp-stream-forms raw-content)))) (defmethod files:serialize ((profile nyxt-profile) (file auto-config-file) stream &key) (loop for form in (files:content file) for i from 0 do (when (> i 0) (terpri stream)) (write (if (class-form-p form) (write-init-form-class form) form) :stream stream) (fresh-line stream))) (defmethod files:write-file ((profile nyxt-profile) (file auto-config-file) &key &allow-other-keys) (let ((*print-case* :downcase) (*package* (find-package :nyxt-user))) (log:info "Writing auto configuration to ~s." (files:expand file)) (call-next-method))) (defun auto-configure (&key form class-name slot (slot-value nil slot-value-supplied-p)) (files:with-file-content (config *auto-config-file*) (if class-name (flet ((ensure-class-form (class-name) (or (when config (find-if (sera:eqs class-name) (sera:filter #'class-form-p config) :key #'class-name)) (sera:lret ((form (make-instance 'class-form :class-name class-name))) (alex:appendf config (list form))))) (ensure-slot-form (class-form slot) (or (find-if (sera:eqs slot) (sera:filter #'slot-form-p (forms class-form)) :key #'name) (sera:lret ((form (make-instance 'slot-form :name slot))) (alex:appendf (forms class-form) (list form))))) (delete-slot-form (class-form slot) (delete-if (sera:eqs slot) (sera:filter #'slot-form-p (forms class-form)) :key #'name))) (let ((class-form (ensure-class-form class-name))) (if slot (if slot-value-supplied-p (sera:lret ((slot-form (ensure-slot-form class-form slot))) (setf (value slot-form) slot-value)) (setf (forms class-form) (delete-slot-form class-form slot))) (alex:appendf (forms class-form) (list form))))) (alex:appendf config (list form)))) (echo "Updated configuration in ~s." (files:expand *auto-config-file*))) (export-always '%slot-value%) (defvar %slot-value% nil "Holds the value of the slot being configured when in `define-configuration'.") (export-always '%slot-default%) (defvar %slot-default% nil "Holds the default value of the slot being configured when in `define-configuration'.") (export-always 'define-configuration) (defmacro define-configuration (classes &body slots-and-values) "Helper macro to customize the class slots of the CLASSES. CLASSES is either a symbol or a list of symbols. Only user-configurable classes are valid, such as `browser', `buffer', `prompt-buffer', `window' or modes such as `nyxt/mode/hint:hint-mode'. SLOTS-AND-VALUES is a list of slot re-definitions, optionally preceded by a docstring. The `%slot-default%' variable is replaced by the slot's initform, while `%slot-value%' is replaced by the slot's current value . Example: \(define-configuration web-buffer ((default-modes (pushnew 'nyxt/mode/force-https:force-https-mode %slot-value%)))) Example to get the `blocker-mode' command to use a new default hostlists: \(define-configuration nyxt/mode/blocker:blocker-mode ((nyxt/mode/blocker:hostlists (append (list *my-blocked-hosts*) %slot-default%) :doc \"You have to define *my-blocked-hosts* first.\"))) To discover the default value of a slot or all slots of a class, use the `describe-slot' or `describe-class' commands, respectively." (alex:with-gensyms (handler hook) `(progn ,@(loop ;; Strip off the docstring, it's merely cosmetic with slots-and-values = (if (stringp (first slots-and-values)) (rest slots-and-values) slots-and-values) for class-name in (uiop:ensure-list classes) ;; NOTE: `or' here because `sym:resolve-symbol' only searches through ;; Nyxt packages, while one may try to configure the ;; extension/application-specific class too. If `sym:resolve-symbol' ;; fails, then hope that `find-class' will either work or highlight ;; the problem. for class = (resolve-user-symbol class-name :class) append (loop for ((slot-name value . rest)) on (first slots-and-values) ;; FIXME: It's alarming that we resolve the slot name at ;; compile-time instead of run-time. Move to the handler ;; body maybe? for slot = (find (symbol-name slot-name) (mopu:slot-names class) :key #'symbol-name :test #'equal) ;; TODO: Shall we really make the name unique? Since we ;; are configuring slots, maybe not. for handler-name = (gensym (format nil "CONFIGURE-~a-~a" class slot)) when slot collect `(let ((,hook (slot-value (find-class (quote ,class)) 'nyxt::customize-hook)) (,handler (make-instance 'hooks:handler :fn (lambda (object) ,@(when (or (getf rest :documentation) (getf rest :doc)) (list (or (getf rest :documentation) (getf rest :doc)))) (declare (ignorable object)) (setf (slot-value object (quote ,slot)) (let* ((%slot-value% (slot-value object (quote ,slot))) (%slot-default% ,(if (c2mop:class-finalized-p (find-class class)) (getf (mopu:slot-properties class slot) :initform) (progn (echo-warning "Slot default not found for slot ~a of class ~a, falling back to its current value" slot class) '%slot-value%)))) (declare (ignorable %slot-value% %slot-default%)) ,value))) :name (quote ,handler-name)))) (hooks:add-hook ,hook ,handler :append t)) else do (log:warn "Not found slot ~a in class ~a, generating the wrapper method for configuration." slot-name class) and collect `(handler-bind ((warning #'muffle-warning)) (defmethod ,slot-name :around ((object ,class)) (let* ((%slot-value% (call-next-method)) (%slot-default% %slot-value%)) ,value)))))))) (defparameter %buffer nil) ; TODO: Make a monad? (export-always 'current-buffer) (defun current-buffer (&optional window) "Get the active buffer for WINDOW, or the active window otherwise." (or %buffer (if-let ((w (or window (current-window)))) (active-buffer w) (when *browser* (log:debug "No active window, picking last active buffer.") (last-active-buffer))))) (export-always 'with-current-buffer) (defmacro with-current-buffer (buffer &body body) "Execute BODY in a context in which `current-buffer' returns BUFFER." ;; We `unwind-protect' to restore the right buffer when nesting this macro. `(let ((old-%buffer %buffer)) (if (buffer-p ,buffer) (unwind-protect (let ((%buffer ,buffer)) ,@body) (setf %buffer old-%buffer)) ;; TODO: Raise error instead? (log:warn "Expected buffer, got ~a" ,buffer)))) ;; TODO: Disallow canceling the prompt? Allow changing order of YES and NO so ;; that one makes a conscious effort to choose a YES? ;; TODO: Add an "always (yes|no)" answers/clauses and do something with those? ;; - Remembering prompt answers in history. ;; - Serializing thing (like notification permissions) to disk. ;; - Or simply leaving the interpretation of this clause to the user. ;; But maybe that's beyond if-confirm. (export-always 'if-confirm) (defmacro if-confirm ((prompt &key (yes "yes" yes-supplied-p) (no "no" no-supplied-p)) &optional (yes-form t) no-form) "Ask the user for confirmation before executing either YES-FORM or NO-FORM. YES-FORM is executed on YES answer, NO-FORM -- otherwise (including NO and prompt cancellation). PROMPT should evaluate to a string. Examples: ;; Return t/nil on user decision. \(if-confirm (\"you agree?\")) ;; Customize the yes/no answers, and get the mood of the user as boolean. \(if-confirm ((format nil \"How are you?\") :yes \"Good!\" :no \"Don't even ask...\")) ;; Commit an action in case of yes, clean up on no \(if-confirm (\"Overwrite the file?\" :no \"cancel\") (overwrite-file-because-confirmed) (clean-up/abort/stop))" `(let ((answer (handler-case (prompt1 :prompt ,prompt :sources (make-instance 'prompter:yes-no-source ,@(when yes-supplied-p (list :yes yes)) ,@(when no-supplied-p (list :no no))) :hide-suggestion-count-p t) (prompt-buffer-canceled () nil)))) (if answer ,yes-form ,no-form))) (defun set-as-default-browser (&key (name "nyxt") (targets (list (uiop:xdg-config-home "mimeapps.list") (uiop:xdg-data-home "applications/mimeapps.list")))) "Return the modified MIME apps list. Return the persisted file as second value." (declare (ignorable name targets)) #+(and unix (not darwin)) (let* ((target (or (first (sera:filter #'uiop:file-exists-p targets)) (first targets))) (config (py-configparser:read-files (py-configparser:make-config) (list target))) (desktop-file (uiop:strcat name ".desktop"))) (dolist (section '("Added Associations" "Default Applications")) (dolist (key '("text/html" "text/gemini" "x-scheme-handler/http" "x-scheme-handler/https" "x-scheme-handler/chrome" "application/x-extension-htm" "application/x-extension-html" "application/x-extension-shtml" "application/xhtml+xml" "application/x-extension-xhtml" "application/x-extension-xht")) (py-configparser:set-option config section key desktop-file))) (with-open-file (s target :direction :output :if-does-not-exist :create :if-exists :supersede) (py-configparser:write-stream config s)) (values config target)) #-(and unix (not darwin)) (log:warn "Only supported on GNU / BSD systems running XDG-compatible desktop environments.")) ;; TODO: Report compilation errors. (export-always 'nyxt-user-system) (defclass nyxt-user-system (asdf:system) ;; We cannot use :pathname because ASDF forces its value. ((config-directory :initarg :config-directory :initform nil :accessor config-directory)) (:documentation "Specialized systems for Nyxt users. This automatically defaults :pathname to the `*config-file*' directory unless overridden by the `:config-directory' option. See `define-nyxt-user-system' and `define-nyxt-user-system-and-load'.")) (defvar *nyxt-user-systems-with-missing-dependencies* '()) (defmethod asdf:component-pathname ((system nyxt-user-system)) "Default to `config-directory-file'." (or (config-directory system) (files:expand (make-instance 'config-directory-file))) ) (export-always 'load-system*) (defun load-system* (system &rest keys &key force force-not verbose version &allow-other-keys) "Like `asdf:load-system' but, instead of signaling an error on missing dependency, it warns the user, skips the load gracefully and returns NIL. When loading succeeds, it goes through the list of all the systems that failed to load and attempts to load them if their dependencies now seem to be met." ;; TODO: Ideally we would make this the default behavior of ;; `nyxt-user-system' by specializing a method Unfortunately ;; `resolve-dependency-name' is a function and `find-component' is called ;; against the `depends-on' element but not the system itself. (declare (ignore force force-not verbose version)) (block done (flet ((report (c) (pushnew (asdf:coerce-name system) *nyxt-user-systems-with-missing-dependencies* :test #'string=) (log:warn "Could not load system ~a: ~a" system c) (return-from done nil))) (handler-bind ((asdf:missing-dependency #'report) (asdf:missing-dependency-of-version #'report)) (prog1 (apply #'asdf:load-system system keys) (alex:removef *nyxt-user-systems-with-missing-dependencies* system :test #'string=) (dolist (system *nyxt-user-systems-with-missing-dependencies*) (when (every (rcurry #'asdf:find-system nil) (asdf:system-depends-on (asdf:find-system system))) (log:info "Load system ~s" system) (load-system* system)))))))) (defun ensure-component (component-designator) (if (consp component-designator) component-designator (list :file (sera:drop-suffix ".lisp" component-designator :test #'string-equal)))) (asdf:defsystem "nyxt-user") ; Dummy parent needs to exist for `define-nyxt-user-system' to define subsystems. (export-always 'define-nyxt-user-system) (defmacro define-nyxt-user-system (name &rest args &key depends-on components &allow-other-keys) "Define a user system, usually meant to load configuration files. Example to load the \"my-slynk-config\" file in your configuration directory. (define-nyxt-user-system nyxt-user/slynk :components (\"my-slynk-config\")) (asdf:load-system :nyxt-user/slynk) See also `define-nyxt-user-system-and-load'. It catches potential load dependency cycles. Arguments are the same as for `asdf:defsystem'. For convenience, we also support `string's or `pathname's directly in COMPONENTS. So instead of :components `((:file \"foo\") (:file #p\"bar\")) you can write :components `(\"foo\" #p\"bar\") It only works for top-level components, so if you introduce a module you'll have to use the full syntax. To change the base directory, pass the `:config-directory' option." ;; We specify DEPENDS-ON to emphasize its availability. (declare (ignore depends-on)) (unless (sera:string-prefix-p "nyxt-user/" (string name) ) (error "User system name must start with 'nyxt-user/'.")) ;; We cannot call `make-instance 'asdf:system' because we need to register the ;; system, and `register-system' is unexported. `(asdf:defsystem ,name :class nyxt-user-system ,@(uiop:remove-plist-key :components args) :components ,(mapcar #'ensure-component components))) (export-always 'define-nyxt-user-system-and-load) (defmacro define-nyxt-user-system-and-load (name &rest args &key depends-on components &allow-other-keys) "Like `define-nyxt-user-system' but schedule to load the system when all DEPENDS-ON packages are loaded. If they already are, load the system now. Return the system." ;; We specify DEPENDS-ON and COMPONENTS to emphasize their availability. (declare (ignore depends-on components)) `(prog1 (define-nyxt-user-system ,name ,@args) (load-system* ',name))) ================================================ FILE: source/describe.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (in-package :nyxt) (defun description-constructor (lister &key (test #'eql)) "LISTER is a function that returns a list of symbols or objects representing them from the given packages. TEST is a function that checks for equality for the purpose of deduplicating the result. See `sym:package-functions' for an example of LISTER." (lambda (source) (delete-duplicates (append (funcall lister (packages source) (visibility source)) (funcall lister (internal-visibility-packages source) :internal) (funcall lister (external-visibility-packages source) :external) (funcall lister (inherited-visibility-packages source) :inherited)) :test test))) (define-class describe-nyxt-source (prompter:source) ((visibility :any :type (member :internal :external :inherited :any) :documentation "Include symbol of this visibility from `packages'.") (packages (nyxt-user-packages) :type (maybe (list-of package)) :documentation "Include symbols of `visibility' from the given packages.") (internal-visibility-packages nil :type (maybe (list-of package)) :documentation "Include internal symbols from the given packages.") (external-visibility-packages (nyxt-packages) :type (maybe (list-of package)) :documentation "Include internal symbols from the given packages.") (inherited-visibility-packages nil :type (maybe (list-of package)) :documentation "Include internal symbols from the given packages.") (prompter:name (alex:required-argument 'prompter:name)) (prompter:constructor (alex:required-argument 'prompter:constructor)) (prompter:filter-preprocessor #'prompter:filter-exact-matches)) (:export-class-name-p nil) ; Internal class. (:export-accessor-names-p t)) (define-class describe-non-nyxt-source (describe-nyxt-source) ((packages nil :type (maybe (list-of package)) :documentation "Include symbols of `visibility' from the given packages.") (external-visibility-packages (non-nyxt-packages) :type (maybe (list-of package)) :documentation "Include internal symbols from the given packages.")) (:export-class-name-p nil) ; Internal class. (:export-accessor-names-p t)) (define-class describe-internal-source (describe-nyxt-source) ((packages nil :type (maybe (list-of package)) :documentation "Include symbols of `visibility' from the given packages.") (internal-visibility-packages (nyxt-packages) :type (maybe (list-of package)) :documentation "Include internal symbols from the given packages.") (external-visibility-packages nil :type (maybe (list-of package)) :documentation "Include internal symbols from the given packages.")) (:export-class-name-p nil) ; Internal class. (:export-accessor-names-p t)) (define-class function-source (describe-nyxt-source) ((prompter:name "Functions") (prompter:constructor (description-constructor #'sym:package-functions))) (:export-accessor-names-p t)) (define-class function-non-nyxt-source (function-source describe-non-nyxt-source) ((prompter:name "Non-Nyxt Functions"))) (define-class function-internal-source (function-source describe-internal-source) ((prompter:name "Internal Functions"))) (defun first-line (string) "Return first non-empty line in STRING." (find-if (complement #'uiop:emptyp) (sera:lines string))) (defmethod prompter:object-attributes ((symbol symbol) (source prompter:source)) (declare (ignore source)) `(("Name" ,(prini-to-string symbol) (:width 1)) ("Documentation" ,(or (cond ((fboundp symbol) (first-line (documentation symbol 'function))) ((and (find-class symbol nil) (mopu:subclassp (find-class symbol) (find-class 'standard-object))) (first-line (documentation symbol 'type))) ((find-package symbol) (first-line (documentation (find-package symbol) t))) (t (first-line (documentation symbol 'variable)))) "") (:width 4)) ("Visibility" ,(prini-to-string (sym:symbol-visibility symbol)) (:width 1)))) ;; Note that `package-source' is populated by symbols, not packages. (defmethod prompter:object-attributes ((package package) (source prompter:source)) (declare (ignore source)) `(("Name" ,(package-name package) (:width 1)) ("Documentation" ,(or (first-line (documentation package t)) "") (:width 4)) ("Nicknames" ,(append (package-nicknames package) ;; Old ASDF/UIOP don't know about package-local-nicknames. (ignore-errors (uiop:symbol-call :uiop :package-local-nicknames package))) (:width 1)))) (define-class class-source (describe-nyxt-source) ((prompter:name "Classes") (prompter:constructor (description-constructor #'sym:package-classes))) (:export-accessor-names-p t)) (define-class class-non-nyxt-source (class-source describe-non-nyxt-source) ((prompter:name "Non-Nyxt Classes"))) (define-class class-internal-source (class-source describe-internal-source) ((prompter:name "Internal Classes"))) (define-class slot-source (describe-nyxt-source) ((prompter:name "Slots") (prompter:constructor (description-constructor #'package-slots :test (lambda (slot-a slot-b) (equal `(,(name slot-a) ,(class-sym slot-a)) `(,(name slot-b) ,(class-sym slot-b))))))) (:export-accessor-names-p t)) (define-class slot-non-nyxt-source (slot-source describe-non-nyxt-source) ((prompter:name "Non-Nyxt Slots"))) (define-class slot-internal-source (slot-source describe-internal-source) ((prompter:name "Internal Slots"))) (defun non-keyword-package-variables (packages visibility) (remove-if #'keywordp (sym:package-variables packages visibility))) (define-class variable-source (describe-nyxt-source) ((prompter:name "Variables") (prompter:constructor (description-constructor #'non-keyword-package-variables))) (:export-accessor-names-p t)) (define-class variable-non-nyxt-source (variable-source describe-non-nyxt-source) ((prompter:name "Non-Nyxt Variables"))) (define-class variable-internal-source (variable-source describe-internal-source) ((prompter:name "Internal Variables"))) (define-class package-source (prompter:source) ((prompter:name "Packages") (prompter:constructor (mapcar (compose #'intern #'package-name) (list-all-packages))) (prompter:filter-preprocessor #'prompter:filter-exact-matches))) (define-internal-page-command-global describe-any (&key input) (buffer (format nil "*Describe-~a*" input) 'nyxt/mode/help:help-mode) "Inspect anything and show it in a help buffer. When input exists, list all the symbols that may match it. Otherwise prompt for matches." (when (symbolp input) (spinneret:with-html-string (:h1 (princ-to-string input)) (:p (princ-to-string input) " may refer to several things. Please choose the one that you need.") (:dl (when (boundp input) (:dt "Variable") (:dd (:nxref :variable input))) (cond ((sym:mode-symbol-p input) (:dt "Mode") (:dd (:nxref :mode input))) ((sym:class-symbol-p input) (:dt "Class") (:nxref :class-name input)) (t nil)) (cond ((sym:command-symbol-p input) (:dt "Command") (:dd (:nxref :command input))) ((sym:macro-symbol-p input) (:dt "Macro") (:dd (:nxref :macro input))) ((sym:function-symbol-p input) (:dt "Function") (:dd (:nxref :function input)))) (when (find-package input) (:dt "Package") (:dd (:nxref :package input))) (dolist (class (sym:package-classes (union (nyxt-packages) (list (symbol-package input))) :external)) (when (find input (class-slots class)) (:dt "Slot in " (:nxref :class-name class)) (:dd (:nxref :class-name class :slot input)))))))) (defmethod describe-any :around (&key (input nil input-supplied-p) %buffer%) (declare (ignorable input %buffer%)) (cond ((and input-supplied-p (symbolp input)) (call-next-method)) (t (let ((sources (list (make-instance 'command-source :actions-on-return (lambda-command describe-command* (commands) (describe-command :command (name (first commands))))) (make-instance 'mode-source :actions-on-return (lambda-command describe-command* (modes) (describe-mode :mode (first modes)))) (make-instance 'variable-source :actions-on-return (lambda-command describe-variable* (variables) (describe-variable :variable (first variables)))) (make-instance 'function-source :actions-on-return (lambda-command describe-function* (functions) (describe-function :fn (first functions)))) (make-instance 'class-source :actions-on-return (lambda-command describe-class* (classes) (describe-class :class (first classes)))) (make-instance 'slot-source :actions-on-return (lambda-command describe-slot** (slots) (describe-slot :class (class-sym (first slots)) :name (name (first slots))))) (make-instance 'variable-non-nyxt-source :actions-on-return (lambda-command describe-variable* (variables) (describe-variable :variable (first variables)))) (make-instance 'function-non-nyxt-source :actions-on-return (lambda-command describe-function* (functions) (describe-function :fn (first functions)))) (make-instance 'class-non-nyxt-source :actions-on-return (lambda-command describe-class* (classes) (describe-class :class (first classes)))) (make-instance 'slot-non-nyxt-source :actions-on-return (lambda-command describe-slot** (slots) (describe-slot :class (class-sym (first slots)) :name (name (first slots))))) (make-instance 'variable-internal-source :actions-on-return (lambda-command describe-variable* (variables) (describe-variable :variable (first variables)))) (make-instance 'function-internal-source :actions-on-return (lambda-command describe-function* (functions) (describe-function :fn (first functions)))) (make-instance 'class-internal-source :actions-on-return (lambda-command describe-class* (classes) (describe-class :class (first classes)))) (make-instance 'slot-internal-source :actions-on-return (lambda-command describe-slot** (slots) (describe-slot :class (class-sym (first slots)) :name (name (first slots)))))))) (prompt :prompt "Describe" :input input :sources sources))))) (define-internal-page describe-value (&key id) (:title "*Help-value*" :page-mode 'nyxt/mode/help:help-mode) "Inspect value under ID and show it in a help buffer." (and-let* ((id id) (value (inspected-value id))) (spinneret:with-html-string (:h1 (:raw (escaped-literal-print value))) (:dl (:dt "Type") (:dd (:pre (if (sym:class-symbol-p (type-of value)) (:nxref :class-name (type-of value)) (prini-to-string (type-of value)))))) (:p (:raw (value->html value)))))) (define-internal-page-command-global describe-package (&key (package (prompt1 :prompt "Describe package" :sources 'package-source))) (buffer (str:concat "*Help-" (package-name (find-package package)) "*") 'nyxt/mode/help:help-mode) "Inspect a package and show it in a help buffer." (let* ((package (find-package package)) (total-symbols (sym:package-symbols (list package))) (external-symbols (sym:package-symbols (list package) :visibility :external))) (flet ((package-markup (package) (spinneret:with-html (:a :href (nyxt-url 'describe-package :package (package-name package)) (package-name package))))) (spinneret:with-html-string (:nstyle (style buffer)) (:h1 (package-name package)) (:pre (:code (:raw (resolve-backtick-quote-links (documentation (find-package package) t) package)))) (:h2 "Symbols:") (:ul (:li "External: " (length external-symbols)) (:li "Internal: " (- (length total-symbols) (length external-symbols))) (:li "Total: " (length total-symbols))) (when (package-use-list package) (:h2 "Use list:") (:ul (dolist (use (safe-sort (package-use-list package) :key #'package-name)) (:li (package-markup use))))) (when (package-used-by-list package) (:h2 "Used by list:") (:ul (dolist (use (safe-sort (package-used-by-list package) :key #'package-name)) (:li (package-markup use))))))))) (define-internal-page-command-global describe-variable (&key (variable (prompt1 :prompt "Describe variable" :sources '(variable-source variable-non-nyxt-source variable-internal-source)))) (buffer (str:concat "*Help-" (symbol-name variable) "*") 'nyxt/mode/help:help-mode) "Inspect a variable and show it in a help buffer." (let ((*print-case* :downcase)) (if (boundp variable) (spinneret:with-html-string (:nstyle (style buffer)) (:h1 (format nil "~s" variable)) ; Use FORMAT to keep package prefix. (:pre (:code (:raw (resolve-backtick-quote-links (documentation variable 'variable) (symbol-package variable))))) (:h2 "Type") (:pre (princ-to-string (type-of (symbol-value variable)))) (:h2 "Current Value:") (:p (:raw (value->html (symbol-value variable)))) (:nsection :title "Describe" (:pre (:code (with-output-to-string (s) (describe variable s)))))) (spinneret:with-html-string (:nstyle (style buffer)) (:h1 (format nil "~s" variable)) (:p "Unbound"))))) (defun format-function-type (function-type) (match function-type ((list 'function argument-types return-types) (with-output-to-string (s) (format s "Argument types: ~s~&" argument-types) (format s "Return types: ~s~&" return-types))))) (define-internal-page-command-global describe-function (&key (fn (prompt1 :prompt "Describe function" :sources '(function-source function-non-nyxt-source function-internal-source))) ;; This is to have a full-word alternative to :fn for those that prefer it. (function fn)) (buffer (str:concat "*Help-" (symbol-name function) "*") 'nyxt/mode/help:help-mode) "Inspect a function and show it in a help buffer. For generic functions, describe all the methods." (if function (let ((input function)) (flet ((fun-desc (input) (spinneret:with-html-string (:pre (:code (:raw (resolve-backtick-quote-links (documentation input 'function) (symbol-package input))))) (when (sym:command-symbol-p input) (let* ((key-keymap-pairs (nth-value 1 (keymaps:pretty-binding-keys input (all-keymaps) :print-style (keymaps:name (keyscheme buffer))))) (key-keymapname-pairs (mapcar (lambda (pair) (list (first pair) (keymaps:name (second pair)))) key-keymap-pairs))) (when key-keymapname-pairs (:nsection :title "Bindings" (:table (:tr (:th "Binding") (:th "Keymap name")) (loop for (binding keymapname) in key-keymapname-pairs collect (:tr (:td binding) (:td keymapname)))))))) (:nsection :title "Argument list" (:pre (:code (prini-to-string (trivial-arguments:arglist input) :package (symbol-package input))))) #+sbcl (unless (or (macro-function input) (eq 'function (sb-introspect:function-type input))) (:nsection :title "Type" (:p (:pre (format-function-type (sb-introspect:function-type input)))))) (:nsection :title "Describe" (:pre (:code (with-output-to-string (s) (describe (symbol-function input) s))))))) (method-desc (method) (spinneret:with-html-string (:details (:summary (:h3 :style "display: inline" (format nil "~s" input) " " (:raw (format nil "(~{~a~^ ~})" (mapcar (lambda (class) (cond ((ignore-errors (mopu:subclassp class 'standard-object)) (spinneret:with-html-string (:a :href (nyxt-url 'describe-class :class (class-name class)) (prini-to-string (class-name class))))) ((ignore-errors (eq t (class-name class))) "t") (t (nyxt::escaped-literal-print class)))) (mopu:method-specializers method)))))) (:button :class "button" :onclick (ps:ps (nyxt/ps:lisp-eval (:buffer buffer :title "describe-function") (remove-method (closer-mop:method-generic-function method) method) (reload-current-buffer))) "Remove method") (:pre (:code (:raw (resolve-backtick-quote-links (documentation method 't) (symbol-package (mopu:method-name method)))))) (:nsection :level 4 :title "Argument list" (:pre (:code (prini-to-string (closer-mop:method-lambda-list method) :package (symbol-package input))))))))) (spinneret:with-html-string (:nstyle (style buffer)) (:h1 (format nil "~s" input) ; Use FORMAT to keep package prefix. (cond ((macro-function input) " (macro)") ((sym:command-symbol-p input) " (command)") ((typep (symbol-function input) 'generic-function) " (generic function)"))) (cond ((not (fboundp input)) (:p "Unbound.")) ((typep (symbol-function input) 'generic-function) (:raw (fun-desc input)) (unless (sym:command-symbol-p input) (:nsection :title "Methods" (:raw (sera:string-join (mapcar #'method-desc (mopu:generic-function-methods (symbol-function input))) ""))))) (t (:raw (fun-desc input))))))) (prompt :prompt "Describe function" :sources 'function-source))) (define-command-global describe-command (&key (command (name (prompt1 :prompt "Describe command" :sources 'command-source)))) "Inspect a command and show it in a help buffer. A command is a special kind of function that can be called with `execute-command' and can be bound to a key." (when command (describe-function :fn command))) (define-internal-page-command-global describe-slot (&key class name) (buffer (str:concat "*Help-" (symbol-name name) "*") 'nyxt/mode/help:help-mode) "Inspect a slot and show it in a help buffer." (if (and class name) (describe-slot* name class :independent-p t) (let ((slot (prompt1 :prompt "Describe slot" :sources '(slot-source slot-non-nyxt-source slot-internal-source)))) (describe-slot :class (class-sym slot) :name (name slot)) ""))) (defun describe-slot* (slot class &key independent-p) "Create the HTML that represents a slot." ;; TODO: Adapt HTML sections / lists to describe-slot and describe-class. ;; TODO: Parse docstrings and highlight code samples. (let ((props (mopu:slot-properties (find-class class) slot)) (*package* (symbol-package slot))) (spinneret:with-html-string (if independent-p (:h1 (prini-to-string slot)) (:h3 (prini-to-string slot))) (:dl (when independent-p (:dt "Class") (:dd (:pre (:a :href (nyxt-url 'describe-class :class class) class)))) (when (getf props :type) (:dt "Type ") (:dd (:pre (if (or (subtypep (getf props :type) 'standard-object) (subtypep (getf props :type) 'structure-object)) (:a :href (nyxt-url 'describe-class :class (getf props :type)) (prini-to-string (getf props :type))) (prini-to-string (getf props :type)))))) (when (getf props :initform) (:dt "Default value") (:dd (:ncode (prini-to-string (getf props :initform))))) (when (getf props :documentation) (:dt "Documentation") (:dd (:pre (:code (:raw (resolve-backtick-quote-links (getf props :documentation) (symbol-package slot)))))))) (unless independent-p (:br ""))))) (define-internal-page-command-global describe-class (&key (class (prompt1 :prompt "Describe class" :sources '(class-source class-non-nyxt-source class-internal-source)))) (buffer (str:concat "*Help-" (symbol-name class) "*") 'nyxt/mode/help:help-mode) "Inspect a class and show it in a help buffer." (if (find-class class nil) (let* ((slots (safe-sort (class-slots class :visibility :external))) (slot-descs (sera:string-join (mapcar (rcurry #'describe-slot* class) slots) "")) (*print-case* :downcase) (mode-p (subtypep class 'mode))) (spinneret:with-html-string (:nstyle (style buffer)) (:h1 (symbol-name class) " (" (sera:class-name-of (find-class class)) ")") (:pre (:code (:raw (resolve-backtick-quote-links (documentation class 'type) (symbol-package class))))) ;; TODO: Show mode keybindings for a better mode help (would be a ;; killer one)? We'd need to do some hack to inspect the keybindings ;; from the class somehow. Maybe :allocation :class so that keymap is ;; allocated/modified in place? ;; REVIEW: Maybe (make-instance MODE-NAME)? (:nsection :title "Slots" (:raw slot-descs)) (when mode-p (:nsection :title "Commands" (:ul (dolist (command (sym:package-commands (symbol-package class))) (:li (:nxref :command command)))))) (when-let ((methods (safe-sort (remove-if #'listp (mapcar #'mopu:generic-function-name (mopu:generic-functions class)))))) (:nsection :title "Methods" (:ul (loop for method in methods collect (:li (:a :href (nyxt-url 'describe-function :fn method) method)))))) (when (mopu:direct-superclasses class) (:nsection :title "Direct superclasses" (:ul (loop for class-name in (mapcar #'class-name (mopu:direct-superclasses class)) collect (:li (:a :href (nyxt-url 'describe-class :class class-name) class-name)))))) (when (mopu:direct-subclasses class) (:nsection :title "Direct subclasses" (:ul (loop for class-name in (safe-sort (mapcar #'class-name (mopu:direct-subclasses class))) collect (:li (:a :href (nyxt-url 'describe-class :class class-name) class-name)))))) (:nsection :title "Describe" (:pre (:code (with-output-to-string (s) (describe class s))))))) (spinneret:with-html-string (:nstyle (style buffer)) (:h2 (format nil "~s" class)) (:p "Unbound.")))) (define-command-global describe-mode (&key (mode (prompt1 :prompt "Describe mode" :sources 'mode-source))) "Inspect a mode and show it in a help buffer." (when mode (describe-class :class mode))) ;; Buffers can't be passed as argument since Nyxt URLs don't handle unreadable ;; objects. (define-internal-page describe-bindings (&key (buffer-id (id (current-buffer)))) (:title "*Help-bindings*" :page-mode 'nyxt/mode/help:help-mode) "Show a list of all available keybindings for buffer corresponding to BUFFER-ID." (if-let ((buffer (nyxt::buffer-get buffer-id))) (spinneret:with-html-string (:h1 "Bindings") (:p (loop for keymap in (current-keymaps buffer) collect (:div (:h2 (keymaps:name keymap)) (:table (:tr (:th "Command") (:th "Documentation")) (loop for keyspec being the hash-keys in (keymaps:keymap-with-parents->map keymap) using (hash-value bound-value) collect (:tr (:td (typecase bound-value (sym:command-symbol (:nxref :command bound-value)) (command (:nxref :command (name bound-value))) (t (prini-to-string bound-value)))) (:td (documentation-line bound-value 'function ""))))))))) (spinneret:with-html-string (:h1 "Bindings") (:p (format nil "Buffer with ID ~a does not exist." buffer-id))))) (define-command-global describe-bindings (&key (buffer (current-buffer))) "Show a list of all available keybindings in the current buffer." (buffer-load-internal-page-focus 'describe-bindings :buffer-id (id buffer))) (defun describe-key-dispatch (command) ;; TODO: Show when something is NOT bound! (unwind-protect (describe-command :command (typecase command (symbol command) (command (name command)))) (setf (command-dispatcher *browser*) #'dispatch-command) (echo-dismiss))) (define-command describe-key () "Display binding of user-inputted keys." (setf (command-dispatcher *browser*) #'describe-key-dispatch) (echo "Press a key sequence to describe:")) (export-always 'system-information) (defun system-information () (str:concat "Nyxt version: " +version+ +newline+ "Web Renderer: " (name *renderer*) +newline+ "OS: " (software-type) " " (software-version) +newline+ "Lisp implementation: " (lisp-implementation-type) " " (lisp-implementation-version) #+sbcl (format nil " (Dynamic space: ~aMB)~%" (/ (sb-ext:dynamic-space-size) 1024 1024)) "ASDF version: " (asdf:asdf-version) +newline+ "Features: " (prin1-to-string *features*))) ================================================ FILE: source/dom.lisp ================================================ ;;;; SPDX-FileCopyrightText: Atlas Engineer LLC ;;;; SPDX-License-Identifier: BSD-3-Clause (nyxt:define-package :nyxt/dom (:documentation "Nyxt-specific DOM classes and functions operating on them. The classes are generated for every HTML element, including `h1-element', `div-element', `img-element' and others. Classes corresponding to non-HTML elements, such as `text-element', `semantic-element', or `h-element', act as higher hierarchical entities of element classes. For instance, every `h-element' inherits from `h-element'. The most useful functions are: - `named-html-parse' and `named-json-parse' to turn HTML and JSON documents into a representation of type `plump:root', converting elements into its matching classes. - `copy' to produce a full recursive copy of a DOM. - `parents', `url' and `body' to access element-specific features in a unified fashion. - `click-element', `focus-select-element', `select-option-element' and others to interact with the page using `nyxt/dom' elements as representations of the actual DOM elements.")) (in-package :nyxt/dom) ;; TODO: Factor out into a library? (defvar *nyxt-dom-classes* (make-hash-table :test #'equalp) "A table associating the HTML tag name (e.g., \"a\") with the corresponding nyxt/dom class.") (defmacro define-element-classes (&body names) (loop for name in names collect (let* ((class-name (alex:ensure-car name)) (tag (str:replace-all "-element" "" (str:downcase (symbol-name class-name)))) (additional-superclasses (when (listp name) (rest name)))) `(progn (define-class ,class-name (,@(if additional-superclasses additional-superclasses '(plump:element))) () (:export-class-name-p t) (:export-accessor-names-p t) (:export-predicate-name-p t) (:documentation ,(format nil "An autogenerated class for <~a> HTML tag." tag))) (setf (gethash ,tag *nyxt-dom-classes*) (quote ,class-name)))) into classes finally (return `(progn ,@classes)))) (define-element-classes ;; All HTML5 tags, including experimental ones. Scraped with: ;; ;; (format t "~{~a-element~^ ~}" ;; (map 'list (lambda (item) ;; (slot-value (elt (slot-value item 'plump-dom::%children) 0) ;; 'plump-dom::%text)) ;; (clss:select ".item-name" (plump:parse (dex:get "https://htmlreference.io/"))))) ;; Pseudo-tags: text-element (h-element text-element) list-element structure-element semantic-element (checkbox-element input-element) (radio-element input-element) (file-chooser-element input-element) ;; HTML5 elements: (a-element text-element) abbr-element address-element area-element (article-element semantic-element) (aside-element semantic-element) audio-element (b-element text-element) base-element bdi-element bdo-element blockquote-element body-element br-element button-element canvas-element caption-element (cite-element text-element) (code-element text-element) col-element colgroup-element data-element datalist-element (dd-element list-element) (del-element text-element) details-element dfn-element div-element (dl-element list-element) (dt-element list-element) em-element embed-element fieldset-element (figcaption-element semantic-element) figure-element (footer-element semantic-element) form-element (h1-element h-element) (h2-element h-element) (h3-element h-element) (h4-element h-element) (h5-element h-element) (h6-element h-element) head-element (header-element semantic-element) hr-element html-element (i-element text-element) iframe-element img-element input-element ins-element kbd-element label-element legend-element (li-element list-element) link-element (main-element semantic-element) map-element (mark-element semantic-element) meta-element meter-element (nav-element semantic-element) (noscript-element plump:fulltext-element) object-element (ol-element list-element) optgroup-element (option-element text-element) output-element (p-element text-element) param-element (pre-element text-element) progress-element q-element rp-element rt-element rtc-element ruby-element samp-element (script-element plump:fulltext-element) (section-element semantic-element) select-element small-element source-element (span-element text-element) (strong-element text-element) (style-element plump:fulltext-element) (sub-element text-element) summary-element (sup-element text-element) table-element tbody-element td-element textarea-element tfoot-element th-element thead-element (time-element semantic-element) title-element tr-element track-element (ul-element list-element) var-element video-element ;; obsolete elements (from https://www.w3.org/TR/2010/WD-html5-20100304/obsolete.html): applet-element acronym-element bgsound-element dir-element frame-element frameset-element noframes-element isindex-element (listing-element text-element) (xmp-element text-element) nextid-element noembed-element (plaintext-element text-element) (rb-element ruby-element) (basefont-element text-element) (big-element text-element) (blink-element text-element) (center-element text-element) (font-element text-element) (marquee-element text-element) (multicol-element text-element) (nobr-element text-element) (s-element text-element) (spacer-element text-element) (strike-element text-element) (tt-element text-element) (u-element text-element) ;; Experimental elements: dialog-element hgroup-element picture-element slot-element template-element (wbr-element text-element)) (defmethod name-dom-elements ((node plump:node)) (when-let* ((tag-p (plump:element-p node)) (class (gethash (plump:tag-name node) *nyxt-dom-classes*))) (change-class node class)) (when (plump:nesting-node-p node) (loop for child across (plump:children node) do (name-dom-elements child))) node) (export-always 'named-html-parse) (-> named-parse (string) (values (or plump-dom:root null) &optional)) (defun named-html-parse (input) "Assign tag classes (e.g., `input-element') to the nodes in the `plump:parse'-d input." (name-dom-elements (plump:parse input))) (define-parenscript get-document-body-json () (defun process-element (element) (let ((object (ps:create :name (ps:@ element node-name))) (attributes (ps:chain element attributes))) (unless (or (ps:undefined attributes) (= 0 (ps:@ attributes length))) (setf (ps:@ object :attributes) (ps:create)) (loop for i from 0 below (ps:@ attributes length) do (setf (ps:@ object :attributes (ps:chain attributes (item i) name)) (ps:chain attributes (item i) value)))) (unless (or (ps:undefined (ps:chain element child-nodes)) (= 0 (ps:chain element child-nodes length))) (setf (ps:chain object :children) (loop for child in (ps:chain element child-nodes) collect (process-element child)))) (when (and (ps:@ element shadow-root) (ps:@ element shadow-root first-child)) (setf (ps:chain object :children) (loop for child in (ps:chain *array (from (ps:@ element shadow-root children)) (concat (ps:chain *array (from (ps:@ element children))))) collect (process-element child)))) (when (or (equal (ps:@ element node-name) "#text") (equal (ps:@ element node-name) "#comment") (equal (ps:@ element node-name) "#cdata-section")) (setf (ps:@ object :text) (ps:@ element text-content))) object)) (ps:chain -j-s-o-n (stringify (process-element (nyxt/ps:qs document "html"))))) (export-always 'named-json-parse) (-> named-json-parse (string) (values (or plump-dom:root null) &optional)) (defun named-json-parse (json) "Return a `plump:root' of a DOM-tree produced from the JSON. JSON should have the format like what `get-document-body-json' produces: - A nested hierarchy of objects (with only one root object), where - Every object has a 'name' (usually a tag name or '#text'/'#comment'). - Some objects can have 'attributes' (a string->string dictionary). - Some objects have a subarray ('children') of objects working by these three rules." (labels ((json-to-plump (json parent) (let ((element (cond ((string-equal (j:get "name" json) "#text") (plump:make-text-node parent (j:get "text" json))) ((string-equal (j:get "name" json) "#cdata-section") (plump:make-cdata parent :text (j:get "text" json))) ((string-equal (j:get "name" json) "#comment") (plump:make-comment parent (j:get "text" json))) (t (plump:make-element parent (str:downcase (j:get "name" json))))))) (when (typep element 'plump:nesting-node) (setf (plump:children element) (plump:ensure-child-array (map 'vector (rcurry #'json-to-plump element) (let ((children (j:get "children" json))) (if (stringp children) (j:decode children) children)))))) (when (typep element 'plump:element) (setf (plump:attributes element) (sera:lret ((map (plump:make-attribute-map))) (when (j:get "attributes" json) (maphash (lambda (key val) (setf (gethash key map) val)) (j:get "attributes" json)))))) element))) (let ((json (j:decode json)) (root (plump:make-root))) (json-to-plump json root) (name-dom-elements root)))) (export-always 'copy) (defgeneric copy (node &optional parent) (:method ((element plump:root) &optional parent) (declare (ignore parent)) (serapeum:lret ((copy (plump:make-root))) (map nil (lambda (c) (plump:append-child copy (copy c copy))) (plump:children element)))) (:method ((element plump:element) &optional parent) (serapeum:lret ((copy (make-instance 'plump:element :parent parent :attributes (alex:copy-hash-table (plump:attributes element)) :tag-name (plump:tag-name element)))) (map nil (lambda (c) (plump:append-child copy (copy c copy))) (plump:children element)))) (:method ((element plump:text-node) &optional parent) (make-instance 'plump:text-node :parent parent :text (plump:text element))) (:method ((element plump:comment) &optional parent) (make-instance 'plump:comment :parent parent :text (plump:text element))) (:method ((element plump:doctype) &optional parent) (make-instance 'plump:doctype :parent parent :doctype (plump:doctype element))) (:method ((element plump:xml-header) &optional parent) (make-instance 'plump:xml-header :parent parent :attributes (alex:copy-hash-table (plump:attributes element)))) (:method ((element plump:cdata) &optional parent) (make-instance 'plump:cdata :parent parent :text (plump:text element))) (:method ((element plump:processing-instruction) &optional parent) (make-instance 'plump:processing-instruction :parent parent :text (plump:text element) :tag-name (plump:tag-name element))) (:documentation "Produce a full copy of NODE as belonging to the PARENT node. Full copy means recursively descending to the children of the NODE too.")) (export-always 'parents) (defgeneric parents (node) (:method ((node plump:node)) nil) (:method ((node plump:child-node)) (let ((parent (plump:parent node))) (cons parent (parents parent)))) (:documentation "Get the recursive parents of the NODE. The closest parent goes first, the furthest one goes last.")) (defmethod url :around ((element plump:element)) (when-let* ((result (call-next-method)) (url (url result))) (if (valid-url-p url) url (quri:merge-uris url (url (current-buffer)))))) (defmethod url ((element plump:element)) (when (plump:has-attribute element "href") (quri:uri (plump:get-attribute element "href")))) (defmethod url ((img img-element)) (when (plump:has-attribute img "src") (quri:uri (plump:get-attribute img "src")))) ;; REVIEW: Export to :nyxt? We are forced to use it with nyxt/dom: prefix. (export-always 'body) (defgeneric body (element) (:method ((element plump:element)) (when (plump:children element) (plump:text element))) (:method :around (element) (declare (ignorable element)) (let ((result (call-next-method))) (when result (sera:collapse-whitespace (sera:trim-whitespace result))))) (:documentation "Return the textual contents of the ELEMENT and its recursive children.")) (defun label-of (element) (let ((label-for (and (plump:has-attribute element "name") (ignore-errors (elt (clss:select (format nil "label[for=\"~a\"]" (plump:attribute element "name")) (alex:lastcar (parents element))) 0))))) (cond ((label-element-p (plump:parent element)) (body (plump:parent element))) (label-for (body label-for)) (t nil)))) (defun fallback-body (element) (when-let ((body (or (plump:get-attribute element "value") (plump:get-attribute element "placeholder")))) body)) (defmethod body ((input input-element)) (or (label-of input) (fallback-body input))) (defmethod body ((textarea textarea-element)) (or (label-of textarea) (fallback-body textarea))) (defmethod body ((details details-element)) (let ((summary (clss:select "summary" details))) (unless (uiop:emptyp summary) (plump:text (elt summary 0))))) (defmethod body ((select select-element)) (or (label-of select) (str:join ", " (map 'list #'plump:text (clss:select "option" select))))) (defmethod body ((img img-element)) (when (plump:has-attribute img "alt") (plump:attribute img "alt"))) (export-always 'get-nyxt-id) (defmethod get-nyxt-id ((element plump:element)) "Get the nyxt-identifier of the page element matching ELEMENT." (plump:attribute element "nyxt-identifier")) (export-always 'click-element) (define-parenscript click-element (element) "Click the ELEMENT (Lisp object) on the page with JS." (ps:chain (nyxt/ps:rqs-nyxt-id document (ps:lisp (get-nyxt-id element))) (click))) (export-always 'focus-select-element) (define-parenscript focus-select-element (element) "Focus the element matching ELEMENT on the page." (let ((element (nyxt/ps:rqs-nyxt-id document (ps:lisp (get-nyxt-id element))))) (unless (nyxt/ps:element-in-view-port-p element) (ps:chain element (scroll-into-view))) (ps:chain element (focus)) (when (functionp (ps:chain element select)) (ps:chain element (select))))) (export-always 'check-element) (define-parenscript check-element (element &key (value t)) "Toggle (to VALUE) the checkbox/radio button matching ELEMENT on the page." (let ((element (nyxt/ps:rqs-nyxt-id document (ps:lisp (get-nyxt-id element))))) (unless (nyxt/ps:element-in-view-port-p element) (ps:chain element (scroll-into-view))) (ps:chain element (set-attribute "checked" (ps:lisp value))))) (export-always 'toggle-details-element) (define-parenscript toggle-details-element (element) "Open/close the
element matching ELEMENT on the page." (ps:let ((element (nyxt/ps:rqs-nyxt-id document (ps:lisp (get-nyxt-id element))))) (unless (nyxt/ps:element-in-view-port-p element) (ps:chain element (scroll-into-view))) (if (ps:chain element (get-attribute "open")) (ps:chain element (remove-attribute "open")) (ps:chain element (set-attribute "open" t))))) (export-always 'select-option-element) (define-parenscript select-option-element (element parent) "Select one of the