[ { "path": ".dir-locals.el", "content": "((nil . ((fill-column . 80)\n (project-vc-ignores . (\"./_build\"))\n (require-final-newline . t)\n (eval . (add-hook 'before-save-hook 'delete-trailing-whitespace nil t))))\n (org-mode . ((org-edit-src-content-indentation 0)))\n (lisp-mode\n . ((eval . (cl-flet ((enhance-imenu-lisp\n (&rest keywords)\n (dolist (keyword keywords)\n (let ((prefix (when (listp keyword) (cl-second keyword)))\n (keyword (if (listp keyword)\n (cl-first keyword)\n keyword)))\n (add-to-list\n 'lisp-imenu-generic-expression\n (list (purecopy (concat (capitalize keyword)\n (if (string= (substring-no-properties keyword -1) \"s\")\n \"es\"\n \"s\")))\n (purecopy (concat \"^\\\\s-*(\"\n (regexp-opt\n (list (if prefix\n (concat prefix \"-\" keyword)\n keyword)\n (concat prefix \"-\" keyword))\n t)\n \"\\\\s-+\\\\(\" lisp-mode-symbol-regexp \"\\\\)\"))\n 2))))))\n ;; This adds the argument to the list of imenu known keywords.\n (enhance-imenu-lisp\n '(\"bookmarklet-command\" \"define\")\n '(\"class\" \"define\")\n '(\"command\" \"define\")\n '(\"ffi-method\" \"define\")\n '(\"ffi-generic\" \"define\")\n '(\"function\" \"define\")\n '(\"internal-page-command\" \"define\")\n '(\"internal-page-command-global\" \"define\")\n '(\"mode\" \"define\")\n '(\"parenscript\" \"define\")\n \"defpsmacro\"))))))\n" }, { "path": ".github/ISSUE_TEMPLATE/bug_report.md", "content": "---\nname: Bug report\nabout: Bug report\ntitle: ''\nlabels: ''\nassignees: ''\n\n---\n\n**Describe the bug**\n\n**Steps to reproduce the issue**\n\n**Information**\n- OS Name+Version:\n- Installation method (Flatpak, Guix, package manager, build from source):\n- Output of Nyxt command `show-system-information`:\n" }, { "path": ".github/ISSUE_TEMPLATE/feature_request.md", "content": "---\nname: Feature request\nabout: Suggest an idea for this project\ntitle: ''\nlabels: feature\nassignees: ''\n\n---\n\n**Is your feature request related to a problem? Please describe.**\n\n\n**Describe the solution you'd like**\n\n\n**Describe alternatives you've considered**\n\n\n**Additional context**\n" }, { "path": ".github/ISSUE_TEMPLATE/ui_request.md", "content": "---\nname: UI request\nabout: Suggest a UI change for this project\ntitle: ''\nlabels: ui/ux\nassignees: ''\n\n---\n\n**Please describe the UI issue:**\n\n\n**Describe the solution you'd like**\n\n\n**Describe alternatives you've considered**\n\n\n**Additional context:**\n\n\n**Screenshots/Mock ups:**\n" }, { "path": ".github/SECURITY.md", "content": "# Security Policy\n\n## Supported Versions\n\nOnly the latest stable version is currently supported with security updates.\n\n## Reporting a Vulnerability\n\nhello@atlas.engineer\n" }, { "path": ".github/pull_request_template.md", "content": "# Description\n\n- Please include a summary of the change.\n\nFixes # (issue)\n\n# Checklist:\n\n- [ ] Git branch state is mergable.\n- [ ] Changelog is up to date (via a separate commit).\n- [ ] New dependencies are accounted for.\n- [ ] Documentation is up to date.\n- [ ] Compilation and tests (`(asdf:test-system :nyxt/)`)\n - No new compilation warnings.\n - Tests are sufficient.\n" }, { "path": ".gitignore", "content": "# Ignore build artifacts\nnyxt\nbuild/\nnode_modules/\npackage.json\npackage-lock.json\n\n# Ignore compiled lisp files\n*.FASL\n*.fasl\n*.fas\n*.lisp-temp\n*.dfsl\n*.pfsl\n*.d64fsl\n*.p64fsl\n*.lx64fsl\n*.lx32fsl\n*.dx64fsl\n*.dx32fsl\n*.fx64fsl\n*.fx32fsl\n*.sx64fsl\n*.sx32fsl\n*.wx64fsl\n*.wx32fsl\n\n# Ignore PNG and XCF\n*.xcf\n*.png\n\n# Generated documentation\nmanual.html\n\n# Ignore etags/ctags\nTAGS\n\n# Ignore C object files and libraries\n*.o\n*.so\n" }, { "path": ".gitmodules", "content": "[submodule \"_build/alexandria\"]\n\tpath = _build/alexandria\n\turl = https://gitlab.common-lisp.net/alexandria/alexandria.git\n\tshallow = true\n[submodule \"_build/bordeaux-threads\"]\n\tpath = _build/bordeaux-threads\n\turl = https://github.com/sionescu/bordeaux-threads\n\tshallow = true\n[submodule \"_build/calispel\"]\n\tpath = _build/calispel\n\turl = https://github.com/hawkir/calispel\n\tshallow = true\n[submodule \"_build/cl-jpl-util\"]\n\tpath = _build/cl-jpl-util\n\turl = https://github.com/hawkir/cl-jpl-util\n\tshallow = true\n[submodule \"_build/trivial-garbage\"]\n\tpath = _build/trivial-garbage\n\turl = https://github.com/trivial-garbage/trivial-garbage\n\tshallow = true\n[submodule \"_build/cl-containers\"]\n\tpath = _build/cl-containers\n\turl = https://github.com/gwkkwg/cl-containers\n\tshallow = true\n[submodule \"_build/metatilities-base\"]\n\tpath = _build/metatilities-base\n\turl = https://github.com/gwkkwg/metatilities-base\n\tshallow = true\n[submodule \"_build/cl-custom-hash-table\"]\n\tpath = _build/cl-custom-hash-table\n\turl = https://github.com/metawilm/cl-custom-hash-table\n\tshallow = true\n[submodule \"_build/cl-ppcre\"]\n\tpath = _build/cl-ppcre\n\turl = https://github.com/edicl/cl-ppcre\n\tshallow = true\n[submodule \"_build/flexi-streams\"]\n\tpath = _build/flexi-streams\n\turl = https://github.com/edicl/flexi-streams\n\tshallow = true\n[submodule \"_build/trivial-gray-streams\"]\n\tpath = _build/trivial-gray-streams\n\turl = https://github.com/trivial-gray-streams/trivial-gray-streams\n\tshallow = true\n[submodule \"_build/cl-prevalence\"]\n\tpath = _build/cl-prevalence\n\turl = https://github.com/40ants/cl-prevalence\n\tshallow = true\n[submodule \"_build/s-sysdeps\"]\n\tpath = _build/s-sysdeps\n\turl = https://github.com/svenvc/s-sysdeps\n\tshallow = true\n[submodule \"_build/usocket\"]\n\tpath = _build/usocket\n\turl = https://github.com/usocket/usocket/\n\tshallow = true\n[submodule \"_build/split-sequence\"]\n\tpath = _build/split-sequence\n\turl = https://github.com/sharplispers/split-sequence\n\tshallow = true\n[submodule \"_build/closer-mop\"]\n\tpath = _build/closer-mop\n\turl = https://github.com/pcostanza/closer-mop\n\tshallow = true\n[submodule \"_build/cluffer\"]\n\tpath = _build/cluffer\n\turl = https://github.com/robert-strandh/cluffer\n\tshallow = true\n[submodule \"_build/Acclimation\"]\n\tpath = _build/Acclimation\n\turl = https://github.com/robert-strandh/Acclimation\n\tshallow = true\n[submodule \"_build/Clump\"]\n\tpath = _build/Clump\n\turl = https://github.com/robert-strandh/Clump\n\tshallow = true\n[submodule \"_build/dexador\"]\n\tpath = _build/dexador\n\turl = https://github.com/fukamachi/dexador\n\tshallow = true\n[submodule \"_build/babel\"]\n\tpath = _build/babel\n\turl = https://github.com/cl-babel/babel\n\tshallow = true\n[submodule \"_build/trivial-features\"]\n\tpath = _build/trivial-features\n\turl = https://github.com/trivial-features/trivial-features\n\tshallow = true\n[submodule \"_build/fast-http\"]\n\tpath = _build/fast-http\n\turl = https://github.com/fukamachi/fast-http\n\tshallow = true\n[submodule \"_build/proc-parse\"]\n\tpath = _build/proc-parse\n\turl = https://github.com/fukamachi/proc-parse\n\tshallow = true\n[submodule \"_build/anaphora\"]\n\tpath = _build/anaphora\n\turl = https://github.com/tokenrove/anaphora\n\tshallow = true\n[submodule \"_build/xsubseq\"]\n\tpath = _build/xsubseq\n\turl = https://github.com/fukamachi/xsubseq\n\tshallow = true\n[submodule \"_build/smart-buffer\"]\n\tpath = _build/smart-buffer\n\turl = https://github.com/fukamachi/smart-buffer\n\tshallow = true\n[submodule \"_build/cl-unicode\"]\n\tpath = _build/cl-unicode\n\turl = https://github.com/edicl/cl-unicode\n\tshallow = true\n[submodule \"_build/named-readtables\"]\n\tpath = _build/named-readtables\n\turl = https://github.com/melisgl/named-readtables\n\tshallow = true\n[submodule \"_build/trivial-types\"]\n\tpath = _build/trivial-types\n\turl = https://github.com/m2ym/trivial-types\n\tshallow = true\n[submodule \"_build/quri\"]\n\tpath = _build/quri\n\turl = https://github.com/fukamachi/quri\n\tshallow = true\n[submodule \"_build/fast-io\"]\n\tpath = _build/fast-io\n\turl = https://github.com/rpav/fast-io\n\tshallow = true\n[submodule \"_build/static-vectors\"]\n\tpath = _build/static-vectors\n\turl = https://github.com/sionescu/static-vectors\n\tshallow = true\n[submodule \"_build/cffi\"]\n\tpath = _build/cffi\n\turl = https://github.com/cffi/cffi\n\tshallow = true\n[submodule \"_build/chunga\"]\n\tpath = _build/chunga\n\turl = https://github.com/edicl/chunga\n\tshallow = true\n[submodule \"_build/cl-cookie\"]\n\tpath = _build/cl-cookie\n\turl = https://github.com/fukamachi/cl-cookie\n\tshallow = true\n[submodule \"_build/local-time\"]\n\tpath = _build/local-time\n\turl = https://github.com/dlowe-net/local-time\n\tshallow = true\n[submodule \"_build/trivial-mimes\"]\n\tpath = _build/trivial-mimes\n\turl = https://github.com/Shinmera/trivial-mimes\n\tshallow = true\n[submodule \"_build/cl-base64\"]\n\tpath = _build/cl-base64\n\turl = https://gitlab.common-lisp.net/nyxt/cl-base64.git\n\tshallow = true\n[submodule \"_build/cl-plus-ssl\"]\n\tpath = _build/cl-plus-ssl\n\turl = https://github.com/cl-plus-ssl/cl-plus-ssl\n\tshallow = true\n[submodule \"_build/drakma\"]\n\tpath = _build/drakma\n\turl = https://github.com/edicl/drakma\n\tshallow = true\n[submodule \"_build/puri\"]\n\tpath = _build/puri\n\turl = https://gitlab.common-lisp.net/nyxt/puri.git\n\tshallow = true\n[submodule \"_build/cl-enchant\"]\n\tpath = _build/cl-enchant\n\turl = https://github.com/tlikonen/cl-enchant\n\tshallow = true\n[submodule \"_build/fset\"]\n\tpath = _build/fset\n\turl = https://github.com/slburson/fset\n\tshallow = true\n[submodule \"_build/misc-extensions\"]\n\tpath = _build/misc-extensions\n\turl = https://gitlab.common-lisp.net/misc-extensions/misc-extensions.git\n\tshallow = true\n[submodule \"_build/iolib\"]\n\tpath = _build/iolib\n\turl = https://github.com/sionescu/iolib\n\tshallow = true\n[submodule \"_build/idna\"]\n\tpath = _build/idna\n\turl = https://github.com/antifuchs/idna\n\tshallow = true\n[submodule \"_build/swap-bytes\"]\n\tpath = _build/swap-bytes\n\turl = https://github.com/sionescu/swap-bytes\n\tshallow = true\n[submodule \"_build/log4cl\"]\n\tpath = _build/log4cl\n\turl = https://github.com/sharplispers/log4cl\n\tshallow = true\n[submodule \"_build/moptilities\"]\n\tpath = _build/moptilities\n\turl = https://github.com/gwkkwg/moptilities/\n\tshallow = true\n[submodule \"_build/parenscript\"]\n\tpath = _build/parenscript\n\turl = https://gitlab.common-lisp.net/parenscript/parenscript\n\tshallow = true\n[submodule \"_build/plump\"]\n\tpath = _build/plump\n\turl = https://github.com/Shinmera/plump\n\tshallow = true\n[submodule \"_build/array-utils\"]\n\tpath = _build/array-utils\n\turl = https://github.com/Shinmera/array-utils\n\tshallow = true\n[submodule \"_build/documentation-utils\"]\n\tpath = _build/documentation-utils\n\turl = https://github.com/Shinmera/documentation-utils\n\tshallow = true\n[submodule \"_build/trivial-indent\"]\n\tpath = _build/trivial-indent\n\turl = https://github.com/Shinmera/trivial-indent\n\tshallow = true\n[submodule \"_build/serapeum\"]\n\tpath = _build/serapeum\n\turl = https://github.com/ruricolist/serapeum\n\tshallow = true\n[submodule \"_build/nhooks\"]\n\tpath = _build/nhooks\n\turl = https://github.com/atlas-engineer/nhooks\n\tshallow = true\n[submodule \"_build/trivia\"]\n\tpath = _build/trivia\n\turl = https://github.com/guicho271828/trivia\n\tshallow = true\n[submodule \"_build/optima\"]\n\tpath = _build/optima\n\turl = https://github.com/m2ym/optima\n\tshallow = true\n[submodule \"_build/lisp-namespace\"]\n\tpath = _build/lisp-namespace\n\turl = https://github.com/guicho271828/lisp-namespace\n\tshallow = true\n[submodule \"_build/trivial-cltl2\"]\n\tpath = _build/trivial-cltl2\n\turl = https://github.com/Zulu-Inuoe/trivial-cltl2\n\tshallow = true\n[submodule \"_build/type-i\"]\n\tpath = _build/type-i\n\turl = https://github.com/guicho271828/type-i\n\tshallow = true\n[submodule \"_build/introspect-environment\"]\n\tpath = _build/introspect-environment\n\turl = https://github.com/Bike/introspect-environment\n\tshallow = true\n[submodule \"_build/string-case\"]\n\tpath = _build/string-case\n\turl = https://github.com/pkhuong/string-case\n\tshallow = true\n[submodule \"_build/parse-number\"]\n\tpath = _build/parse-number\n\turl = https://github.com/sharplispers/parse-number/\n\tshallow = true\n[submodule \"_build/parse-declarations\"]\n\tpath = _build/parse-declarations\n\turl = https://gitlab.common-lisp.net/parse-declarations/parse-declarations.git\n\tshallow = true\n[submodule \"_build/global-vars\"]\n\tpath = _build/global-vars\n\turl = https://github.com/lmj/global-vars\n\tshallow = true\n[submodule \"_build/trivial-file-size\"]\n\tpath = _build/trivial-file-size\n\turl = https://github.com/ruricolist/trivial-file-size\n\tshallow = true\n[submodule \"_build/trivial-macroexpand-all\"]\n\tpath = _build/trivial-macroexpand-all\n\turl = https://github.com/cbaggers/trivial-macroexpand-all\n\tshallow = true\n[submodule \"_build/cl-str\"]\n\tpath = _build/cl-str\n\turl = https://github.com/vindarel/cl-str\n\tshallow = true\n[submodule \"_build/cl-change-case\"]\n\tpath = _build/cl-change-case\n\turl = https://github.com/rudolfochrist/cl-change-case\n\tshallow = true\n[submodule \"_build/trivial-clipboard\"]\n\tpath = _build/trivial-clipboard\n\turl = https://github.com/snmsts/trivial-clipboard\n\tshallow = true\n[submodule \"_build/trivial-package-local-nicknames\"]\n\tpath = _build/trivial-package-local-nicknames\n\turl = https://github.com/phoe/trivial-package-local-nicknames\n\tshallow = true\n[submodule \"_build/unix-opts\"]\n\tpath = _build/unix-opts\n\turl = https://github.com/atlas-engineer/unix-opts\n\tshallow = true\n[submodule \"_build/cl-webkit\"]\n\tpath = _build/cl-webkit\n\turl = https://github.com/joachifm/cl-webkit\n\tshallow = true\n[submodule \"_build/cl-gobject-introspection\"]\n\tpath = _build/cl-gobject-introspection\n\turl = https://github.com/andy128k/cl-gobject-introspection\n\tshallow = true\n[submodule \"_build/lparallel\"]\n\tpath = _build/lparallel\n\turl = https://github.com/lmj/lparallel/\n\tshallow = true\n[submodule \"_build/jpl-queues\"]\n\tpath = _build/jpl-queues\n\turl = https://gitlab.common-lisp.net/nyxt/jpl-queues.git\n\tshallow = true\n[submodule \"_build/mt19937\"]\n\tpath = _build/mt19937\n\turl = https://gitlab.common-lisp.net/nyxt/mt19937\n\tshallow = true\n[submodule \"_build/s-xml\"]\n\tpath = _build/s-xml\n\turl = https://gitlab.common-lisp.net/s-xml/s-xml\n\tshallow = true\n[submodule \"_build/cl-utilities\"]\n\tpath = _build/cl-utilities\n\turl = https://gitlab.common-lisp.net/cl-utilities/cl-utilities\n\tshallow = true\n[submodule \"_build/cl-qrencode\"]\n\tpath = _build/cl-qrencode\n\turl = https://github.com/jnjcc/cl-qrencode\n\tshallow = true\n[submodule \"_build/clss\"]\n\tpath = _build/clss\n\turl = https://github.com/Shinmera/clss\n\tshallow = true\n[submodule \"_build/spinneret\"]\n\tpath = _build/spinneret\n\turl = https://github.com/ruricolist/spinneret/\n\tshallow = true\n[submodule \"_build/salza2\"]\n\tpath = _build/salza2\n\turl = https://github.com/xach/salza2\n\tshallow = true\n[submodule \"_build/zpng\"]\n\tpath = _build/zpng\n\turl = https://github.com/xach/zpng\n\tshallow = true\n[submodule \"_build/iterate\"]\n\tpath = _build/iterate\n\turl = https://gitlab.common-lisp.net/iterate/iterate.git\n\tshallow = true\n[submodule \"_build/cl-gopher\"]\n\tpath = _build/cl-gopher\n\turl = https://github.com/knusbaum/cl-gopher\n\tshallow = true\n[submodule \"_build/phos\"]\n\tpath = _build/phos\n\turl = https://github.com/omar-polo/phos\n\tshallow = true\n[submodule \"_build/cl-tld\"]\n\tpath = _build/cl-tld\n\turl = https://github.com/lu4nx/cl-tld\n\tshallow = true\n[submodule \"_build/nfiles\"]\n\tpath = _build/nfiles\n\turl = https://github.com/atlas-engineer/nfiles\n\tshallow = true\n[submodule \"_build/nkeymaps\"]\n\tpath = _build/nkeymaps\n\turl = https://github.com/atlas-engineer/nkeymaps\n\tshallow = true\n[submodule \"_build/py-configparser\"]\n\tpath = _build/py-configparser\n\turl = https://gitlab.common-lisp.net/nyxt/py-configparser\n\tshallow = true\n[submodule \"_build/trivial-custom-debugger\"]\n\tpath = _build/trivial-custom-debugger\n\turl = https://github.com/phoe/trivial-custom-debugger\n\tshallow = true\n[submodule \"_build/lisp-unit2\"]\n\tpath = _build/lisp-unit2\n\turl = https://github.com/AccelerationNet/lisp-unit2\n\tshallow = true\n[submodule \"_build/nsymbols\"]\n\tpath = _build/nsymbols\n\turl = https://github.com/atlas-engineer/nsymbols\n\tshallow = true\n[submodule \"_build/LASS\"]\n\tpath = _build/LASS\n\turl = https://github.com/Shinmera/LASS\n\tshallow = true\n[submodule \"_build/njson\"]\n\tpath = _build/njson\n\turl = https://github.com/atlas-engineer/njson\n\tshallow = true\n[submodule \"_build/nclasses\"]\n\tpath = _build/nclasses\n\turl = https://github.com/atlas-engineer/nclasses/\n\tshallow = true\n[submodule \"_build/prompter\"]\n\tpath = _build/prompter\n\turl = https://github.com/atlas-engineer/prompter\n\tshallow = true\n[submodule \"_build/chipz\"]\n\tpath = _build/chipz\n\turl = https://github.com/sharplispers/chipz\n\tshallow = true\n[submodule \"_build/cl-cffi-gtk\"]\n\tpath = _build/cl-cffi-gtk\n\turl = https://github.com/sharplispers/cl-cffi-gtk\n\tshallow = true\n[submodule \"_build/cl-json\"]\n\tpath = _build/cl-json\n\turl = https://github.com/sharplispers/cl-json\n\tshallow = true\n[submodule \"_build/cl-sqlite\"]\n\tpath = _build/cl-sqlite\n\turl = https://github.com/TeMPOraL/cl-sqlite\n\tshallow = true\n[submodule \"_build/cl-electron\"]\n\tpath = _build/cl-electron\n\turl = https://github.com/atlas-engineer/cl-electron/\n\tshallow = true\n[submodule \"_build/cl-colors-ng\"]\n\tpath = _build/cl-colors-ng\n\turl = https://codeberg.org/cage/cl-colors-ng.git\n\tshallow = true\n[submodule \"_build/cl-interpol\"]\n\tpath = _build/cl-interpol\n\turl = https://github.com/edicl/cl-interpol\n\tshallow = true\n[submodule \"_build/symbol-munger\"]\n\tpath = _build/symbol-munger\n\turl = https://github.com/AccelerationNet/symbol-munger\n\tshallow = true\n[submodule \"_build/in-nomine\"]\n\tpath = _build/in-nomine\n\turl = https://github.com/phoe/in-nomine\n\tshallow = true\n[submodule \"_build/trivial-arguments\"]\n\tpath = _build/trivial-arguments\n\turl = https://github.com/Shinmera/trivial-arguments.git\n\tshallow = true\n" }, { "path": "INSTALL", "content": "Usage:\n\n make all # Generate Nyxt binary at $PWD.\n make install # Install Nyxt.\n make doc # Generate Nyxt static documentation.\n\nDESTDIR and PREFIX set the target destination. Both must be absolute paths.\nWhen unbound, DESTDIR is set to / and PREFIX is set to $DESTDIR/usr/local/.\n\nNASDF_SOURCE_PATH sets where the source files will be installed. When unbound,\nit is set to $PREFIX/share/.\n\nWhen NYXT_SUBMODULES is \"true\" (the default), all Lisp dependencies are searched\nat ./_build. Otherwise, they need to be made visible to ASDF by other means.\nIn case you have received an archive that includes the source of these Lisp\ndependencies, then it all should work out of the box.\n\nNYXT_RENDERER sets the renderer, by default \"electron\".\n\nNYXT_VERSION forces the version number, in the rare eventuality that it can't be\nfetched in another way.\n\nThe static documentation is particularly useful when it can't be consulted from\nNyxt itself (where it is dynamically generated at runtime).\n" }, { "path": "README.org", "content": "* Nyxt browser\n#+html: \n\n*Nyxt* [nýkst] is a keyboard-driven web browser designed for hackers. Inspired by\nEmacs 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\nextensible in Lisp.\n\n*Attention:* Nyxt is under active development. Please feel free to [[https://github.com/atlas-engineer/nyxt/issues][report]] bugs,\ninstabilities or feature wishes.\n\n-----\n\n* Features\nFor an exhaustive description of all of the features, please refer to the\nmanual.\n\n** Fast tab switching\n\nSwitch easily between your open tabs via fuzzy search. If you are looking for\n~https://www.example.com~, you could type in ~ele~, ~exa~, ~epl~, or any other\nmatching series of letters.\n\n#+html: \n\n** Multiple marking\n\nCommands can accept multiple inputs, allowing you to quickly perform an\noperation against multiple objects. In the example below we simultaneously open\nseveral bookmarks.\n\n#+html: \n\n** Powerful bookmarks\n\nBookmark a page with tags. Search bookmarks with compound queries. Capture\nmore data about your bookmarks, and group and wrangle them in any way you like.\n\n#+html: \n\n** Multi tab search\n\nSearch multiple tabs at the same time, and view all the results in a single\nwindow. Jump quickly through your open tabs to find what you need.\n\n#+html: \n\n** History as a tree\n\nHistory is represented as a tree that you can traverse. Smarter than the\n\"forwards-backwards\" abstraction found in other browsers, the tree makes sure\nyou never lose track of where you've been.\n\n#+html: \n\n* Installation\n\nSupported platforms:\n\n- GNU/Linux\n- macOS (in development)\n- Windows (in development)\n- FreeBSD (unofficial)\n\n** GNU/Linux\n\nThe Nyxt team maintains the following distribution means:\n\n- [[https://flathub.org/apps/engineer.atlas.Nyxt][Nyxt on Flathub]]\n\n[[https://repology.org/project/nyxt/versions][Non-official distribution means are supported by the community as well]]. We're\nnot accountable for their quality, so we kindly ask to report issues to the\nmaintainers of those packaging efforts.\n\n* Contributing\n\nPlease refer to the [[file:developer-manual.org][developer's documentation]].\n" }, { "path": "_build/README.org", "content": "This directory contains all Common Lisp dependencies. They are fetched via Git\nsubmodules. This gives us good reproducibility and control, unlike with\nQuicklisp which might not have the right versions.\n\nWe store these in a directory that's excluded from recursion by ASDF.\nas per =asdf/source-registry:*source-registry-exclusions*=.\nThis way we won't conflict with user or system libraries.\n" }, { "path": "assets/Info.plist", "content": "\n\n\n \n NSPrincipalClass\n Nyxt\n CFBundleIconFile\n nyxt.icns\n CFBundlePackageType\n APPL\n CFBundleGetInfoString\n Nyxt\n CFBundleSignature\n ????\n CFBundleExecutable\n nyxt\n CFBundleIdentifier\n engineer.Atlas.Nyxt\n NSAppTransportSecurity\n \n NSAllowsLocalNetworking\n \n \n CFBundleURLTypes\n \n \n\t CFBundleURLName\n\t http URL\n\t CFBundleURLSchemes\n\t \n\t http\n\t \n \n \n\t CFBundleURLName\n\t https URL\n\t CFBundleURLSchemes\n\t \n\t https\n\t \n \n \n\t CFBundleURLName\n\t gopher URL\n\t CFBundleURLSchemes\n\t \n\t gopher\n\t \n \n \n\t CFBundleURLName\n\t gemini URL\n\t CFBundleURLSchemes\n\t \n\t gemini\n\t \n \n \n CFBundleDocumentTypes\n \n \n\t CFBundleTypeExtensions\n\t \n\t html\n xhtml\n\t \n \n \n \n\n" }, { "path": "assets/nyxt.appimage.desktop", "content": "[Desktop Entry]\nName=Nyxt\nComment=Web Browser for Hackers\nGenericName=Web Browser\nKeywords=Internet;WWW;Browser;Web;Explorer\nExec=\"~a\"\nTerminal=false\nX-MultipleArgs=false\nType=Application\nIcon=nyxt\nCategories=Network;WebBrowser;\nMimeType=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;\nStartupNotify=true\nStartupWMClass=nyxt\n" }, { "path": "assets/nyxt.desktop", "content": "[Desktop Entry]\nName=Nyxt\nComment=Web Browser for Hackers\nGenericName=Web Browser\nKeywords=Internet;WWW;Browser;Web;Explorer\nExec=nyxt %u\nTerminal=false\nX-MultipleArgs=false\nType=Application\nIcon=nyxt\nCategories=Network;WebBrowser;\nMimeType=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;\nStartupNotify=true\nStartupWMClass=nyxt\n" }, { "path": "assets/nyxt.metainfo.xml", "content": "\n\n \n engineer.atlas.Nyxt\n CC-BY-SA-3.0\n BSD-3-Clause\n \n Atlas Engineer\n Nyxt\n The hacker's browser\n \n

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

\n \n \n Network\n \n https://nyxt-browser.com/\n https://github.com/atlas-engineer/nyxt\n https://github.com/atlas-engineer/nyxt/issues\n https://nyxt-browser.com/faq\n https://discourse.atlas.engineer/\n https://nyxt-browser.com/purchase\n \n https://atlas.engineer/contact\n https://github.com/atlas-engineer/nyxt/blob/master/developer-manual.org\n nyxt.desktop\n \n nyxt\n \n \n \n https://nyxt-browser.com/static/image/switch-buffer.png\n Fast tab switching\n \n \n https://nyxt-browser.com/static/image/multi-select.png\n Multiple marking\n \n \n https://nyxt-browser.com/static/image/bookmark.png\n Powerful bookmarks\n \n \n https://nyxt-browser.com/static/image/multi-search.png\n Multi tab search\n \n \n https://nyxt-browser.com/static/image/history.png\n History as a tree\n \n\n \n \n \n https://nyxt-browser.com/article/release-3.11.8.org\n \n \n https://nyxt-browser.com/article/release-3.11.7.org\n \n \n https://nyxt-browser.com/article/release-3.11.6.org\n \n \n https://nyxt-browser.com/article/release-3.11.5.org\n \n \n https://nyxt-browser.com/article/release-3.11.4.org\n \n \n https://nyxt-browser.com/article/release-3.11.3.org\n \n \n https://nyxt-browser.com/article/release-3.11.2.org\n \n \n https://nyxt-browser.com/article/release-3.11.1.org\n \n \n https://nyxt-browser.com/article/release-3.11.0.org\n \n \n https://nyxt-browser.com/article/release-3.10.0.org\n \n \n https://nyxt-browser.com/article/release-3.9.2.org\n \n \n https://nyxt-browser.com/article/release-3.9.1.org\n \n \n https://nyxt-browser.com/article/release-3.9.0.org\n \n \n https://nyxt-browser.com/article/release-3.8.0.org\n \n \n https://nyxt-browser.com/article/release-3.7.0.org\n \n \n https://nyxt-browser.com/article/release-3.6.1.org\n \n \n\n" }, { "path": "developer-manual.org", "content": "#+TITLE: Nyxt Developer's Manual\n\n# Install org-make-toc so the TOC below will be automatically generated.\n# https://github.com/alphapapa/org-make-toc\n* Table of contents :TOC:\n:PROPERTIES:\n:TOC: :include all :ignore this\n:END:\n:CONTENTS:\n- [[#bill-of-materials][Bill of Materials]]\n - [[#source][Source]]\n - [[#common-lisp][Common Lisp]]\n - [[#web-renderers][Web renderers]]\n - [[#webkitgtk][WebKitGTK]]\n - [[#electron][Electron]]\n - [[#other][Other]]\n- [[#development-environment][Development environment]]\n - [[#tests][Tests]]\n- [[#installation][Installation]]\n- [[#contributing][Contributing]]\n - [[#help][Help]]\n - [[#commit-style][Commit style]]\n - [[#branch-management][Branch management]]\n - [[#programming-conventions][Programming conventions]]\n:END:\n\n* Bill of Materials\n** Source\n\nEither get a tarball (=nyxt--source-with-submodules.tar.xz=) from a\n[[https://github.com/atlas-engineer/nyxt/releases][tagged release]], or clone as a git repository:\n\n#+begin_src sh\nmkdir -p ~/common-lisp\ngit clone --recurse-submodules https://github.com/atlas-engineer/nyxt ~/common-lisp/nyxt\n#+end_src\n\n** Common Lisp\n\nNyxt is written in Common Lisp. Currently, we only target one of its\nimplementations - [[http://www.sbcl.org/][SBCL]].\n\nNyxt also depends on Common Lisp libraries. These are bundled in the tarball\nmentioned above or fetched as Git submodules (under =./_build=).\n\nNote for advanced users: the single source of truth for CL libraries is dictated\nby the Git submodules. Any Nyxt build that deviates from it is considered\nunofficial. See environment variable =NYXT_SUBMODULES= defined in the makefile\nto override the default behavior.\n\n** Web renderers\n\nNyxt is designed to be web engine agnostic so its dependencies vary.\n\n*** WebKitGTK\n\nUsing the latest [[https://webkitgtk.org][WebKitGTK]] version is advised for security concerns. The oldest\nversion that supports all features is 2.36.\n\nThe packages that provide the following shared objects are required:\n\n- libwebkit2gtk-4.1.so\n- libgobject-2.0.so\n- libgirepository-1.0.so\n- libglib-2.0.so\n- libgthread-2.0.so\n- libgio-2.0.so\n- libcairo.so\n- libpango-1.0.so\n- libpangocairo-1.0.so\n- libgdk_pixbuf-2.0.so\n- libgdk-3.so\n- libgtk-3.so\n\nTo improve media stream it is recommended to install =gst-libav= and the\nfollowing plugins:\n\n- gst-plugins-bad\n- gst-plugins-base\n- gst-plugins-good\n- gst-plugins-ugly\n\n*** Electron\n\nExperimental support for [[https://www.electronjs.org/][Electron]]. Further documentation soon.\n\n** Other\n\nThe packages that provide the following shared objects are required:\n\n- libssl.so.3\n- libcrypto.so.3\n- libfixposix.so.3\n- libsqlite3.so\n\nAdditionally, the following packages:\n\n- xclip :: when using X system;\n- wl-clipboard :: when using Wayland;\n- enchant :: spellchecking (optional).\n\n* Development environment\n\nLisp favors incremental program development meaning that you make some changes\nand compile them. In other words, there's no need to compile the whole codebase\nor even restart the program.\n\nThe typical Common Lisp IDE is [[https://github.com/slime/slime][SLIME]] (or its fork [[https://github.com/joaotavora/sly][SLY]]), which requires being\ncomfortable with Emacs. Add the snippet below to Emacs' init file.\n\n#+begin_src emacs-lisp\n(setq slime-lisp-implementations\n '((nyxt (\"sbcl\" \"--dynamic-space-size 3072\")\n :env (\"CL_SOURCE_REGISTRY=~/common-lisp//:~/common-lisp/nyxt/_build//\"))))\n#+end_src\n\nStart the REPL by issuing =M-- M-x sly RET nyxt RET= and evaluate:\n\n#+begin_src lisp\n(asdf:load-system :nyxt/gi-gtk)\n(nyxt:start)\n#+end_src\n\nNote that:\n\n- [[https://asdf.common-lisp.dev/asdf/Configuring-ASDF-to-find-your-systems.html][ASDF must be configured to find the required systems]];\n- =cffi= must be configured to find the required shared objects by setting env\n var =LD_LIBRARY_PATH= or =cffi:*foreign-library-directories*=.\n\n** Tests\n\nIt is recommended to restart the Lisp image before and after running the tests\nsince some of them are stateful:\n\n#+begin_src lisp\n(asdf:test-system :nyxt/gi-gtk)\n#+end_src\n\n* Installation\n\nNyxt uses the =Make= build system. Run =make= to display the documentation or\nsee the [[../makefile][Makefile]] for more details.\n\n* Contributing\n\nNyxt 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\nissue tracker]] to suit your interests and skills. Please fork the project and\nopen a pull request (PR) on GitHub to undergo the reviewing process. Refer to\nthe [[*Branch management][branch management section]] for more detailed information.\n\nPlease resist the temptation of discussing changes without drafting its\nimplementation. Currently, we value pragmatism over creativity.\n\n** Help\n\nFeel free to contact us at any point if you need guidance.\n\n- To learn Common Lisp, see [[https://nyxt-browser.com/learn-lisp]];\n- [[https://github.com/atlas-engineer/nyxt/issues][Open up an issue on GitHub]];\n- Find Nyxt on Libera IRC: =#nyxt=\n- [[https://discord.gg/YXCk7gDKgJ][Nyxt's Discord]];\n\n** Commit style\n\nEnsure to isolate commits containing whitespace changes (including indentation)\nor code movements as to avoid noise in the diffs.\n\nRegarding commit messages, we follow the convention of prefixing the title with\nthe basename when there's a single modified file. For instance, for changes in\n=source/mode/blocker.lisp= the commit message would look as per below:\n\n#+begin_example\nmode/blocker: Short description of the change\n\nFurther explanation.\n#+end_example\n\n** Branch management\n\nNyxt uses the following branches:\n\n- =master= for development;\n- == for working on particular features;\n- =-series= to backport commits corresponding to specific major\n versions.\n\nBranch off from the target branch and rebase onto it right before merging as to\navoid merge conflicts.\n\nA commit is said to be atomic when it builds and starts Nyxt successfully. At\ntimes, for the sake of readability, it is wise to break the changes down to\nsmaller non-atomic commits. In that case, a merge commit is required (use merge\noption =no-ff=). This guarantees that running =git bisect= with option\n=--first-parent= only picks atomic commits, which streamlines the process.\n\nThose with commit access may push trivial changes directly to the target branch.\n\n** Programming conventions\n\nThe usual style guides by [[https://www.cs.umd.edu/~nau/cmsc421/norvig-lisp-style.pdf][Norvig & Pitman's Tutorial on Good Lisp Programming\nStyle]] and [[https://google.github.io/styleguide/lispguide.xml][Google Common Lisp Style Guide]] are advised.\n\nFor symbol naming conventions, see https://www.cliki.net/Naming+conventions.\n\nSome of our conventions include:\n\n- Prefer =first= and =rest= over =car= and =cdr=, respectively.\n- Use =define-class= instead of =defclass=.\n- Use =nyxt:define-package= for Nyxt-related pacakges. Notice that it features\n default imports (e.g. =export-always=) and package nicknames (e.g. =alex=,\n =sera=, etc.). Prefer =uiop:define-package= for general purpose packages.\n- Export using =export-always= next to the symbol definition. This helps\n prevent exports to go out-of-sync, or catch typos. Unlike =export=,\n =export-always= saves you from surprises upon recompilation.\n- When sensible, declaim the function types using =->=. Note that there is then\n no need to mention the type of the arguments and the return value in the\n docstring.\n- Use the =maybe= and =maybe*= types instead of =(or null ...)= and =(or null\n (array * (0)) ...)=, respectively.\n- Use the =list-of= type for typed lists.\n- Use =funcall*= to not error when function does not exist.\n- Prefer classes over structs.\n- Classes should be usable with just a =make-instance=.\n- Slots classes should be formatted in the following way:\n#+begin_src lisp\n(slot-name\n slot-value\n ...\n :documentation \"Foo.\")\n#+end_src\n\nWhen =slot-value= is the only parameter specified then:\n#+begin_src lisp\n(slot-name slot-value)\n#+end_src\n- =customize-instance= is reserved for end users. Use\n =initialize-instance :after= or =slot-unbound= to initialize the slots.\n Set up the rest of the class in =customize-instance :after=. Bear in mind\n that anything in this last method won't be customizable for the end user.\n- Almost all files should be handled via the =nfiles= library.\n- =(setf SLOT-WRITER) :after= is reserved for \"watchers\",\n i.e. handlers that are run whenever the slot is set. The =:around= method is\n not used by watchers, and thus the watcher may be overridden.\n- We use the =%foo%= naming convention for special local variables.\n- We suffix predicates with =-p=. Unlike the usual convention, we always use a\n dash (i.e. =foo-p= over =foop=).\n- Prefer the term =url= over =uri=.\n- URLs should be of type =quri:uri=. If you need to manipulate a URL string, call\n it =url-string=. In case the value contains a URL, but is not =quri:url=, use\n =url-designator= and its =url= method to normalize into =quri:uri=.\n- Paths should be of type =cl:pathname=.\n Use =uiop:native-namestring= to \"send\" to OS-facing functions,\n =uiop:ensure-pathname= to \"receive\" from OS-facing functions or to \"trunamize\".\n- Prefer =handler-bind= over =handler-case=: when running from the REPL, this\n triggers the debugger with a full stacktrace; when running the Nyxt binary,\n all conditions are caught anyway.\n- Do not handle the =T= condition, this may break everything. Handle =error=,\n =serious-condition=, or exceptionally =condition= (for instance if you do not\n control the called code, and some libraries subclass =condition= instead of\n =error=).\n- Dummy variables are called =_=.\n- Prefer American spelling.\n- Construct =define-command= requires a short one-line docstring without\n newlines.\n- Name keyword function parameters as follows =&key (var default-value\n var-supplied-p)=.\n\n# - Conversion functions =FROM->TO= or =->TO= for generic functions. The\n# only one that comes to mind is =url= which does not follow this convention...\n\n# - Blocking function should be prefixed with =wait-on-=.\n\n# Local Variables:\n# eval: (add-hook 'before-save-hook\n# (lambda nil (if (fboundp 'org-make-toc)\n# (org-make-toc)\n# (message-box \"Please install org-make-toc.\")))\n# nil\n# t)\n# End:\n" }, { "path": "libraries/analysis/README.org", "content": "* Analysis\nAnalysis is a library that provides facilities to help analyze and\nunderstand data. Listed below are the classes:\n\n** Document\nThe document class represents a document. After creating a document,\nyou can perform several operations on it, some examples:\n\n+ term count: how many times does a term appear in a document?\n+ term frequency: how many times does a term appear divided by the\n total number of words in the document?\n\n** Document Collection\nThe document collection class represents a collection of documents. As\nwith a document, there are several operations available, some examples:\n\n+ dictionary: which words appear in the document collection?\n+ keywords: what are the important keywords in this document\n collection?\n\n** Document Vertex\nThe document vertex class represents a document that is part of a\ngraph. The edges slot of the document vertex class is used to store\nedges of that particular vertex. The keys in the edges slot hash table\nare the actual vertexes, and the values are the edge weights.\n\n** Document Cluster\nThe document cluster class represents a document that is part of a\ngraph which will be clustered. It extends the document-vertex class\nand adds support for a cluster tag and a list of neighbors. These\nslots are useful for clustering algorithms.\n" }, { "path": "libraries/analysis/analysis.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :analysis)\n\n(export-always 'document)\n(defclass document ()\n ((source :accessor source :initarg :source\n :documentation \"The source object for the document.\")\n (string-contents :initarg :string-contents :accessor string-contents)\n (term-count-table :initform (make-hash-table :test #'equal)\n :documentation \"Contains a mapping of term ->\namount of times word appears in the document.\")\n (vector-data :accessor vector-data\n :documentation \"Vector representation of the document.\")\n (rank :accessor rank :documentation \"Rank used for sorting.\")\n (tokens :accessor tokens)\n (token-count :accessor token-count))\n (:documentation \"The document class represents a document. After\ncreating a document, you can perform several operations on it, some\nexamples:\n\n+ term count: how many times does a term appear in a document?\n+ term frequency: how many times does a term appear divided by the\n total number of words in the document?\"))\n\n(defclass document-collection ()\n ((documents :initform () :initarg :documents :accessor documents))\n (:documentation \"The document collection class represents a\ncollection of documents. As with a document, there are several\noperations available, some examples:\n\n+ dictionary: which words appear in the document collection?\n+ keywords: what are the important keywords in this document\n collection?\"))\n\n(defmethod initialize-instance :after ((document document) &key)\n (setf (tokens document) (word-tokenize (string-contents document)))\n (setf (token-count document) (length (tokens document)))\n (loop for token in (tokens document) do\n (incf (gethash token (slot-value document 'term-count-table) 0))))\n\n(defmethod term-count ((document document) term)\n (gethash term (slot-value document 'term-count-table) 0))\n\n(defmethod term-frequency ((document document) term)\n \"How often does the word exist in the document?\"\n (/ (term-count document term)\n ;; prevent division by zero for malformed documents\n (max 1 (token-count document))))\n\n(defmethod termp ((document document) term)\n \"Does the term exist in the document?\"\n (> (term-count document term) 0))\n\n(defmethod add-document ((document-collection document-collection) document)\n \"Add a document to the document collection.\"\n (push document (documents document-collection)))\n\n(defun match-term (term)\n (lambda (document)\n (termp document term)))\n\n(defmethod document-frequency ((document-collection document-collection) term)\n (/ (count-if (match-term term) (documents document-collection))\n (length (documents document-collection))))\n\n(defmethod inverse-document-frequency ((document-collection document-collection) term)\n (log (/ (length (documents document-collection))\n (count-if (match-term term) (documents document-collection)))))\n\n(defmethod term-frequency-inverse-document-frequency ((document document)\n (document-collection document-collection)\n term)\n (* (term-frequency document term) (inverse-document-frequency document-collection term)))\n\n(defmethod dictionary ((document document))\n \"Return a list of all of the words that appear in a document.\"\n (loop for key being the hash-keys of (slot-value document 'term-count-table)\n collect key))\n\n(defmethod dictionary ((document-collection document-collection))\n \"Return a list of all of the words that appear in a document collection.\"\n (let ((words (list)))\n (loop for document in (documents document-collection)\n do (alexandria:appendf words (tokens document)))\n (remove-duplicates words :test #'equalp)))\n\n(export-always 'keywords)\n(defmethod keywords ((document document) &optional document-collection)\n (if document-collection\n (sort (loop for word in (dictionary document)\n collect (cons word (term-frequency-inverse-document-frequency\n document document-collection word)))\n #'>\n :key #'rest)\n (sort (loop for word in (dictionary document)\n collect (cons word (term-frequency document word)))\n #'>\n :key #'rest)))\n\n(export-always 'extract-keywords)\n(defun extract-keywords (text &key (limit 5))\n \"Extract keywords from a string of text.\"\n (serapeum:take limit (keywords (make-instance 'analysis:document\n :string-contents text))))\n" }, { "path": "libraries/analysis/composite-sequence.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n;; Given the following sequence:\n;; 1 2 3 4 5\n;;\n;; We would record the following sequences/outcomes.\n;;\n;; Chain length of 1:\n;; 1 -> 2\n;; 2 -> 3\n;; 3 -> 4\n;; 4 -> 5\n;;\n;; Chain length of 2:\n;; 1 2 -> 3\n;; 2 3 -> 4\n;; 3 4 -> 5\n;;\n;; Chain length of 3:\n;; 1 2 3 -> 4\n;; 2 3 4 -> 5\n;;\n;; As can be seen above, the amount of subsequences within a given sequence is\n;; equal to (- (length sequence) chain length).\n\n(in-package :analysis)\n\n(export-always 'sequence-model)\n(defclass sequence-model (node)\n ()\n (:documentation \"The sequence-model class represents the root of a directed\n graph. The edges represent possible sequences of events. It may help to\n envision the graph as a finite state machine.\"))\n\n(defclass node ()\n ((edges :accessor edges :initform (make-hash-table :test #'equal))))\n\n(export-always 'element)\n(defclass element-node (node)\n ((element :accessor element :initarg :element)\n (occurrences\n :accessor occurrences\n :initform 0\n :documentation \"Number of times this element has appeared at the end of a\n sequence.\")))\n\n(defmethod add-edge ((from-node node) (to-node node))\n (alexandria:ensure-gethash (element to-node)\n (edges from-node) to-node))\n\n(defmethod list-edge-elements ((node node))\n (mapcar #'element (alexandria:hash-table-values (edges node))))\n\n(defmethod increment ((node node))\n (incf (occurrences node)))\n\n(export-always 'add-record)\n(defmethod add-record ((model sequence-model) sequence)\n (multiple-value-bind (list-but-last-element last-element) (serapeum:halves sequence)\n (let ((leaf (alexandria:ensure-gethash list-but-last-element\n (edges model)\n (make-instance 'node))))\n (increment (add-edge leaf (make-instance 'element-node :element (first last-element)))))))\n\n(defmethod add-record-subsequence ((model sequence-model) sequence)\n \"Add a record for all subsequences. E.g. transform '(3 2 1)' into:\n'(3 2 1), '(2 1), '(1)\"\n (loop while (> (length sequence) 1)\n collect (add-record model sequence)\n do (setf sequence (rest sequence))))\n\n(export-always 'predict)\n(defmethod predict ((model sequence-model) sequence)\n (serapeum:and-let* ((leaf (gethash sequence (edges model)))\n (edges (alexandria:hash-table-values (edges leaf))))\n (first (sort edges #'> :key #'occurrences))))\n\n(defmethod predict-subsequence-simple ((model sequence-model) sequence)\n \"Predict a sequence's next value based on all subsequence predictions. This is\na naive implementation which simply considers the amount of occurences without\nregard to the weight of different chain lengths.\"\n (let* ((subsequence-results\n (loop while (> (length sequence) 1)\n collect (let* ((leaf (gethash sequence (edges model)))\n (edges (alexandria:hash-table-values (edges leaf))))\n (first (sort edges #'> :key #'occurrences)))\n do (setf sequence (rest sequence)))))\n (first (sort subsequence-results #'> :key #'occurrences))))\n" }, { "path": "libraries/analysis/data.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :analysis)\n\n(defclass language-data ()\n ((stop-words\n :initarg :stop-words\n :accessor stop-words\n :initform\n (list \"a\" \"able\" \"about\" \"above\" \"according\" \"accordingly\" \"across\" \"actually\" \"after\"\n \"afterwards\" \"again\" \"against\" \"ain't\" \"all\" \"allow\" \"allows\" \"almost\" \"alone\"\n \"along\" \"already\" \"also\" \"although\" \"always\" \"am\" \"among\" \"amongst\" \"an\" \"and\"\n \"another\" \"any\" \"anybody\" \"anyhow\" \"anyone\" \"anything\" \"anyway\" \"anyways\" \"anywhere\"\n \"apart\" \"appear\" \"appreciate\" \"appropriate\" \"are\" \"aren't\" \"around\" \"as\" \"a's\" \"aside\"\n \"ask\" \"asking\" \"associated\" \"at\" \"available\" \"away\" \"awfully\" \"be\" \"became\" \"because\" \"become\"\n \"becomes\" \"becoming\" \"been\" \"before\" \"beforehand\" \"behind\" \"being\" \"believe\" \"below\" \"beside\"\n \"besides\" \"best\" \"better\" \"between\" \"beyond\" \"both\" \"brief\" \"but\" \"by\" \"came\" \"can\" \"cannot\"\n \"cant\" \"can't\" \"cause\" \"causes\" \"certain\" \"certainly\" \"changes\" \"clearly\" \"c'mon\" \"co\" \"com\"\n \"come\" \"comes\" \"concerning\" \"consequently\" \"consider\" \"considering\" \"contain\" \"containing\"\n \"contains\" \"corresponding\" \"could\" \"couldn't\" \"course\" \"c's\" \"currently\" \"definitely\" \"described\"\n \"despite\" \"did\" \"didn't\" \"different\" \"do\" \"does\" \"doesn't\" \"doing\" \"don\" \"done\" \"don't\" \"down\"\n \"downwards\" \"during\" \"each\" \"edu\" \"eg\" \"eight\" \"either\" \"else\" \"elsewhere\" \"enough\" \"entirely\"\n \"especially\" \"et\" \"etc\" \"even\" \"ever\" \"every\" \"everybody\" \"everyone\" \"everything\" \"everywhere\"\n \"ex\" \"exactly\" \"example\" \"except\" \"far\" \"few\" \"fifth\" \"first\" \"five\" \"followed\" \"following\" \"follows\"\n \"for\" \"former\" \"formerly\" \"forth\" \"four\" \"from\" \"further\" \"furthermore\" \"get\" \"gets\" \"getting\" \"given\"\n \"gives\" \"go\" \"goes\" \"going\" \"gone\" \"got\" \"gotten\" \"greetings\" \"had\" \"hadn't\" \"happens\" \"hardly\" \"has\"\n \"hasn't\" \"have\" \"haven't\" \"having\" \"he\" \"he'd\" \"he'll\" \"hello\" \"help\" \"hence\" \"her\" \"here\" \"hereafter\"\n \"hereby\" \"herein\" \"here's\" \"hereupon\" \"hers\" \"herself\" \"he's\" \"hi\" \"him\" \"himself\" \"his\" \"hither\"\n \"hopefully\" \"how\" \"howbeit\" \"however\" \"how's\" \"i\" \"i'd\" \"ie\" \"if\" \"ignored\" \"i'll\" \"i'm\" \"immediate\"\n \"in\" \"inasmuch\" \"inc\" \"indeed\" \"indicate\" \"indicated\" \"indicates\" \"inner\" \"insofar\" \"instead\" \"into\"\n \"inward\" \"is\" \"isn't\" \"it\" \"it'd\" \"it'll\" \"its\" \"it's\" \"itself\" \"i've\" \"just\" \"keep\" \"keeps\" \"kept\"\n \"know\" \"known\" \"knows\" \"last\" \"lately\" \"later\" \"latter\" \"latterly\" \"least\" \"less\" \"lest\" \"let\" \"let's\"\n \"like\" \"liked\" \"likely\" \"little\" \"look\" \"looking\" \"looks\" \"ltd\" \"mainly\" \"many\" \"may\" \"maybe\" \"me\"\n \"mean\" \"meanwhile\" \"merely\" \"might\" \"more\" \"moreover\" \"most\" \"mostly\" \"much\" \"must\" \"mustn't\" \"my\"\n \"myself\" \"name\" \"namely\" \"nd\" \"near\" \"nearly\" \"necessary\" \"need\" \"needs\" \"neither\" \"never\" \"nevertheless\"\n \"new\" \"next\" \"nine\" \"no\" \"nobody\" \"non\" \"none\" \"noone\" \"nor\" \"normally\" \"not\" \"nothing\" \"novel\" \"now\"\n \"nowhere\" \"obviously\" \"of\" \"off\" \"often\" \"oh\" \"ok\" \"okay\" \"old\" \"on\" \"once\" \"one\" \"ones\" \"only\" \"onto\"\n \"or\" \"other\" \"others\" \"otherwise\" \"ought\" \"our\" \"ours\" \"ourselves\" \"out\" \"outside\" \"over\" \"overall\" \"own\"\n \"particular\" \"particularly\" \"per\" \"perhaps\" \"placed\" \"please\" \"plus\" \"possible\" \"presumably\" \"probably\"\n \"provides\" \"que\" \"quite\" \"qv\" \"rather\" \"rd\" \"re\" \"really\" \"reasonably\" \"regarding\" \"regardless\" \"regards\"\n \"relatively\" \"respectively\" \"right\" \"s\" \"said\" \"same\" \"saw\" \"say\" \"saying\" \"says\" \"second\" \"secondly\" \"see\"\n \"seeing\" \"seem\" \"seemed\" \"seeming\" \"seems\" \"seen\" \"self\" \"selves\" \"sensible\" \"sent\" \"serious\" \"seriously\"\n \"seven\" \"several\" \"shall\" \"shan't\" \"she\" \"she'd\" \"she'll\" \"she's\" \"should\" \"shouldn't\" \"since\" \"six\" \"so\"\n \"some\" \"somebody\" \"somehow\" \"someone\" \"something\" \"sometime\" \"sometimes\" \"somewhat\" \"somewhere\" \"soon\" \"sorry\"\n \"specified\" \"specify\" \"specifying\" \"still\" \"sub\" \"such\" \"sup\" \"sure\" \"t\" \"take\" \"taken\" \"tell\" \"tends\" \"th\"\n \"than\" \"thank\" \"thanks\" \"thanx\" \"that\" \"thats\" \"that's\" \"the\" \"their\" \"theirs\" \"them\" \"themselves\" \"then\"\n \"thence\" \"there\" \"thereafter\" \"thereby\" \"therefore\" \"therein\" \"theres\" \"there's\" \"thereupon\" \"these\" \"they\"\n \"they'd\" \"they'll\" \"they're\" \"they've\" \"think\" \"third\" \"this\" \"thorough\" \"thoroughly\" \"those\" \"though\"\n \"three\" \"through\" \"throughout\" \"thru\" \"thus\" \"to\" \"together\" \"too\" \"took\" \"toward\" \"towards\" \"tried\"\n \"tries\" \"truly\" \"try\" \"trying\" \"t's\" \"twice\" \"two\" \"un\" \"under\" \"unfortunately\" \"unless\" \"unlikely\"\n \"until\" \"unto\" \"up\" \"upon\" \"us\" \"use\" \"used\" \"useful\" \"uses\" \"using\" \"usually\" \"value\" \"various\" \"very\"\n \"via\" \"viz\" \"vs\" \"want\" \"wants\" \"was\" \"wasn't\" \"way\" \"we\" \"we'd\" \"welcome\" \"well\" \"we'll\" \"went\" \"were\"\n \"we're\" \"weren't\" \"we've\" \"what\" \"whatever\" \"what's\" \"when\" \"whence\" \"whenever\" \"when's\" \"where\"\n \"whereafter\" \"whereas\" \"whereby\" \"wherein\" \"where's\" \"whereupon\" \"wherever\" \"whether\" \"which\" \"while\"\n \"whither\" \"who\" \"whoever\" \"whole\" \"whom\" \"who's\" \"whose\" \"why\" \"why's\" \"will\" \"willing\" \"wish\" \"with\"\n \"within\" \"without\" \"wonder\" \"won't\" \"would\" \"wouldn't\" \"yes\" \"yet\" \"you\" \"you'd\" \"you'll\" \"your\"\n \"you're\" \"yours\" \"yourself\" \"yourselves\" \"you've\" \"zero\"))\n (stop-words-lookup :accessor stop-words-lookup)))\n\n(defmethod initialize-instance :after ((data language-data) &key)\n (setf (stop-words-lookup data)\n (loop with ht = (make-hash-table :test #'equal)\n for stop in (stop-words data)\n do (setf (gethash stop ht) t)\n finally (return ht))))\n\n(defparameter *language-data* (make-instance 'language-data))\n" }, { "path": "libraries/analysis/dbscan.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :analysis)\n\n;;; dbscan.lisp -- implementation of Density-based spatial clustering\n;;; of applications with noise (DBSCAN) algorithm\n\n(defclass document-cluster (document-vertex)\n ((cluster :accessor cluster :initform :noise)\n (neighbors :accessor neighbors))\n (:documentation \"The document cluster class represents a document\nthat is part of a graph which will be clustered. It extends the\ndocumenet-vertex class and adds support for a cluster tag and a list\nof neighbors. These slots are useful for clustering algorithms.\"))\n\n(defmethod clusters ((collection document-collection))\n \"Return a list of clusters. Each hash key represents a cluster, and\n the hash value is the list of elements in that cluster.\n\n Please note: this function is not responsible for computing the\n clusters, only for returning the list of pre-tagged documents in\n cluster lists.\"\n (let ((result (make-hash-table)))\n (loop for document in (documents collection)\n do (push document (gethash (cluster document) result (list))))\n result))\n\n(defun get-cluster (cluster-label points)\n \"Return all matching points for a given cluster label.\"\n (remove-if-not (lambda (i) (eq (cluster i) cluster-label)) points))\n\n(defmethod distance ((vector-1 t) (vector-2 t))\n \"Return the Euclidean distance between two vectors.\"\n (sqrt (loop for i across vector-1\n for j across vector-2\n sum (expt (- i j) 2))))\n\n(defmethod distance ((document-a document-cluster) (document-b document-cluster))\n (distance (vector-data document-a) (vector-data document-b)))\n\n(defmethod generate-document-distance-vectors ((collection document-collection))\n \"Set the edge weights for all document neighbors (graph is fully connected).\"\n (with-accessors ((documents documents)) collection\n (loop for document-a in documents\n do (loop for document-b in documents\n do (setf (gethash document-b (edges document-a))\n (distance document-a document-b))))))\n\n(defmethod dbscan ((collection document-collection) &key (minimum-points 3)\n (epsilon 0.5))\n \"Minimum points refers to the minimum amount of points that must\n exist in the neighborhood of a point for it to be considered a\n core-point in a cluster. Epsilon refers to the distance between\n two points for them to be considered neighbors.\"\n (labels ((range-query (document)\n \"Return all points that have a distance less than epsilon.\"\n (loop for vertex being the hash-keys of (edges document)\n when (and (<= (gethash vertex (edges document)) epsilon)\n (not (eq vertex document)))\n collect vertex))\n (core-point-p (point)\n \"Is a point a core-point?\"\n (<= minimum-points (length (range-query point))))\n (cluster-match-p (point cluster)\n \"Check if a core point belongs to a cluster.\"\n (intersection cluster (range-query point))))\n ;;; identify core points\n (let* ((core-points (remove-if-not #'core-point-p (documents collection)))\n (non-core-points (set-difference (documents collection) core-points)))\n ;;; assign labels to core points\n (loop for point in core-points\n with cluster-count = 0\n do (loop named cluster-set\n for i from 0 to cluster-count\n ;; point found cluster match, setf and break\n when (cluster-match-p point (get-cluster i core-points))\n do (setf (cluster point) i)\n (return-from cluster-set)\n ;; point found no cluster-match, create new cluster\n finally (setf (cluster point) (incf cluster-count))))\n ;;; assign labels to non-core points\n (loop for point in non-core-points\n for intersection = (intersection core-points (range-query point))\n when intersection\n do (setf (cluster point) (cluster (first intersection)))))))\n" }, { "path": "libraries/analysis/document-vector.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :analysis)\n\n;;; document-vector.lisp: transform a document into a vector\n\n(defmethod word-count-vectorize ((document document) dictionary)\n \"Transform a document into a vector using word counts.\"\n (let ((vector-data (make-array (length dictionary) :initial-element 0)))\n (loop for word in dictionary\n for index from 0 below (length vector-data)\n do (setf (aref vector-data index) (term-count document word)))\n (setf (vector-data document) vector-data)))\n\n(defmethod tf-idf-vectorize ((document document) (collection document-collection) dictionary)\n \"Transform a document into a vector using tf-idf.\nDefinition: tf-idf: term frequency, inverse document frequency. How\noften does a term a appear in a document as compared to all other\ndocuments?\"\n (let ((vector-data (make-array (length dictionary) :initial-element 0)))\n (loop for word in dictionary\n for index from 0 below (length vector-data)\n do (setf (aref vector-data index)\n (term-frequency-inverse-document-frequency document collection word)))\n (setf (vector-data document) vector-data)))\n\n(defmethod tf-vectorize ((document document) dictionary)\n \"Transform a document into a vector using tf.\nDefinition: tf: term frequency. How often does a term appear in a\ndocument?\"\n (let ((vector-data (make-array (length dictionary) :initial-element 0)))\n (loop for word in dictionary\n for index from 0 below (length vector-data)\n do (setf (aref vector-data index)\n (term-frequency document word)))\n (setf (vector-data document) vector-data)))\n\n(defmethod vectorize-documents ((document-collection document-collection) operation)\n (let ((dictionary (dictionary document-collection)))\n (loop for document in (documents document-collection)\n do (funcall operation document dictionary))))\n\n(defmethod word-count-vectorize-documents ((document-collection document-collection))\n (vectorize-documents document-collection #'word-count-vectorize))\n\n(defmethod tf-vectorize-documents ((document-collection document-collection))\n \"Definition: tf: term frequency. How often does a term appear in a\ndocument?\"\n (vectorize-documents document-collection #'tf-vectorize))\n\n(defmethod tf-idf-vectorize-documents ((document-collection document-collection))\n \"Definition: tf-idf: term frequency, inverse document frequency. How\noften does a term appear in a document as compared to all other\ndocuments?\"\n (vectorize-documents document-collection (lambda (document dictionary)\n (tf-idf-vectorize document document-collection dictionary))))\n\n\n" }, { "path": "libraries/analysis/package.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(uiop:define-package :analysis\n (:use :cl)\n (:import-from :serapeum #:export-always))\n" }, { "path": "libraries/analysis/section.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :analysis)\n\n;;; section.lisp -- given a document, automatically generate sections\n\n\n(export-always 'extract-sections)\n(defun extract-sections (text &key (epsilon 0.5))\n \"Extract the sections from a string of text. Epsilon refers to the\n distance between two points for them to be considered related.\"\n (labels ((average-distance (point points)\n (/ (reduce #'+ points\n :key (lambda (i) (distance (vector-data i)\n (vector-data point))))\n (length points))))\n (let ((collection (make-instance 'document-collection)))\n (loop for sentence in (sentence-tokenize text)\n do (add-document collection\n (make-instance 'document-cluster\n :string-contents sentence)))\n (tf-vectorize-documents collection)\n (loop for document in (documents collection)\n with cluster-index = 0\n for cluster = (get-cluster cluster-index (documents collection))\n do (if (and cluster (>= epsilon (average-distance document cluster)))\n (setf (cluster document) cluster-index)\n (setf (cluster document) (incf cluster-index))))\n collection)))\n" }, { "path": "libraries/analysis/stem.lisp", "content": "(in-package :analysis)\n\n;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n;; The software is completely free for any purpose, unless notes at\n;; the head of the program text indicates otherwise (which is\n;; rare). In any case, the notes about licensing are never more\n;; restrictive than the BSD License.\n;\n;; In every case where the software is not written by me (Martin\n;; Porter), this licensing arrangement has been endorsed by the\n;; contributor, and it is therefore unnecessary to ask the contributor\n;; again to confirm it.\n;\n;; The Porter Stemming Algorithm, somewhat mechanically hand translated to Common Lisp by\n;; Steven M. Haflich smh@franz.com Feb 2002. Most of the inline comments refer to the\n;; original C code. At the time of this translation the code passes the associated Porter\n;; test files. See the function test at the end of this file.\n\n;; This port is intended to be portable ANSI Common Lisp. However, it has only been\n;; compiled and tested with Allegro Common Lisp. This code is offered in the hope it will\n;; be useful, but with no warranty of correctness, suitability, usability, or anything\n;; else. The C implementation from which this code was derived was not reentrant, relying\n;; on global variables. This implementation corrects that. It is intended that a word to\n;; be stemmed will be in a string with fill-pointer, as this is a natural result when\n;; parsing user input, web scraping, whatever. If not, a string with fill-pointer is\n;; created, but this is an efficiency hit and is here intended only for lightweight use or\n;; testing. Using some resource mechanism on these strings would be a useful improvement,\n;; whether here or in the calling code.\n\n;; Postscript: When I contacted Martin Porter about this anachronism, he decided to fix\n;; the C version to implement proper reentrancy. The CL version is now also served from\n;; his central site. It should be functionally identical to this one, modulo the current\n;; comment and a couple harmless formatting and comment changes.\n;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n\n;; This is the Porter stemming algorithm, coded up in ANSI C by the\n;; author. It may be regarded as canonical, in that it follows the\n;; algorithm presented in\n\n;; Porter, 1980, An algorithm for suffix stripping, Program, Vol. 14,\n;; no. 3, pp 130-137,\n\n;; only differing from it at the points maked --DEPARTURE-- below.\n\n;; See also http://www.tartarus.org/~martin/PorterStemmer\n\n;; The algorithm as described in the paper could be exactly replicated\n;; by adjusting the points of DEPARTURE, but this is barely necessary,\n;; because (a) the points of DEPARTURE are definitely improvements, and\n;; (b) no encoding of the Porter stemmer I have seen is anything like\n;; as exact as this version, even with the points of DEPARTURE!\n\n;; You can compile it on Unix with 'gcc -O3 -o stem stem.c' after which\n;; 'stem' takes a list of inputs and sends the stemmed equivalent to\n;; stdout.\n\n;; The algorithm as encoded here is particularly fast.\n\n;; Release 1\n\n;; The main part of the stemming algorithm starts here. b is a buffer\n;; holding a word to be stemmed. The letters are in b[k0], b[k0+1] ...\n;; ending at b[k]. In fact k0 = 0 in this demo program. k is readjusted\n;; downwards as the stemming progresses. Zero termination is not in fact\n;; used in the algorithm.\n\n;; Note that only lower case sequences are stemmed. Forcing to lower case\n;; should be done before stem(...) is called.\n\n;; cons(i) is TRUE <=> b[i] is a consonant.\n\n;;; Common Lisp port Version 1.01\n\n;;;\n;;; Common Lisp port Version history\n;;;\n;;; 1.0 -- smh@franz.com Feb 2002\n;;; initial release\n;;;\n;;; 1.01 -- smh@franz.com 25 Apr 2004\n;;; step4 signalled error for \"ion\" \"ions\". Thanks to Jeff Heard\n;;; for detecting this and suggesting the fix.\n\n(defun consonantp (str i)\n (let ((char (char str i)))\n (cond ((member char '(#\\a #\\e #\\i #\\o #\\u)) nil)\n\t ((eql char #\\y)\n\t (if (= i 0) t (not (consonantp str (1- i)))))\n\t (t t))))\n\n;; m() measures the number of consonant sequences between k0 and j. if c is\n;; a consonant sequence and v a vowel sequence, and <..> indicates arbitrary\n;; presence,\n\n;; gives 0\n;; vc gives 1\n;; vcvc gives 2\n;; vcvcvc gives 3\n;; ....\n\n(defun m (str lim)\n (let ((n 0)\n\t(i 0))\n (loop\n (when (>= i lim) (return-from m n))\n (if (not (consonantp str i)) (return nil))\n (incf i))\n (incf i)\n (loop\n (loop\n\t(if (>= i lim) (return-from m n))\n\t(if (consonantp str i) (return nil))\n\t(incf i))\n (incf i)\n (incf n)\n (loop\n\t(if (>= i lim) (return-from m n))\n\t(if (not (consonantp str i)) (return nil))\n\t(incf i))\n (incf i))))\n\n;; vowelinstem() is TRUE <=> k0,...j contains a vowel\n\n(defun vowelinstem (str)\n (loop for i from 0 below (fill-pointer str)\n unless (consonantp str i) return t))\n\n;; doublec(j) is TRUE <=> j,(j-1) contain a double consonant.\n\n(defun doublec (str i)\n (cond ((< i 1) nil)\n\t((not (eql (char str i) (char str (1- i)))) nil)\n\t(t (consonantp str i))))\n\n;; cvc(i) is TRUE <=> i-2,i-1,i has the form consonant - vowel - consonant\n;; and also if the second c is not w,x or y. this is used when trying to\n;; restore an e at the end of a short word. e.g.\n\n;; cav(e), lov(e), hop(e), crim(e), but\n;; snow, box, tray.\n\n(defun cvc (str lim)\n (decf lim)\n (if (or (< lim 2)\n\t (not (consonantp str lim))\n\t (consonantp str (1- lim))\n\t (not (consonantp str (- lim 2))))\n (return-from cvc nil))\n (if (member (char str lim) '(#\\w #\\x #\\y)) (return-from cvc nil))\n t)\n\n;; ends(s) is TRUE <=> k0,...k ends with the string s.\n\n(defun ends (str ending)\n (declare (string str) (simple-string ending))\n (let ((len1 (length str)) (len2 (length ending)))\n (loop\n\tfor pa downfrom (1- len1) to 0\n\tand pb downfrom (1- len2) to 0\n\tunless (eql (char str pa) (char ending pb))\n\treturn nil\n\tfinally (return (when (< pb 0)\n\t\t\t (decf (fill-pointer str) len2)\n\t\t\t t)))))\n\n;; setto(s) sets (j+1),...k to the characters in the string s, readjusting k.\n\n(defun setto (str suffix)\n (declare (string str) (simple-string suffix))\n (loop for char across suffix\n do (vector-push-extend char str)))\n\n;; r(s) is used further down.\n\n(defun r (str s sfp)\n (if (> (m str (fill-pointer str)) 0)\n (setto str s)\n (setf (fill-pointer str) sfp)))\n\n;; step1ab() gets rid of plurals and -ed or -ing. e.g.\n\n;; caresses -> caress\n;; ponies -> poni\n;; ties -> ti\n;; caress -> caress\n;; cats -> cat\n\n;; feed -> feed\n;; agreed -> agree\n;; disabled -> disable\n\n;; matting -> mat\n;; mating -> mate\n;; meeting -> meet\n;; milling -> mill\n;; messing -> mess\n\n;; meetings -> meet\n\n(defun step1ab (str)\n (when (eql (char str (1- (fill-pointer str))) #\\s)\n (cond ((ends str \"sses\") (incf (fill-pointer str) 2))\n\t ((ends str \"ies\") (setto str \"i\"))\n\t ((not (eql (char str (- (fill-pointer str) 2)) #\\s)) (decf (fill-pointer str)))))\n (cond ((ends str \"eed\") (if (> (m str (fill-pointer str)) 0)\n\t\t\t (incf (fill-pointer str) 2)\n\t\t\t (incf (fill-pointer str) 3)))\n\t((let ((sfp (fill-pointer str)))\n\t (if (or (ends str \"ed\")\n\t\t (ends str \"ing\"))\n\t (if (vowelinstem str)\n\t\t t\n\t\t (progn (setf (fill-pointer str) sfp)\n\t\t\tnil))))\n\t (cond ((ends str \"at\") (setto str \"ate\"))\n\t ((ends str \"bl\") (setto str \"ble\"))\n\t ((ends str \"iz\") (setto str \"ize\"))\n\t ((doublec str (1- (fill-pointer str)))\n\t\t(unless (member (char str (1- (fill-pointer str))) '(#\\l #\\s #\\z))\n\t\t (decf (fill-pointer str))))\n\t (t (if (and (= (m str (fill-pointer str)) 1)\n\t\t\t (cvc str (fill-pointer str)))\n\t\t (setto str \"e\"))))))\n str)\n\n;; step1c() turns terminal y to i when there is another vowel in the stem.\n\n(defun step1c (str)\n (let ((saved-fill-pointer (fill-pointer str)))\n (when (and (ends str \"y\")\n\t (vowelinstem str))\n\t(setf (char str (fill-pointer str)) #\\i))\n (setf (fill-pointer str) saved-fill-pointer))\n str)\n\n;; step2() maps double suffices to single ones. so -ization ( = -ize plus\n;; -ation) maps to -ize etc. note that the string before the suffix must give\n;; m() > 0.\n\n(defun step2 (str)\n (let ((sfp (fill-pointer str)))\n (when (> sfp 2)\n (block nil\n\t(case (char str (- (length str) 2))\n\t (#\\a (when (ends str \"ational\") (r str \"ate\" sfp) (return))\n\t (when (ends str \"tional\") (r str \"tion\" sfp) (return)))\n\t (#\\c (when (ends str \"enci\") (r str \"ence\" sfp) (return))\n\t (when (ends str \"anci\") (r str \"ance\" sfp) (return)))\n\t (#\\e (when (ends str \"izer\") (r str \"ize\" sfp) (return)))\n\t (#\\l (when (ends str \"bli\") (r str \"ble\" sfp) (return))\n\t ;; -DEPARTURE-\n\t ;; To match the published algorithm, replace prev line with\n\t ;; ((when (ends str \"abli\") (r str \"able\" sfp) (return))\n\t (when (ends str \"alli\") (r str \"al\" sfp) (return))\n\t (when (ends str \"entli\") (r str \"ent\" sfp) (return))\n\t (when (ends str \"eli\") (r str \"e\" sfp) (return))\n\t (when (ends str \"ousli\") (r str \"ous\" sfp) (return)))\n\t (#\\o (when (ends str \"ization\") (r str \"ize\" sfp) (return))\n\t (when (ends str \"ation\") (r str \"ate\" sfp) (return))\n\t (when (ends str \"ator\") (r str \"ate\" sfp) (return)))\n\t (#\\s (when (ends str \"alism\") (r str \"al\" sfp) (return))\n\t (when (ends str \"iveness\") (r str \"ive\" sfp) (return))\n\t (when (ends str \"fulness\") (r str \"ful\" sfp) (return))\n\t (when (ends str \"ousness\") (r str \"ous\" sfp) (return)))\n\t (#\\t (when (ends str \"aliti\") (r str \"al\" sfp) (return))\n\t (when (ends str \"iviti\") (r str \"ive\" sfp) (return))\n\t (when (ends str \"biliti\") (r str \"ble\" sfp) (return)))\n\t ;; -DEPARTURE-\n\t ;; To match the published algorithm, delete next line.\n\t (#\\g (when (ends str \"logi\") (r str \"log\" sfp) (return)))))))\n str)\n\n;; step3() deals with -ic-, -full, -ness etc. similar strategy to step2.\n\n(defun step3 (str)\n (let ((sfp (fill-pointer str)))\n (block nil\n (case (char str (1- (length str)))\n\t(#\\e (when (ends str \"icate\") (r str \"ic\" sfp) (return))\n\t (when (ends str \"ative\") (r str \"\" sfp) (return)) ; huh?\n\t (when (ends str \"alize\") (r str \"al\" sfp) (return)))\n\t(#\\i (when (ends str \"iciti\") (r str \"ic\" sfp) (return)))\n\t(#\\l (when (ends str \"ical\") (r str \"ic\" sfp) (return))\n\t (when (ends str \"ful\") (r str \"\" sfp) (return))) ; huh?\n\t(#\\s (when (ends str \"ness\") (r str \"\" sfp) (return))) ; huh?\n\t)))\n str)\n\n;; step4() takes off -ant, -ence etc., in context vcvc.\n\n(defun step4 (str)\n (let ((sfp (fill-pointer str)))\n (when (> sfp 2)\t\t\t; Unnecessary?\n (block nil\n\t(case (char str (- sfp 2))\n\t (#\\a (if (ends str \"al\") (return)))\n\t (#\\c (if (ends str \"ance\") (return))\n\t (if (ends str \"ence\") (return)))\n\t (#\\e (if (ends str \"er\") (return)))\n\t (#\\i (if (ends str \"ic\") (return)))\n\t (#\\l (if (ends str \"able\") (return))\n\t (if (ends str \"ible\") (return)))\n\t (#\\n (if (ends str \"ant\") (return))\n\t (if (ends str \"ement\") (return))\n\t (if (ends str \"ment\") (return))\n\t (if (ends str \"ent\") (return)))\n\t (#\\o (if (ends str \"ion\")\n\t\t (let ((len (length str)))\n\t\t (if (and (> len 0)\n\t\t\t (let ((c (char str (1- len))))\n\t\t\t\t(or (eql c #\\s) (eql c #\\t))))\n\t\t\t (return)\n\t\t (setf (fill-pointer str) sfp))))\n\t (if (ends str \"ou\") (return))) ; takes care of -ous\n\t (#\\s (if (ends str \"ism\") (return)))\n\t (#\\t (if (ends str \"ate\") (return))\n\t (if (ends str \"iti\") (return)))\n\t (#\\u (if (ends str \"ous\") (return)))\n\t (#\\v (if (ends str \"ive\") (return)))\n\t (#\\z (if (ends str \"ize\") (return))))\n\t(return-from step4 str))\n (unless (> (m str (fill-pointer str)) 1)\n\t(setf (fill-pointer str) sfp)))\n str))\n\n;; step5() removes a final -e if m() > 1, and changes -ll to -l if m() > 1.\n\n(defun step5 (str)\n (let ((len (fill-pointer str)))\n (if (eql (char str (1- len)) #\\e)\n\t(let ((a (m str len)))\n\t (if (or (> a 1)\n\t\t (and (= a 1)\n\t\t (not (cvc str (1- len)))))\n\t (decf (fill-pointer str))))))\n (let ((len (fill-pointer str)))\n (if (and (eql (char str (1- len)) #\\l)\n\t (doublec str (1- len))\n\t (> (m str len) 1))\n\t(decf (fill-pointer str))))\n str)\n\n;; In stem(p,i,j), p is a char pointer, and the string to be stemmed is from p[i] to p[j]\n;; inclusive. Typically i is zero and j is the offset to the last character of a string,\n;; (p[j+1] == '\\0'). The stemmer adjusts the characters p[i] ... p[j] and returns the new\n;; end-point of the string, k. Stemming never increases word length, so i <= k <= j. To\n;; turn the stemmer into a module, declare 'stem' as extern, and delete the remainder of\n;; this file.\n\n(defun stem (str)\n (let ((len (length str)))\n ;; With this line, strings of length 1 or 2 don't go through the\n ;; stemming process, although no mention is made of this in the\n ;; published algorithm. Remove the line to match the published\n ;; algorithm.\n (if (<= len 2) (return-from stem str)) ; /*-DEPARTURE-*/\n (if (typep str 'simple-string)\t; Primarily for testing.\n\t(setf str\n\t (make-array len :element-type 'character\n\t\t :fill-pointer len :initial-contents str)))\n (step1ab str) (step1c str) (step2 str) (step3 str) (step4 str) (step5 str)\n str))\n\n#+never\n(trace step1ab step1c step2 step3 step4 step5)\n\n#+never\n(defun test ()\t\t\t\t; Run against the distributed test files.\n (with-open-file (f1 \"voc.txt\")\n (with-open-file (f2 \"output.txt\")\n (loop as w1 = (read-line f1 nil nil)\n\t while w1\n\t as w2 = (read-line f2 nil nil)\n\t as w3 = (stem w1)\n\t if (equal w2 w3)\n\t count t into successes\n\t else count t into failures\n\t and do (format t \"(stem ~s) => ~s wanted ~s~%\" w1 w3 w2)\n\t finally (progn (format t \"sucesses ~d failures ~d~%\" successes failures)\n\t\t\t (return failures))))))\n" }, { "path": "libraries/analysis/tests/tests.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(uiop:define-package :analysis/tests\n (:use :cl :lisp-unit2)\n (:import-from :analysis))\n(in-package :analysis/tests)\n\n(define-test test-single-length ()\n (let ((model (make-instance 'analysis::sequence-model)))\n (analysis::add-record model '(1 2))\n (assert-equal (analysis::element (analysis::predict model '(1))) 2))\n\n (let ((model (make-instance 'analysis::sequence-model)))\n (analysis::add-record model '(1 2))\n (analysis::add-record model '(2 3))\n (analysis::add-record model '(2 3))\n (assert-equal (analysis::element (analysis::predict model '(1))) 2))\n\n (let ((model (make-instance 'analysis::sequence-model)))\n (analysis::add-record model '(1 2))\n (analysis::add-record model '(1 2))\n (analysis::add-record model '(1 2))\n (analysis::add-record model '(1 3))\n (analysis::add-record model '(1 3))\n (assert-equal (analysis::element (analysis::predict model '(1))) 2))\n\n (let ((model (make-instance 'analysis::sequence-model)))\n (analysis::add-record model '(1 2))\n (analysis::add-record model '(1 2))\n (analysis::add-record model '(1 3))\n (analysis::add-record model '(1 3))\n (analysis::add-record model '(1 3))\n (assert-equal (analysis::element (analysis::predict model '(1))) 3))\n\n (let ((model (make-instance 'analysis::sequence-model)))\n (analysis::add-record model '(1 2))\n (analysis::add-record model '(1 3))\n (analysis::add-record model '(1 2))\n (assert-equal (analysis::element (analysis::predict model '(1))) 2)))\n\n(define-test test-multiple-length ()\n (let ((model (make-instance 'analysis::sequence-model)))\n (analysis::add-record model '(1 2 3))\n (assert-equal (analysis::element (analysis::predict model '(1 2))) 3))\n\n ;; Make sure the most temporally recent element is used\n ;; Fails in CCL.\n (let ((model (make-instance 'analysis::sequence-model)))\n (analysis::add-record model '(1 2 4))\n (analysis::add-record model '(1 2 3))\n (assert-equal (analysis::element (analysis::predict model '(1 2))) 3))\n\n (let ((model (make-instance 'analysis::sequence-model)))\n (analysis::add-record model '(1 2 3))\n (analysis::add-record model '(1 2 4))\n (analysis::add-record model '(1 2 4))\n (analysis::add-record model '(1 2 4))\n (assert-equal (analysis::element (analysis::predict model '(1 2))) 4))\n\n (let ((model (make-instance 'analysis::sequence-model)))\n (analysis::add-record model '(1 2 3))\n (analysis::add-record model '(1 2 4))\n (analysis::add-record model '(1 2 4))\n (analysis::add-record model '(1 2 4))\n (analysis::add-record model '(1 2 3))\n (analysis::add-record model '(1 2 3))\n (analysis::add-record model '(1 2 3))\n (analysis::add-record model '(1 2 3))\n (assert-equal (analysis::element (analysis::predict model '(1 2))) 3)))\n\n(define-test test-variable-length ()\n (let ((model (make-instance 'analysis::sequence-model)))\n (analysis::add-record model '(1 2 3))\n (analysis::add-record model '(1 2 4))\n (analysis::add-record model '(1 2 4))\n (analysis::add-record model '(1 2 4))\n (analysis::add-record model '(1 2))\n (analysis::add-record model '(1 2))\n (analysis::add-record model '(1 2))\n (analysis::add-record model '(1 2 3))\n (analysis::add-record model '(1 2 3))\n (analysis::add-record model '(1 2 3))\n (analysis::add-record model '(1 2 3))\n (assert-equal (analysis::element (analysis::predict model '(1 2))) 3))\n\n (let ((model (make-instance 'analysis::sequence-model)))\n (analysis::add-record model '(1 2 3))\n (analysis::add-record model '(1 2 4))\n (analysis::add-record model '(1 2 4))\n (analysis::add-record model '(1 2 4))\n (analysis::add-record model '(1 2))\n (analysis::add-record model '(1 2))\n (analysis::add-record model '(1 3))\n (analysis::add-record model '(1 3))\n (analysis::add-record model '(1 3))\n (analysis::add-record model '(1 2 3))\n (analysis::add-record model '(1 2 3))\n (analysis::add-record model '(1 2 3))\n (analysis::add-record model '(1 2 3))\n (assert-equal (analysis::element (analysis::predict model '(1))) 3)\n (assert-equal (analysis::element (analysis::predict model '(1 2))) 3)))\n" }, { "path": "libraries/analysis/text-rank.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :analysis)\n\n;;; text-rank.lisp -- implementation of textrank algorithm\n\n(defclass document-vertex (document)\n ((edges :accessor edges :initform (make-hash-table)\n :documentation \"The keys of the hash table represent the\n edges, the values of the hash table represent the edge\n weights.\"))\n (:documentation \"The document vertex class represents a document\nthat is part of a graph. The edges slot of the document vertex class\nis used to store edges of that particular vertex. The keys in the\nedges slot hash table are the actual vertexes, and the values are the\nedge weights.\"))\n\n(defmethod cosine-similarity ((document-a document) (document-b document))\n \"Calculate the cosine similarity between two vectors.\"\n (flet ((vector-product (document-a document-b)\n (loop for a across (vector-data document-a)\n for b across (vector-data document-b)\n sum (* a b)))\n (vector-sum-root (document)\n (sqrt (loop for i across (vector-data document)\n sum (* i i))))\n (vector-zero-p (document)\n (every #'zerop (vector-data document))))\n (if (or (vector-zero-p document-a) (vector-zero-p document-b))\n 0 ; if either vector is completely zero, they are dissimilar\n (/ (vector-product document-a document-b)\n (* (vector-sum-root document-a) (vector-sum-root document-b))))))\n\n(defmethod generate-document-similarity-vectors ((collection document-collection))\n \"Set the edge weights for all document neighbors (graph is fully connected).\"\n (with-accessors ((documents documents)) collection\n (loop for document-a in documents\n do (loop for document-b in documents\n do (setf (gethash document-b (edges document-a))\n (cosine-similarity document-a document-b))))))\n\n(defmethod text-rank ((collection document-collection) &key (epsilon 0.001)\n (damping 0.85)\n (initial-rank)\n (iteration-limit 100))\n \"This method is used to calculate the text rankings for a document\n collection. The `epsilon' is the maximum delta for a given node\n rank change during an iteration to be considered convergent. The\n `damping' is a factor utilized to normalize the data. The\n `initial-rank' is the rank given to nodes before any\n iterations. The `iteration-limit' is the amount of times the\n algorithm may traverse the graph before giving up (if the algorithm\n does not converge).\"\n (with-accessors ((documents documents)) collection\n (unless (zerop (length documents))\n (labels ((set-initial-rank ()\n \"Set the initial rank of all documents to a supplied\n value OR 1/length of the documents.\"\n (let ((initial-rank (or initial-rank (/ 1 (length documents)))))\n (mapcar (lambda (document) (setf (rank document) initial-rank)) documents)))\n (graph-neighbors (document)\n \"Return a list of neighbors. In a fully connected graph,\n all nodes are a neighbor except for the node itself.\"\n (remove document documents))\n (graph-neighbor-edge-sum (document)\n \"Add up the edges of all neighbors of a given node.\"\n (let ((sum (- (reduce #'+ (alexandria:hash-table-values (edges document))) 1)))\n (if (> sum 0) sum 1)))\n (document-similarity (document-a document-b)\n (gethash document-b (edges document-a) 0))\n (convergedp (previous-score current-score)\n \"Check if a delta qualifies for convergence.\"\n (<= (abs (- previous-score current-score)) epsilon))\n (calculate-rank (document)\n \"Calculate the rank of a document.\"\n (loop for neighbor in (graph-neighbors document)\n sum (/ (* damping (rank neighbor) (document-similarity document neighbor))\n (graph-neighbor-edge-sum neighbor)))))\n (set-initial-rank)\n (loop with converged = nil\n for iteration from 0 to iteration-limit until converged\n do (setf converged t)\n (loop for document in documents\n for old-rank = (rank document)\n for new-rank = (calculate-rank document)\n do (setf (rank document) new-rank)\n unless (convergedp old-rank new-rank)\n do (setf converged nil)))))))\n\n(export-always 'summarize-text)\n(defun summarize-text (text &key (summary-length 3) (show-rank-p nil))\n (let ((collection (make-instance 'document-collection)))\n (loop for sentence in (sentence-tokenize text)\n do (add-document collection\n (make-instance 'document-vertex\n :string-contents sentence)))\n (tf-idf-vectorize-documents collection)\n (generate-document-similarity-vectors collection)\n (text-rank collection :iteration-limit 100)\n (serapeum:take summary-length\n (mapcar (if show-rank-p\n (lambda (i) (cons (rank i) (string-contents i)))\n #'string-contents)\n (sort (documents collection) #'> :key #'rank)))))\n" }, { "path": "libraries/analysis/tokenize.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :analysis)\n\n(defun word-tokenize (string &key (remove-stop-words t) (stem nil) (down-case t) (alphabetic t))\n \"Split a string into a list of words.\"\n (let* ((alpha-scanner (cl-ppcre:create-scanner \"^[A-Za-z]*$\"))\n (tokens (str:split \" \" (str:collapse-whitespaces string)))\n (tokens (if remove-stop-words\n (delete-if (lambda (x) (gethash (string-downcase x) (stop-words-lookup *language-data*))) tokens)\n tokens))\n (tokens (if stem\n (mapcar #'stem tokens)\n tokens))\n (tokens (if down-case\n (mapcar #'string-downcase tokens)\n tokens))\n (tokens (if alphabetic\n (delete-if-not (lambda (x) (cl-ppcre:scan alpha-scanner x)) tokens)\n tokens)))\n tokens))\n\n(defun sentence-tokenize (string)\n \"Split a string into a list of sentences.\"\n ;; TODO: Use \"\\\\p{Terminal_Punctuation}\" regexp instead to catch all terminal\n ;; punctuation marks, including \",\" and \";\"?\n (remove \"\" (mapcar #'str:trim (cl-ppcre:split \"[.!?]\" string)) :test #'equal))\n" }, { "path": "libraries/download-manager/engine.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :download-manager)\n\n(defvar *default-download-directory* #p\"~/Downloads/\")\n(defun default-download-directory ()\n (let ((dir (ignore-errors (uiop:run-program '(\"xdg-user-dir\" \"DOWNLOAD\")\n :output '(:string :stripped t)))))\n (when (or (null dir) (string= dir (uiop:getenv \"HOME\")))\n (setf dir (uiop:getenv \"XDG_DOWNLOAD_DIR\")))\n (unless dir\n (setf dir *default-download-directory*))\n dir))\n\n(defun download-directory (&optional (directory (default-download-directory)))\n \"Return path to download directory.\nCreate it if it does not exist.\"\n (unless directory\n (setf directory (default-download-directory)))\n (unless (string= \"\" (file-namestring directory))\n (setf directory (format nil \"~a/\" (namestring directory))))\n (truename (ensure-directories-exist directory)))\n\n(defun ensure-unique-file (file)\n \"Return FILE if unique or suffix it with a number otherwise.\"\n (loop with original-name = file\n with suffix = 1\n while (uiop:file-exists-p file)\n do (setf file (make-pathname :defaults original-name\n :name (format nil \"~a.~d\" (pathname-name (pathname original-name))\n suffix)))\n do (incf suffix))\n (namestring (pathname file)))\n\n(defvar *notifications* nil\n \"A channel which can be queried for download notifications.\nThe channel return value is a `download'.\")\n\n(defclass download ()\n ((requested-url\n :accessor requested-url\n :initarg :requested-url\n :initform (quri:uri \"\")\n :type quri:uri\n :documentation \"The URL that the user requested.\nThis may be different from the actual location of the download, e.g. in case of\nautomatic redirection. See RESOLVED-URL.\")\n (resolved-url\n :accessor resolved-url\n :initarg :resolved-url\n :initform (quri:uri \"\")\n :type quri:uri\n :documentation \"The actual source of the download.\nThis may be different from the URL the user requested, see REQUESTED-URL.\")\n (file\n :accessor file\n :initarg :file\n :initform \"\"\n :documentation \"Path pointing to the local storage location of the\ndownloaded file.\")\n (downstream\n :accessor downstream\n :initarg :downstream\n :initform nil\n :documentation \"The stream which can be read from to do the actual\ndownload.\")\n (status\n :accessor status\n :initarg :status\n ;; TODO: String?\n :initform nil)\n (header\n :accessor header\n :initarg :header\n :initform \"\")\n (update-interval\n :type alexandria:non-negative-real\n :accessor update-interval\n :initarg :update-interval\n :initform 1.0\n :documentation \"Time in seconds after which a notification is sent to the\n`*notifications*' channel.\")\n (last-update\n :type alexandria:non-negative-real\n :accessor last-update\n :initarg :last-update\n :initform 0.0\n :documentation \"Time in seconds when the last notification was sent.\")\n (finished-p\n :accessor finished-p\n :initform nil\n :documentation \"Non-nil if it has finished downloading.\")\n (bytes-fetched\n :accessor bytes-fetched\n :initform 0)\n (bytes-last-update\n :accessor bytes-last-update\n :initform 0\n :documentation \"Bytes fetched when last `update' was called.\")\n (last-update-speed\n :accessor last-update-speed\n :initform 0\n :documentation \"Download speed in B/s when last `update' was called.\")))\n\n(defmethod filename ((download download))\n \"Return the full name of this downloaded file, as a string.\"\n (format nil \"~a\" (file download)))\n\n(defmethod temp-file ((download download))\n \"Return a file name suitable for unfinished\ndownloads.\"\n (ensure-unique-file\n (format nil \"~a.part\" (namestring (file download)))))\n\n(defmethod bytes-total ((download download))\n (let ((bytes (gethash \"content-length\"\n (header download) 0)))\n (if (stringp bytes) (parse-integer bytes) bytes)))\n\n(defmethod progress ((download download))\n \"Return progress ratio.\nWhen download is completed, return 1.0.\nWhen progress cannot be computer (because bytes-total is unknown), return\n(values 0 'unknown).\"\n (cond\n ((finished-p download) 1)\n ((if (> (bytes-total download) 0)\n (/ (float (bytes-fetched download))\n (float (bytes-total download)))\n (values 0 'unknown)))))\n\n(defmethod update ((download download))\n \"Send DOWNLOAD to the `notifications' channel.\nOnly send if last update was more than `update-interval' seconds ago.\"\n (let* ((new-time (/ (get-internal-real-time) (float internal-time-units-per-second)))\n (time-diff (- new-time (last-update download))))\n (when (or (< (update-interval download) time-diff)\n (finished-p download))\n (calispel:! *notifications* download)\n (setf (last-update-speed download)\n (if (= 0 time-diff)\n 0\n (round (/ (float (- (bytes-fetched download) (bytes-last-update download)))\n time-diff))))\n (setf (bytes-last-update download) (bytes-fetched download))\n (setf (last-update download) new-time))))\n\n(declaim (ftype (function (quri:uri &key (:directory (or string pathname))\n (:proxy (or quri:uri null))\n (:cookies (or string null))))\n resolve))\n(defun resolve (url &key\n (directory (default-download-directory))\n proxy\n cookies)\n \"Start downloading URL concurrently and return a corresponding `download' object.\nIf DIRECTORY is nil, `default-download-directory' will be used. COOKIES can\nspecify a cookie jar as a string, which is useful for authenticated downloads.\nPROXY is the full proxy address, e.g. \\\"socks5://127.0.0.1:9050\\\".\"\n (unless *notifications*\n (setf *notifications* (make-instance 'calispel:channel)))\n (let ((download (cache :url url\n :directory (download-directory directory)\n :cookies cookies\n :proxy proxy)))\n ;; TODO: We just use bt:make-thread, no need for a channel... Unless need to\n ;; watch for unfinished downloads and warn the user before closing.\n (bt:make-thread\n (lambda ()\n (fetch download))\n :name \"download-manager\")\n download))\n" }, { "path": "libraries/download-manager/native.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n;;; Native Common Lisp download manager backend.\n(in-package :download-manager)\n\n(defmethod cache ((type (eql :url)) url &rest args)\n (log:debug url args)\n (apply #'locally-cache url args))\n\n(defun parse-cookie-jar-string (cookie-jar-string host path)\n \"Host is for instance \\\"example.org\\\" and path is \\\"/foo/bar\\\".\"\n (cl-cookie:make-cookie-jar\n :cookies (mapcar (lambda (c)\n (cl-cookie:parse-set-cookie-header c host path))\n (cl-ppcre:split \" *; *\" cookie-jar-string))))\n\n(defun locally-cache (requested-url\n &key\n (directory (download-directory))\n cookies\n proxy)\n (let* ((cookies-jar\n (unless (str:emptyp cookies)\n (parse-cookie-jar-string cookies (quri:uri-host requested-url)\n (quri:uri-path requested-url)))))\n (handler-case\n (multiple-value-bind (stream status response-headers resolved-url)\n (dex:get (quri:render-uri requested-url)\n :want-stream t :force-binary t :keep-alive nil\n :proxy (and proxy (quri:render-uri proxy)) :cookie-jar cookies-jar)\n ;; TODO: Allow caller to set the target filename?\n (let* ((file (merge-pathnames\n directory (extract-filename requested-url\n response-headers))))\n ;; TODO: Touch file now to ensure uniqueness when actually downloading?\n (make-instance 'download\n :requested-url requested-url\n :resolved-url (quri:uri resolved-url)\n :header response-headers\n :file file\n :status status\n :downstream stream)))\n (error (c)\n (error c)))))\n\n(defmethod fetch ((download download)\n &key (buffer-size 16)) ; Small for testing.\n \"Return the number of bytes fetched.\"\n (let* ((buffer (make-array buffer-size :element-type '(unsigned-byte 8)))\n ;; Without `uiop:parse-native-namestring' `with-open-file' would fail\n ;; if `temp-file' had a wildcard.\n (temp-file (uiop:parse-native-namestring (temp-file download))))\n (with-open-file (output temp-file\n :direction :output\n :if-exists :supersede\n :element-type '(unsigned-byte 8))\n (log:info \"Downloading ~s~% to ~s.\"\n (or (ignore-errors (quri:url-decode (quri:render-uri (resolved-url download))))\n (quri:render-uri (resolved-url download)))\n (namestring (file download)))\n (loop :for byte-position = (read-sequence buffer (downstream download))\n\n :do (update download)\n\n :when (plusp byte-position)\n :do (incf (bytes-fetched download) byte-position)\n\n :if (plusp byte-position)\n :do (write-sequence buffer output :end byte-position)\n :else :return nil))\n ;; TODO: Report something if bytes-fetched is not the same as bytes-total.\n (setf (finished-p download) t)\n (uiop:rename-file-overwriting-target temp-file\n (ensure-unique-file\n ;; Same as above for `parse-native-namestring'.\n (uiop:parse-native-namestring\n (namestring (file download)))))\n (update download)\n (bytes-fetched download)))\n\n(defun parse-http-header (header-entry)\n \"Return the alist of key-value paris in HEADER-ENTRY.\"\n (mapcar (lambda (key-value)\n (cl-ppcre:split \"=\" key-value))\n ;; TODO: Don't split at escaped or quoted semicolons?\n (cl-ppcre:split \" *; *\" header-entry)))\n\n(defun normalize-filename (filename)\n \"Remove surrounding quotes and return the basename as a string.\nReturn NIL if filename is not a string or a pathname.\"\n (when (pathnamep filename)\n (setf filename (namestring filename)))\n (when (stringp filename)\n (file-namestring (string-trim \"\\\"\" filename))))\n\n(defun extract-filename (url &optional headers)\n \"Extract a filename to save the contents of a URL under.\"\n ;; See https://en.wikipedia.org/wiki/List_of_HTTP_header_fields.\n (or (normalize-filename\n (second (assoc \"filename\"\n (parse-http-header\n (gethash \"content-disposition\" headers))\n :test #'string=)))\n (let ((basename\n (ignore-errors (file-namestring (quri:uri-path url)))))\n (if (or (null basename) (string= \"\" basename))\n \"index.html\"\n basename))))\n" }, { "path": "libraries/download-manager/package.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(uiop:define-package :download-manager\n (:use :cl)\n (:export #:init\n #:*notifications*\n #:default-download-directory\n #:download\n #:resolved-url\n #:requested-url\n #:header\n #:file\n #:filename\n #:bytes-fetched\n #:bytes-total\n #:progress\n #:finished-p\n #:last-update-speed\n #:cache\n #:resolve))\n" }, { "path": "libraries/nasdf/install.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :nasdf)\n\n(export-always 'nasdf-file)\n(defclass nasdf-file (static-file)\n ((if-does-not-exist\n :initform :error\n :initarg :if-does-not-exist\n :type (member :error nil)\n :documentation \"What to do when input file is missing:\n- `:error': Signal an error.\n- `nil': Skip it.\"))\n (:documentation \"Component type for files to install.\"))\n(import 'nasdf-file :asdf-user)\n\n(export-always 'nasdf-binary-file)\n(defclass nasdf-binary-file (nasdf-file) ()\n (:documentation \"Component type for executables to install.\"))\n(import 'nasdf-binary-file :asdf-user)\n\n(export-always 'nasdf-library-file)\n(defclass nasdf-library-file (nasdf-binary-file) ()\n (:documentation \"Component type for libraries (shared objects) to install.\"))\n(import 'nasdf-library-file :asdf-user)\n\n(export-always 'nasdf-desktop-file)\n(defclass nasdf-desktop-file (nasdf-file) ()\n (:documentation \"Component type for XDG .desktop files to install.\"))\n(import 'nasdf-desktop-file :asdf-user)\n\n(export-always 'nasdf-appdata-file)\n(defclass nasdf-appdata-file (nasdf-file) ()\n (:documentation \"Component type for Appdata files to install.\"))\n(import 'nasdf-appdata-file :asdf-user)\n\n(export-always 'nasdf-icon-scalable-file)\n(defclass nasdf-icon-scalable-file (nasdf-file) ()\n (:documentation \"Component type for the SVG icon.\"))\n(import 'nasdf-icon-scalable-file :asdf-user)\n\n(export-always 'nasdf-icon-directory)\n(defclass nasdf-icon-directory (nasdf-file)\n ((asdf/interface::type :initform \"png\")) ; TODO: Is there a standard way to access the type?\n (:documentation \"Component type for directory containing icon files to install.\nFile of type `type' are looked for.\nThe last number found in the file name is used to install the icon in the right directory.\"))\n(import 'nasdf-icon-directory :asdf-user)\n\n;; TODO: Is it possible to list all files targetted by an ASDF system?\n(export-always 'nasdf-source-directory)\n(defclass nasdf-source-directory (nasdf-file)\n ((exclude-subpath\n :initform '()\n :type (or null (cons string *))\n :accessor exclude-subpath\n :initarg :exclude-subpath\n :documentation \"Subpath to exclude from installation.\nSubpaths are relative to the component, so\n\n (:nasdf-source-directory \\\"foo\\\" :exclude-subpath (\\\"bar\\\"))\n\nmeans that foo/bar is excluded, but foo/baz is not.\n\nIf subpath is a directory, then all its subpaths are excluded as well.\")\n (exclude-types\n :initform '(\"fasl\")\n :type (or null (cons string *))\n :accessor exclude-types\n :initarg :exclude-types\n :documentation \"Pattern of files to exclude when not using Git.\"))\n (:documentation \"Directory of Common Lisp source files.\nSubdirectory is included.\nGit is used to list the tracked files -- untracked files will be ignored.\nIf Git is not found, fall back to copying everything except files of type in `exclude-types'.\n\nDestination directory is given by the `dest-source-dir' generic function.\"))\n(import 'nasdf-source-directory :asdf-user)\n\n(defun nil-pathname-p (pathname)\n \"Return non-nil if PATHNAME is `*nil-pathname*' or nil.\"\n (the (values boolean &optional)\n (or (null pathname)\n (pathname-equal pathname *nil-pathname*))))\n\n(defun basename (pathname) ; From nfiles.\n \"Return the basename, that is:\n- if it's a directory, the name of the directory,\n- if it's a file, the name of the file including its type (extension),\n- nil if it's a nil-pathname (#p\\\"\\\").\"\n (if (nil-pathname-p pathname)\n nil ; TODO: Shouldn't we return #p\"\" instead?\n (first (last (pathname-directory\n ;; Ensure directory _after_ truenamizing, otherwise if\n ;; non-directory file exists it may not yield a directory.\n (ensure-directory-pathname\n (ensure-pathname pathname :truenamize t)))))))\n\n(defun path-from-env (environment-variable default)\n (let ((env (getenv environment-variable)))\n (if env\n (ensure-directory-pathname env)\n default)))\n\n(defun relative-path-from-env (environment-variable default)\n (let ((env (getenv environment-variable)))\n (if env\n (relativize-pathname-directory (ensure-directory-pathname env))\n default)))\n\n;; We use `defparameter' so that paths are re-computed on system reload.\n(export-always '*destdir*)\n(defparameter *destdir* (if (getenv \"DESTDIR\")\n (ensure-directory-pathname (getenv \"DESTDIR\"))\n #p\"/\"))\n\n(export-always '*prefix*)\n(defparameter *prefix* (merge-pathnames* (relative-path-from-env \"PREFIX\" #p\"usr/local/\")\n *destdir*))\n\n(export-always '*datadir*)\n(defparameter *datadir* (path-from-env \"DATADIR\" (merge-pathnames* \"share/\" *prefix*)))\n(export-always '*bindir*)\n(defparameter *bindir* (path-from-env \"BINDIR\" (merge-pathnames* \"bin/\" *prefix*)))\n(export-always '*libdir*)\n(defparameter *libdir* (path-from-env \"LIBDIR\" (merge-pathnames* \"lib/\" *prefix*)))\n\n(export-always 'libdir)\n(defmethod libdir ((component nasdf-library-file))\n (let ((name (primary-system-name (component-system component))))\n (ensure-directory-pathname (merge-pathnames* name *libdir*))))\n\n(export-always '*dest-source-dir*)\n(defvar *dest-source-dir* (path-from-env \"NASDF_SOURCE_PATH\" *datadir*)\n \"Root of where the source will be installed.\nFinal path is resolved in `dest-source-dir'.\")\n\n(export-always 'dest-source-dir)\n(defmethod dest-source-dir ((component nasdf-source-directory))\n \"The directory into which the source is installed.\"\n (let ((name (primary-system-name (component-system component))))\n (ensure-directory-pathname\n (merge-pathnames* name *dest-source-dir*))))\n\n(export-always '*chmod-program*)\n(defvar *chmod-program* \"chmod\")\n(export-always '*chmod-executable-arg*)\n(defvar *chmod-executable-arg* \"+x\")\n\n(export-always 'make-executable)\n(defun make-executable (file)\n \"Does nothing if files does not exist.\"\n ;; TODO: Use iolib/os:file-permissions instead of chmod? Too verbose?\n (when (file-exists-p file)\n (run-program (list *chmod-program* *chmod-executable-arg* (native-namestring file)))))\n\n(export-always 'install-file)\n(defun install-file (file dest)\n \"Like `copy-file' but ensures all parent directories are created if necessary.\"\n (ensure-all-directories-exist\n (list (directory-namestring dest)))\n (copy-file file dest))\n\n(defmethod perform ((op compile-op) (c nasdf-file)) ; REVIEW: load-op?\n (loop for input in (input-files op c)\n for output in (output-files op c)\n do (if (or (file-exists-p input)\n (slot-value c 'if-does-not-exist))\n (progn\n (install-file input output)\n ;; (format *error-output* \"~&; installing file~%; ~s~%; to~%; ~s~%\" source dest) ; Too verbose?\n (logger \"installed ~s\" output))\n (logger \"skipped ~s\" output)))\n nil)\n\n(defmethod output-files ((op compile-op) (c nasdf-file))\n (values (list (merge-pathnames* (pathname-name (component-name c))\n *prefix*))\n t))\n\n(defmethod output-files ((op compile-op) (c nasdf-binary-file))\n (values (list (merge-pathnames* (basename (component-name c)) *bindir*))\n t))\n\n(defmethod perform ((op compile-op) (c nasdf-binary-file))\n (call-next-method)\n (mapc #'make-executable (output-files op c))\n nil)\n\n(defmethod output-files ((op compile-op) (c nasdf-library-file))\n (values (list (merge-pathnames* (basename (component-name c)) (libdir c)))\n t))\n\n(defmethod output-files ((op compile-op) (c nasdf-desktop-file))\n (values (list (merge-pathnames* (merge-pathnames*\n (basename (component-name c))\n \"applications/\")\n *datadir*))\n t))\n\n(defmethod output-files ((op compile-op) (c nasdf-appdata-file))\n (values (list (merge-pathnames* (merge-pathnames*\n (basename (component-name c))\n \"metainfo/\")\n *datadir*))\n t))\n\n(defmethod output-files ((op compile-op) (c nasdf-icon-scalable-file))\n (values (list (merge-pathnames* (merge-pathnames*\n (basename (component-name c))\n \"icons/hicolor/scalable/apps/\")\n *datadir*))\n t))\n\n;; TODO Moving png icons to assets/icons would simplify their handling.\n(defun scan-last-number (path)\n \"Return the last number found in PATH.\nReturn NIL is there is none.\"\n (let ((result (block red\n (reduce (lambda (&optional next-char result)\n (if (parse-integer (string next-char) :junk-allowed t)\n (cons next-char result)\n (if result\n (return-from red result)\n result)))\n (native-namestring path)\n :initial-value '()\n :from-end t))))\n (when result\n (coerce result 'string))))\n\n(defmethod input-files ((op compile-op) (c nasdf-icon-directory))\n \"Return all files of NASDF-ICON-DIRECTORY `type' in its directory.\nFile must contain a number in their path.\"\n (let ((result (remove-if (complement #'scan-last-number)\n (directory-files (component-pathname c)\n (strcat \"*.\" (file-type c))))))\n (let* ((dimensions (mapcar #'scan-last-number result))\n (dups (set-difference dimensions\n (remove-duplicates dimensions)\n :test 'string=)))\n (if (= 0 (length dups))\n result\n (error \"Directory contains icons with duplicate dimensions: ~a\" dups)))))\n\n(defmethod output-files ((op compile-op) (c nasdf-icon-directory))\n (let ((name (primary-system-name (component-system c))))\n (values\n (mapcar (lambda (path)\n (let ((icon-size (scan-last-number path)) )\n (format nil \"~a/icons/hicolor/~ax~a/apps/~a.png\"\n *datadir*\n icon-size icon-size\n name)))\n (input-files op c))\n t)))\n\n(defun file-excluded-type (file exclude-types)\n (member (pathname-type file) exclude-types :test 'equalp))\n\n(defun list-directory (directory &key exclude-subpath (exclude-types '(\"fasl\")))\n (let ((result '()))\n (collect-sub*directories\n (ensure-directory-pathname directory)\n (constantly t)\n (lambda (dir)\n (notany (lambda (exclusion)\n (string-suffix-p (basename dir) exclusion))\n (mapcar #'basename exclude-subpath)))\n (lambda (subdirectory)\n (setf result (append result\n (remove-if\n (lambda (file) (file-excluded-type file exclude-types))\n (directory-files subdirectory))))))\n result))\n\n(export-always 'copy-directory)\n(defun copy-directory (source destination &key exclude-subpath (exclude-types '(\"fasl\")) verbose-p) ; REVIEW: Unused, but seem quite useful.\n \"Copy the content (the file tree) of SOURCE to DESTINATION.\"\n (when verbose-p\n (logger \"copy ~s/* inside ~s.\" source destination))\n (mapc (lambda (file)\n (unless (member (pathname-type file) exclude-types :test 'equalp)\n (let ((destination-file\n (merge-pathnames*\n (subpathp file (ensure-directory-pathname source))\n (ensure-pathname destination :truenamize t :ensure-directory t))))\n (install-file file destination-file))))\n (list-directory source :exclude-subpath exclude-subpath\n :exclude-types exclude-types)))\n\n\n(defmethod input-files ((op compile-op) (component nasdf-source-directory))\n \"Return all files of NASDF-SOURCE-DIRECTORY.\"\n (with-current-directory ((system-source-directory (component-system component)))\n (list-directory (component-pathname component)\n :exclude-subpath (exclude-subpath component)\n :exclude-types (exclude-types component))))\n\n(defmethod output-files ((op compile-op) (component nasdf-source-directory))\n (let ((root (system-source-directory (component-system component))))\n (values\n (mapcar (lambda (path)\n (merge-pathnames* (subpathp path root) (dest-source-dir component)))\n (input-files op component))\n t)))\n\n(export-always 'nasdf-source-file)\n(defclass nasdf-source-file (nasdf-file) ()\n (:documentation \"Common Lisp source files.\n\nDestination directory is given by the `dest-source-dir' generic function.\"))\n(import 'nasdf-source-file :asdf-user)\n\n(defmethod dest-source-dir ((component nasdf-source-file)) ; TODO: Factor with other method?\n \"The directory into which the source is installed.\"\n (let ((name (primary-system-name (component-system component))))\n (ensure-directory-pathname\n (merge-pathnames* name *dest-source-dir*))))\n\n(defmethod output-files ((op compile-op) (c nasdf-source-file))\n (values (list (merge-pathnames* (basename (component-name c)) (dest-source-dir c)))\n t))\n" }, { "path": "libraries/nasdf/log.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :nasdf)\n\n;; TODO: Use full-fledged logging facility?\n;; Maybe we want to keep this dependency-free though...\n\n(defvar *log-prefix* \"; \")\n\n(defun logger (control-string &rest format-arguments)\n \"Like `format' but assumes `*error-output*' as a stream and ensures fresh lines.\"\n (let ((*standard-output* *error-output*))\n (fresh-line)\n (princ *log-prefix*)\n (apply #'format t control-string format-arguments)\n (fresh-line)))\n" }, { "path": "libraries/nasdf/nasdf.asd", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(defsystem \"nasdf\"\n :version \"0.1.8\"\n :author \"Atlas Engineer LLC\"\n :description \"ASDF helpers for system setup, testing and installation.\"\n :license \"BSD 3-Clause\"\n :components ((:file \"package\")\n (:file \"log\")\n (:file \"nasdf\")\n (:file \"install\")\n (:file \"systems\")\n (:file \"tests\")))\n" }, { "path": "libraries/nasdf/nasdf.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :nasdf)\n\n(defmacro export-always (symbols &optional (package nil package-supplied?))\n \"Like `export', but also evaluated at compile time.\"\n `(eval-when (:compile-toplevel :load-toplevel :execute)\n (export ,symbols ,@(and package-supplied? (list package)))))\n\n(defun env-true-p (env-variable)\n (let ((value (getenv env-variable)))\n (or (string-equal \"true\" value)\n (string-equal \"yes\" value)\n (string-equal \"on\" value)\n (string-equal \"1\" value))))\n" }, { "path": "libraries/nasdf/package.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n#+sb-package-locks\n(eval-when (:compile-toplevel :load-toplevel :execute)\n (when (find-package :nasdf)\n (sb-ext:unlock-package :nasdf)))\n\n(uiop:define-package :nasdf\n (:use #:cl #:uiop #:asdf)\n (:documentation \"ASDF helpers for system setup, testing and installation.\n\nA system that installs files:\n\n(defsystem \\\"my-project/install\\\"\n :defsystem-depends-on (\\\"nasdf\\\")\n :depends-on (alexandria)\n :components ((:nasdf-desktop-file \\\"assets/my-project.desktop\\\")\n (:nasdf-icon-directory \\\"assets/\\\")\n (:nasdf-binary-file \\\"my-project\\\")\n (:nasdf-library-file \\\"libraries/web-extensions/libmy.so\\\"\n :if-does-not-exist nil)\n (:nasdf-source-directory \\\"source\\\")\n (:nasdf-source-directory \\\"nasdf\\\")\n (:nasdf-source-directory \\\"libraries\\\"\n :exclude-subpath (\\\"web-extensions\\\") ; Do not install this non-Lisp source.\n :exclude-types (\\\"o\\\" \\\"c\\\" \\\"h\\\" ; C code and artifacts.\n \\\"fasl\\\"))))\n\nA test system:\n\n(defsystem \\\"my-project/tests\\\"\n :defsystem-depends-on (\\\"nasdf\\\")\n :class :nasdf-test-system\n :depends-on (alexandria lisp-unit2)\n :components ((:file \\\"tests\\\"))\n :test-suite-args (:package :my-project/tests))\"))\n\n#+sb-package-locks\n(sb-ext:lock-package :nasdf)\n" }, { "path": "libraries/nasdf/readme.org", "content": "#+TITLE: NASDF\n\nNASDF is an ASDF extension providing utilities to ease system setup, testing and\ninstallation.\n\n* Features\n\n- Test suite helpers.\n- Installation helpers such as handling of icons or desktop files.\n\nSee [[file:package.lisp]] for more details.\n\n* Environment variables\n\nNASDF exposes the following environment variables for convenience:\n\n- =NASDF_SOURCE_PATH= :: See =nasdf:*dest-source-dir*=.\n- =NASDF_USE_LOGICAL_PATHS= :: Allow non-expanded logical pathnames in system\n pathnames.\n This is particularly useful when shipping the source.\n Disable it if your tooling (e.g. SLIME) encounters issues to find the\n definition of symbols.\n See =asdf:nasdf-file=.\n\nAll boolean environment variables try to be smart enough to understand what you\nmean; for instance both =on= and =true= are valid values to enable the feature.\n" }, { "path": "libraries/nasdf/systems.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :nasdf)\n\n(export-always 'nasdf-system)\n(defclass nasdf-system (system) ()\n (:documentation \"Extended ASDF system.\nIt enables features such as:\n- Togglable logical-pathnames depending on NASDF_USE_LOGICAL_PATHS.\n- Executable dependencies are made immutable for ASDF to prevent accidental reloads.\"))\n(import 'nasdf-system :asdf-user)\n\n(defmethod perform :before ((o image-op) (c nasdf-system))\n \"Perform some last minute tweaks to the final image.\n\n- Register immutable systems to prevent compiled images from\ntrying to recompile the application and its dependencies.\nSee `:*immutable-systems*'.\n\n- If on SBCL, include `sb-sprof', the statistical profiler, since it's one of\nthe few modules that's not automatically included in the image.\"\n #+sbcl\n (require :sb-sprof)\n (map () 'register-immutable-system (already-loaded-systems)))\n\n(defun set-new-translation (host logical-directory\n root-directory\n &optional (translated-directory (string-downcase (substitute #\\/ #\\; logical-directory))))\n \"Add default translations for LOGICAL-DIRECTORY (e.g. \\\"foo;bar;\\\") in HOST.\nDefault translations:\n- FASL files are expanded as usual with `apply-output-translations' (should default to the ASDF cache).\n- Other files are expanded to their absolute location.\n\nThis effectively makes the logical pathname behave as if it had been a physical\npathname.\"\n (let* ((logical-directory (if (string-suffix-p logical-directory \";\")\n logical-directory\n (strcat logical-directory \";\")))\n (logical-path (strcat host \":\" logical-directory \"**;*.*.*\"))\n (logical-fasl-path (strcat host \":\" logical-directory \"**;*.fasl.*\"))\n (path-translation (ensure-pathname\n (subpathname* root-directory\n translated-directory)\n :ensure-directory t\n :wilden t))\n (fasl-translation (ensure-pathname\n (apply-output-translations\n (subpathname* root-directory\n translated-directory))\n :wilden t)))\n (if (ignore-errors (logical-pathname-translations host))\n (flet ((set-alist (key value)\n (let ((pair (assoc key (logical-pathname-translations host)\n :key #'namestring\n :test #'string-equal)))\n (if pair\n (setf (rest pair) (list value))\n (push (list key value)\n (logical-pathname-translations host))))))\n (set-alist logical-path path-translation)\n (set-alist logical-fasl-path fasl-translation)\n ;; Return this for consistency:\n (list (list logical-fasl-path fasl-translation)\n (list logical-path path-translation)))\n (setf (logical-pathname-translations host)\n ;; WARNING: fasl path must come first as it's more specific.\n (list (list logical-fasl-path fasl-translation)\n (list logical-path path-translation))))))\n\n(defun logical-word-or-lose (word) ; From `sb-impl::logical-word-or-lose'.\n (declare (string word))\n (when (string= word \"\")\n (error 'namestring-parse-error\n :complaint \"Attempted to treat invalid logical hostname ~\n as a logical host:~% ~S\"\n :args (list word)\n :namestring word :offset 0))\n (let ((word (string-upcase word)))\n (dotimes (i (length word))\n (let ((ch (schar word i)))\n (unless (and (typep ch 'standard-char)\n (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\\-)))\n (error 'namestring-parse-error\n :complaint \"logical namestring character which ~\n is not alphanumeric or hyphen:~% ~S\"\n :args (list ch)\n :namestring word :offset i))))\n (coerce word 'string)))\n\n(defun parse-logical-pathname (pathname)\n \"Return two values:\n- the host;\n- the directory.\"\n (let* ((name (namestring pathname))\n (pos (position #\\: name)))\n (when pos\n (let ((host (subseq name 0 (position #\\: name))))\n (when (ignore-errors (logical-word-or-lose host))\n (values host\n (subseq name (1+ (position #\\: name)))))))))\n\n(defmethod component-pathname ((system nasdf-system))\n \"If NASDF_USE_LOGICAL_PATHS environment variable is set, use logical path source\nlocation, otherwise use the translated path.\n\nTools such as Emacs (SLIME and SLY) may fail to make use of logical paths, say,\nto go to the compilation error location.\"\n (let ((path (call-next-method)))\n (when path\n (let ((final-path (let ((host (parse-logical-pathname path)))\n (if host\n (progn\n (set-new-translation host\n (subseq (namestring path) (1+ (length host)))\n (system-source-directory system))\n ;; The #p reader macro expands to logical\n ;; pathnames only if the host is already\n ;; defined, which may not be the case at this\n ;; point, so we remake the pathname.\n (make-pathname :defaults path))\n path))))\n (if (env-true-p \"NASDF_USE_LOGICAL_PATHS\")\n final-path\n (translate-logical-pathname final-path))))))\n\n(defclass nyxt-renderer-system (system) ()\n (:documentation \"Specialized systems for Nyxt with renderer dependency.\nThe renderer is configured from NYXT_RENDERER or `*nyxt-renderer*'.\"))\n(import 'nyxt-renderer-system :asdf-user)\n\n(export '*nyxt-renderer*)\n(defvar *nyxt-renderer* (or (getenv \"NYXT_RENDERER\")\n \"gi-gtk\"))\n\n(defmethod component-depends-on ((o prepare-op) (c nyxt-renderer-system))\n `((load-op ,(format nil \"nyxt/~a-application\" *nyxt-renderer*))\n ,@(call-next-method)))\n" }, { "path": "libraries/nasdf/tests.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :nasdf)\n\n(export-always 'nasdf-test-system)\n(defclass nasdf-test-system (nasdf-system)\n ((test-suite-args\n :initform nil\n :initarg :test-suite-args\n :reader test-suite-args\n :documentation \"Arguments passed to `lisp-unit2:run-tests'.\"))\n (:documentation \"Specialized system that runs `lisp-unit2' test suites, whose parameters are\nspecified by the `test-suite-args' slot.\"))\n(import 'nasdf-test-system :asdf-user)\n\n(defmethod perform ((op test-op) (c nasdf-test-system))\n (destructuring-bind (&key package tags exclude-tags &allow-other-keys) (test-suite-args c)\n (let ((output (symbol-call\n :lisp-unit2 :run-tests\n :package package\n :tags tags\n :run-contexts (find-symbol* :with-summary-context :lisp-unit2)))))))\n\n(export-always 'print-benchmark)\n(defun print-benchmark (benchmark-results)\n (labels ((rat->float (num)\n (if (integerp num) num (float num)))\n (print-times (entry)\n (let ((title (first entry))\n (attr (rest entry)))\n (unless (or (member (symbol-name title)\n '(\"RUN-TIME\" \"SYSTEM-RUN-TIME\"))\n (and (member (symbol-name title)\n '(\"PAGE-FAULTS\" \"EVAL-CALLS\")\n :test #'string=)\n (zerop (getf attr :average))))\n (format t \" ~a: ~,9t~a\"\n (string-downcase title)\n (rat->float (getf attr :average)))\n (format t \"~32,8t[~a, ~a]\"\n (rat->float (getf attr :minimum))\n (rat->float (getf attr :maximum)))\n (format t \"~56,8t(median ~a, deviation ~a, total ~a)\"\n (rat->float (getf attr :median))\n (rat->float (getf attr :deviation))\n (rat->float (getf attr :total)))\n (format t \"~%\")))))\n (dolist (mark benchmark-results)\n (format t \"~a (~a sample~:p):~%\" (first mark)\n (getf (rest (second mark)) :samples))\n (mapc #'print-times (rest mark)))))\n" }, { "path": "libraries/password-manager/package.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(uiop:define-package :password\n (:use :cl)\n (:import-from :nclasses #:define-class)\n (:import-from :serapeum #:export-always))\n\n(eval-when (:compile-toplevel :load-toplevel :execute)\n (trivial-package-local-nicknames:add-package-local-nickname :sera :serapeum :password))\n" }, { "path": "libraries/password-manager/password-keepassxc.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :password)\n\n(define-class keepassxc-interface (password-interface)\n ((executable (pathname->string (sera:resolve-executable \"keepassxc-cli\")))\n (password-file\n :documentation \"The path to the KeePass password database.\")\n (key-file\n nil\n :type (or null string pathname)\n :documentation \"The key file for `password-file'.\")\n (master-password\n \"\"\n :type string\n :documentation \"The password to the `password-file'.\")\n (yubikey-slot\n nil\n :documentation \"Yubikey slot to unlock the `password-file'.\")\n (entries-cache\n nil\n :type list\n :export nil\n :documentation \"The cache to speed the entry listing up.\"))\n (:export-class-name-p t)\n (:export-accessor-names-p t))\n\n(push 'keepassxc-interface *interfaces*)\n\n(defmethod list-passwords ((password-interface keepassxc-interface))\n (or (entries-cache password-interface)\n (let* ((st (make-string-input-stream (master-password password-interface)))\n (output (execute password-interface\n (append (list \"ls\" \"-Rf\") ; Recursive flattened.\n (when (key-file password-interface)\n (list \"-k\" (uiop:native-namestring (key-file password-interface))))\n (when (yubikey-slot password-interface)\n (list \"-y\" (yubikey-slot password-interface)))\n (list (password-file password-interface)))\n :input st :output '(:string :stripped t))))\n (setf (entries-cache password-interface)\n (remove-if (alexandria:curry #'str:ends-with-p \"/\") (sera:lines output))))))\n\n(defmethod clip-password ((password-interface keepassxc-interface) &key password-name service)\n (declare (ignore service))\n (with-input-from-string (st (master-password password-interface))\n (execute password-interface\n (append\n (list \"clip\")\n (when (key-file password-interface)\n (list \"-k\" (uiop:native-namestring (key-file password-interface))))\n (when (yubikey-slot password-interface)\n (list \"-y\" (yubikey-slot password-interface)))\n (list (password-file password-interface) password-name))\n :input st\n :wait-p nil)))\n\n(defmethod clip-username ((password-interface keepassxc-interface) &key password-name service)\n (declare (ignore service))\n (with-input-from-string (st (master-password password-interface))\n (execute password-interface\n (append (list \"clip\" \"--attribute\" \"username\")\n (when (key-file password-interface)\n (list \"-k\" (uiop:native-namestring (key-file password-interface))))\n (when (yubikey-slot password-interface)\n (list \"-y\" (yubikey-slot password-interface)))\n (list (password-file password-interface) password-name))\n :input st\n :wait-p nil)))\n\n(defmethod save-password ((password-interface keepassxc-interface)\n &key password-name username password service)\n (declare (ignore service))\n ;; This is to force entries re-fetching the next time we need passwords.\n (setf (entries-cache password-interface) nil)\n (with-input-from-string (st (format nil \"~a~C~a\"\n (master-password password-interface)\n #\\newline password))\n (execute password-interface\n (append (list \"add\" \"--username\" username\n \"--password-prompt\" (password-file password-interface))\n (when (key-file password-interface)\n (list \"-k\" (uiop:native-namestring (key-file password-interface))))\n (when (yubikey-slot password-interface)\n (list \"-y\" (yubikey-slot password-interface)))\n (list (if (str:emptyp password-name)\n \"--generate\"\n password-name)))\n :input st)))\n\n(defmethod password-correct-p ((password-interface keepassxc-interface))\n (handler-case\n (list-passwords password-interface)\n (uiop/run-program:subprocess-error ()\n nil)))\n" }, { "path": "libraries/password-manager/password-pass.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :password)\n\n(define-class password-store-interface (password-interface)\n ((executable (pathname->string (sera:resolve-executable \"pass\")))\n (sleep-timer (or (uiop:getenv \"PASSWORD_STORE_CLIP_TIME\") 45))\n (password-directory (or (uiop:getenv \"PASSWORD_STORE_DIR\")\n (format nil \"~a/.password-store\" (uiop:getenv \"HOME\")))\n :type string\n :reader password-directory))\n (:export-class-name-p t)\n (:export-accessor-names-p t))\n\n(push 'password-store-interface *interfaces*)\n\n(defmethod list-passwords ((password-interface password-store-interface))\n (let ((directory (uiop:truename* (uiop:parse-native-namestring\n (password-directory password-interface)))))\n (when directory\n ;; Special care must be taken for symlinks. Say `~/.password-store/work`\n ;; points to `~/work/pass`, would we follow symlinks, we would not be able to\n ;; truncate `~/.password-store/` in `~/work/pass/some/password.gpg`. Because\n ;; of this, we don't follow symlinks.\n (let* ((raw-list (uiop:directory*\n ;; We truncate the root directory so that the password list\n ;; resembles the output from `pass list`. To do so, we\n ;; truncate `~/.password-store/` in the pathname strings of\n ;; the passwords.\n (format nil \"~a/**/*.gpg\" directory)))\n (dir-length (length (namestring directory))))\n (mapcar (lambda (x)\n (subseq (namestring x) dir-length (- (length (namestring x)) (length \".gpg\"))))\n raw-list)))))\n\n(defmethod clip-password ((password-interface password-store-interface) &key password-name service)\n (declare (ignore service))\n (execute password-interface (list \"show\" \"--clip\" password-name)\n ;; Outputting to string blocks `pass'.\n :output 'nil))\n\n(defvar *multiline-separator* \": *\"\n \"A regular expression to separate keys from values in the `pass' multiline format.\")\n\n(defun parse-multiline (content)\n \"Return an alist of the multiple entries.\nAn entry is a sequence of\n- a key string,\n- a colon,\n- optional spaces,\n- a value string.\n\nThis is meant to handle the organization suggestion from\nhttp://www.passwordstore.org/#organization.\n\nLines that don't match the format are ignored.\nThe first line (the password) is skipped.\"\n (unless (uiop:emptyp content)\n (let ((lines (str:split (string #\\newline)\n content)))\n (delete nil (mapcar (lambda (line)\n (let ((entry (ppcre:split *multiline-separator* line :limit 2)))\n (when (= 2 (length entry))\n entry)))\n ;; Skip first line to ignore password:\n (rest lines))))))\n\n(defvar *username-keys* '(\"login\" \"user\" \"username\")\n \"A list of string keys used to find the `pass' username in `clip-username'.\")\n\n(defmethod clip-username ((password-interface password-store-interface) &key password-name service)\n \"Save the multiline entry that's prefixed with on of the `*username-keys*' to clipboard.\nCase is ignored.\nThe prefix is discarded from the result and returned.\"\n (declare (ignore service))\n (when password-name\n (let* ((content (execute password-interface (list \"show\" password-name)\n :output '(:string :stripped t)))\n (entries (parse-multiline content))\n (username-entry (when entries\n (some (lambda (key)\n (find key entries :test #'string-equal :key #'first))\n *username-keys*))))\n (when username-entry\n (trivial-clipboard:text (second username-entry))\n (second username-entry)))))\n\n(defmethod save-password ((password-interface password-store-interface)\n &key password-name username password service)\n (declare (ignore service))\n (with-open-stream (st (make-string-input-stream (format nil \"~a~%username:~a\"\n password\n username)))\n (execute password-interface (list \"insert\" \"--multiline\" password-name)\n :input st))\n (when (str:emptyp password)\n (execute password-interface (list \"generate\" password-name))))\n\n(defmethod password-correct-p ((password-interface password-store-interface))\n t)\n" }, { "path": "libraries/password-manager/password-security.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :password)\n\n;;; Provide an interface to the command line \"security\" program used\n;;; on BSD and Darwin systems to interface with the system keychain\n\n(define-class security-interface (password-interface)\n ((executable (pathname->string (sera:resolve-executable \"security\"))))\n (:export-class-name-p t)\n (:export-accessor-names-p t))\n\n(push 'security-interface *interfaces*)\n\n(defmethod list-passwords ((password-interface security-interface))\n (error \"Listing passwords not supported by the 'security' interface.\"))\n\n(defmethod clip-password ((password-interface security-interface) &key password-name service)\n (clip-password-string password-interface\n (str:replace-all\n \"\\\"\" \"\"\n (str:replace-first\n \"password: \" \"\"\n (nth-value 1\n (execute password-interface\n (list \"find-internet-password\"\n \"-a\" password-name \"-s\" service \"-g\")\n :error-output '(:string :stripped t)))))))\n\n(defmethod clip-username ((password-interface security-interface) &key password-name service)\n (declare (ignore password-name service))\n (error \"Username clipping is not supported by security interface.\"))\n\n(defmethod password-correct-p ((password-interface security-interface)) t)\n" }, { "path": "libraries/password-manager/password.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :password)\n\n(define-class password-interface ()\n ((executable\n nil\n :type (or null string)\n :documentation \"The program to query for password information.\")\n (sleep-timer\n 15\n :type alexandria:non-negative-real\n :documentation \"The amount of time to sleep, in seconds.\"))\n (:export-class-name-p t)\n (:export-accessor-names-p t))\n\n(export-always 'list-passwords)\n(defgeneric list-passwords (password-interface)\n (:documentation \"Retrieve all available passwords.\"))\n\n(export-always 'clip-password)\n(defgeneric clip-password (password-interface &key password-name service)\n (:documentation \"Retrieve specific password by name.\"))\n\n(export-always 'clip-username)\n(defgeneric clip-username (password-interface &key password-name service)\n (:documentation \"Retrieve specific login by name of the password entry.\"))\n\n(export-always 'save-password)\n(defgeneric save-password (password-interface\n &key password-name username password service)\n (:documentation \"Save password to database.\nIf PASSWORD-NAME is empty, then generate a new password.\"))\n\n(export-always 'password-correct-p)\n(defgeneric password-correct-p (password-interface)\n (:documentation \"Return T if set password is correct, NIL otherwise.\"))\n\n(export-always 'complete-interface)\n(defgeneric complete-interface (password-interface)\n (:method ((password-interface password-interface))\n password-interface)\n (:documentation \"Return the PASSWORD-INTERFACE with all the misfilled fields corrected.\"))\n\n(defgeneric execute (interface arguments &rest run-program-args &key wait-p &allow-other-keys)\n (:method ((interface password-interface) (arguments list) &rest run-program-args &key (wait-p t) &allow-other-keys)\n (apply (if wait-p #'uiop:run-program #'uiop:launch-program)\n (append (uiop:ensure-list (executable interface)) arguments)\n (alexandria:remove-from-plist run-program-args :wait-p)))\n (:documentation \"Execute the command matching the INTERFACE, with ARGS.\n\n`uiop:run-program' is used underneath, with RUN-PROGRAM-ARGS being its\narguments.\n\nWhen the WAIT-P is NIL, `uiop:launch-program' is used instead of\n`uiop:run-program'.\"))\n\n(defun safe-clipboard-text ()\n \"Return clipboard content, or \\\"\\\" if the content is not textual.\"\n ;; xclip errors out when the clipboard contains non-text:\n ;; https://github.com/astrand/xclip/issues/38#issuecomment-466625564.\n (ignore-errors (trivial-clipboard:text)))\n\n;;; Prerequisite Functions\n(defmethod clip-password-string ((password-interface password-interface) pass)\n (trivial-clipboard:text pass)\n (bt:make-thread\n (lambda ()\n (sleep (sleep-timer password-interface))\n (when (string= (safe-clipboard-text) pass)\n ;; Reset the clipboard so that the user does not accidentally paste\n ;; something else.\n (trivial-clipboard:text \"\")))))\n\n\n;;; Commands to wrap together.\n(defun pathname->string (pathname)\n \"Like `namestring' but return NIL if PATHNAME is NIL.\"\n (when pathname\n (namestring pathname)))\n\n(export-always '*interfaces*)\n(defvar *interfaces* '())\n" }, { "path": "libraries/text-buffer/package.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(uiop:define-package :text-buffer\n (:use :cl)\n (:export #:text-buffer #:cursor))\n" }, { "path": "libraries/text-buffer/text-buffer.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :text-buffer)\n\n(defclass text-buffer (cluffer-simple-line:line) ())\n\n(defclass cursor (cluffer-simple-line::right-sticky-cursor)\n ((word-separation-characters\n :accessor word-separation-characters\n :initform '(\":\" \"/\" \".\" \" \" \" \"))))\n\n(defmethod string-representation ((buffer text-buffer))\n (with-output-to-string (out)\n (map nil (lambda (string)\n (write-string string out))\n (cluffer:items buffer))))\n\n(defmethod invisible-string-representation ((buffer text-buffer))\n (make-string (cluffer:item-count buffer) :initial-element #\\*))\n\n(defmethod safe-forward ((cursor cursor))\n (unless (cluffer:end-of-line-p cursor)\n (cluffer:forward-item cursor)\n (cluffer:item-before-cursor cursor)))\n\n(defmethod safe-backward ((cursor cursor))\n (unless (cluffer:beginning-of-line-p cursor)\n (cluffer:backward-item cursor)\n (cluffer:item-after-cursor cursor)))\n\n(defmethod delete-item-forward ((cursor cursor))\n (unless (cluffer:end-of-line-p cursor)\n (cluffer:delete-item cursor)\n t))\n\n(defmethod delete-item-backward ((cursor cursor))\n (unless (cluffer:beginning-of-line-p cursor)\n (cluffer:erase-item cursor)\n t))\n\n(defmethod word-separation-chars-at-cursor-p ((cursor cursor) &key direction)\n \"Return non-nil when `word-separation-characters' are found\nbefore/after the cursor position. You can specify to look before or\nafter the cursor by supplying :backward or :forward for the direction\nvalue.\"\n (find (cond ((and (not (cluffer:beginning-of-line-p cursor))\n (eq direction :backward))\n (cluffer:item-before-cursor cursor))\n ((and (not (cluffer:end-of-line-p cursor))\n (eq direction :forward))\n (cluffer:item-after-cursor cursor)))\n (word-separation-characters cursor)\n :test #'equal))\n\n(defmethod move-to-word ((cursor cursor) &key direction conservative-word-move)\n \"Move the cursor to the boundary of a word and return its\nposition. A word is a string bounded by\n`word-separation-characters'. Specify a `direction' of :forward or\n:backward to change the movement.\"\n (labels ((move-to-boundary (&key over-non-word-chars)\n \"Move the cursor while it finds\n `word-separation-characters' adjacent to it. When\n `over-non-word-chars' is `t' move the cursor otherwise.\"\n (loop named movement\n while (if over-non-word-chars\n (word-separation-chars-at-cursor-p cursor :direction direction)\n (not (word-separation-chars-at-cursor-p cursor :direction direction)))\n unless (if (eq direction :backward)\n (safe-backward cursor)\n (safe-forward cursor))\n do (return-from movement))))\n (if (word-separation-chars-at-cursor-p cursor :direction direction)\n (progn (move-to-boundary :over-non-word-chars t)\n (when conservative-word-move (move-to-boundary)))\n (move-to-boundary)))\n (cluffer:cursor-position cursor))\n\n(defmethod move-forward-word ((cursor cursor) &key conservative-word-move)\n (move-to-word cursor :direction :forward\n :conservative-word-move conservative-word-move))\n\n(defmethod move-backward-word ((cursor cursor) &key conservative-word-move)\n (move-to-word cursor :direction :backward\n :conservative-word-move conservative-word-move))\n\n(defmethod delete-word ((cursor cursor) &key direction)\n \"Delete characters until encountering the boundary of a\nword. Specify a `direction' as :forward or :backward.\"\n (let ((start-cursor-position (cluffer:cursor-position cursor))\n (end-cursor-position\n (if (eq direction :backward)\n (move-backward-word cursor :conservative-word-move t)\n (move-forward-word cursor :conservative-word-move t))))\n (dotimes (i (abs (- start-cursor-position end-cursor-position)))\n (if (eq direction :backward)\n (cluffer:delete-item cursor)\n (cluffer:erase-item cursor)))))\n\n(defmethod delete-forward-word ((cursor cursor))\n \"Delete characters forward until encountering the end of a word.\"\n (delete-word cursor :direction :forward))\n\n(defmethod delete-backward-word ((cursor cursor))\n \"Delete characters backward until encountering the end of a word.\"\n (delete-word cursor :direction :backward))\n\n(defmethod kill-forward-line ((cursor cursor))\n (loop while (delete-item-forward cursor)))\n\n(defmethod insert-string ((cursor cursor) string)\n (loop for char across string do\n (cluffer:insert-item cursor (string char))))\n\n(defmethod word-at-cursor ((cursor cursor))\n \"Return word at cursor. If cursor is between two words, return the\nfirst one.\"\n (let ((original-cursor-position (cluffer:cursor-position cursor)))\n (move-backward-word cursor)\n (let* ((delta (abs (- (cluffer:cursor-position cursor)\n (move-forward-word cursor))))\n (word-at-cursor (reverse (apply #'concatenate 'string\n (loop repeat delta\n collect (safe-backward cursor))))))\n (setf (cluffer:cursor-position cursor) original-cursor-position)\n word-at-cursor)))\n\n(defmethod replace-word-at-cursor ((cursor cursor) string)\n (unless (uiop:emptyp (word-at-cursor cursor))\n (move-backward-word cursor)\n (delete-forward-word cursor))\n (insert-string cursor string))\n\n(defmethod kill-line ((cursor cursor))\n \"Kill the complete line.\"\n (cluffer:beginning-of-line cursor)\n (kill-forward-line cursor))\n\n(defun word-start (s position &optional (white-spaces '(#\\space #\\no-break_space)))\n \"Return the index of the beginning word at POSITION in string S.\"\n (apply #'max\n (mapcar (lambda (char)\n (let ((pos (position char s\n :end position\n :from-end t)))\n (if pos\n (1+ pos)\n 0)))\n white-spaces)))\n\n(defun word-end (s position &optional (white-spaces '(#\\space #\\no-break_space)))\n \"Return the index of the end of the word at POSITION in string S.\"\n (apply #'min\n (mapcar (lambda (char)\n (or (position char s :start position)\n (length s)))\n white-spaces)))\n" }, { "path": "libraries/theme/README.org", "content": "#+TITLE: Theme library for Nyxt\n#+PROPERTY: :results silent\n\n* Overview\n\nThis general purpose theme library provides the means to customize the colors\nand fonts of Nyxt's UI. Besides exposing the set of tweakable options,\nopinionated defaults are provided.\n\nOwing to its flexibility, it can be used to theme other projects.\n\n** Palette's rationale\n\nThe following semantic color groups are defined:\n\n- ~background~ :: large surfaces.\n- ~primary~ :: primary interface elements.\n- ~secondary~ :: secondary or decorative interface elements.\n- ~action~ :: focus or call to action.\n- ~success~ :: successful completion, download, or evaluation.\n- ~warning~ :: errors, invalid operations, or consequential actions.\n- ~highlight~ :: eye-catching text highlighting.\n\nFor each group, 2 variation colors with more and less contrast are defined.\nThese are intended for cases of complex and overlapping\ninterfaces. E.g. ~background+~ and ~background-~.\n\nAdditionally, a foreground color is defined. E.g. ~on-background~.\n\nThis rationale is loosely based on [[https://m2.material.io/design/material-theming/implementing-your-theme.html][Google Material Design Guidelines]].\n\n** Example\n\n#+begin_src lisp\n(defvar my-theme\n (make-instance 'theme:theme\n :background-color \"#F0F0F0\"\n :primary-color \"#595959\"\n :secondary-color \"#E6E6E6\"\n :action-color \"#5FCFFF\"\n :highlight-color \"#FAC090\"\n :success-color \"#AEE5BE\"\n :warning-color \"#F3B5AF\"\n :font-family \"Iosevka\"\n :monospace-font-family \"Iosevka\")\n \"Example theme.\n\nWhen the values for on-colors are omitted, they're automatically set to either\nblack or white, according to what achieves a better contrast.\n\nWhen the values for color+ and color- are omitted, they fallback on regular\ncolor values.\n\nNote that not all semantic color groups need to be defined.\")\n\n;; Set the theme in Nyxt's config file\n(define-configuration browser ((theme my-theme)))\n#+end_src\n\n* Defaults\n\nWe suggest following the WCAG (Web Content Accessibility Guidelines) with\nrespect to contrast ratios. The lowest standard (Level AA) requires a ratio of\n4.5:1, while a higher standard (Level AAA) requires 7:1.\n\nThe target contrast ratios for the default palette are summarized below.\n\n- Minus colors (e.g. ~background-~) :: >= 4.5:1\n- Regular colors (e.g. ~background~) :: >= 6.5:1\n- Plus colors (e.g. ~background+~) :: >= 8.5:1\n\n** Light theme\n\n| Color Name | Value | ~on-*~ Value | Contrast |\n|---------------+---------+--------------+----------|\n| ~background+~ | #FFFFFF | #000000 | 21.00 |\n| ~background~ | #F8F8F8 | #000000 | 19.77 |\n| ~background-~ | #ECECEC | #000000 | 17.78 |\n|---------------+---------+--------------+----------|\n| ~primary+~ | #474747 | #FFFFFF | 9.29 |\n| ~primary~ | #555555 | #FFFFFF | 7.46 |\n| ~primary-~ | #686868 | #FFFFFF | 5.57 |\n|---------------+---------+--------------+----------|\n| ~secondary+~ | #BFBFBF | #000000 | 11.42 |\n| ~secondary~ | #A6A6A6 | #000000 | 8.63 |\n| ~secondary-~ | #909090 | #000000 | 6.58 |\n|---------------+---------+--------------+----------|\n| ~action+~ | #72CDFE | #000000 | 11.88 |\n| ~action~ | #37A8E4 | #000000 | 7.88 |\n| ~action-~ | #178DCC | #000000 | 5.72 |\n|---------------+---------+--------------+----------|\n| ~highlight+~ | #FFFA66 | #000000 | 19.12 |\n| ~highlight~ | #FCE304 | #000000 | 16.13 |\n| ~highlight-~ | #FCBA04 | #000000 | 12.16 |\n|---------------+---------+--------------+----------|\n| ~success+~ | #71FE7D | #000000 | 16.18 |\n| ~success~ | #8AEA92 | #000000 | 14.26 |\n| ~success-~ | #86D58E | #000000 | 11.92 |\n|---------------+---------+--------------+----------|\n| ~warning+~ | #88040D | #FFFFFF | 10.14 |\n| ~warning~ | #AF1923 | #FFFFFF | 7.03 |\n| ~warning-~ | #D2232E | #FFFFFF | 5.22 |\n|---------------+---------+--------------+----------|\n#+TBLFM: $4='(contrast $2 $3);%.2f\n\n** Dark theme\n\n| Color Name | Value | ~on-*~ Value | Contrast |\n|---------------+---------+--------------+----------|\n| ~background+~ | #000000 | #FFFFFF | 21.00 |\n| ~background~ | #121212 | #FFFFFF | 18.73 |\n| ~background-~ | #333333 | #FFFFFF | 12.63 |\n|---------------+---------+--------------+----------|\n| ~primary+~ | #EFA671 | #000000 | 10.36 |\n| ~primary~ | #E48D4E | #000000 | 8.22 |\n| ~primary-~ | #D7752F | #000000 | 6.47 |\n|---------------+---------+--------------+----------|\n| ~secondary+~ | #683008 | #FFFFFF | 10.42 |\n| ~secondary~ | #844115 | #FFFFFF | 7.64 |\n| ~secondary-~ | #9F592D | #FFFFFF | 5.33 |\n|---------------+---------+--------------+----------|\n| ~action+~ | #481FA2 | #FFFFFF | 10.54 |\n| ~action~ | #571FD2 | #FFFFFF | 8.29 |\n| ~action-~ | #763DF2 | #FFFFFF | 5.65 |\n|---------------+---------+--------------+----------|\n| ~highlight+~ | #FC83F2 | #000000 | 9.67 |\n| ~highlight~ | #F46DE8 | #000000 | 8.20 |\n| ~highlight-~ | #EA43DD | #000000 | 6.35 |\n|---------------+---------+--------------+----------|\n| ~success+~ | #87FCDF | #000000 | 17.02 |\n| ~success~ | #4CFBCF | #000000 | 16.01 |\n| ~success-~ | #05F4CD | #000000 | 14.83 |\n|---------------+---------+--------------+----------|\n| ~warning+~ | #FFD152 | #000000 | 14.49 |\n| ~warning~ | #FCBA04 | #000000 | 12.16 |\n| ~warning-~ | #FCA904 | #000000 | 10.82 |\n|---------------+---------+--------------+----------|\n#+TBLFM: $4='(contrast $2 $3);%.2f\n\n** Remarks\n\nThe minus and plus colors, when omitted, are set to the corresponding regular\ncolor.\n\n~on-colors~, when omitted, are set to either black or white, depending on which\nresults in a higher contrast ratio with its corresponding ~color~.\n\nOne might be tempted to think that ~on-colors~ are meant to be used solely for\ntext, but the principle holds more generality, when placing tiny elements over\nhuge surfaces.\n\nTake blue and yellow, colors that have a poor contrast ratio. Consider that,\n(1) you inscribe a blue circle that covers most of the yellow square's surface,\nand (2) you were to draw a tiny blue cross on the same yellow background. In\nsituation (1), you still properly discern the circle, whereas in (2) you'd\nstruggle to see it.\n\n* COMMENT TBLFM Code\nAuxiliary code to update contrast ratios on the tables shown in this document.\n\nInstructions:\n- Evaluate the cell below;\n- Run command =org-table-recalculate-buffer-tables=.\n\n#+begin_src emacs-lisp\n(defun contrast (c1 c2)\n \"Measure WCAG contrast ratio between C1 and C2.\nC1 and C2 are color values written in hexadecimal RGB.\"\n (cl-flet ((wcag-formula (hex)\n (cl-loop for k in '(0.2126 0.7152 0.0722)\n for x in (color-name-to-rgb hex)\n sum (* k (if (<= x 0.03928)\n (/ x 12.92)\n (expt (/ (+ x 0.055) 1.055) 2.4))))))\n (let ((ct (/ (+ (wcag-formula c1) 0.05)\n (+ (wcag-formula c2) 0.05))))\n (max ct (/ ct)))))\n#+end_src\n" }, { "path": "libraries/theme/package.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(uiop:define-package :theme\n (:use :cl)\n (:shadow #:warning)\n (:import-from :serapeum #:export-always)\n (:import-from :nclasses #:define-class))\n" }, { "path": "libraries/theme/tests/tests.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package cl-user)\n(uiop:define-package :theme/tests\n (:use :cl :lisp-unit2)\n (:import-from :theme))\n(in-package :theme/tests)\n\n(defvar *theme* (make-instance 'theme:theme\n :background-color \"white\"\n :action-color \"#37A8E4\")\n \"Dummy theme for testing.\")\n\n(define-test fallback-colors ()\n (assert-string= \"white\" (theme:background-color- *theme*))\n (assert-string= \"white\" (theme:background-color+ *theme*))\n (assert-string= \"black\" (theme:on-background-color *theme*))\n (assert-false (theme:primary-color+ *theme*))\n (assert-false (theme:primary-color *theme*))\n (assert-false (theme:primary-color- *theme*))\n (assert-false (theme:on-primary-color *theme*)))\n\n(define-test css-substitution ()\n (assert-string= \"a{background-color:white;color:black;}h1{color:#37A8E4 !important;}\"\n (let ((lass:*pretty* nil))\n (theme:themed-css *theme*\n `(a\n :background-color ,theme:background-color\n :color ,theme:on-background-color)\n `(h1\n :color ,theme:action-color \"!important\")))))\n\n(defmethod assert-contrast ((theme theme:theme)\n &key (min-color+-contrast 8.5)\n (min-color-contrast 6.5)\n (min-color--contrast 4.5))\n (macrolet ((assert-contrast-ratio (color1 color2 min-contrast)\n `(assert-true (>= (theme:contrast-ratio ,color1 ,color2)\n ,min-contrast))))\n (multiple-value-bind (on-colors regular-colors minus-colors plus-colors)\n (values-list\n (theme:filter-palette (list (alexandria:curry #'uiop:string-prefix-p \"ON-\")\n (alexandria:rcurry #'uiop:string-suffix-p \"COLOR\")\n (alexandria:rcurry #'uiop:string-suffix-p \"COLOR-\")\n (alexandria:rcurry #'uiop:string-suffix-p \"COLOR+\"))\n (theme:palette theme)))\n (loop for on-color in on-colors\n for regular-color in regular-colors\n for minus-color in minus-colors\n for plus-color in plus-colors\n do (assert-contrast-ratio (funcall regular-color theme)\n (funcall on-color theme)\n min-color-contrast)\n do (assert-contrast-ratio (funcall plus-color theme)\n (funcall on-color theme)\n min-color+-contrast)\n do (assert-contrast-ratio (funcall minus-color theme)\n (funcall on-color theme)\n min-color--contrast)))))\n\n(define-test default-light-theme-contrast ()\n (assert-contrast theme:+light-theme+))\n\n(define-test default-dark-theme-contrast ()\n (assert-contrast theme:+dark-theme+))\n" }, { "path": "libraries/theme/theme.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :theme)\n\n(define-class theme ()\n ((background-color+\n :documentation \"More contrasting variation of `background-color'.\")\n (background-color\n :documentation \"The background color of the theme.\")\n (background-color-\n :documentation \"Less contrasting variation of `background-color'.\")\n (on-background-color\n :documentation \"The color for elements/text in front of `background-color'.\")\n (primary-color+\n :documentation \"More contrasting variation of `primary-color'.\")\n (primary-color\n :documentation \"Primary UI element color.\")\n (primary-color-\n :documentation \"Less contrasting variation of `primary-color'.\")\n (on-primary-color\n :documentation \"The color for elements/text in front of `primary-color'.\")\n (secondary-color+\n :documentation \"More contrasting variation of `secondary-color'.\")\n (secondary-color\n :documentation \"Secondary UI element color.\")\n (secondary-color-\n :documentation \"Less contrasting variation of `secondary-color'.\")\n (on-secondary-color\n :documentation \"The color for elements/text in front of `secondary-color'.\")\n (action-color+\n :documentation \"More contrasting variation of `action-color'.\")\n (action-color\n :documentation \"Color for focused and important elements.\")\n (action-color-\n :documentation \"Less contrasting variation of `action-color'.\")\n (on-action-color\n :documentation \"The color for elements/text in front of `action-color'.\")\n (highlight-color+\n :documentation \"More contrasting variation of `highlight-color'.\")\n (highlight-color\n :documentation \"The color for elements requiring attention.\")\n (highlight-color-\n :documentation \"Less contrasting variation of `highlight-color'.\")\n (on-highlight-color\n :documentation \"The color for elements/text in front of `highlight-color'.\")\n (success-color+\n :documentation \"More contrasting variation of `success-color'.\")\n (success-color\n :documentation \"The color to express success.\")\n (success-color-\n :documentation \"Less contrasting variation of `success-color'.\")\n (on-success-color\n :documentation \"The color for elements/text in front of `success-color'.\")\n (warning-color+\n :documentation \"More contrasting variation of `warning-color'.\")\n (warning-color\n :documentation \"The color to express errors.\")\n (warning-color-\n :documentation \"Less contrasting variation of `warning-color'.\")\n (on-warning-color\n :documentation \"The color for elements/text in front of `warning-color'.\")\n (font-family\n \"Public Sans\"\n :documentation \"The font family to use by default.\")\n (monospace-font-family\n \"DejaVu Sans Mono\"\n :documentation \"The monospace font family to use by default.\"))\n (:export-class-name-p t)\n (:export-accessor-names-p t)\n (:export-predicate-name-p t))\n\n(defmethod initialize-instance :after ((theme theme) &key)\n (multiple-value-bind (on-colors regular-colors minus-colors plus-colors)\n (values-list\n (filter-palette (list (alexandria:curry #'uiop:string-prefix-p \"ON-\")\n (alexandria:rcurry #'uiop:string-suffix-p \"COLOR\")\n (alexandria:rcurry #'uiop:string-suffix-p \"COLOR-\")\n (alexandria:rcurry #'uiop:string-suffix-p \"COLOR+\"))\n (palette theme)))\n (loop for on-color in on-colors\n for regular-color in regular-colors\n for minus-color in minus-colors\n for plus-color in plus-colors\n do (when (and (not (slot-value theme on-color))\n (slot-value theme regular-color))\n (setf (slot-value theme on-color)\n (contrasting-color (slot-value theme regular-color))))\n do (when (and (not (slot-value theme minus-color))\n (slot-value theme regular-color))\n (setf (slot-value theme minus-color)\n (slot-value theme regular-color)))\n do (when (and (not (slot-value theme plus-color))\n (slot-value theme regular-color))\n (setf (slot-value theme plus-color)\n (slot-value theme regular-color))))))\n\n(export-always 'dark-p)\n(defmethod dark-p ((theme theme))\n \"Whether the theme is dark.\"\n (when (string= \"white\" (contrasting-color (background-color theme))) t))\n\n(export-always 'palette)\n(defmethod palette ((theme theme))\n \"Return color slots of THEME.\n\nExample that returns the palette's color values:\n(mapcar (alexandria:rcurry #'funcall +light-theme+)\n (palette +light-theme+))\"\n (serapeum:filter (alexandria:curry #'serapeum:string-contains-p \"COLOR\")\n (mopu:direct-slot-names theme)\n :key #'string))\n\n(export-always 'filter-palette)\n(defun filter-palette (preds palette)\n \"Partition PALETTE according to PREDS.\"\n (serapeum:partitions preds palette :key #'string))\n\n(export-always 'with-theme)\n(defmacro with-theme (theme-instance &body body)\n \"Evaluate BODY with THEME and THEME's slots let-bound.\"\n `(let ((theme ,theme-instance))\n (with-slots ,(mopu:direct-slot-names 'theme) theme\n ,@body)))\n\n(export-always 'themed-css)\n(defmacro themed-css (theme &body forms)\n \"Generate CSS via lass FORMS styled according to THEME.\n\nExample:\n\n(themed-css (make-instance 'theme :background-color \\\"white\\\")\n `(|h1,h2,h3,h4,h5,h6|\n :border-style \\\"solid\\\"\n :border-color ,theme:on-background-color)\n `(p\n :color ,(if (theme:dark-p theme:theme) \\\"yellow\\\" \\\"green\\\")))\"\n `(with-theme ,theme (lass:compile-and-write ,@forms)))\n\n(export-always '+light-theme+)\n(defvar +light-theme+\n (make-instance 'theme\n :background-color+ \"#FFFFFF\"\n :background-color \"#F8F8F8\"\n :background-color- \"#ECECEC\"\n :primary-color+ \"#999999\"\n :primary-color \"#686868\"\n :primary-color- \"#555555\"\n :secondary-color+ \"#BFBFBF\"\n :secondary-color \"#A6A6A6\"\n :secondary-color- \"#909090\"\n :action-color+ \"#72CDFE\"\n :action-color \"#37A8E4\"\n :action-color- \"#178DCC\"\n :highlight-color+ \"#FFFA66\"\n :highlight-color \"#FCE304\"\n :highlight-color- \"#FCBA04\"\n :success-color+ \"#71FE7D\"\n :success-color \"#8AEA92\"\n :success-color- \"#86D58E\"\n :warning-color+ \"#88040D\"\n :warning-color \"#AF1923\"\n :warning-color- \"#D2232E\"))\n\n(export-always '+dark-theme+)\n(defvar +dark-theme+\n (make-instance 'theme:theme\n :background-color- \"#3B4252\"\n :background-color \"#2E3440\"\n :background-color+ \"#434C5E\"\n :on-background-color \"#E5E9F0\"\n :primary-color- \"#5E81AC\"\n :primary-color \"#5E81AC\"\n :primary-color+ \"#81A1C1\"\n :on-primary-color \"#ECEFF4\"\n :secondary-color- \"#4C566A\"\n :secondary-color \"#4C566A\"\n :secondary-color+ \"#5E81AC\"\n :on-secondary-color \"#E5E9F0\"\n :action-color- \"#88C0D0\"\n :action-color \"#88C0D0\"\n :action-color+ \"#81A1C1\"\n :on-action-color \"#2E3440\"\n :success-color- \"#8FBCBB\"\n :success-color \"#8FBCBB\"\n :success-color+ \"#81A1C1\"\n :on-success-color \"#2E3440\"\n :highlight-color- \"#B48EAD\"\n :highlight-color \"#B48EAD\"\n :highlight-color+ \"#D8DEE9\"\n :on-highlight-color \"#2E3440\"\n :warning-color- \"#EBCB8B\"\n :warning-color \"#EBCB8B\"\n :warning-color+ \"#D08770\"\n :on-warning-color \"#2E3440\"))\n" }, { "path": "libraries/theme/utilities.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :theme)\n\n(serapeum:-> relative-luminance ((or string integer cl-colors-ng:rgb cl-colors-ng:hsv))\n real)\n(defun relative-luminance (color)\n \"Compute relative luminance of COLOR.\"\n ;; See https://www.w3.org/WAI/GL/wiki/Relative_luminance\n (loop for const in '(0.2126 0.7152 0.0722)\n for rgb-component in (list (cl-colors-ng:rgb-red (cl-colors-ng:as-rgb color))\n (cl-colors-ng:rgb-green (cl-colors-ng:as-rgb color))\n (cl-colors-ng:rgb-blue (cl-colors-ng:as-rgb color)))\n sum (* const (if (<= rgb-component 0.04045)\n (/ rgb-component 12.92)\n (expt (/ (+ rgb-component 0.055) 1.055) 2.4)))))\n\n(serapeum:-> contrast-ratio ((or string integer cl-colors-ng:rgb cl-colors-ng:hsv)\n (or string integer cl-colors-ng:rgb cl-colors-ng:hsv))\n (real 0 21)) ; Ratio between black and white.\n(export-always 'contrast-ratio)\n(defun contrast-ratio (color1 color2)\n \"Compute contrast ratio between COLOR1 and COLOR2.\"\n ;; See https://www.w3.org/WAI/GL/wiki/Contrast_ratio\n (let ((ratio (/ (+ (relative-luminance color1) 0.05)\n (+ (relative-luminance color2) 0.05))))\n (max ratio (/ ratio))))\n\n(serapeum:-> contrasting-color ((or string integer cl-colors-ng:rgb cl-colors-ng:hsv)) string)\n(export-always 'contrasting-color)\n(defun contrasting-color (color)\n \"Determine whether black or white best contrasts with COLOR.\"\n (if (>= (contrast-ratio color \"white\")\n (contrast-ratio color \"black\"))\n \"white\"\n \"black\"))\n" }, { "path": "libraries/user-interface/package.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(uiop:define-package :user-interface\n (:use :cl))\n" }, { "path": "libraries/user-interface/user-interface.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :user-interface)\n\n;; Taken from serapeum\n(defmacro export-always (symbols &optional (package nil package-supplied?))\n \"Like `export', but also evaluated at compile time.\"\n `(eval-when (:compile-toplevel :load-toplevel :execute)\n (export ,symbols ,@(and package-supplied? (list package)))))\n\n(export-always 'id)\n(defvar *id* 0 \"Counter used to generate a unique ID.\")\n\n(defun unique-id ()\n (format nil \"ui-element-~d\" (incf *id*)))\n\n(defgeneric to-html (object)\n (:documentation \"The HTML representation of OBJECT.\nA form suitable to be compiled by Spinneret.\"))\n\n(export-always 'buffer)\n(defclass ui-element ()\n ((id :accessor id)\n (buffer :accessor buffer :initarg :buffer\n :documentation \"Buffer where element is drawn.\")))\n\n(defmethod initialize-instance :after ((element ui-element) &key)\n (setf (id element) (unique-id)))\n\n(export-always 'connect)\n(defmethod connect ((element ui-element) buffer)\n (setf (buffer element) buffer))\n\n(export-always 'update)\n(defgeneric update (ui-element)\n (:documentation \"Propagate changes to the buffer.\"))\n\n(export-always 'button)\n(export-always 'text)\n(export-always 'action)\n(defclass button (ui-element)\n ((text :initform \"\" :initarg :text :accessor text)\n (alt-text :initform \"\" :initarg :alt-text :accessor alt-text)\n (action :initform \"\" :initarg :action :accessor action)))\n\n(defmethod (setf text) :after (text (button button))\n (declare (ignorable text))\n (when (slot-boundp button 'buffer)\n (update button)))\n\n(defmethod (setf action) :after (action (button button))\n (declare (ignorable action))\n (when (slot-boundp button 'buffer)\n (update button)))\n\n(defmethod (setf alt-text) :after (text (button button))\n (declare (ignorable text))\n (when (slot-boundp button 'buffer)\n (update button)))\n\n(export-always 'to-html)\n(defmethod to-html ((button button))\n (spinneret:with-html\n (:button :id (id button)\n :class \"button\"\n :title (alt-text button)\n :onclick (action button)\n (text button))))\n\n(export-always 'paragraph)\n(defclass paragraph (ui-element)\n ((text :initform \"\" :initarg :text :accessor text)))\n\n(defmethod (setf text) :after (text (paragraph paragraph))\n (declare (ignorable text))\n (when (slot-boundp paragraph 'buffer)\n (update paragraph)))\n\n(defmethod to-html ((paragraph paragraph))\n (spinneret:with-html\n (:p :id (id paragraph) (text paragraph))))\n\n(export-always 'progress-bar)\n(export-always 'percentage)\n(defclass progress-bar (ui-element)\n ((percentage :initform 0\n :initarg :percentage\n :accessor percentage\n :documentation \"The percentage the progress bar is\nfilled up, use a number between 0 and 100.\")))\n\n(defmethod to-html ((progress-bar progress-bar))\n (spinneret:with-html\n (:div :class \"progress-bar-base\"\n (:div :class \"progress-bar-fill\"\n :id (id progress-bar)\n ;; empty string to force markup to make closing :div tag\n \"\"))))\n\n(defmethod (setf percentage) :after (percentage (progress-bar progress-bar))\n (declare (ignorable percentage))\n (when (slot-boundp progress-bar 'buffer)\n (update progress-bar)))\n" }, { "path": "licenses/ASSET-LICENSE", "content": "All non-source code assets are licensed as CC BY-SA.\n\nCreative Commons Deed\nThis is a human-readable summary of the full license below.\nYou are free:\n\nto Share— to copy, distribute and transmit the work, and\nto Remix— to adapt the work for any purpose, even commercially.\n\nUnder the following conditions:\n\nAttribution— You must attribute the work in the manner specified by the\nauthor or licensor (but not in any way that suggests that they endorse\nyou or your use of the work.) Share Alike—If you alter, transform, or\nbuild upon this work, you may distribute the resulting work only under\nthe same, similar or a compatible license. With the understanding\nthat:\n\nWaiver— Any of the above conditions can be waived if you get\npermission from the copyright holder. Other Rights—In no way are any\nof the following rights affected by the license: your fair dealing or\nfair use rights; the author's moral rights; and rights other persons\nmay have either in the work itself or in how the work is used, such as\npublicity or privacy rights.\n\nNotice—For any reuse or distribution, you must make clear to others\nthe license terms of this work. The best way to do that is with a link\nto https://creativecommons.org/licenses/by-sa/3.0/\n" }, { "path": "licenses/DejaVu Fonts License.txt", "content": "Fonts are (c) Bitstream (see below). DejaVu changes are in public domain.\nGlyphs imported from Arev fonts are (c) Tavmjong Bah (see below)\n\nBitstream Vera Fonts Copyright\n------------------------------\n\nCopyright (c) 2003 by Bitstream, Inc. All Rights Reserved. Bitstream Vera is\na trademark of Bitstream, Inc.\n\nPermission is hereby granted, free of charge, to any person obtaining a copy\nof the fonts accompanying this license (\"Fonts\") and associated\ndocumentation files (the \"Font Software\"), to reproduce and distribute the\nFont Software, including without limitation the rights to use, copy, merge,\npublish, distribute, and/or sell copies of the Font Software, and to permit\npersons to whom the Font Software is furnished to do so, subject to the\nfollowing conditions:\n\nThe above copyright and trademark notices and this permission notice shall\nbe included in all copies of one or more of the Font Software typefaces.\n\nThe Font Software may be modified, altered, or added to, and in particular\nthe designs of glyphs or characters in the Fonts may be modified and\nadditional glyphs or characters may be added to the Fonts, only if the fonts\nare renamed to names not containing either the words \"Bitstream\" or the word\n\"Vera\".\n\nThis License becomes null and void to the extent applicable to Fonts or Font\nSoftware that has been modified and is distributed under the \"Bitstream\nVera\" names.\n\nThe Font Software may be sold as part of a larger software package but no\ncopy of one or more of the Font Software typefaces may be sold by itself.\n\nTHE FONT SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS\nOR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF MERCHANTABILITY,\nFITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT OF COPYRIGHT, PATENT,\nTRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL BITSTREAM OR THE GNOME\nFOUNDATION BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, INCLUDING\nANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES,\nWHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF\nTHE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM OTHER DEALINGS IN THE\nFONT SOFTWARE.\n\nExcept as contained in this notice, the names of Gnome, the Gnome\nFoundation, and Bitstream Inc., shall not be used in advertising or\notherwise to promote the sale, use or other dealings in this Font Software\nwithout prior written authorization from the Gnome Foundation or Bitstream\nInc., respectively. For further information, contact: fonts at gnome dot\norg. \n\nArev Fonts Copyright\n------------------------------\n\nCopyright (c) 2006 by Tavmjong Bah. All Rights Reserved.\n\nPermission is hereby granted, free of charge, to any person obtaining\na copy of the fonts accompanying this license (\"Fonts\") and\nassociated documentation files (the \"Font Software\"), to reproduce\nand distribute the modifications to the Bitstream Vera Font Software,\nincluding without limitation the rights to use, copy, merge, publish,\ndistribute, and/or sell copies of the Font Software, and to permit\npersons to whom the Font Software is furnished to do so, subject to\nthe following conditions:\n\nThe above copyright and trademark notices and this permission notice\nshall be included in all copies of one or more of the Font Software\ntypefaces.\n\nThe Font Software may be modified, altered, or added to, and in\nparticular the designs of glyphs or characters in the Fonts may be\nmodified and additional glyphs or characters may be added to the\nFonts, only if the fonts are renamed to names not containing either\nthe words \"Tavmjong Bah\" or the word \"Arev\".\n\nThis License becomes null and void to the extent applicable to Fonts\nor Font Software that has been modified and is distributed under the \n\"Tavmjong Bah Arev\" names.\n\nThe Font Software may be sold as part of a larger software package but\nno copy of one or more of the Font Software typefaces may be sold by\nitself.\n\nTHE FONT SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND,\nEXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF\nMERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT\nOF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL\nTAVMJONG BAH BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,\nINCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL\nDAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING\nFROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM\nOTHER DEALINGS IN THE FONT SOFTWARE.\n\nExcept as contained in this notice, the name of Tavmjong Bah shall not\nbe used in advertising or otherwise to promote the sale, use or other\ndealings in this Font Software without prior written authorization\nfrom Tavmjong Bah. For further information, contact: tavmjong @ free\n. fr." }, { "path": "licenses/SOURCE-LICENSE", "content": "BSD 3-Clause License\n\nCopyright (c) 2017-2025, Atlas Engineer LLC.\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n* Redistributions of source code must retain the above copyright notice, this\n list of conditions and the following disclaimer.\n\n* Redistributions in binary form must reproduce the above copyright notice,\n this list of conditions and the following disclaimer in the documentation\n and/or other materials provided with the distribution.\n\n* Neither the name of the copyright holder nor the names of its\n contributors may be used to endorse or promote products derived from\n this software without specific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS \"AS IS\"\nAND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE\nIMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\nDISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE\nFOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL\nDAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR\nSERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER\nCAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,\nOR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\n" }, { "path": "makefile", "content": "# SPDX-FileCopyrightText: Atlas Engineer LLC\n# SPDX-License-Identifier: BSD-3-Clause\n\n## Use Bourne shell syntax.\nSHELL = /bin/sh\nUNAME := $(shell uname)\n\nLISP ?= sbcl\nSBCL_FLAGS =\nifeq ($(LISP), sbcl)\n\tSBCL_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)\nendif\n\nLISP_FLAGS ?= $(SBCL_FLAGS) --no-userinit --non-interactive\n\nNYXT_SUBMODULES ?= true\nNYXT_RENDERER ?= electron\nNASDF_USE_LOGICAL_PATHS ?= true\nNODE_SETUP ?= true\n\nexport NYXT_SUBMODULES\nexport NYXT_RENDERER\nexport NASDF_USE_LOGICAL_PATHS\nexport NODE_SETUP\n\n.PHONY: help\nhelp:\n\t@cat INSTALL\n\nmakefile_dir := $(dir $(abspath $(lastword $(MAKEFILE_LIST))))\n\nifeq ($(NYXT_SUBMODULES),true)\n\tCL_SOURCE_REGISTRY = $(makefile_dir)_build//\n\texport CL_SOURCE_REGISTRY\nendif\n\nlisp_eval:=$(LISP) $(LISP_FLAGS) \\\n\t--eval '(require \"asdf\")' \\\n\t--eval '(asdf:load-asd \"$(makefile_dir)/libraries/nasdf/nasdf.asd\")' \\\n\t--eval '(asdf:load-asd \"$(makefile_dir)/nyxt.asd\")' \\\n\t--eval\n\nlisp_quit:=--eval '(uiop:quit 0 \\#+bsd nil)'\n\n## asdf:load-system is a bit slow on :nyxt/$(NYXT_RENDERER)-application, so we\n## keep a Make dependency on the Lisp files.\nlisp_files := nyxt.asd $(shell find . -type f -name '*.lisp')\nnyxt: $(lisp_files)\n\tif [ \"$(NYXT_RENDERER)\" = \"electron\" ] && \\\n\t [ \"$(NODE_SETUP)\" = \"true\" ] && \\\n\t [ \"$(NYXT_SUBMODULES)\" = \"true\" ]; then \\\n\t\t$(MAKE) -C $(makefile_dir)_build/cl-electron install; \\\n\tfi\n\t$(lisp_eval) '(asdf:load-system :nyxt/$(NYXT_RENDERER)-application)' \\\n\t\t--eval '(asdf:make :nyxt/$(NYXT_RENDERER)-application)' \\\n\t\t$(lisp_quit) || (printf \"\\n%s\\n%s\\n\" \"Compilation failed, see the above stacktrace.\" && exit 1)\n\n.PHONY: all\nall: nyxt\n\n.PHONY: doc\ndoc:\n\t$(lisp_eval) '(asdf:load-system :nyxt)' \\\n\t\t--eval '(asdf:load-system :nyxt/documentation)' $(lisp_quit)\n\n.PHONY: check\ncheck:\n\t$(lisp_eval) '(asdf:test-system :nyxt)'\n\n.PHONY: clean\nclean:\n\trm nyxt\n" }, { "path": "nyxt.asd", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n#-asdf3.1 (error \"Nyxt requires ASDF 3.1.2\")\n\n;; WARNING: We _must_ declare the translation host or else ASDF won't recognize\n;; the pathnames as logical-pathnames, thus returning the system directory\n;; instead.\n(setf (logical-pathname-translations \"NYXT\") nil)\n\n(defsystem \"nyxt\"\n :defsystem-depends-on (\"nasdf\")\n :class :nasdf-system\n :version \"4\" ; 4.0.0-pre-release-3\n :author \"Atlas Engineer LLC\"\n :homepage \"https://nyxt-browser.com\"\n :description \"Extensible web browser in Common Lisp\"\n :license \"BSD 3-Clause\"\n :depends-on (alexandria\n bordeaux-threads\n calispel\n cl-base64\n cl-colors-ng\n cl-gopher\n cl-json\n cl-ppcre\n cl-ppcre-unicode\n cl-prevalence\n cl-qrencode\n cl-tld\n closer-mop\n clss\n dexador\n enchant\n flexi-streams\n iolib\n iolib/os\n lass\n local-time\n log4cl\n lparallel\n nclasses\n nfiles\n nhooks\n njson/cl-json\n nkeymaps\n nsymbols/star\n parenscript\n phos\n plump\n prompter\n py-configparser\n quri\n serapeum\n spinneret\n sqlite\n str\n trivia\n trivial-arguments\n trivial-clipboard\n trivial-package-local-nicknames\n trivial-types\n unix-opts\n ;; Local systems:\n nyxt/analysis\n nyxt/download-manager\n nyxt/password-manager\n nyxt/text-buffer\n nyxt/theme\n nyxt/user-interface)\n :pathname #p\"NYXT:source;\"\n :components ((:file \"utilities\")\n (:file \"types\")\n (:file \"package\" :depends-on (\"utilities\" \"types\"))\n (:module \"Utilities\"\n :pathname \"\"\n :depends-on (\"package\")\n :components\n ((:file \"time\")\n (:file \"keyscheme\")\n (:file \"conditions\")\n (:file \"user-interface\")))\n (:module \"Core\"\n :pathname \"\"\n :depends-on (\"Utilities\")\n :serial t\n :components\n ((:file \"renderer\")\n (:file \"global\")\n (:file \"concurrency\")\n (:file \"user-files\")\n (:file \"user-classes\")\n (:file \"configuration\")\n (:file \"parenscript-macro\")\n (:file \"message\")\n (:file \"command\")\n (:file \"renderer-script\")\n (:file \"urls\")\n (:file \"inspector\")\n (:file \"dom\")\n (:file \"search-engine\")\n (:file \"buffer\")\n (:file \"window\")\n (:file \"mode\")\n (:file \"history\")\n (:file \"spinneret-tags\")\n (:file \"browser\")\n (:file \"foreign-interface\")\n (:file \"clipboard\")\n (:file \"color\")\n (:file \"input\")\n (:file \"prompt-buffer\")\n (:file \"command-commands\")\n (:file \"recent-buffers\")\n (:file \"external-editor\")))\n (:module \"Core modes\"\n :pathname \"mode\"\n :depends-on (\"Core\")\n :components\n ((:file \"input-edit\")\n (:file \"buffer-listing\")\n (:file \"message\")\n (:file \"passthrough\")\n (:file \"document\" :depends-on (\"passthrough\"))\n (:file \"hint\" :depends-on (\"document\"))\n (:file \"search-buffer\")\n (:file \"spell-check\" :depends-on (\"document\"))\n (:file \"help\" :depends-on (\"document\" \"search-buffer\"))\n (:file \"history\")\n (:file \"keyscheme\")\n (:file \"process\")))\n (:file \"describe\" :depends-on (\"Core modes\"))\n (:module \"Prompter modes\"\n :pathname \"mode\"\n :depends-on (\"describe\" \"Core modes\")\n :components\n ((:file \"prompt-buffer\")\n (:file \"hint-prompt-buffer\" :depends-on (\"prompt-buffer\"))\n (:file \"file-manager\" :depends-on (\"prompt-buffer\"))\n (:file \"download\" :depends-on (\"file-manager\"))))\n (:file \"mode/base\" :depends-on (\"Core modes\"))\n (:file \"status\" :depends-on (\"Core\"))\n (:module \"Help\"\n :pathname \"\"\n :depends-on (\"Core modes\" \"Modes\")\n :components\n ((:file \"help\")\n (:file \"about\")\n (:file \"tutorial\")))\n (:file \"configuration-commands\" :depends-on (\"Help\"))\n (:file \"start\" :depends-on (\"configuration-commands\"))\n (:file \"manual\" :depends-on (\"configuration-commands\"))\n (:module \"Modes\"\n :pathname \"mode\"\n :depends-on (\"Core modes\")\n :components\n ((:file \"annotate\")\n (:file \"autofill\")\n (:file \"bookmark\")\n (:file \"bookmarklets\")\n (:file \"cruise-control\" :depends-on (\"repeat\"))\n (:file \"emacs\")\n (:file \"expedition\")\n (:file \"history-migration\")\n (:file \"macro-edit\")\n (:file \"no-sound\")\n (:file \"password\")\n (:file \"reading-line\")\n (:file \"repeat\")\n (:file \"small-web\")\n (:file \"style\" :depends-on (\"bookmarklets\"))\n (:file \"visual\")\n (:file \"vi\")\n (:file \"watch\"))))\n :in-order-to ((test-op (test-op \"nyxt/tests\")\n ;; Dumping the manual may catch errors.\n (compile-op \"nyxt/documentation\")\n ;; Subsystems:\n (test-op \"nyxt/analysis\")\n (test-op \"nyxt/theme\"))))\n\n(defsystem \"nyxt/tests\"\n :defsystem-depends-on (\"nasdf\")\n :class :nasdf-test-system\n :depends-on (nyxt lisp-unit2)\n :pathname #p\"NYXT:tests;\"\n :components ((:file \"package\")\n (:file \"define-configuration\")\n (:file \"prompt-buffer\")\n (:file \"urls\")\n (:file \"user-script-parsing\")\n (:file \"mode\")\n (:module \"Modes\"\n :pathname \"mode\"\n :components\n ((:file \"autofill\")\n (:file \"annotate\")\n (:file \"base\")\n (:file \"blocker\")\n (:file \"bookmark\")\n (:file \"bookmarklets\")\n (:file \"buffer-listing\")\n (:file \"certificate-exception\")\n (:file \"cruise-control\")\n (:file \"document\")\n (:file \"download\")\n (:file \"emacs\")\n (:file \"expedition\")\n (:file \"file-manager\")\n (:file \"force-https\")\n (:file \"help\")\n (:file \"hint-prompt-buffer\")\n (:file \"hint\")\n (:file \"history\")\n (:file \"input-edit\")\n (:file \"keyscheme\")\n (:file \"macro-edit\")\n (:file \"message\")\n (:file \"no-image\")\n (:file \"no-script\")\n (:file \"no-sound\")\n (:file \"no-webgl\")\n (:file \"passthrough\")\n (:file \"password\")\n (:file \"process\")\n (:file \"prompt-buffer\")\n (:file \"proxy\")\n (:file \"reading-line\")\n ;; TODO Fix repeat-mode architecture. Visit the file below for\n ;; more information.\n ;; (:file \"repeat\")\n (:file \"search-buffer\")\n (:file \"small-web\")\n (:file \"spell-check\")\n (:file \"style\")\n (:file \"vi\")\n ;; TODO Fix visual-mode architecture. Visit the file below for\n ;; more information.\n ;; (:file \"visual\")\n (:file \"user-script\")\n (:file \"watch\"))))\n :test-suite-args (:package :nyxt/tests))\n\n(defsystem \"nyxt/benchmarks\"\n :defsystem-depends-on (\"nasdf\")\n :class :nasdf-system\n :depends-on (nyxt alexandria trivial-benchmark)\n :pathname #p\"NYXT:tests;benchmarks;\"\n :components ((:file \"package\")\n (:file \"prompter\"))\n :perform (test-op (op c)\n (eval-input\n \"(nasdf:print-benchmark\n (alexandria:hash-table-alist\n (benchmark:run-package-benchmarks :package :nyxt/benchmarks\n :verbose t)))\")))\n\n(defsystem \"nyxt/documentation\"\n :depends-on (nyxt)\n :perform (compile-op (o c)\n (with-open-file (out \"manual.html\" :direction :output :if-exists :supersede)\n (write-string (symbol-call :nyxt :manual-html) out)\n (format *error-output* \"Manual dumped to ~s.~&\" \"manual.html\"))))\n\n(defsystem \"nyxt/gtk\"\n :defsystem-depends-on (\"nasdf\")\n :class :nasdf-system\n :depends-on (nyxt cl-webkit2)\n :pathname #p\"NYXT:source;\"\n :components ((:file \"renderer/gtk\")\n ;; TODO: Port to other renderers.\n (:file \"mode/blocker\")\n (:file \"mode/certificate-exception\")\n (:file \"mode/force-https\")\n (:file \"mode/user-script\")\n (:file \"mode/no-image\")\n (:file \"mode/no-script\")\n (:file \"mode/no-webgl\")\n (:file \"mode/proxy\")))\n\n(defsystem \"nyxt/gi-gtk\"\n :defsystem-depends-on (\"nasdf\")\n :class :nasdf-system\n :depends-on (nyxt/gtk cl-gobject-introspection)\n :pathname #p\"NYXT:source;renderer;\"\n :components ((:file \"gi-gtk\"))\n :in-order-to ((test-op (test-op \"nyxt/gi-gtk/tests\")\n (test-op \"nyxt/tests\")\n ;; Dumping the manual may catch errors.\n (compile-op \"nyxt/documentation\")\n ;; Subsystems:\n (test-op \"nyxt/analysis\")\n (test-op \"nyxt/theme\"))))\n\n(defsystem \"nyxt/gi-gtk/tests\"\n :defsystem-depends-on (\"nasdf\")\n :class :nasdf-test-system\n :depends-on (nyxt/gi-gtk lisp-unit2)\n :pathname #p\"NYXT:tests;renderer;\"\n :serial t\n :components ((:file \"package\")\n (:file \"set-url\")\n (:file \"custom-schemes\")\n (:file \"search-buffer\"))\n :test-suite-args (:package :nyxt/tests/renderer))\n\n(defsystem \"nyxt/electron\"\n :depends-on (nyxt cl-electron)\n :pathname #p\"NYXT:source;renderer;\"\n :components ((:file \"electron\")))\n\n;; We should not set the build-pathname in systems that have a component.\n;; Indeed, when an external program (like Guix) builds components, it needs to\n;; know the name of the output. But ASDF/SYSTEM::COMPONENT-BUILD-PATHNAME is\n;; non-exported so the only reliable way to know the build pathname is to use\n;; the default.\n;;\n;; The workaround is to set a new dummy system of which the sole purpose is to\n;; produce the desired binary.\n\n(defsystem \"nyxt/gtk-application\"\n :defsystem-depends-on (\"nasdf\")\n :class :nasdf-system\n :depends-on (nyxt/gtk)\n :build-operation \"program-op\"\n :build-pathname \"nyxt\"\n :entry-point \"nyxt:entry-point\")\n\n(defsystem \"nyxt/gi-gtk-application\"\n :defsystem-depends-on (\"nasdf\")\n :class :nasdf-system\n :depends-on (nyxt/gi-gtk)\n :build-operation \"program-op\"\n :build-pathname \"nyxt\"\n :entry-point \"nyxt:entry-point\")\n\n(defsystem \"nyxt/electron-application\"\n :defsystem-depends-on (\"nasdf\")\n :class :nasdf-system\n :depends-on (nyxt/electron)\n :build-operation \"program-op\"\n :build-pathname \"nyxt\"\n :entry-point \"nyxt:entry-point\")\n\n(defsystem \"nyxt/install\"\n :defsystem-depends-on (\"nasdf\")\n :class :nyxt-renderer-system\n :components ((:nasdf-desktop-file \"assets/nyxt.desktop\")\n (:nasdf-appdata-file \"assets/nyxt.metainfo.xml\")\n (:nasdf-icon-scalable-file \"assets/glyphs/nyxt.svg\")\n (:nasdf-icon-directory \"assets/\")\n (:nasdf-binary-file \"nyxt\")\n (:nasdf-source-file \"nyxt.asd\")\n (:nasdf-source-directory \"source\")\n (:nasdf-source-directory \"nasdf\")\n (:nasdf-source-directory \"libraries\"\n :exclude-types (\"o\" \"c\" \"h\" ; C code and artifacts.\n \"fasl\"))))\n\n;; Library subsystems:\n\n(defsystem \"nyxt/download-manager\"\n :defsystem-depends-on (\"nasdf\")\n :class :nasdf-system\n :depends-on (calispel\n cl-ppcre\n dexador\n log4cl\n quri\n str)\n :pathname #p\"NYXT:libraries;download-manager;\"\n :components ((:file \"package\")\n (:file \"engine\")\n (:file \"native\")))\n\n(defsystem \"nyxt/analysis\"\n :defsystem-depends-on (\"nasdf\")\n :class :nasdf-system\n :depends-on (alexandria\n cl-ppcre\n serapeum\n str)\n :pathname #p\"NYXT:libraries;analysis;\"\n :components ((:file \"package\")\n (:file \"composite-sequence\")\n (:file \"data\")\n (:file \"stem\")\n (:file \"tokenize\")\n (:file \"analysis\")\n (:file \"document-vector\")\n (:file \"text-rank\")\n (:file \"dbscan\")\n (:file \"section\"))\n :in-order-to ((test-op (test-op \"nyxt/analysis/tests\"))))\n\n(defsystem \"nyxt/analysis/tests\"\n :defsystem-depends-on (\"nasdf\")\n :class :nasdf-test-system\n :depends-on (nyxt/analysis lisp-unit2)\n :pathname #p\"NYXT:libraries;analysis;tests;\"\n :components ((:file \"tests\"))\n :test-suite-args (:package :analysis/tests))\n\n(defsystem \"nyxt/user-interface\"\n :defsystem-depends-on (\"nasdf\")\n :class :nasdf-system\n :depends-on (spinneret)\n :pathname #p\"NYXT:libraries;user-interface;\"\n :components ((:file \"package\")\n (:file \"user-interface\")))\n\n(defsystem \"nyxt/text-buffer\"\n :defsystem-depends-on (\"nasdf\")\n :class :nasdf-system\n :depends-on (cluffer)\n :pathname #p\"NYXT:libraries;text-buffer;\"\n :components ((:file \"package\")\n (:file \"text-buffer\")))\n\n(defsystem \"nyxt/password-manager\"\n :defsystem-depends-on (\"nasdf\")\n :class :nasdf-system\n :depends-on (bordeaux-threads\n cl-ppcre\n nclasses\n serapeum\n str\n trivial-clipboard\n uiop)\n :pathname #p\"NYXT:libraries;password-manager;\"\n :components ((:file \"package\")\n (:file \"password\")\n (:file \"password-keepassxc\")\n (:file \"password-security\")\n ;; Keep password-pass as to ensure higher priority.\n (:file \"password-pass\")))\n\n(defsystem \"nyxt/theme\"\n :defsystem-depends-on (\"nasdf\")\n :class :nasdf-system\n :depends-on (alexandria\n cl-colors-ng\n lass\n nclasses\n serapeum)\n :pathname #p\"NYXT:libraries;theme;\"\n :components ((:file \"package\")\n (:file \"utilities\")\n (:file \"theme\"))\n :in-order-to ((test-op (test-op \"nyxt/theme/tests\"))))\n\n(defsystem \"nyxt/theme/tests\"\n :defsystem-depends-on (\"nasdf\")\n :class :nasdf-test-system\n :depends-on (nyxt/theme lisp-unit2)\n :pathname #p\"NYXT:libraries;theme;tests;\"\n :components ((:file \"tests\"))\n :test-suite-args (:package :theme/tests))\n" }, { "path": "source/about.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :nyxt)\n\n(define-internal-page-command-global about ()\n (buffer \"*About*\")\n \"Show the list of contributors.\"\n (spinneret:with-html-string\n (:nstyle (style buffer))\n (:h1 \"Contributors\")\n (:ul\n (:li \"Adom Hartell (@4t0m)\")\n (:li \"André A. Gomes (@aadcg)\")\n (:li \"Artyom Bologov (@aartaka)\")\n (:li \"John Mercouris (@jmercouris)\")\n (:li \"@hendursaga\")\n (:li \"@kssytsrk\")\n (:li \"Pedro Delfino (@pdelfino)\")\n (:li \"Pierre Neidhardt (@ambrevar)\")\n (:li \"Solomon Bloch (@noogie13)\")\n (:li \"Vincent Dardel (@vindarel)\"))\n (:h1 \"Supporters\")\n (:p \"Many thanks to all of our backers who've supported Nyxt development.\")\n (:p \"Thank you to NLnet for supporting Nyxt!\")\n (:h1 \"Crowdfunding backers\")\n (:p \"Thank you to all who have supported and made Nyxt possible!\")\n (:h2 \"2018-11 campaign: *NIX Support\")\n (:h3 \"Digital Omnipresence\")\n (:ul\n (:li \"Alexander.Shendi\")\n (:li \"Ashish SHUKLA\")\n (:li \"Christopher Nascone\")\n (:li \"dan.girsh\")\n (:li \"Eric Monson\")\n (:li \"Jack Randall\")\n (:li \"James Anderson\")\n (:li \"liweitian\")\n (:li \"Marco Heisig\")\n (:li \"Oluwafemi Agbabiaka\")\n (:li \"pjb\")\n (:li \"Robert Krahn\")\n (:li \"Robert Uhl\")\n (:li \"1 anonymous\"))\n (:h3 \"Digital Magma\")\n (:ul\n (:li \"Daniel V\")\n (:li \"Jason Hamilton\")\n (:li \"Magnus Nyberg\")\n (:li \"Marek Kochanowicz\")\n (:li \"Rich Smith\")\n (:li \"Robert Uhl\")\n (:li \"simon\")\n (:li \"slade\")\n (:li \"Steve Last\")\n (:li \"ulf.makestad\")\n (:li \"1 anonymous\"))\n (:h3 \"Digital Immortality\")\n (:ul\n (:li \"Alexey Abramov\")\n (:li \"Are Jensen\")\n (:li \"Joseph Mingrone\")\n (:li \"Nikita Poliakov\")\n (:li \"pjb\")\n (:li \"Sainath Adapa\")\n (:li \"Spencer Heywood\")\n (:li \"Sungjin Chun\")\n (:li \"Tom Delord\")\n (:li \"2 anonymous\"))\n (:h3 \"Others\")\n (:ul\n (:li \"Nicholas Zivkovic\")\n (:li \"Pierre Neidhardt\")\n (:li \"Simon Zugmeyer\")\n (:li \"vindarel\")\n (:li \"5 anonymous\"))\n (:h2 \"2019-10 campaign: v1.4.0\")\n (:h3 \"Digital Immortality\")\n (:ul\n (:li \"Tim Johann\")\n (:li \"Julien Rousé\")\n (:li \"ebababi\")\n (:li \"Emil Oppeln-Bronikowski\")\n (:li \"Fox Kiester\")\n (:li \"Stefan Husmann\")\n (:li \"Nils Grunwald\")\n (:li \"Florian Adamsky\")\n (:li \"Valentin Atanasov\")\n (:li \"Pranav Vats\")\n (:li \"Jörn Gersdorf\")\n (:li \"Matt Skinner\")\n (:li \"Jelle Dirk Licht\")\n (:li \"Minori Yamashita\")\n (:li \"Hugh Daschbach\")\n (:li \"Niklas Carlsson\")\n (:li \"mestelan\")\n (:li \"Camille Troillard\")\n (:li \"mace nicolas\")\n (:li \"dan.girsh\")\n (:li \"Michael Bruderer\")\n (:li \"Patrice Rault\")\n (:li \"Cees de Groot\")\n (:li \"Sam Hedin\")\n (:li \"rbarzic\")\n (:li \"Jake Waksbaum\")\n (:li \"Lukas Jenks\")\n (:li \"Rodrigo Lazo\")\n (:li \"Lucas Sifoni\")\n (:li \"Calle Helmertz\")\n (:li \"Kristian Nygaard Jensen\")\n (:li \"Robert Uhl\")\n (:li \"Francis Burstall\")\n (:li \"Arnaud BEAUD'HUIN\")\n (:li \"Daniel V\")\n (:li \"Albin Heimerson\")\n (:li \"Alexander ter Weele\")\n (:li \"Jeremy Firth\")\n (:li \"aim\")\n (:li \"liweitian\")\n (:li \"Philipe Dallaire\")\n (:li \"Travis Brown\")\n (:li \"Divan Santana\")\n (:li \"John C Haprian\")\n (:li \"Pierrick Maillard\")\n (:li \"Dardel Renaud\")\n (:li \"Dardel Renaud\")\n (:li \"Nils Grunwald\")\n (:li \"hector\")\n (:li \"Jean Morel\")\n (:li \"Jos van Bakel\")\n (:li \"slade\")\n (:li \"dietrich ayala\")\n (:li \"bacon totem\")\n (:li \"Pierre Neidhardt\")\n (:li \"18 anonymous\"))))\n" }, { "path": "source/browser.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :nyxt)\n\n(hooks:define-hook-type prompt-buffer (function (prompt-buffer))\n \"Hook acting on `prompt-buffer'.\")\n(hooks:define-hook-type resource (function (request-data) (or request-data null))\n \"Hook acting on `request-data' resource.\nReturns:\n- Possibly modified `request-data'---redirect/block request.\n- NIL---block request.\")\n(hooks:define-hook-type browser (function (browser))\n \"Hook acting on `browser' (likely `*browser*').\")\n(export-always '(hook-resource))\n\n(define-class proxy ()\n ((url\n (quri:uri \"socks5://127.0.0.1:9050\")\n :documentation \"The address of the proxy server.\nIt's made of three components: protocol, host and port.\nExample: \\\"http://192.168.1.254:8080\\\".\")\n (allowlist\n '(\"localhost\" \"localhost:8080\")\n :type (list-of string)\n :documentation \"A list of URIs not to forward to the proxy.\")\n (proxied-downloads-p\n t\n :documentation \"Non-nil if downloads should also use the proxy.\"))\n (:export-class-name-p t)\n (:export-accessor-names-p t)\n (:documentation \"Enable forwarding of all network requests to a specific host.\nThis can apply to specific buffer.\"))\n\n(export-always 'combine-composed-hook-until-nil)\n(defmethod combine-composed-hook-until-nil ((hook hooks:hook) &optional arg)\n \"Return the composition of the HOOK handlers on ARG, from oldest to youngest.\n\nStop processing when a handler returns nil. Without handlers, return ARG.\n\nThis is an acceptable `hooks:combination' for `hooks:hook'.\"\n (labels ((compose-handlers (handlers result)\n (if handlers\n (let ((new-result (funcall (first handlers) result)))\n (log:debug \"Handler (~a ~a): ~a\" (first handlers) result new-result)\n (when new-result\n (compose-handlers (rest handlers) new-result)))\n result)))\n (compose-handlers (mapcar #'hooks:fn (hooks:handlers hook)) arg)))\n\n(export-always 'renderer-browser)\n(defclass renderer-browser ()\n ()\n (:metaclass interface-class)\n (:documentation \"Renderer-specific representation for the global browser.\nShould be redefined by the renderer.\"))\n\n(define-class browser (renderer-browser)\n ((search-engines\n (mapcar #'make-instance '(ddg-search-engine\n wikipedia-search-engine))\n :type (cons search-engine *)\n :documentation \"A list of `search-engine' objects.\nThe first one is the default, as per `default-search-engine'.\")\n (search-engine-suggestions-p\n t\n :type boolean\n :documentation \"Whether search suggestions are displayed.\")\n (remote-execution-p\n nil\n :type boolean\n :documentation \"Whether code sent to the socket gets executed. You must\nunderstand the risks before enabling this: a privileged user with access to your\nsystem can then take control of the browser and execute arbitrary code under\nyour user profile.\")\n (exit-code\n 0\n :type alex:non-negative-integer\n :reader t\n :export t\n :documentation \"The exit code return to the operating system.\n0 means success.\nNon-zero means failure.\")\n (socket-thread\n nil\n :type t\n :documentation \"Thread that listens on socket.\nSee `*socket-file*'.\nThis slot is mostly meant to clean up the thread if necessary.\")\n (messages-content\n '()\n :export t\n :reader messages-content\n :documentation \"A list of all echoed messages.\nMost recent messages are first.\")\n (clipboard-ring\n (make-ring)\n :documentation \"The ring with all the clipboard contents Nyxt could cache.\nNote that it may be incomplete.\")\n (command-model\n (make-instance 'analysis:sequence-model)\n :documentation \"This model is used to generate predictions for what the user will do.\nWhich commands will they invoke next?\")\n (last-command\n nil\n :type (maybe function)\n :documentation \"The last command invoked by the user.\")\n (command-dispatcher\n #'dispatch-command\n :type (or sym:function-symbol function)\n :documentation \"Function to process the command processed in `dispatch-input-event'.\nTakes the function/command as the only argument.\")\n (prompt-buffer-generic-history\n (make-ring)\n :documentation \"The default history of all prompt buffer entries.\nThis history is used if no history is specified for a given prompt buffer.\")\n (default-new-buffer-url\n (quri:uri (nyxt-url 'new))\n :type url-designator\n :documentation \"The URL set to a new blank buffer opened by Nyxt.\")\n (set-url-history\n (make-ring)\n :documentation \"A ring that keeps track of all URLs set by `set-url'.\")\n (recent-buffers\n (make-ring :size 50)\n :export nil\n :documentation \"A ring that keeps track of deleted buffers.\")\n (windows\n (make-hash-table)\n :export nil\n :documentation \"Table of all windows, indexed by their `id'.\")\n (last-active-window\n nil\n :type (or window null)\n :export nil\n :documentation \"Records the last active window. This is\nuseful when no Nyxt window is focused and we still want `ffi-window-active' to\nreturn something.\nSee `current-window' for the user-facing function.\")\n (buffers\n :initform (make-hash-table)\n :documentation \"Table of all live buffers, indexed by their `id'.\nSee `buffer-list', `buffer-get', `buffer-set' and `buffer-delete'.\")\n (startup-error-reporter-function\n nil\n :type (or function null)\n :export nil\n :documentation \"When supplied, upon startup, if there are errors, they will\nbe reported by this function.\")\n (open-external-link-in-new-window-p\n nil\n :documentation \"Whether to open links issued by an external program or\nissued by Control+ in a new window.\")\n (downloads\n :documentation \"List of downloads. Used for rendering by the download manager.\")\n (startup-timestamp\n (time:now)\n :export nil\n :documentation \"`time:timestamp' of when Nyxt was started.\")\n (startup-promise\n (lpara:promise)\n :export nil\n :accessor nil\n :documentation \"Promise used to make `start-browser' synchronous.\nWithout it, `start-browser' would return before the `*browser*' is effectively usable.\nImplementation detail.\")\n (init-time\n 0.0\n :type alex:non-negative-real\n :export nil\n :documentation \"Initialization time in seconds.\")\n (ready-p\n nil\n :reader ready-p\n :documentation \"If non-nil, the browser is ready for operation (make\nbuffers, load data files, open prompt buffer, etc).\")\n (native-dialogs\n t\n :type boolean\n :documentation \"Whether to replace renderer specific dialog boxes with the\nprompt buffer.\")\n (theme\n theme:+light-theme+\n :type theme:theme\n :documentation \"The theme to use for all the browser interface elements.\")\n (glyph-logo\n (gethash \"nyxt.svg\" *static-data*)\n :documentation \"The logo of Nyxt as an SVG.\")\n (history-file\n (make-instance 'history-file)\n :type history-file\n :documentation \"A file to persist history data across sessions.\")\n (history-vector\n (make-array 0 :fill-pointer t :adjustable t)\n :type vector\n :documentation \"A vector holding `history-entry' objects.\")\n (default-cookie-policy\n :no-third-party\n :type cookie-policy\n :documentation \"Cookie policy of new buffers.\nValid values are `:accept', `:never' and `:no-third-party'.\")\n ;; Hooks follow:\n (after-init-hook\n (make-instance 'hook-browser)\n :documentation \"The entry-point hook to configure everything in Nyxt.\nThe hook takes browser as the argument.\n\nThis hook is run after the `*browser*' is instantiated and before the\n`startup' is run.\n\nA handler can be added with:\n\\(define-configuration browser\n (after-init-hook (hooks:add-hook %slot-value% 'my-init-handler)))\")\n (after-startup-hook\n (make-instance 'hook-browser)\n :documentation \"Hook run when the browser is started and ready for interaction.\nThe handlers take browser as the argument.\n\nA handler can be added with:\n\\(define-configuration browser\n (after-startup-hook (hooks:add-hook %slot-value% 'my-startup-handler)))\")\n (before-exit-hook\n (make-instance 'hooks:hook-void)\n :type hooks:hook-void\n :documentation \"Hook run before both `*browser*' and the renderer get terminated.\nThe handlers take no argument.\")\n (window-make-hook\n (make-instance 'hook-window)\n :type hook-window\n :documentation \"Hook run after `window-make'.\nThe handlers take the window as argument.\")\n (buffer-make-hook\n (make-instance 'hook-buffer)\n :type hook-buffer\n :documentation \"Hook run after `buffer' initialization and before the URL is\nloaded.\nIt is run before mode initialization so that the default mode list can still be\naltered from the hooks.\nThe handlers take the buffer as argument.\")\n (buffer-before-make-hook\n (make-instance 'hook-buffer)\n :type hook-buffer\n :documentation \"Hook run at the beginning of `buffer' initialization.\nThe buffer web view is not allocated, so it's not possible to run arbitrary\nparenscript from this hook.\nSee `buffer-make-hook' and `buffer-after-make-hook' for other hook options.\nThe handlers take the buffer as argument.\")\n (buffer-after-make-hook\n (make-instance 'hook-buffer)\n :type hook-buffer\n :documentation \"Hook run after `buffer' initialization and before the URL is\nloaded.\nIt is run as the very last step of buffer initialization, when everything else is ready.\nSee also `buffer-make-hook' and `buffer-before-make-hook'.\nThe handlers take the buffer as argument.\")\n (prompt-buffer-make-hook\n (make-instance 'hook-prompt-buffer)\n :type hook-prompt-buffer\n :documentation \"Hook run after the `prompt-buffer' class is instantiated and\nbefore initializing the `prompt-buffer' modes.\nThe handlers take the `prompt-buffer' as argument.\")\n (prompt-buffer-ready-hook\n (make-instance 'hook-prompt-buffer)\n :type hook-prompt-buffer\n :documentation \"Hook run while waiting for the prompt buffer to be available.\nThe handlers take the `prompt-buffer' as argument.\")\n (external-editor-program\n (or (uiop:getenvp \"VISUAL\")\n (uiop:getenvp \"EDITOR\")\n (when (sera:resolve-executable \"gio\") \"gio open\"))\n :type (or string null)\n :reader nil\n :writer t\n :export t\n :documentation \"The external editor to use for editing files.\nThe full command, including its arguments, may be specified as list of strings\nor as a single string.\"))\n (:export-class-name-p t)\n (:export-accessor-names-p t)\n (:documentation \"The browser class defines the overall behavior of Nyxt, in\nthe sense that it manages the display of buffers. For instance, it abstracts\nthe renderer, and lays the foundations to track and manipulate buffers and\nwindows.\n\nA typical Nyxt session encompasses a single instance of this class, but nothing\nprevents otherwise.\")\n (:metaclass user-class))\n\n(export-always 'recent-history-entries)\n(defmethod recent-history-entries (n (browser browser) &key deduplicate-p)\n \"Return the N most recent browsing history entries as a list.\n\nWhen DEDUPLICATE-P is non-nil, remove duplicated entries.\"\n (nreverse (coerce (let ((recent-entries (sera:slice (history-vector browser) (- n))))\n (if deduplicate-p\n (remove-duplicates recent-entries :test #'equals)\n recent-entries))\n 'list)))\n\n(defmethod theme ((ignored (eql nil)))\n \"Fallback theme in case `*browser*' is NIL.\"\n (declare (ignore ignored))\n theme:+light-theme+)\n\n(defmethod external-editor-program ((browser browser))\n \"Specialized reader for `external-editor-program' slot.\nA list of strings is returned, as to comply with `uiop:launch-program' or\n`uiop:run-program'.\"\n (with-slots ((cmd external-editor-program)) browser\n (if (str:blank? cmd)\n (progn (echo-warning \"Invalid value of `external-editor-program' browser slot.\") nil)\n (str:split \" \" cmd :omit-nulls t))))\n\n(defmethod default-search-engine ((browser browser))\n (first (search-engines browser)))\n\n(defmacro on-renderer-ready (thread-name &body body)\n \"Run BODY from a new thread when renderer is ready.\n`ffi-within-renderer-thread' runs its body on the renderer thread when it's\nidle, so it should do the job.\"\n `(ffi-within-renderer-thread (lambda () (run-thread ,thread-name ,@body))))\n\n(defmethod finalize-startup ((browser browser) urls startup-timestamp)\n \"Run `after-init-hook' then BROWSER's `startup'.\"\n ;; `messages-appender' requires `*browser*' to be initialized.\n (unless (find-if (sera:eqs 'messages-appender) (log4cl:all-appenders)\n :key #'sera:class-name-of)\n (log4cl:add-appender log4cl:*root-logger* (make-instance 'messages-appender)))\n (ignore-errors\n (handler-bind ((error (lambda (c) (log:error \"In after-init-hook: ~a\" c))))\n (hooks:run-hook (after-init-hook browser) browser))) ; TODO: Run outside the main loop?\n ;; `startup' must be run _after_ this function returns; It's not enough since\n ;; the `startup' may invoke the prompt buffer, which cannot be invoked from\n ;; the renderer thread: this is why we run the `startup' in a new thread from\n ;; there.\n (on-renderer-ready \"finalize-startup\"\n (window-make browser)\n (let ((history-file-contents (files:content (history-file browser))))\n (setf (history-vector browser)\n (make-array (length history-file-contents)\n :fill-pointer t\n :adjustable t\n :initial-contents history-file-contents)))\n (open-urls (or urls (list (default-new-buffer-url browser))))\n (lpara:fulfill (slot-value browser 'startup-promise))\n (hooks:run-hook (after-startup-hook browser) browser)\n (funcall* (startup-error-reporter-function browser)))\n ;; Set `init-time' at the end of finalize to take the complete startup time\n ;; into account.\n (setf (slot-value *browser* 'init-time)\n (time:timestamp-difference (time:now) startup-timestamp))\n (setf (slot-value *browser* 'ready-p) t))\n\n;; Catch a common case for a better error message.\n(defmethod buffers :before ((browser t))\n (when (null browser)\n (error \"There is no current *browser*. Is Nyxt started?\")))\n\n(-> set-window-title (&optional window) *)\n(export-always 'set-window-title)\n(defun set-window-title (&optional (window (current-window)))\n \"Set WINDOW title.\"\n (setf (ffi-window-title window) (titler window)))\n\n(-> open-urls ((maybe (cons quri:uri *))) *)\n(defun open-urls (urls)\n \"Create new buffers and load URLS.\nThe buffer corresponding to the first URL is focused.\"\n (with-protect (\"Could not make buffer to open ~a: ~a\" urls :condition)\n (let ((first-buffer (first (mapcar (lambda (url) (make-buffer :url url))\n urls))))\n (when first-buffer\n (if (open-external-link-in-new-window-p *browser*)\n (ffi-window-set-buffer (window-make *browser*) first-buffer)\n (set-current-buffer first-buffer))))))\n\n(defun get-keymap (buffer buffer-keyscheme-map)\n \"Return the keymap in BUFFER-KEYSCHEME-MAP corresponding to BUFFER's `keyscheme'.\nIf none is found, fall back to `keyscheme:cua'.\"\n (keymaps:get-keymap (or (keyscheme buffer) keyscheme:cua) buffer-keyscheme-map))\n\n(defun request-resource-open-url (&key url &allow-other-keys)\n (make-buffer :url url))\n\n(defun request-resource-open-url-focus (&key url &allow-other-keys)\n (make-buffer-focus :url url))\n\n(export-always 'renderer-request-data)\n(defclass renderer-request-data ()\n ()\n (:metaclass interface-class)\n (:documentation \"Renderer-specific request object.\nShould be redefined by the renderer.\"))\n\n(define-class request-data (renderer-request-data)\n ((buffer\n (current-buffer)\n :type buffer\n :documentation \"Buffer targeted by the request.\")\n (url\n (quri:uri \"\")\n :documentation \"URL of the request\")\n (event-type\n :other\n :accessor nil ; TODO: No public accessor for now, we first need a use case.\n :export nil\n :documentation \"The type of request, e.g. `:link-click'.\")\n (new-window-p\n nil\n :documentation \"Whether the request takes place in a\nnew window.\")\n (http-method\n nil\n :type (maybe string)\n :documentation \"The HTTP method (GET, POST and friends) of the request.\")\n (request-headers\n nil\n :type trivial-types:association-list\n :documentation \"Dotted alist of headers for the request.\")\n (response-headers\n nil\n :type trivial-types:association-list\n :documentation \"Dotted alist of headers for the response to the given request.\")\n (toplevel-p\n nil\n :documentation \"Whether the request happens in a toplevel frame.\")\n (resource-p\n nil\n :documentation \"Whether the request is a resource request.\nResource requests cannot be redirected or blocked.\")\n (mime-type\n nil\n :type (maybe string)\n :documentation \"The MIME type of the resource at the other end of the request.\")\n (known-type-p\n nil\n :documentation \"Whether the request is for content with\nsupported MIME-type, such as a picture that can be displayed in the web\nview.\")\n (file-name\n nil\n :type (maybe string)\n :documentation \"The name this file will be saved on disk with, if downloaded.\")\n (keys\n '()\n :type list\n :documentation \"The key sequence that generated the request.\"))\n (:export-class-name-p t)\n (:export-accessor-names-p t)\n (:documentation \"Representation of HTTP(S) request.\nMost important slots are:\n- `buffer' request belongs to.\n- `url' requested.\n- `request-headers'/`response-headers' for headers it's requested with.\n- and `toplevel-p'/`resource-p' for whether it's a new page or resource\n request (respectively).\"))\n\n(export-always 'url-dispatching-handler)\n(-> url-dispatching-handler\n (symbol\n (function (quri:uri) boolean)\n (or string (function (quri:uri) (or quri:uri null))))\n *)\n(defun url-dispatching-handler (name test action)\n \"Return a `hook-request' handler apply its ACTION on the URLs conforming to TEST.\nFit for `request-resource-hook'.\n\nTEST should be function of one argument, the requested URL.\n\nACTION can be either\n- a shell command as a string,\n- or a function taking a URL as argument.\n\nIn case ACTION returns nil (always the case for shell command), URL request is\naborted. If ACTION returns a URL, it's loaded.\n\n`match-host', `match-scheme', `match-domain' and `match-file-extension' can be\nused to create TEST-functions, but any other function of one argument would fit\nthe TEST slot as well.\n\nThe following example does a few things:\n- Forward DOI links to the doi.org website.\n- Open magnet links with Transmission.\n- Open local files (file:// URIs) with Emacs.\n\n\\(define-configuration web-buffer\n (request-resource-hook\n (hooks:add-hook %slot-value%\n (url-dispatching-handler\n 'doi-link-dispatcher\n (match-scheme \\\"doi\\\")\n (lambda (url)\n (quri:uri (format nil \\\"https://doi.org/~a\\\"\n (quri:uri-path url))))))))\n\n\\(defmethod customize-instance ((buffer web-buffer))\n (hooks:add-hook\n (request-resource-hook buffer)\n (url-dispatching-handler\n 'transmission-magnet-links\n (match-scheme \\\"magnet\\\")\n \\\"transmission-remote --add ~a\\\"))\n (hooks:add-hook\n (request-resource-hook buffer)\n (url-dispatching-handler\n 'emacs-file\n (match-scheme \\\"file\\\")\n (lambda (url)\n (uiop:launch-program\n `(\\\"emacs\\\" ,(quri:uri-path url)))\n nil))))\"\n (make-instance\n 'hooks:handler\n :fn (lambda (request-data)\n (let ((url (url request-data)))\n (if (funcall test url)\n (etypecase action\n (function\n (let* ((new-url (funcall action url)))\n (log:info \"Applied ~s URL-dispatcher on ~s and got ~s\"\n (symbol-name name)\n (render-url url)\n (when new-url (render-url new-url)))\n (when new-url\n (setf (url request-data) new-url)\n request-data)))\n (string (let ((action (lambda (url)\n (uiop:launch-program\n (format nil action\n (render-url url)))\n nil)))\n (funcall action url)\n (log:info \"Applied ~s shell-command URL-dispatcher on ~s\"\n (symbol-name name)\n (render-url url)))))\n request-data)))\n :name name))\n\n(defun javascript-error-handler (condition)\n (echo-warning \"JavaScript error: ~a\" condition))\n\n(defun print-message (html-body &optional (window (current-window)))\n (ffi-print-message (message-buffer window) html-body))\n\n(export-always 'current-window)\n(defun current-window (&optional no-rescan)\n \"Return the current window.\nIf NO-RESCAN is non-nil, fetch the window from the `last-active-window' cache\ninstead of asking the renderer for the active window. It is faster but\nmay yield the wrong result.\"\n (when *browser*\n (if (and no-rescan (slot-value *browser* 'last-active-window))\n (slot-value *browser* 'last-active-window)\n ;; No window when browser is not started.\n (ignore-errors (ffi-window-active *browser*)))))\n\n(export-always 'set-current-buffer)\n(defmethod set-current-buffer ((buffer modable-buffer) &key (focus t))\n \"Set the active BUFFER for the active window.\nReturn BUFFER.\"\n (cond ((not (current-window)) (make-window buffer))\n ((and (active-buffer-p buffer)\n (not (eq (current-window) (window buffer))))\n (ffi-window-set-buffer (window buffer) (get-inactive-buffer) :focus nil)\n (ffi-window-set-buffer (current-window) buffer :focus focus))\n ((and (not (active-buffer-p buffer))\n (not (eq (current-window) (window buffer))))\n (ffi-window-set-buffer (current-window) buffer :focus focus))\n (t nil))\n buffer)\n\n(export-always 'current-prompt-buffer)\n(defun current-prompt-buffer ()\n \"Return the current prompt-buffer.\"\n (first (active-prompt-buffers (current-window))))\n\n(export-always 'focused-buffer)\n(defun focused-buffer (&optional (window (current-window)) )\n \"Return the currently focused buffer.\"\n (find-if #'ffi-focused-p\n (list (first (active-prompt-buffers window))\n (active-buffer window)\n (status-buffer window)\n (message-buffer window))))\n\n(define-internal-page-command-global reduce-to-buffer (&key (delete t))\n (reduced-buffer \"*Reduced Buffers*\")\n \"Query the buffer(s) to \\\"reduce \\\" by copying their titles/URLs to a\nsingle buffer, optionally delete them. This function is useful for archiving a\nset of useful URLs or preparing a list to send to a someone else.\"\n (let ((buffers (prompt\n :prompt \"Reduce buffer(s)\"\n :sources (make-instance 'buffer-source\n :constructor (remove-if #'internal-url-p (buffer-list)\n :key #'url)\n :actions-on-return #'identity\n :enable-marks-p t))))\n (unwind-protect\n (spinneret:with-html-string\n (:h1 \"Reduced Buffers:\")\n (:div\n (if buffers\n (loop for buffer in buffers\n collect\n (with-current-buffer buffer\n (:div\n (:p (:b \"Title: \") (title buffer))\n (:p (:b \"URL: \") (:a :href (render-url (url buffer))\n (render-url (url buffer))))\n (:p (:b \"Automatically generated summary: \")\n (:ul\n (loop for summary-bullet in (analysis:summarize-text\n (document-get-paragraph-contents :limit 10000))\n collect (:li (str:collapse-whitespaces summary-bullet)))))\n (:hr \"\"))))\n (:p \"None chosen.\"))))\n (when delete (mapcar #'buffer-delete buffers)))))\n\n(export-always 'render-menu)\n(defun render-menu (mode-symbol &optional (buffer (current-buffer)))\n \"Render a menu for a given mode symbol.\"\n (spinneret:with-html\n (:div :class \"mode-menu\"\n (loop for command in (list-mode-commands mode-symbol)\n collect\n (let ((name (string-downcase (closer-mop:generic-function-name command)))\n (bindings (keymaps:pretty-binding-keys\n (name command)\n (current-keymaps buffer)\n :print-style (keymaps:name (keyscheme buffer)))))\n (:nbutton\n :class \"button binding\"\n :text (if bindings (first bindings) \"⏎\")\n `(nyxt::run-async ,command))\n (:nbutton\n :class \"button command\"\n :text name\n `(nyxt::run-async ,command)))))))\n" }, { "path": "source/buffer.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :nyxt)\n\n(hooks:define-hook-type keymaps-buffer\n (function ((list-of keymaps:keymap) buffer)\n (values &optional (list-of keymaps:keymap) buffer))\n \"Hook to modify keymaps.\nGet a list of `nkeymaps:keymap's and `buffer' and return a new list and buffer.\")\n(export-always '(hook-keymaps-buffer))\n(hooks:define-hook-type url->url (function (quri:uri) quri:uri)\n \"Hook getting a `quri:uri' and returning same/another one. \")\n\n(export-always 'renderer-buffer)\n(defclass renderer-buffer ()\n ()\n (:metaclass interface-class)\n (:documentation \"Renderer-specific buffer objects.\nShould be redefined by the renderer.\"))\n\n(defvar %default-modes '(base-mode)\n \"The default modes for unspecialized buffers.\nThis is useful when there is no current buffer.\")\n\n(define-class buffer (renderer-buffer)\n ((default-modes\n %default-modes\n :accessor nil\n :type (list-of symbol)\n :documentation \"The symbols of the modes to instantiate on buffer creation.\nThe mode instances are stored in the `modes' BUFFER slot.\n\nThe default modes returned by this method are appended to the default modes\ninherited from the superclasses.\")\n (id\n (new-id)\n :type unsigned-byte\n :documentation \"Unique identifier for a buffer.\")\n (key-stack\n '()\n :documentation \"A stack of the key chords a user has pressed.\")\n (last-access\n (time:now)\n :export nil\n :documentation \"Timestamp when the buffer was last switched to.\")\n (last-key\n nil\n :export nil\n :type (or null keymaps:key)\n :documentation \"Last pressed key.\")\n (url (quri:uri \"\"))\n (url-at-point (quri:uri \"\"))\n (title \"\")\n (style\n (theme:themed-css (theme *browser*)\n '(:font-face :font-family \"public sans\" :font-style \"normal\" :font-weight\n \"400\" :src \"url('nyxt-resource:PublicSans-Regular.woff')\"\n \"format('woff')\")\n '(:font-face :font-family \"public sans\" :font-style \"italic\" :font-weight\n \"400\" :src \"url('nyxt-resource:PublicSans-Italic.woff')\"\n \"format('woff')\")\n '(:font-face :font-family \"public sans\" :font-style \"normal\" :font-weight\n \"100\" :src \"url('nyxt-resource:PublicSans-Thin.woff')\"\n \"format('woff')\")\n '(:font-face :font-family \"public sans\" :font-style \"italic\" :font-weight\n \"100\" :src \"url('nyxt-resource:PublicSans-ThinItalic.woff')\"\n \"format('woff')\")\n '(:font-face :font-family \"public sans\" :font-style \"normal\" :font-weight\n \"200\" :src \"url('nyxt-resource:PublicSans-ExtraLight.woff')\"\n \"format('woff')\")\n '(:font-face :font-family \"public sans\" :font-style \"italic\" :font-weight\n \"200\" :src \"url('nyxt-resource:PublicSans-ExtraLightItalic.woff')\"\n \"format('woff')\")\n '(:font-face :font-family \"public sans\" :font-style \"normal\" :font-weight\n \"300\" :src \"url('nyxt-resource:PublicSans-Light.woff')\"\n \"format('woff')\")\n '(:font-face :font-family \"public sans\" :font-style \"italic\" :font-weight\n \"300\" :src \"url('nyxt-resource:PublicSans-LightItalic.woff')\"\n \"format('woff')\")\n '(:font-face :font-family \"public sans\" :font-style \"normal\" :font-weight\n \"500\" :src \"url('nyxt-resource:PublicSans-Medium.woff')\"\n \"format('woff')\")\n '(:font-face :font-family \"public sans\" :font-style \"italic\" :font-weight\n \"500\" :src \"url('nyxt-resource:PublicSans-MediumItalic.woff')\"\n \"format('woff')\")\n '(:font-face :font-family \"public sans\" :font-style \"normal\" :font-weight\n \"600\" :src \"url('nyxt-resource:PublicSans-SemiBold.woff')\"\n \"format('woff')\")\n '(:font-face :font-family \"public sans\" :font-style \"italic\" :font-weight\n \"600\" :src \"url('nyxt-resource:PublicSans-SemiBoldItalic.woff')\"\n \"format('woff')\")\n '(:font-face :font-family \"public sans\" :font-style \"normal\" :font-weight\n \"700\" :src \"url('nyxt-resource:PublicSans-Bold.woff')\"\n \"format('woff')\")\n '(:font-face :font-family \"public sans\" :font-style \"italic\" :font-weight\n \"700\" :src \"url('nyxt-resource:PublicSans-BoldItalic.woff')\"\n \"format('woff')\")\n '(:font-face :font-family \"public sans\" :font-style \"normal\" :font-weight\n \"800\" :src \"url('nyxt-resource:PublicSans-ExtraBold.woff')\"\n \"format('woff')\")\n '(:font-face :font-family \"public sans\" :font-style \"italic\" :font-weight\n \"800\" :src \"url('nyxt-resource:PublicSans-ExtraBoldItalic.woff')\"\n \"format('woff')\")\n '(:font-face :font-family \"public sans\" :font-style \"normal\" :font-weight\n \"900\" :src \"url('nyxt-resource:PublicSans-Black.woff')\"\n \"format('woff')\")\n '(:font-face :font-family \"public sans\" :font-style \"italic\" :font-weight\n \"900\" :src \"url('nyxt-resource:PublicSans-BlackItalic.woff')\"\n \"format('woff')\")\n '(:font-face :font-family \"dejavu sans mono\"\n :src \"url('nyxt-resource:DejaVuSansMono.ttf')\" \"format('ttf')\")\n '(*\n :box-sizing border-box)\n `(body\n :background-color ,theme:background-color\n :color ,theme:on-background-color\n :font-family ,theme:font-family\n :margin-left \"20px\"\n :margin-top \"20px\")\n '(ul\n :margin-top \"0\"\n :margin-bottom \"0\")\n '(\"details > *\"\n :margin-left \"18px\")\n '(\"details > ul\"\n :margin-left \"inherit\")\n '(\"details summary\"\n :margin-left \"inherit\"\n :margin-bottom \"8px\"\n :cursor \"pointer\")\n '(\"summary::-webkit-details-marker\"\n :padding-bottom \"4px\")\n '(\"details > summary\"\n :list-style-type \"none\")\n '(\"details > summary::-webkit-details-marker\"\n :display \"none\")\n '(\"details > summary::before\"\n :font-weight \"bold\"\n :content \"+\"\n :margin-right \"5px\"\n :display \"inline-block\")\n '(\"details[open] > summary::before\"\n :content \"−\")\n '(.section\n :margin-top \"2em\")\n `(\"h1,h2,h3,h4,h5,h6\"\n :color ,theme:primary-color)\n `(hr\n :background-color ,theme:secondary-color\n :color ,theme:on-secondary-color\n :height \"2px\"\n :border-radius \"2px\"\n :border-width \"0\")\n '(button\n :background \"transparent\"\n :color \"inherit\"\n :border \"none\"\n :padding 0\n :font \"inherit\"\n :outline \"inherit\")\n `(.button\n :appearance \"menulist-button\"\n :background-color ,theme:primary-color\n :color ,theme:on-primary-color\n :display \"inline-block\"\n :text-decoration \"none\"\n :border-radius \"4px\"\n :border-color ,theme:primary-color\n :border-style \"solid\"\n :border-width \"0.2em\"\n :padding \"0.2em\"\n :margin \"0.2em\")\n `(select.button\n :appearance auto\n :background-color ,theme:primary-color\n :color ,theme:on-primary-color)\n `(code\n :font-family ,theme:monospace-font-family\n :font-size \"0.9rem\")\n `(.code-select\n :position \"absolute\"\n :top \"0\"\n :right \"0\"\n :padding-right \"8px !important\"\n :direction \"rtl\"\n :appearance \"none !important\"\n :border \"none\"\n :background-color \"transparent !important\"\n :color \"black !important\")\n `(\".code-select:hover\"\n :color ,theme:action-color !important)\n '((:and .button :hover)\n :cursor \"pointer\"\n :opacity 0.8)\n `((:and .button (:or :visited :active))\n :color ,theme:background-color)\n `(.link\n :appearance none\n :text-decoration \"underline\"\n :display \"inline\"\n :color ,theme:primary-color)\n '(\".link:hover\"\n :opacity 0.8)\n `(.action\n :color ,theme:action-color)\n `(.button.action\n :background-color ,theme:action-color\n :color ,theme:on-action-color\n :border-color ,theme:action-color+)\n `(.warning\n :color ,theme:warning-color)\n `(.button.warning\n :background-color ,theme:warning-color\n :color ,theme:on-warning-color\n :border-color ,theme:warning-color+)\n `(.success\n :color ,theme:success-color)\n `(.button.success\n :background-color ,theme:success-color\n :color ,theme:on-success-color\n :border-color ,theme:success-color+)\n `(.highlight\n :color ,theme:highlight-color)\n `(.button.highlight\n :background-color ,theme:highlight-color\n :color ,theme:on-highlight-color\n :border-color ,theme:highlight-color+)\n `(.plain\n :color ,theme:on-background-color\n :background-color ,theme:background-color)\n `(.input\n :appearance \"textfield\"\n :display \"inline-block\"\n :color \"black\"\n :background-color \"white\"\n :border \"0.2em\" solid ,theme:secondary-color\n :border-radius \"4px\"\n :outline \"none\"\n :padding \"0.2em\"\n :margin \"0.2em\")\n `(a\n :color ,theme:primary-color)\n `(\"a:hover\"\n :opacity 0.8)\n `(pre\n :font-family ,theme:monospace-font-family\n :font-size \"0.9rem\"\n :border-radius \"2px\"\n :overflow \"auto\"\n :padding \"5px\")\n '(\"table\"\n :border-radius \"2px\"\n :border-spacing \"0\"\n :width \"100%\")\n `(\"pre, p code\"\n :color ,theme:on-background-color\n :background-color ,theme:background-color-)\n '(\"a code\"\n :text-decoration underline)\n `(\"table, th, td\"\n :border-color ,theme:primary-color\n :border-width \"1px\"\n :border-style \"solid\"\n :background-color ,theme:background-color\n :color ,theme:on-background-color)\n '(\"td, th\"\n :padding \"6px\")\n `(th\n :background-color ,theme:primary-color\n :color ,theme:on-primary-color\n :text-align \"left\")\n '(\"th:first-of-type\"\n :border-top-left-radius \"1px\")\n '(\"th:last-of-type\"\n :border-top-right-radius \"1px\")\n '(\"tr:last-of-type td:first-of-type\"\n :border-bottom-left-radius \"2px\")\n '(\"tr:last-of-type td:last-of-type\"\n :border-bottom-right-radius \"2px\")\n '(\"table.resizable-table th\"\n :resize \"horizontal\"\n :overflow \"auto\")\n `(\"::selection\"\n :color ,theme:on-action-color\n :background-color ,theme:action-color)\n `(\".mode-menu\"\n :overflow-x \"scroll\"\n :white-space \"nowrap\"\n :background-color ,theme:background-color-\n :position \"sticky\"\n :margin-top \"-20px\"\n :top 0\n :width \"100%\"\n :height \"32px\")\n `(\".mode-menu > button\"\n :color ,theme:on-secondary-color\n :padding-left \"8px\"\n :padding-right \"8px\"\n :font-size \"14px\"\n :border-radius \"2px\"\n :margin \"0\"\n :margin-right \"12px\"\n :border \"none\"\n :height \"32px\")\n `(\".mode-menu > .binding\"\n :background-color ,theme:secondary-color)\n `(\".mode-menu > .command\"\n :background-color ,theme:background-color-)\n '(\".mode-menu::-webkit-scrollbar\"\n :display \"none\")\n '(\"dl\"\n :display \"grid\"\n :grid-template-columns \"max-content auto\"\n :row-gap \"10px\"\n :column-gap \"10px\")\n `(\"dt\"\n :grid-column-start 1\n :padding \"4px\"\n :padding-left \"8px\"\n :padding-right \"8px\"\n :border-radius \"2px\"\n :font-weight \"bold\"\n :background-color ,theme:background-color-)\n '(\"dd\"\n :margin-inline-start \"0\"\n :grid-column-start 2)\n '(\"dd pre\"\n :margin-top \"0\"\n :margin-bottom \"0\")\n '(\".nsection-anchor\"\n :display \"none\")\n '(\".nsection-summary:hover .nsection-anchor\"\n :display \"inline-block\")))\n (buffer-delete-hook\n (make-instance 'hook-buffer)\n :type hook-buffer\n :documentation \"Hook run before `buffer-delete'.\nThe handlers take the buffer as argument.\"))\n (:export-class-name-p t)\n (:export-accessor-names-p t)\n (:export-predicate-name-p t)\n (:metaclass user-class)\n (:documentation \"A buffer is the fundamental unit of displayed content.\nBuffers result from the computations of a web renderer, which generates a visual\nrepresentation of HTML documents.\n\nRendered URLs or the Nyxt's manual qualify as examples. Buffers are fully\nseparated from one another, so that each has its own behavior and settings.\"))\n\n(defmethod request-resource-hook ((buffer buffer))\n \"A method to not error out if the buffer has no `request-resource-hook'.\n\nUseful in FFI functions where we usually specialize things against\n`renderer-buffer', not knowing the exact class of those.\"\n nil)\n\n(defmethod initialize-instance :after ((buffer buffer) &key &allow-other-keys)\n \"Dummy method to allow forwarding other key arguments.\"\n buffer)\n\n(define-class modable-buffer (buffer)\n ((modes\n '()\n :documentation \"The list of mode instances.\nModes are instantiated over the result of the `default-modes' method, with\n`customize-instance' and not in the initform so that the instantiation form can\naccess the initialized buffer.\")\n (page-mode\n nil\n :documentation \"A single mode enabled for internal pages.\nThis slot stores the mode enabled by internal pages. When the user navigates\naway from the internal page, this mode is disabled.\")\n (enable-mode-hook\n (make-instance 'hook-mode)\n :type hook-mode\n :documentation \"Hook run on mode enabling, after the mode-specific hook.\")\n (disable-mode-hook\n (make-instance 'hook-mode)\n :type hook-mode\n :documentation \"Hook run on mode disabling, after the mode-specific hook.\"))\n (:export-class-name-p t)\n (:export-accessor-names-p t)\n (:export-predicate-name-p t)\n (:metaclass user-class)\n (:documentation \"A buffer whose behavior can be modified with `mode's.\"))\n\n(defmethod enable-page-mode ((modable-buffer modable-buffer) mode)\n (enable-modes* mode modable-buffer)\n (setf (page-mode modable-buffer) mode))\n\n(defmethod disable-page-mode ((modable-buffer modable-buffer))\n (when (page-mode modable-buffer)\n (disable-modes* (page-mode modable-buffer) modable-buffer)\n (setf (page-mode modable-buffer) nil)))\n\n(defmethod modes ((buffer buffer))\n \"Return the modes active in BUFFER.\n\nNon-`modable-buffer's never have modes.\nThe default specialization on `buffer' is useful to be able to call the method\nregardless of the buffer, with a meaningful result.\"\n '())\n\n(export-always 'enabled-modes)\n(defmethod enabled-modes ((buffer modable-buffer))\n \"Only return enabled modes.\"\n (sera:filter #'enabled-p (modes buffer)))\n\n(defmethod enabled-modes ((buffer buffer))\n \"Unless a modable buffer, return NIL for modes.\"\n nil)\n\n(define-class input-buffer (buffer)\n ((keyscheme\n keyscheme:cua\n :documentation \"The keyscheme that will be used for all modes.\")\n (current-keymaps-hook\n (make-instance 'hook-keymaps-buffer\n :combination #'hooks:combine-composed-hook)\n :type hook-keymaps-buffer\n :documentation \"Hook run as a return value of `current-keymaps'.\")\n (conservative-word-move\n t\n :documentation \"If non-nil, the cursor moves to the end\n(resp. beginning) of the word when `move-forward-word'\n(resp. `move-backward-word') is called.\")\n (forward-input-events-p\n nil\n :documentation \"When non-nil, keyboard events are\nforwarded to the renderer when no binding is found. Pointer\nevents (e.g. mouse events) are not affected by this, they are always\nforwarded when no binding is found.\")\n (last-event\n nil\n :type t\n :export nil\n ;; TODO: Store multiple events? Maybe when implementing keyboard macros.\n :documentation \"The last event received in the current buffer.\")\n (lisp-url-callbacks\n (sera:dict)\n :type hash-table\n :export nil\n :documentation \"The index of callbacks for `lisp://' URLs.\nThey are populated by the `nyxt/ps:lisp-eval' Parenscript macro.\n\nIt's part of `input-buffer' since any (even offline) buffer that can be clicked\non may want to have dynamic interactions.\"))\n (:export-class-name-p t)\n (:export-accessor-names-p t)\n (:export-predicate-name-p t)\n (:metaclass user-class)\n (:documentation \"A buffer in which the user can input.\"))\n\n(define-class document-buffer (buffer)\n ((document-model-delta-threshold\n 10\n :documentation \"The `document-model' is updated when the changed elements\nexceed this amount.\"\n :export nil)\n (document-model\n nil\n :reader nil ; We use a custom reader.\n :writer t\n :export t\n :type (or null plump:node)\n :documentation \"A parsed representation of the rendered buffer.\nComputed by `plump:parse', see `update-document-model' for details.\")\n (keep-search-marks-p\n t\n :type boolean\n :documentation \"Whether to keep search marks after exiting the prompt\nbuffer.\")\n (scroll-distance\n 32\n :type integer\n :documentation \"The distance in pixels for `scroll-down' or `scroll-up'.\")\n (smooth-scrolling\n nil\n :documentation \"Whether to scroll smoothly.\")\n (horizontal-scroll-distance\n 50\n :type integer\n :documentation \"The distance in pixels for `scroll-left' or `scroll-right'.\")\n (zoom-ratio\n nil\n :type (or null float)\n :reader t\n :export t\n :documentation \"The current zoom ratio as per `ffi-buffer-zoom-ratio'.\nIt is an implementation detail and must not be set by the user. For the\nuser-facing slot, see `zoom-ratio-default'.\")\n (zoom-ratio-step\n 0.1\n :type float\n :documentation \"The step size for zooming in and out.\")\n (zoom-ratio-default\n 1.0\n :type float\n :documentation \"The default zoom ratio.\")\n (page-scroll-ratio\n 0.90\n :type float\n :documentation \"The ratio of the page to scroll.\nA value of 0.95 means that the bottom 5% will be the top 5% when scrolling\ndown.\"))\n (:export-class-name-p t)\n (:export-accessor-names-p t)\n (:export-predicate-name-p t)\n (:metaclass user-class)\n (:documentation \"Buffers holding structured documents.\"))\n\n(define-class context-buffer (buffer)\n ((download-directory\n (make-instance 'download-directory)\n :type download-directory\n :documentation \"Directory where downloads will be stored.\")\n (download-engine\n :initform :renderer\n :type symbol\n :documentation \"Select a download engine to use, such as `:lisp' or\n`:renderer'.\"))\n (:export-class-name-p t)\n (:export-accessor-names-p t)\n (:export-predicate-name-p t)\n (:metaclass user-class)\n (:documentation \"A buffer that holds buffer-specific settings (see its slots).\n\nGlobal settings should be stored in `browser' instead.\n\nConceptually, it's similar to \\\"private windows\\\" in popular browsers but the\nscope is that of buffers.\"))\n\n(defmethod print-object ((buffer buffer) stream)\n (print-unreadable-object (buffer stream :type t)\n (format stream \"~a ~a\" (id buffer) (url buffer))))\n\n(defmethod (setf url) :around (value (buffer document-buffer))\n (declare (ignore value))\n (call-next-method)\n (set-window-title))\n(defmethod (setf title) :around (value (buffer document-buffer))\n (declare (ignore value))\n (call-next-method)\n (set-window-title))\n\n(export-always 'default-modes)\n(defgeneric default-modes (buffer)\n (:method-combination append)\n ;; TODO: Add a warning method when passing NIL to guard the current buffer not\n ;; bound errors?\n (:method append ((buffer t))\n %default-modes)\n (:method append ((buffer buffer))\n (slot-value buffer 'default-modes))\n (:method :around ((buffer buffer))\n \"Remove the duplicates from the `default-modes' and normalize them.\nThis allows setting modes as :DARK-MODE or 'EMACS-MODE in whatever package, and\nNsymbols will find the proper symbol, unless duplicate.\"\n (mapcar (alex:rcurry #'resolve-user-symbol :mode (list-all-packages))\n (remove-duplicates (call-next-method)\n ;; Modes at the beginning of the list have higher\n ;; priority.\n :from-end t)))\n (:documentation \"BUFFER's default modes. `append's all the methods applicable\nto BUFFER to get the full list of modes.\"))\n\n(define-class network-buffer (buffer)\n ((status\n :unloaded\n :type (member :loading :finished :unloaded :failed)\n :export nil\n :documentation \"The status of the buffer.\n- `:loading' when loading a web resource.\n- `:finished' when done loading a web resource.\n- `:unloaded' for buffers that have not been loaded yet, like\n session-restored buffers, dead buffers or new buffers that haven't started the\n loading process yet.\")\n (buffer-load-hook\n (make-instance 'hook-url->url\n :combination #'hooks:combine-composed-hook)\n :type hook-url->url\n :accessor nil\n :export nil\n :documentation \"Hook run in `buffer-load' before loading.\nThe handlers take the URL going to be loaded as argument and must return a\n(possibly new) URL.\")\n (buffer-loaded-hook\n (make-instance 'hook-buffer)\n :type hook-buffer\n :documentation \"Hook run on `on-signal-load-finished'.\nThe handlers take the buffer as argument.\")\n (request-resource-keyscheme-map\n (define-keyscheme-map \"request-resource\" ()\n keyscheme:default\n (list\n \"C-button1\" 'request-resource-open-url\n \"button2\" 'request-resource-open-url\n \"C-shift-button1\" 'request-resource-open-url-focus\n \"shift-button2\" 'request-resource-open-url-focus))\n :documentation \"Looked up when `request-resource-hook' handlers run. The\nkeymap takes functions whose key arguments are `:url' and `:buffer'.\")\n (request-resource-hook\n (make-instance 'hook-resource\n :combination #'combine-composed-hook-until-nil)\n :type hook-resource\n :documentation \"Hook run on every resource load.\nThe handlers are composed, passing a `request-data'\nuntil one of them returns nil or all handlers apply successfully.\n\nNewest hook is run first.\nIf a `request-data' object is returned, it gets passed to other handlers\nor right to the renderer if there are no more handlers.\nIf nil is returned, stop the hook and cancel the resource load.\n\nThe current buffer URL should not be relied upon. With WebKitGTK, it is the\nsame as (url REQUEST-DATA). If you need to access the URL before this request,\ninspect the document-mode history.\n\nExample:\n\n\\(defmethod configure-instance ((buffer buffer))\n (reduce #'hooks:add-hook\n '(old-reddit-handler auto-proxy-handler)\n :initial-value (request-resource-hook buffer)))\")\n (proxy\n nil\n :accessor nil\n :type (or proxy null)\n :documentation \"Proxy for buffer.\")\n (certificate-exceptions\n '()\n :type (list-of string)\n :documentation \"A list of hostnames for ignoring certificate errors.\"))\n (:export-class-name-p t)\n (:export-accessor-names-p t)\n (:export-predicate-name-p t)\n (:metaclass user-class)\n (:documentation \"Buffers that must interact with resources over the network.\"))\n\n(define-class web-buffer\n (context-buffer network-buffer modable-buffer document-buffer input-buffer)\n ((keywords\n nil\n :reader nil\n :writer t\n :documentation \"The keywords parsed from the current web buffer.\"))\n (:export-class-name-p t)\n (:export-accessor-names-p t)\n (:export-predicate-name-p t)\n (:metaclass user-class)\n (:documentation \"Buffer for browsing the web.\"))\n\n(defmethod customize-instance :after\n ((buffer buffer) &key (browser *browser*) no-hook-p\n &allow-other-keys)\n \"Finalize buffer.\nReturn the created buffer.\"\n (unless (or no-hook-p (not browser))\n (hooks:run-hook (buffer-before-make-hook browser) buffer))\n buffer)\n\n(defmethod customize-instance :after\n ((buffer modable-buffer)\n &key (browser *browser*) no-hook-p extra-modes\n &allow-other-keys)\n \"Finalize instantiation of modable BUFFER.\nIn particular,\n- Run `buffer-make-hook';\n- `enable' the modes from the `modes' slot, `default-modes', and the\nEXTRA-MODES\n- Run `buffer-after-make-hook'.\"\n (unless no-hook-p\n (hooks:run-hook (buffer-make-hook browser) buffer))\n (mapc #'enable (modes buffer))\n (enable-modes* (append (reverse (default-modes buffer))\n (uiop:ensure-list extra-modes))\n buffer)\n (unless no-hook-p\n (hooks:run-hook (buffer-after-make-hook browser) buffer))\n buffer)\n\n(defmethod customize-instance :after ((buffer context-buffer)\n &key &allow-other-keys)\n \"Finalize buffer.\nReturn the created buffer.\"\n (buffer-set (id buffer) buffer)\n buffer)\n\n(export-always 'update-document-model)\n(defun update-document-model (&key (buffer (current-buffer)))\n \"Update BUFFER's `document-model' as to include Nyxt identifiers.\"\n (ps-eval :buffer buffer\n (defvar nyxt-identifier-counter 0)\n (defun add-nyxt-identifiers (node)\n (unless (ps:chain node (has-attribute \"nyxt-identifier\"))\n (ps:chain node (set-attribute \"nyxt-identifier\"\n (ps:stringify nyxt-identifier-counter))))\n (incf nyxt-identifier-counter)\n (dolist\n (child\n (if (ps:chain node shadow-root)\n (ps:chain *array\n (from (ps:@ node shadow-root children))\n (concat (ps:chain *array (from (ps:@ node children)))))\n (ps:chain node children)))\n (add-nyxt-identifiers child))\n (when (ps:@ node shadow-root)\n (ps:chain node (set-attribute \"nyxt-shadow-root\" \"\")))\n nyxt-identifier-counter)\n (setf nyxt-identifier-counter\n (add-nyxt-identifiers (ps:chain document body))))\n (when-let ((body-json (with-current-buffer buffer\n (nyxt/dom::get-document-body-json))))\n (let ((dom (nyxt/dom::named-json-parse body-json)))\n (unless (uiop:emptyp (plump:text dom))\n (when (slot-boundp buffer 'keywords) (setf (keywords buffer) nil))\n (setf (document-model buffer) dom)))))\n\n(defun dead-buffer-p (buffer)\n (not (buffer-get (id buffer))))\n\n(defmethod document-model ((buffer buffer) &key use-cached-p)\n \"A wraparound accessor to BUFFER's `document-model'.\n\nIn case the page changed more than `document-model-delta-threshold', runs\n`update-document-model'.\"\n (if use-cached-p\n (slot-value buffer 'document-model)\n (ps-labels :buffer buffer\n ((%count-dom-elements\n ()\n (defvar dom-counter 0)\n (defun count-dom-elements (node)\n (incf dom-counter)\n (dolist (child (ps:chain node children))\n (count-dom-elements child))\n dom-counter)\n (setf dom-counter 0)\n (count-dom-elements (nyxt/ps:qs document \"html\"))))\n (if (dead-buffer-p buffer)\n (slot-value buffer 'document-model)\n (let ((value (slot-value buffer 'document-model))\n (element-count (%count-dom-elements)))\n (if (and value\n element-count\n ;; Check the difference in element count.\n (< (abs (- (length (clss:select \"*\" value))\n (truncate element-count)))\n (document-model-delta-threshold buffer)))\n value\n (progn\n (update-document-model :buffer buffer)\n (slot-value buffer 'document-model))))))))\n\n(defmethod proxy ((buffer buffer))\n (slot-value buffer 'proxy))\n\n(defmethod (setf proxy) (proxy (buffer buffer))\n (setf (slot-value buffer 'proxy) proxy)\n (if proxy\n (setf (ffi-buffer-proxy buffer)\n (list (url proxy)\n (allowlist proxy)))\n (setf (ffi-buffer-proxy buffer)\n (quri:uri \"\"))))\n\n(defmethod keywords ((buffer web-buffer))\n \"Return the terms that best describe the contents of BUFFER.\"\n (or (slot-value buffer 'keywords)\n (when-let ((document (document-model buffer)))\n (setf (slot-value buffer 'keywords)\n (analysis:extract-keywords\n (str:join \" \"\n (map 'list #'plump:text\n (clss:select \"p\" document))))))))\n\n(define-class keyword-source (prompter:source)\n ((prompter:name \"Keywords\")\n (buffer\n (current-buffer)\n :type buffer)\n (prompter:enable-marks-p t)\n (prompter:constructor (lambda (source)\n (mapcar #'first (nyxt::keywords (buffer source))))))\n (:export-class-name-p t)\n (:documentation \"Source listing the keywords for source `buffer'.\"))\n\n(-> proxy-url (buffer &key (:downloads-only boolean)) *)\n(defun proxy-url (buffer &key (downloads-only nil))\n \"Return the proxy address, nil if not set.\nIf DOWNLOADS-ONLY is non-nil, then it only returns the proxy address (if any)\nwhen `proxied-downloads-p' is true.\"\n (let* ((proxy (and buffer (proxy buffer)))\n (proxied-downloads (and proxy (proxied-downloads-p proxy))))\n (when (or (and (not downloads-only) proxy)\n proxied-downloads)\n (url proxy))))\n\n(defun load-failed-p (buffer)\n \"Only `network-buffer' loads can fail.\"\n (and (network-buffer-p buffer)\n (eq (slot-value buffer 'status) :failed)))\n\n(hooks:define-hook-type buffer (function (buffer))\n \"Hook acting on `buffer's.\")\n\n(define-command make-buffer (&rest args &key (title \"\") modes\n (url (if *browser*\n (default-new-buffer-url *browser*)\n (quri:uri (nyxt-url 'new))))\n (load-url-p t) (buffer-class 'web-buffer)\n &allow-other-keys)\n \"Create a new buffer.\nMODES is a list of mode symbols.\nIf URL is empty, the `default-new-buffer-url' browser slot is used instead.\nTo load nothing, set it to 'about:blank'.\nLOAD-URL-P controls whether to load URL right at buffer creation.\"\n (let* ((url (url url))\n (buffer (apply #'make-instance\n buffer-class\n :title title\n :extra-modes modes\n (append (unless (url-empty-p url) (list :url url))\n (uiop:remove-plist-keys '(:title :modes :url)\n args)))))\n (when load-url-p\n (ffi-buffer-load buffer url))\n buffer))\n\n(define-command make-buffer-focus (&key (url (default-new-buffer-url *browser*)))\n \"Switch to a new buffer.\nSee `make-buffer'.\"\n (let ((buffer (make-buffer :url url)))\n (set-current-buffer buffer)\n buffer))\n\n(-> add-to-recent-buffers (buffer) *)\n(defun add-to-recent-buffers (buffer)\n \"Push BUFFER to the front of `recent-buffers'.\nThe notion of first element is dictated by `containers:first-item'.\"\n (when (web-buffer-p buffer)\n (containers:delete-item (recent-buffers *browser*) buffer)\n (containers:insert-item (recent-buffers *browser*) buffer)))\n\n(export-always 'buffer-list)\n(defun buffer-list ()\n \"Order is stable.\"\n (sort (alex:hash-table-values (buffers *browser*))\n #'>\n :key #'id))\n\n(export-always 'internal-buffers)\n(defun internal-buffer-list (&key (all nil))\n ;; Note that the `buffers' slot only keeps track of \"main\" buffers.\n (append (sera:filter #'internal-url-p (buffer-list))\n (when all\n (alex:flatten (loop for window in (window-list)\n collect (active-prompt-buffers window)\n collect (status-buffer window)\n collect (message-buffer window))))))\n\n(defun buffer-get (id)\n \"Get the `buffer' with the corresponding ID.\"\n (or (gethash id (slot-value *browser* 'buffers))\n (find-if\n (lambda (prompt-buffer) (eql (id prompt-buffer) id))\n (mapcan\n #'active-prompt-buffers\n (alexandria:hash-table-values (windows *browser*))))))\n\n(defun buffer-set (id buffer)\n \"Ensure that entry ID->BUFFER belongs to `buffers' hash table.\"\n (when *browser*\n ;; Mutate state of the hash table.\n (setf (gethash id (slot-value *browser* 'buffers)) buffer)\n ;; Notify `buffers' of the new hash table state. Useful, for example, to\n ;; update the status buffer.\n (setf (buffers *browser*) (buffers *browser*))))\n\n(defun buffer-delete (id)\n \"Remove `buffers' hash table entry matching key ID.\n\nThis is a low-level function. See `buffer-delete' and `delete-buffer'.\"\n ;; Mutate state of the hash table.\n (when *browser*\n (remhash id (slot-value *browser* 'buffers))\n ;; Notify `buffers' of the new hash table state. Useful, for example, to\n ;; update the status buffer.\n (setf (buffers *browser*) (buffers *browser*))))\n\n(export-always 'window-list)\n(defun window-list ()\n \"Return a list of all the open `windows'.\"\n (when *browser*\n (alex:hash-table-values (windows *browser*))))\n\n(defmethod window ((buffer buffer))\n \"Get the window containing a buffer.\"\n (find buffer (alex:hash-table-values (windows *browser*))\n :key #'active-buffer))\n\n(defun last-active-buffer ()\n \"Return buffer with most recent `last-access'.\"\n (first (sort-by-time (buffer-list))))\n\n(defmethod active-buffer-p ((buffer buffer))\n (find buffer (mapcar #'active-buffer (window-list))))\n\n(defun get-inactive-buffer ()\n \"Return inactive buffers sorted by `last-access', when applicable.\nIf none exist, make a new inactive buffer.\"\n (if-let ((inactive (set-difference (buffer-list)\n (mapcar #'active-buffer (window-list)))))\n (first (sort-by-time inactive))\n (make-buffer)))\n\n(define-command copy-url ()\n \"Save current URL to clipboard.\"\n (echo \"~s copied to clipboard.\"\n (copy-to-clipboard (render-url (url (current-buffer))))))\n\n(define-command copy-title ()\n \"Save current page title to clipboard.\"\n (echo \"~a copied to clipboard.\"\n (copy-to-clipboard (title (current-buffer)))))\n\n(define-class buffer-source (prompter:source)\n ((prompter:name \"Buffer list\")\n (prompter:constructor (append (list (active-buffer (current-window)))\n (remove (active-buffer (current-window))\n (buffer-list))))\n (prompter:filter-preprocessor #'prompter:filter-exact-matches)\n (prompter:enable-marks-p t)\n (prompter:actions-on-return (list (lambda-unmapped-command set-current-buffer)\n (lambda-mapped-command ffi-buffer-delete)\n 'reload-buffers))\n (prompter:actions-on-current-suggestion-enabled-p t)\n (prompter:actions-on-current-suggestion\n (lambda-command set-current-buffer* (buffer)\n \"Set current BUFFER for the active window.\"\n (set-current-buffer buffer :focus nil)))\n (prompter:destructor (let ((buffer (current-buffer)))\n (lambda (prompter source)\n (declare (ignore source))\n (unless (or (prompter:returned-p prompter)\n (eq buffer (current-buffer)))\n (set-current-buffer buffer)))))\n (prompter:active-attributes-keys\n '(\"Title\" \"URL\" \"Keywords\")\n :accessor nil))\n (:export-class-name-p t)\n (:metaclass user-class)\n (:documentation \"Source for choosing one (or several) of the open buffers.\n\nThe `prompter:actions-on-current-suggestion' are set up to preview/switch to the\nbuffer currently chosen as suggestion.\"))\n\n(defmethod prompter:object-attributes ((buffer buffer) (source prompter:source))\n (declare (ignore source))\n `((\"Title\" ,(title buffer) (:width 3))\n (\"URL\" ,(render-url (url buffer)) (:width 2))\n ,(when (web-buffer-p buffer)\n `(\"Keywords\" ,(format nil \"~:{~a~^ ~}\" (keywords buffer)) (:width 2)))\n (\"ID\" ,(id buffer) (:width 1))))\n\n(define-command switch-buffer ()\n \"Switch buffer using fuzzy completion.\"\n (prompt\n :prompt \"Switch to buffer\"\n :sources (make-instance 'buffer-source)))\n\n(define-command switch-buffer-domain (&key domain (buffer (current-buffer)))\n \"Switch to buffer sharing the same domain as the current one.\"\n (let ((domain (or domain (quri:uri-domain (url buffer)))))\n (prompt\n :prompt \"Switch to buffer in current domain\"\n :sources (make-instance 'buffer-source\n :constructor\n (sera:filter (match-domain domain)\n (sort-by-time (buffer-list)))))))\n\n(define-command toggle-prompt-buffer-focus ()\n \"Toggle the focus between the current buffer and the current prompt buffer.\"\n (let ((prompt-buffer (current-prompt-buffer)))\n (if (ffi-focused-p prompt-buffer)\n (prog1 (ffi-focus-buffer (current-buffer))\n (ps-eval :buffer prompt-buffer\n (setf (ps:@ (nyxt/ps:qs document \"*\") style opacity) \"0.5\")))\n (prog1 (ffi-focus-buffer prompt-buffer)\n (ps-eval :buffer prompt-buffer\n (setf (ps:@ (nyxt/ps:qs document \"*\") style opacity) \"1\"))))))\n\n\n(flet ((delete-all (buffers &optional predicate)\n (mapcar #'ffi-buffer-delete\n (sera:filter (or predicate #'identity) buffers))))\n (define-command delete-buffer\n (&key\n (buffers\n (prompt\n :prompt \"Delete buffer(s)\"\n :sources (make-instance\n 'buffer-source\n :enable-marks-p t\n :actions-on-return\n (list\n (lambda-mapped-command ffi-buffer-delete)\n (lambda-command buffer-delete-duplicates* (buffers)\n \"Delete all buffers with same URLs, except selected.\"\n (delete-all\n (set-difference (buffer-list) buffers)\n (lambda (buffer)\n (member (url buffer) buffers\n :key #'url :test #'quri:uri-equal))))\n (lambda-command buffer-delete-same-host* (buffers)\n \"Delete all the buffers with the same website open.\"\n (delete-all\n (buffer-list)\n (lambda (buffer)\n (member (quri:uri-host (url buffer))\n (mapcar #'url buffers)\n :key #'quri:uri-host\n :test #'string-equal))))\n (lambda-command buffer-delete-same-url* (buffers)\n \"Delete all the buffers with the same page open.\"\n (delete-all\n (buffer-list)\n (lambda (buffer)\n (member (url buffer) buffers\n :key #'url :test #'quri:uri-equal)))))))\n buffers-supplied-p))\n \"Query the buffer(s) to delete.\n\nBUFFERS should be a list of `buffer's.\"\n (when buffers-supplied-p\n (delete-all (uiop:ensure-list buffers)))))\n\n(define-command delete-all-buffers ()\n \"Delete all buffers, with confirmation.\"\n (if-confirm ((format nil \"Delete ~a buffer(s)?\" (length (buffer-list))))\n (mapcar #'ffi-buffer-delete (buffer-list))))\n\n(define-command delete-current-buffer ()\n \"Delete the current buffer and switch to the last visited one.\nIf no other buffers exist, load the start page.\"\n (ffi-buffer-delete (current-buffer)))\n\n(define-command delete-other-buffers (&optional (buffer (current-buffer)))\n \"Delete all buffers except BUFFER.\nWhen BUFFER is omitted, it defaults to the current one.\"\n (let ((buffers-to-delete (remove buffer (buffer-list))))\n (if-confirm ((format nil \"Delete ~a buffer(s)?\" (length buffers-to-delete)))\n (mapcar #'ffi-buffer-delete buffers-to-delete))))\n\n;; Useful to be used by prompt buffer actions, since they take a list as\n;; argument.\n(export-always 'buffer-load*)\n(defun buffer-load* (url-list)\n \"Load first element of URL-LIST in current buffer and the rest in new buffers.\"\n (mapc (lambda (url) (make-buffer :url (url url))) (rest url-list))\n (ffi-buffer-load (current-buffer) (url (first url-list))))\n\n(define-class global-history-source (prompter:source)\n ((prompter:name \"Global history\")\n (prompter:constructor (recent-history-entries 200 *browser* :deduplicate-p t))\n (prompter:enable-marks-p t)\n (prompter:filter-preprocessor #'prompter:filter-exact-matches)\n (prompter:actions-on-return #'buffer-load*))\n (:export-class-name-p t)\n (:metaclass user-class)\n (:documentation \"Source listing all the entries in history.\nLoads the entry with default `prompter:actions-on-return'.\"))\n\n(define-class url-or-query ()\n ((data\n \"\"\n :type string\n :documentation \"A string to be resolved to a URL via `url'.\")\n (kind\n :initarg nil\n :type (maybe keyword)\n :documentation \"A keyword that classifies `data' based on its content.\nOne of `:url' or `:search-query'.\")\n (search-engine\n :type (maybe search-engine)\n :documentation \"Applicable when `kind' is `:search-query'.\")\n (search-query\n :initarg nil\n :type (maybe string)\n :documentation \"Applicable when `kind' is `:search-query'.\"))\n (:export-class-name-p t)\n (:export-accessor-names-p t)\n (:documentation \"Helper structure that resolves user input to a URL.\n\nDetermine whether a valid https URL, local file or a search engine query is\nrequested. When the first word of `data' matches the `shortcut' of a\n`search-engine', then it is interpreted as a search engine query.\"))\n\n(defmethod print-object ((query url-or-query) stream)\n (print-unreadable-object (query stream :type t)\n (format stream \"~a\" (data query))))\n\n(defmethod initialize-instance :after ((query url-or-query)\n &key &allow-other-keys)\n (with-slots (data kind search-engine search-query) query\n (setf data (str:trim data))\n (cond ((str:blankp data) t)\n ((valid-url-p data :check-tld-p nil) (setf kind :url))\n ((ignore-errors (valid-url-p (str:concat \"https://\" data)\n :check-tld-p t))\n (setf kind :url\n data (str:concat \"https://\" data)))\n ((uiop:file-exists-p data)\n (setf kind :url\n data (str:concat \"file://\" (uiop:native-namestring data))))\n (t\n (let* ((terms (sera:tokens data))\n (explicit-engine\n (find (first terms) (search-engines *browser*)\n :key #'shortcut :test #'string-equal))\n (engine (or explicit-engine\n (default-search-engine *browser*))))\n (setf kind :search-query\n search-engine engine)\n (if explicit-engine\n (setf search-query (str:join \" \" (rest terms)))\n (setf search-query data\n data (format-query data engine))))))))\n\n(export-always 'search-suggestions)\n(defmethod search-suggestions ((query url-or-query))\n (with-slots (search-engine search-query) query\n (when search-engine\n (let ((suggestions (suggestions search-query search-engine)))\n (mapcar (lambda (suggestion)\n (make-instance 'url-or-query\n :data (format-query suggestion search-engine)))\n ;; Ensure that search-query is the first suggestion.\n (if (string-equal search-query (first suggestions))\n suggestions\n (append (list search-query) suggestions)))))))\n\n(defmethod url ((query url-or-query))\n (with-slots (data kind search-engine search-query) query\n (quri:uri (if (eq :search-query kind)\n (format-url search-query search-engine)\n data))))\n\n(define-class url-or-query-source (prompter:source)\n ((prompter:name \"URL or search query\")\n (prompter:filter-preprocessor\n (lambda (suggestions source input)\n (declare (ignore suggestions source))\n (list (make-instance 'url-or-query :data input))))\n (prompter:filter-postprocessor\n (lambda (prompt-suggestions source input)\n (declare (ignore source input))\n (sleep 0.15) ; Delay search suggestions while typing.\n (if-let ((_ (search-engine-suggestions-p *browser*))\n (completion (search-suggestions\n (prompter:value (first prompt-suggestions)))))\n completion\n prompt-suggestions)))\n (prompter:filter nil)\n (prompter:actions-on-return #'buffer-load*))\n (:export-class-name-p t)\n (:metaclass user-class)\n (:documentation \"Source listing URL queries from user input in a DWIM fashion.\nSee `url-or-query'.\"))\n\n(defmethod prompter:object-attributes ((query url-or-query)\n (source url-or-query-source))\n (declare (ignore source))\n (with-slots (data kind search-engine search-query) query\n `((\"Input\" ,(or search-query data) (:width 5))\n (\"Type\" ,(cond ((null kind) \"\")\n ((eq kind :search-query) (name search-engine))\n (t kind))\n (:width 2)))))\n\n(export-always 'url-sources)\n(defmethod url-sources ((buffer buffer) actions-on-return)\n \"Return list of `set-url' sources.\nThe returned sources should have `url' or `prompter:actions-on-return' methods\nspecified for their contents.\"\n (let ((actions-on-return (uiop:ensure-list actions-on-return)))\n (append\n (list (make-instance 'url-or-query-source\n :actions-on-return actions-on-return)\n (make-instance 'global-history-source\n :actions-on-return actions-on-return))\n (mappend (rcurry #'url-sources (uiop:ensure-list actions-on-return))\n (enabled-modes buffer)))))\n\n(define-command set-url (&key (default-action #'buffer-load*))\n \"Set the URL for the current buffer, completing with history.\"\n (let* ((history (set-url-history *browser*))\n (actions-on-return\n (list #'buffer-load*\n (lambda-command copy-url* (suggestions)\n \"Copy the URL of the chosen suggestion.\"\n (trivial-clipboard:text\n (render-url (url (first suggestions))))))))\n (pushnew default-action actions-on-return)\n (prompt :prompt \"Open URL\"\n :input (render-url (url (current-buffer)))\n :history history\n :sources (url-sources (current-buffer) actions-on-return))\n (current-buffer)))\n\n(define-command set-url-new-buffer ()\n (set-url :default-action\n (lambda-command new-buffer-load* (suggestion-values)\n \"Load URL(s) in new buffer(s).\"\n (mapc (lambda (suggestion) (make-buffer :url (url suggestion)))\n (rest suggestion-values))\n (make-buffer-focus :url (url (first suggestion-values))))))\n\n(define-command reload-current-buffer ()\n \"Reload current buffer.\nReturn it.\"\n (ffi-buffer-reload (current-buffer)))\n\n(define-command reload-buffers\n (&optional (buffers\n (prompt\n :prompt \"Reload buffer(s)\"\n :sources (make-instance 'buffer-source :enable-marks-p t))))\n \"Prompt for BUFFERS to be reloaded.\nReturn BUFFERS.\"\n (mapcar #'ffi-buffer-reload (alex:ensure-list buffers))\n buffers)\n\n(define-command switch-buffer-previous (&key (offset 1) (buffer (current-buffer)))\n \"Switch to the previous buffer.\"\n (let ((buffer-list (buffer-list)))\n (set-current-buffer (nth (mod (+ offset (position buffer buffer-list))\n (length buffer-list))\n buffer-list))))\n\n(define-command switch-buffer-next\n (&key (offset 1) (buffer (current-buffer)))\n \"Switch to the next buffer.\"\n (switch-buffer-previous :offset (- offset) :buffer buffer))\n\n(define-command switch-buffer-last ()\n \"Switch to the last visited buffer.\n\nThe buffer with the most recent access time is returned.\"\n (when-let ((buffer (second (sort-by-time (buffer-list)))))\n (set-current-buffer buffer)))\n\n(define-command open-inspector ()\n \"Open the inspector, a graphical tool to inspect the buffer.\"\n (ffi-inspector-show (current-buffer))\n (current-buffer))\n" }, { "path": "source/clipboard.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :nyxt)\n\n(-> ring-insert-clipboard (containers:ring-buffer-reverse) (maybe string))\n(export-always 'ring-insert-clipboard)\n(defun ring-insert-clipboard (ring)\n \"Check if clipboard-content is most recent entry in RING.\nIf not, insert clipboard-content into RING.\nReturn most recent entry in RING.\"\n (let ((clipboard-content (handler-case (trivial-clipboard:text)\n (uiop:subprocess-error ()\n nil))))\n (when clipboard-content\n (unless (string= clipboard-content (unless (containers:empty-p ring)\n (containers:first-item ring)))\n (containers:insert-item ring clipboard-content)))\n (unless (containers:empty-p ring)\n (string (containers:first-item ring)))))\n\n(export-always 'copy-to-clipboard)\n(defun copy-to-clipboard (input)\n \"Save INPUT text to clipboard, and ring.\"\n (containers:insert-item (clipboard-ring *browser*)\n (trivial-clipboard:text input)))\n" }, { "path": "source/color.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :nyxt)\n\n(defvar *css-colors*\n '(\"AliceBlue\" \"AntiqueWhite\" \"Aqua\" \"Aquamarine\" \"Azure\" \"Beige\" \"Bisque\"\n \"Black\" \"BlanchedAlmond\" \"Blue\" \"BlueViolet\" \"Brown\" \"BurlyWood\" \"CadetBlue\"\n \"Chartreuse\" \"Chocolate\" \"Coral\" \"CornflowerBlue\" \"Cornsilk\" \"Crimson\" \"Cyan\"\n \"DarkBlue\" \"DarkCyan\" \"DarkGoldenRod\" \"DarkGray\" \"DarkGrey\" \"DarkGreen\"\n \"DarkKhaki\" \"DarkMagenta\" \"DarkOliveGreen\" \"DarkOrange\" \"DarkOrchid\" \"DarkRed\"\n \"DarkSalmon\" \"DarkSeaGreen\" \"DarkSlateBlue\" \"DarkSlateGray\" \"DarkSlateGrey\"\n \"DarkTurquoise\" \"DarkViolet\" \"DeepPink\" \"DeepSkyBlue\" \"DimGray\" \"DimGrey\"\n \"DodgerBlue\" \"FireBrick\" \"FloralWhite\" \"ForestGreen\" \"Fuchsia\" \"Gainsboro\"\n \"GhostWhite\" \"Gold\" \"GoldenRod\" \"Gray\" \"Grey\" \"Green\" \"GreenYellow\" \"HoneyDew\"\n \"HotPink\" \"IndianRed\" \"Indigo\" \"Ivory\" \"Khaki\" \"Lavender\" \"LavenderBlush\"\n \"LawnGreen\" \"LemonChiffon\" \"LightBlue\" \"LightCoral\" \"LightCyan\"\n \"LightGoldenRodYellow\" \"LightGray\" \"LightGrey\" \"LightGreen\" \"LightPink\"\n \"LightSalmon\" \"LightSeaGreen\" \"LightSkyBlue\" \"LightSlateGray\" \"LightSlateGrey\"\n \"LightSteelBlue\" \"LightYellow\" \"Lime\" \"LimeGreen\" \"Linen\" \"Magenta\" \"Maroon\"\n \"MediumAquaMarine\" \"MediumBlue\" \"MediumOrchid\" \"MediumPurple\" \"MediumSeaGreen\"\n \"MediumSlateBlue\" \"MediumSpringGreen\" \"MediumTurquoise\" \"MediumVioletRed\"\n \"MidnightBlue\" \"MintCream\" \"MistyRose\" \"Moccasin\" \"NavajoWhite\" \"Navy\" \"OldLace\"\n \"Olive\" \"OliveDrab\" \"Orange\" \"OrangeRed\" \"Orchid\" \"PaleGoldenRod\" \"PaleGreen\"\n \"PaleTurquoise\" \"PaleVioletRed\" \"PapayaWhip\" \"PeachPuff\" \"Peru\" \"Pink\" \"Plum\"\n \"PowderBlue\" \"Purple\" \"RebeccaPurple\" \"Red\" \"RosyBrown\" \"RoyalBlue\"\n \"SaddleBrown\" \"Salmon\" \"SandyBrown\" \"SeaGreen\" \"SeaShell\" \"Sienna\" \"Silver\"\n \"SkyBlue\" \"SlateBlue\" \"SlateGray\" \"SlateGrey\" \"Snow\" \"SpringGreen\" \"SteelBlue\"\n \"Tan\" \"Teal\" \"Thistle\" \"Tomato\" \"Turquoise\" \"Violet\" \"Wheat\" \"White\"\n \"WhiteSmoke\" \"Yellow\" \"YellowGreen\")\n \"All the named CSS colors to construct `color-source' from.\")\n\n(defvar copy-actions\n (list (lambda-command copy-as-hex* (colors)\n \"Copy the color as hex #XXXXXX string.\"\n (let ((hex (cl-colors-ng:print-hex (first colors))))\n (ffi-buffer-copy (current-buffer) hex)\n (echo \"~s copied to clipboard.\" hex)))\n (lambda-command copy-as-rgb* (colors)\n \"Copy the color as CSS rgb() function string.\"\n (let ((rgb (cl-colors-ng:print-css-rgb/a (first colors))))\n (ffi-buffer-copy (current-buffer) rgb)\n (echo \"Copied ~a to clipboard!\" rgb)))\n (lambda-command copy-as-hsl* (colors)\n \"Copy the color as CSS hsl() function string.\"\n (let ((hsl (cl-colors-ng:print-css-hsl (first colors))))\n (ffi-buffer-copy (current-buffer) hsl)\n (echo \"Copied ~a to clipboard!\" hsl)))))\n\n(export-always 'color-source)\n(define-class color-source (prompter:source)\n ((prompter:name \"Color\")\n (prompter:constructor *css-colors*)\n (prompter:filter-preprocessor #'prompter:filter-exact-matches)\n (prompter:filter-postprocessor\n (lambda (suggestions source input-color)\n (unless (str:empty? input-color) (sleep 0.2))\n (append (when (ignore-errors (cl-colors-ng:as-rgb input-color))\n (list (make-instance 'prompter:suggestion\n :value input-color\n :attributes (prompter:object-attributes input-color source))))\n suggestions)))\n (prompter:actions-on-current-suggestion-enabled-p t)\n (prompter:actions-on-return\n (cons #'identity copy-actions)))\n (:documentation \"A source for color search and copying.\nAllows looking through the colors based on their names, HEX values, and\nrgb()/hsl() CSS functions representing them.\"))\n\n(defmethod prompter:object-attributes ((color string) (source color-source))\n `((\"Color\" ,color)\n (\"HEX\" ,(cl-colors-ng:print-hex color))\n (\"RGB\" ,(cl-colors-ng:print-css-rgb/a color))))\n\n(define-command-global pick-color ()\n \"Pick a color and copy it to clipboard.\nThe current color is previewed in the prompt buffer's input area.\n\nColor can be entered as:\n- CSS color name: \\\"PapayaWhip\\\" (capitalization is optional.)\n- HEX code: \\\"#37A8E4\\\".\n- HSL and RGB functions inspired by CSS.\"\n (prompt :prompt \"Color\"\n :sources (make-instance 'color-source\n :actions-on-return copy-actions)))\n" }, { "path": "source/command-commands.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :nyxt)\n\n(define-class hook-description ()\n ((name\n \"\"\n :documentation \"The hook name.\")\n (value\n nil\n :documentation \"The hook value.\")))\n\n(defun command-attributes\n (command &optional (buffer (active-buffer (current-window :no-rescan))))\n (let ((command-name (name command)))\n `((\"Name\" ,(string-downcase command-name) (:width 1))\n (\"Bindings\" ,(format nil \"~{~a~^, ~}\"\n (keymaps:pretty-binding-keys\n command-name\n (current-keymaps buffer)\n :print-style (keymaps:name (keyscheme buffer))))\n (:width 1))\n (\"Docstring\" ,(documentation-line command 'function \"\") (:width 4))\n (\"Mode\" ,(let ((package-name (uiop:symbol-package-name command-name)))\n (if (str:starts-with-p \"NYXT/MODE/\" package-name)\n (string-downcase (str:replace-first \"NYXT/MODE/\" \"\"\n package-name))\n \"\"))\n (:width 1)))))\n\n(define-class command-source (prompter:source)\n ((prompter:name \"Commands\")\n (global-p\n t\n :type boolean\n :documentation \"Whether global commands are included in the suggestions.\")\n (buffer\n (current-buffer)\n :type buffer)\n (prompter:constructor\n (lambda (source)\n (sort-by-time\n (list-commands\n :global-p (global-p source)\n :mode-symbols (mapcar #'sera:class-name-of\n (sera:filter #'enabled-p\n (enabled-modes (buffer source))))))))\n (prompter:active-attributes-keys\n '(\"Name\" \"Bindings\" \"Docstring\")\n :accessor nil)\n (prompter:filter-preprocessor #'prompter:filter-exact-matches))\n (:export-class-name-p t)\n (:documentation \"Prompter source to execute commands.\nGlobal commands are listed if `global-p' is non-nil.\nMode commands of enabled modes are also listed.\nWhile disabled-mode commands are not listed, it's still possible to call them\nfrom a key binding.\")\n (:metaclass user-class))\n\n(defmethod predict-next-command ((browser browser))\n (when-let ((prediction (analysis:predict (command-model browser)\n (list (last-command browser)))))\n (analysis:element prediction)))\n\n(define-class predicted-command-source (prompter:source)\n ((prompter:name \"Predicted Command\")\n (prompter:constructor\n (lambda (source)\n (declare (ignore source))\n (list (predict-next-command *browser*))))\n (prompter:filter-preprocessor #'prompter:filter-exact-matches))\n (:export-class-name-p t)\n (:documentation \"Prompter source to predict commands.\")\n (:metaclass user-class))\n\n(define-command execute-predicted-command ()\n \"Execute the predicted next command.\"\n (run-async (predict-next-command *browser*)))\n\n(defmethod prompter:object-attributes\n ((command command) (source prompter:source))\n (declare (ignore source))\n (command-attributes command))\n\n(define-command execute-command ()\n \"Execute a command by name.\n\nAlso accepts arbitrary Lisp expressions (even without the outermost level of\nparentheses), and lists the possible completions for the incomplete symbols,\ntogether with the arglists and documentations of the functions typed in.\"\n (unless (active-prompt-buffers (current-window))\n (prompt\n :prompt \"Execute command\"\n :sources\n (list (make-instance\n 'command-source\n :actions-on-return\n (list (lambda-command run-command* (commands)\n \"Run the chosen command.\"\n (let ((command (first commands)))\n (setf (last-access command) (local-time:now))\n (run-async command)))\n (lambda-command describe-command* (commands)\n \"Show the documentation and properties of this command.\"\n (describe-command :command (name (first commands))))))\n (make-instance\n 'predicted-command-source\n :actions-on-return\n (lambda-command run-command* (commands)\n \"Run the chosen command.\"\n (when-let ((command (first commands)))\n (setf (last-access command) (time:now))\n (run-async command)))))\n :hide-suggestion-count-p t)))\n\n(defun get-hooks ()\n (flet ((list-hooks (object)\n (mapcar (lambda (hook)\n (make-instance\n 'hook-description\n :name (str:downcase (closer-mop:slot-definition-name hook))\n :value (funcall (symbol-function\n (closer-mop:slot-definition-name hook))\n object)))\n (remove-if-not\n (lambda (s)\n (let ((name (closer-mop:slot-definition-name s)))\n (and (str:ends-with-p \"-hook\" (string name)\n :ignore-case t)\n (fboundp name))))\n (closer-mop:class-slots (class-of object))))))\n (let ((window-hooks (list-hooks (current-window)))\n (buffer-hooks (list-hooks (current-buffer)))\n (browser-hooks (list-hooks *browser*)))\n (append window-hooks\n buffer-hooks\n browser-hooks))))\n\n(define-class hook-source (prompter:source)\n ((prompter:name \"Hooks\")\n (prompter:constructor (get-hooks))\n (prompter:actions-on-return (lambda-mapped-command value))))\n\n(defmethod prompter:object-attributes\n ((hook-description hook-description) (source hook-source))\n (declare (ignore source))\n `((\"Name\" ,(name hook-description))))\n\n(define-class handler-source (prompter:source)\n ((prompter:name \"Handlers\")\n (hook\n nil\n :documentation \"The hook for which to retrieve handlers for.\")\n (prompter:constructor (lambda (source) (hooks:handlers (hook source))))))\n\n(defmethod prompter:object-attributes ((handler symbol) (source handler-source))\n (declare (ignore source))\n `((\"Name\" ,(str:downcase (hooks:name handler)))))\n\n(define-class disabled-handler-source (handler-source)\n ((prompter:constructor\n (lambda (source) (hooks:disabled-handlers (hook source))))))\n\n(defun manage-hook-handler (action)\n (let ((hook (prompt1 :prompt \"Hook\"\n :sources 'hook-source)))\n (funcall (case action\n (:enable #'hooks:enable-hook)\n (:disable #'hooks:disable-hook))\n hook\n (prompt1 :prompt \"Handler\"\n :sources (make-instance\n (case action\n (:enable 'disabled-handler-source)\n (:disable 'handler-source))\n :hook hook)))))\n\n(define-command-global disable-hook-handler ()\n \"Remove handler of a hook.\"\n (manage-hook-handler :disable))\n\n(define-command-global enable-hook-handler ()\n \"Add handler of a hook.\"\n (manage-hook-handler :enable))\n" }, { "path": "source/command.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :nyxt)\n\n(defvar *command-list* '()\n \"The list of known commands, for internal use only.\")\n\n(define-class command (standard-generic-function)\n ((visibility\n :mode\n :type (member :global :mode :anonymous)\n :reader t\n :writer nil\n :documentation \"Sets whether command is listed in `command-source'.\n\n- `:global' always lists it. This is mostly useful for third-party packages to\ndefine globally-accessible commands without polluting the official Nyxt\npackages.\n\n- `:mode' lists it when the corresponding mode is active.\n\n- `:anonymous' never lists it.\")\n (last-access\n (time:now)\n :type time:timestamp\n :documentation \"Last time this command was called from prompt buffer.\nUseful to sort the commands by most recent use.\"))\n (:metaclass closer-mop:funcallable-standard-class)\n (:export-class-name-p t)\n (:export-accessor-names-p t)\n (:export-predicate-name-p t)\n (:documentation \"Commands are interactive functions.\n(As in Emacs.)\n\nCommands are funcallable.\n\nWe need a `command' class for multiple reasons:\n- Identify commands uniquely.\n\n- Customize prompt buffer display value with properties.\n\n- Last access: This is useful to sort command by the time they were last\n called. The only way to do this is to persist the command instances.\n\nSince they are generic functions, they can be specialize with `:before',\n`:after' and `:around' qualifiers, effectively acting as hooks.\nThese specializations are reserved to the user.\"))\n\n(defmethod name ((command command))\n \"A useful shortcut.\"\n (closer-mop:generic-function-name command))\n\n(defun initialize-command (command lambda-expression)\n (when (uiop:emptyp (closer-mop:generic-function-name command))\n (alex:required-argument 'name))\n (when lambda-expression\n ;; `closer-mop:ensure-method' calls `add-method' which reinitializes the\n ;; command / generic function, thus running `initialize-command' twice each\n ;; time. TODO: Can we avoid this?\n (closer-mop:ensure-method command lambda-expression)\n (when (uiop:emptyp (documentation command t))\n (let ((doc (nth-value 2 (alex:parse-body (rest (rest lambda-expression)) :documentation t))))\n (if (and (uiop:emptyp doc)\n (not (eq :anonymous (visibility command))))\n (error \"Command ~a requires documentation.\" (name command))\n (setf (documentation command 'function) doc)))))\n (unless (eq :anonymous (visibility command))\n ;; Overwrite previous command:\n (setf *command-list* (delete (closer-mop:generic-function-name command) *command-list*\n :key #'closer-mop:generic-function-name))\n (push command *command-list*)))\n\n(defmethod initialize-instance :after ((command command) &key lambda-expression &allow-other-keys)\n (initialize-command command lambda-expression))\n(defmethod reinitialize-instance :after ((command command) &key lambda-expression &allow-other-keys)\n (initialize-command command lambda-expression))\n\n(defun find-command (name)\n (find name *command-list* :key #'name))\n\n;; TODO: Can we use `alex:named-lambda'? How do we get the name then?\n(export-always 'make-command)\n(defun make-command (name lambda-expression &optional (visibility :anonymous))\n \"Return an non-globally defined command named NAME.\"\n (make-instance 'command :name name\n :lambda-expression lambda-expression\n :visibility visibility))\n\n(export-always 'lambda-command)\n(defmacro lambda-command (name args &body body)\n \"ARGS may only be a list of required arguments (optional and keyword argument\nnot allowed).\n\nExample:\n\n\\(let ((source (make-my-source)))\n (lambda-command open-file* (files)\n \\\"Open files in some way.\\\"\n ;; Note that `source' is captured in the closure.\n (mapc (opener source) files)))\"\n (let ((doc (nth-value 2 (alex:parse-body body :documentation t))))\n (alex:with-gensyms (closed-over-body)\n ;; Warning: `make-command' takes a lambda-expression as an unevaluated list,\n ;; thus the BODY environment is not that of the lexical environment\n ;; (closures would thus fail to close over). To avoid this problem, we capture\n ;; the lexical environment in a lambda.\n ;;\n ;; Note that this relies on the assumption that ARGS is just a list of\n ;; _required arguments_, which is a same assumption for prompt buffer actions.\n ;; We could remove this limitation with some argument parsing.\n `(let ((,closed-over-body (lambda ,args ,@body)))\n (make-command ',name\n (list 'lambda ',args ,doc (list 'apply ,closed-over-body '(list ,@args))))))))\n\n(export-always 'lambda-mapped-command)\n(defmacro lambda-mapped-command (function-symbol)\n \"Define a command which `mapcar's FUNCTION-SYMBOL over a list of arguments.\"\n (let ((name (intern (str:concat (string function-symbol) \"-*\"))))\n `(lambda-command ,name (arg-list)\n ,(documentation function-symbol 'function)\n (mapcar ',function-symbol arg-list))))\n\n(export-always 'lambda-unmapped-command)\n(defmacro lambda-unmapped-command (function-symbol)\n \"Define a command which calls FUNCTION-SYMBOL over the first element of a list\nof arguments.\"\n (let ((name (intern (str:concat (string function-symbol) \"-1\"))))\n `(lambda-command ,name (arg-list)\n ,(documentation function-symbol 'function)\n (,function-symbol (first arg-list)))))\n\n(eval-always\n (defun generalize-lambda-list (lambda-list)\n \"Return a lambda-list compatible with generic-function definitions.\nGeneric function lambda lists differ from ordinary lambda list in some ways;\nsee HyperSpec '3.4.2 Generic Function Lambda Lists'.\"\n (multiple-value-bind (required optional rest keywords aok? aux key?)\n (alex:parse-ordinary-lambda-list lambda-list)\n (declare (ignore aux))\n (sera:unparse-ordinary-lambda-list required (mapcar #'first optional) rest (mapcar #'cadar keywords) aok? nil key?))))\n\n(export-always 'define-command)\n(defmacro define-command (name (&rest arglist) &body body)\n \"Define new command NAME.\n`define-command' syntax is similar to `defmethod'.\n\nExample:\n\n\\(define-command play-video-in-current-page (&optional (buffer (current-buffer)))\n \\\"Play video in the currently open buffer.\\\"\n (uiop:run-program (list \\\"mpv\\\" (render-url (url buffer)))))\"\n (let ((doc (or (nth-value 2 (alex:parse-body body :documentation t)) \"\")))\n `(progn\n (export-always ',name (symbol-package ',name))\n ;; Warning: We use `defgeneric' instead of `make-instance' (or even\n ;; `ensure-generic-function') so that the compiler stores source location\n ;; information (for \"go to definition\" to work).\n (sera:lret ((gf (defgeneric ,name (,@(generalize-lambda-list arglist))\n (:documentation ,doc)\n (:method (,@arglist) ,@body)\n (:generic-function-class command))))\n (setf (slot-value gf 'visibility) :mode)))))\n\n(export-always 'define-command-global)\n(defmacro define-command-global (name (&rest arglist) &body body)\n \"Like `define-command' but mark the command as global.\nThis means it will be listed in `command-source' when the global option is on.\nThis is mostly useful for third-party packages to define globally-accessible\ncommands without polluting Nyxt packages.\"\n `(sera:lret ((cmd (define-command ,name (,@arglist) ,@body)))\n (setf (slot-value cmd 'visibility) :global)))\n\n(export-always 'delete-command)\n(defun delete-command (name)\n \"Remove command NAME, if any.\nAny function or macro definition of NAME is also removed,\nregardless of whether NAME is defined as a command.\"\n (setf *command-list* (delete name *command-list* :key #'name))\n (fmakunbound name))\n\n(-> list-all-maybe-subpackages () (list-of types:package-designator))\n(defun list-all-maybe-subpackages ()\n (remove-if-not (lambda (pkg) (find #\\/ (package-name pkg)))\n (list-all-packages)))\n\n(export-always 'subpackage-p)\n(-> subpackage-p (types:package-designator types:package-designator) (values boolean &optional))\n(defun subpackage-p (subpackage package)\n \"Return non-nil if SUBPACKAGE is a subpackage of PACKAGE or is PACKAGE itself.\nA subpackage has a name that starts with that of PACKAGE followed by a '/' separator.\"\n (or (eq (find-package subpackage) (find-package package))\n (uiop:string-prefix-p (uiop:strcat (package-name package) \"/\")\n (package-name subpackage))))\n\n(export-always 'subpackages)\n(-> subpackages (types:package-designator) (list-of types:package-designator))\n(defun subpackages (package)\n \"Return all subpackages of PACKAGE, including itself.\"\n (append (list package)\n (remove-if-not (lambda (p) (subpackage-p p package))\n (list-all-maybe-subpackages))))\n\n(-> nyxt-subpackage-p (types:package-designator) boolean)\n(defun nyxt-subpackage-p (package)\n \"Return non-nil if PACKAGE is a sub-package of `nyxt'.\"\n (subpackage-p package :nyxt))\n\n(-> nyxt-user-subpackage-p (types:package-designator) boolean)\n(defun nyxt-user-subpackage-p (package)\n \"Return non-nil if PACKAGE is a sub-package of `nyxt' or `nyxt-user'.\"\n (subpackage-p package :nyxt-user))\n\n(defun nyxt-packages ()\n \"Return all Nyxt packages.\nSee also `nyxt-user-packages', `nyxt-extension-packages' and `non-nyxt-packages'.\"\n (sera:filter #'nyxt-subpackage-p (list-all-packages)))\n\n(defun nyxt-user-packages ()\n \"Return all Nyxt user packages.\"\n (sera:filter #'nyxt-user-subpackage-p (list-all-packages)))\n\n(defun nyxt-extension-packages ()\n \"Return all the Nyxt extension packages.\nA package is considered an extension one if its name is \\\"nx-\\\"-prefixed.\"\n (remove-if-not (curry #'str:starts-with-p \"NX-\") (list-all-packages)\n :key #'package-name))\n\n(defun non-nyxt-packages ()\n \"Return the packages that are not related to Nyxt.\nIt's the complement of `nyxt-packages' and `nyxt-user-packages'.\"\n (set-difference (list-all-packages)\n (append (nyxt-packages) (nyxt-user-packages))))\n\n(define-class slot ()\n ((name nil\n :type (or symbol null))\n (class-sym nil\n :type (or symbol null))))\n\n(defun class-slots (class-sym &key (visibility :any))\n \"Return the list of slots with VISIBILITY.\"\n (sym:filter-symbols visibility (mopu:slot-names class-sym)))\n\n(defmethod prompter:object-attributes ((slot slot) (source prompter:source))\n (declare (ignore source))\n `((\"Name\" ,(string (name slot)))\n (\"Class\" ,(string (class-sym slot)))))\n\n(defun package-slots (packages &optional (visibility :any))\n \"Return the list of all slot symbols in PACKAGES.\nSee `sym:package-symbols'.\"\n (mappend (lambda (class-sym)\n (mapcar (lambda (slot) (make-instance 'slot\n :name slot\n :class-sym class-sym))\n (class-slots class-sym :visibility visibility)))\n (sym:package-classes packages)))\n\n(sym:define-symbol-type command (function)\n (command-p (ignore-errors (symbol-function sym:%symbol%))))\n\n(defun list-commands (&key global-p mode-symbols)\n \"List commands.\nCommands are instances of the `command' class.\nWhen MODE-SYMBOLS are provided, list only the commands that belong to the\ncorresponding mode packages or of a parent mode packages. Otherwise list all\ncommands. Additionally, list all commands within the Nyxt package.\nWith MODE-SYMBOLS and GLOBAL-P, include global commands.\"\n ;; TODO: Make sure we list commands of inherited modes.\n (if mode-symbols\n (lpara:premove-if\n (lambda (command)\n (and (or (not global-p)\n (not (eq :global (visibility command))))\n (notany\n (lambda (mode-symbol)\n (or (eq (symbol-package (name command))\n (symbol-package mode-symbol))\n (member\n (symbol-package (name command))\n (mapcar #'symbol-package\n (sera:filter (symbol-function (uiop:safe-read-from-string \"sym:mode-symbol-p\"\n :package :nyxt))\n (mapcar #'class-name (mopu:superclasses mode-symbol)))))))\n mode-symbols)))\n *command-list*)\n *command-list*))\n\n(defun list-mode-commands (mode-symbol)\n \"List commands.\nCommands are instances of the `command' class. Only commands defined within the\ncontext of a mode are listed.\"\n (remove-if-not\n (lambda (command)\n (eq (symbol-package (name command))\n (symbol-package mode-symbol)))\n *command-list*))\n\n(defun run-command (command &optional args)\n ;; Bind current buffer for the duration of the command. This\n ;; way, if the user switches buffer after running a command\n ;; but before command termination, `current-buffer' will\n ;; return the buffer from which the command was invoked.\n (with-current-buffer (current-buffer)\n (handler-case (apply #'funcall command args)\n (prompt-buffer-canceled ()\n (log:debug \"Prompt buffer interrupted\")\n nil))))\n\n(defun run (command &optional args)\n \"Run COMMAND over ARGS and return its result.\nThis is blocking, see `run-async' for an asynchronous way to run commands.\"\n (let ((channel (make-channel 1))\n (error-channel (make-channel 1)))\n (run-thread \"run command\"\n ;; TODO: This `handler-case' overlaps with `with-protect' from `run-thread'. Factor them!\n (handler-case (calispel:! channel (run-command command args))\n (condition (c)\n (calispel:! error-channel c))))\n (calispel:fair-alt\n ((calispel:? channel result)\n result)\n ((calispel:? error-channel c)\n (echo-warning \"Error when running ~a: ~a\" command c)))))\n\n(defun run-async (command &optional args)\n \"Run COMMAND over ARGS asynchronously.\nSee `run' for a way to run commands in a synchronous fashion and return the\nresult.\"\n (run-thread \"run-async command\"\n (run-command command args)))\n\n(define-command nothing () ; TODO: Replace with ESCAPE special command that allows dispatched to cancel current key stack.\n \"A command that does nothing.\nThis is useful to override bindings to do nothing.\"\n (values))\n" }, { "path": "source/concurrency.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :nyxt)\n\n(defun initialize-lparallel-kernel (&key (worker-count (sera:count-cpus)))\n \"Initialize the lparallel kernel with WORKER-COUNT, if not supplied set it to\nthe amount of CPU cores.\"\n (unless lpara:*kernel*\n (setf lpara:*kernel* (lpara:make-kernel worker-count))))\n\n(defun restart-browser (c)\n \"Restart browser reporting condition C.\"\n (funcall 'restart-with-message ; Not defined yet.\n :condition c\n :backtrace (with-output-to-string (stream)\n (uiop:print-backtrace :stream stream :condition c))))\n\n(export-always 'with-protect)\n(defmacro with-protect ((format-string &rest args) &body body)\n \"Run body with muffled conditions when `*run-from-repl-p*' is nil, run normally otherwise.\nWhen the condition is muffled, a warning is reported to the user as per\nFORMAT-STRING and ARGS.\nAs a special case, the first `:condition' keyword in ARGS is replaced with the\nraised condition.\"\n (alex:with-gensyms (c sub-c)\n `(if (or *run-from-repl-p*)\n (handler-case (progn ,@body)\n (prompt-buffer-canceled ()\n (log:debug \"Prompt buffer interrupted\")))\n (ignore-errors\n (handler-bind\n ((error\n (lambda (,c)\n (declare (ignorable ,c))\n (if *restart-on-error*\n (restart-browser ,c)\n ,(let ((condition-index (position :condition args)))\n (flet ((new-args (condition condition-index &optional escaped-p)\n (if condition-index\n (append (subseq args 0 condition-index)\n (list (if escaped-p\n `(plump:encode-entities (princ-to-string ,condition))\n `,condition))\n (subseq args (1+ condition-index)))\n 'args)))\n `(handler-bind ((t (lambda (,sub-c)\n (declare (ignore ,sub-c))\n (log:error ,format-string ,@(new-args c condition-index))\n (invoke-restart 'continue))))\n (echo-warning ,format-string ,@(new-args c condition-index :escaped-p)))))))))\n ,@body)))))\n\n(defun make-channel (&optional size)\n \"Return a channel of capacity SIZE.\nIf SIZE is NIL, capacity is infinite.\"\n (cond\n ((null size)\n (make-instance 'calispel:channel\n :buffer (make-instance 'jpl-queues:unbounded-fifo-queue)))\n ((zerop size)\n (make-instance 'calispel:channel))\n ((plusp size)\n (make-instance 'calispel:channel\n :buffer (make-instance 'jpl-queues:bounded-fifo-queue :capacity size)))))\n\n(defun drain-channel (channel &optional timeout)\n \"Listen to CHANNEL until a value is available, then return all CHANNEL values\nas a list.\nTIMEOUT specifies how long to wait for a value after the first one.\nThis is a blocking operation.\"\n (labels ((fetch ()\n (multiple-value-bind (value received?)\n (calispel:? channel timeout)\n (if received?\n (cons value (fetch))\n nil))))\n (cons (calispel:? channel)\n (nreverse (fetch)))))\n\n(export-always 'run-thread)\n(defmacro run-thread (name &body body)\n \"Run body in a new protected thread.\nThis supersedes `bt:make-thread' in Nyxt. Don't use the latter unless you know\nwhat you are doing!\"\n `(lparallel.thread-util:with-thread (:name ,(str:concat \"Nyxt \" name)\n :bindings (append '((*run-from-repl-p* . *run-from-repl-p*)\n (*headless-p* . *headless-p*))\n bt:*default-special-bindings*))\n (with-protect (\"Error on separate thread: ~a\" :condition)\n ,@body)))\n\n(defun evaluate (string)\n \"Evaluate all expressions in STRING and return the last result as a list of values.\nThe list of values is useful when the last result is multi-valued, e.g. (values 'a 'b).\nYou need not wrap multiple values in a PROGN, all top-level expressions are\nevaluated in order.\"\n (let ((channel (make-channel 2)))\n (run-thread \"evaluator\"\n (let ((*standard-output* (make-string-output-stream)))\n (calispel:!\n channel\n (with-input-from-string (input string)\n (first\n (last\n (mapcar (lambda (s-exp)\n (multiple-value-list\n (with-protect (\"Error in s-exp evaluation: ~a\" :condition)\n (eval s-exp))))\n (safe-slurp-stream-forms input))))))\n (calispel:! channel (get-output-stream-string *standard-output*))))\n (values (calispel:? channel) (calispel:? channel))))\n\n(defun evaluate-async (string)\n \"Like `evaluate' but does not block and does not return the result.\"\n (run-thread \"async evaluator\"\n (with-input-from-string (input string)\n (dolist (s-exp (safe-slurp-stream-forms input))\n (funcall (lambda () (with-protect (\"Error in s-exp evaluation: ~a\" :condition)\n (eval s-exp))))))))\n" }, { "path": "source/conditions.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :nyxt)\n\n(export-always 'nyxt-error)\n(define-condition nyxt-error (error)\n ((message :initarg :message :accessor message))\n (:report (lambda (c stream)\n (format stream \"~a\" (slot-value c 'message))))\n (:documentation \"An error internal to Nyxt.\nIt should abort the ongoing command, but not the whole process.\"))\n\n(export-always 'browser-already-started)\n(define-condition browser-already-started (nyxt-error)\n ()\n (:documentation \"An existing instance of Nyxt is already running.\"))\n\n(export-always 'prompt-buffer-canceled)\n(define-condition prompt-buffer-canceled (error)\n ()\n (:documentation \"Signaled when prompt buffer is exited abnormally (via ESC key, for example).\"))\n" }, { "path": "source/configuration-commands.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :nyxt)\n\n(defun error-in-new-window (title condition-string backtrace)\n (sera:lret* ((window (window-make *browser*))\n (error-buffer (make-instance 'document-buffer)))\n (with-current-buffer error-buffer\n (html-set\n (values\n (spinneret:with-html-string\n (:head\n (:title title)\n (:nstyle (style (current-buffer))))\n (:body\n (:h1 title)\n (:h2 \"Condition\")\n (:pre condition-string)\n (:h2 \"Backtrace\")\n (:pre backtrace)))\n \"text/html;charset=utf8\")\n error-buffer))\n (ffi-window-set-buffer window error-buffer)))\n\n(-> load-lisp\n ((or null types:pathname-designator) &key (:package (or null package)))\n *)\n(defun load-lisp (file &key package)\n \"Load the Lisp FILE (can also be a stream).\nReturn T on success.\nOn error, return the condition as a first value and the backtrace as second value.\"\n (unless (files:nil-pathname-p file)\n (let ((*package* (or (find-package package) *package*)))\n (flet ((unsafe-load ()\n (cond\n ((streamp file)\n (load file))\n ((uiop:file-exists-p file)\n (log:info \"Loading Lisp file ~s.\" file)\n (load file))\n (t\n (log:debug \"Lisp file ~s does not exist.\" file)))\n nil))\n (if *run-from-repl-p*\n (tagbody\n loop\n (restart-case (unsafe-load)\n (load-lisp-retry ()\n :report \"Retry loading Lisp file.\"\n (go loop))))\n (catch 'lisp-file-error\n (handler-bind ((error (lambda (c)\n (let ((backtrace (with-output-to-string (stream)\n (uiop:print-backtrace :stream stream :condition c))))\n (throw 'lisp-file-error\n (if *browser*\n (error-in-new-window \"*Config file errors*\" (princ-to-string c) backtrace)\n (values c backtrace)))))))\n (unsafe-load))))))))\n\n(define-command load-file ()\n \"Load the prompted Lisp file.\"\n (prompt :prompt \"Load file\"\n :input (uiop:native-namestring\n (let ((config-path (files:expand *config-file*)))\n (if (uiop:file-exists-p config-path)\n (uiop:pathname-directory-pathname config-path)\n (uiop:getcwd))))\n :extra-modes 'nyxt/mode/file-manager:file-manager-mode\n :sources\n (make-instance 'nyxt/mode/file-manager:file-source\n :extensions '(\"lisp\")\n :actions-on-return (lambda-command load-file* (files)\n (dolist (file files)\n (load-lisp file))))))\n\n(export-always 'clean-configuration)\n(defun clean-configuration ()\n \"Undo user configuration set by `define-configuration' or `customize-instance'.\"\n (dolist (class (sera:filter #'user-class-p (sym:package-classes* (nyxt-packages))))\n (setf (hooks:handlers-alist (slot-value class 'customize-hook)) nil))\n (dolist (method (mopu:generic-function-methods #'customize-instance))\n (unless (or (equal (list (find-class t)) ; Don't remove default method.\n (mopu:method-specializers method))\n ;; We only preserve :after methods for ourselves.\n (equal (list :after) (method-qualifiers method))))))\n\n(define-command load-config-file (&key (config-file (files:expand *config-file*)))\n \"Load or reload the CONFIG-FILE.\"\n (if (files:nil-pathname-p config-file)\n (echo \"No config file.\")\n (progn\n (clean-configuration)\n (load-lisp config-file :package (find-package :nyxt-user))\n (echo \"~a loaded.\" config-file))))\n\n#+(and unix (not darwin))\n(define-command add-desktop-entry ()\n \"Install the running AppImage to the system menu via a `.desktop' entry.\nThe path installed to is `~/.local/share/applications/'.\"\n (let* ((appimage-path (uiop:getenv \"APPIMAGE_PATH\"))\n (desktop-entry-dir \"~/.local/share/applications/\")\n (icons-dir \"~/.local/share/icons/hicolor/\")\n (desktop-entry-path (uiop:merge-pathnames*\n (make-pathname :name \"nyxt.desktop\")\n desktop-entry-dir)))\n (ensure-directories-exist desktop-entry-dir)\n (uiop:with-output-file (stream desktop-entry-path :if-exists :supersede)\n (format stream (gethash \"nyxt.desktop\" *static-data*) appimage-path))\n (loop for resolution in '(\"16x16\" \"32x32\" \"128x128\" \"256x256\")\n do (let* ((icon (gethash (format nil \"nyxt_~a.png\" resolution)\n *static-data*))\n (icon-dir (uiop:merge-pathnames*\n (format nil \"~a/apps/\" resolution) icons-dir))\n (icon-path\n (uiop:merge-pathnames* \"nyxt.png\" icon-dir)))\n (ensure-directories-exist icon-dir)\n (uiop:with-output-file (stream icon-path :element-type\n '(unsigned-byte 8)\n :if-exists :supersede)\n (write-sequence icon stream))))\n (uiop:launch-program \"update-desktop-database\")\n (echo \"Added Nyxt to the system menu.~%\")))\n" }, { "path": "source/configuration.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :nyxt)\n\n(define-class config-directory-file (files:config-file nyxt-file)\n ((files:base-path #p\"\"))\n (:export-class-name-p t)\n (:documentation \"Nyxt directory for config files.\"))\n\n(define-class config-special-file (config-directory-file)\n ((files:base-path #p\"\")\n (command-line-option :config\n :accessor nil\n :type keyword))\n (:export-class-name-p t)\n (:documentation \"Like `config-directory-file' but can be controlled from command line options.\"))\n\n(define-class config-file (config-special-file nyxt-lisp-file)\n ((files:base-path #p\"config\")\n (command-line-option :config\n :accessor nil\n :type keyword))\n (:export-class-name-p t)\n (:documentation \"Lisp configuration file which path can be controlled from command line options.\nUnlike `auto-config-file', it can only be loaded with `cl:load', it is not meant to be read with\n`nfiles:read-file' or `nfiles:content'.\"))\n\n(defmethod files:read-file ((profile nyxt-profile) (file config-file) &key)\n \"Don't load anything for `config-file's since they are Lisp file to be loaded with `cl:load'.\"\n nil)\n\n(define-class auto-config-file (config-special-file nyxt-lisp-file)\n ((files:base-path (files:join #p\"auto-config.\" (princ-to-string (version))))\n (command-line-option :auto-config\n :accessor nil\n :type keyword))\n (:export-class-name-p t)\n (:documentation \"Lisp configuration file which path can be controlled from command line options.\nUnlike `config-file', it can both loaded with `cl:load' and read with\n`nfiles:read-file'. The latter should return a structured reification of the configuration.\"))\n\n(defmethod files:resolve ((profile nyxt-profile) (config-file config-special-file))\n (let* ((option (slot-value config-file 'command-line-option))\n (no-option (alex:make-keyword\n (uiop:strcat \"NO-\" (symbol-name option)))))\n (if (getf *options* no-option)\n #p\"\"\n (let ((path (or (uiop:ensure-pathname (getf *options* option))\n (call-next-method))))\n (unless (uiop:emptyp path)\n (when (and (getf *options* option) (not (uiop:file-exists-p path)))\n (log:warn \"File ~s does not exist.\" path))\n path)))))\n\n(export-always '*auto-config-file*)\n(defvar *auto-config-file* (make-instance 'auto-config-file)\n \"The generated configuration file.\")\n\n(export-always '*config-file*)\n(defvar *config-file* (make-instance 'config-file)\n \"The configuration file entry point.\")\n\n(define-class log-file (files:data-file nyxt-file)\n ((files:base-path #p\"nyxt.log\")\n (files:name \"log-file\"))\n (:export-class-name-p t)\n (:documentation \"Data file for Nyxt logs.\"))\n\n(export-always '*log-file*)\n(defvar *log-file* (make-instance 'log-file)\n \"Path to the file where log is saved.\nThis is global because logging starts before the `*browser*' is even initialized.\")\n\n(defvar *log-pattern* \"<%p> [%D{%H:%M:%S}] %m%n\"\n \"Non-verbose log pattern.\")\n\n(define-class nyxt-source-directory (nyxt-file)\n ((files:name \"source\"))\n (:export-class-name-p t)\n (:documentation \"Directory with Nyxt sources.\"))\n\n(defmethod files:resolve ((profile nyxt-profile) (directory nyxt-source-directory))\n \"Try hard to find Nyxt source on disk.\nReturn #p\\\"\\\" if not found.\"\n (let ((asd-path (ignore-errors (asdf:system-source-directory :nyxt))))\n (if (uiop:directory-exists-p asd-path)\n asd-path\n (or\n ;; XDG / FHS:\n (find-if (lambda (d)\n (uiop:file-exists-p (uiop:merge-pathnames* \"nyxt.asd\" d)))\n (uiop:xdg-data-dirs \"nyxt\"))\n ;; Location relative to the binary:\n (let ((relative-dir (uiop:merge-pathnames*\n \"share/nyxt/\"\n (files:parent\n (files:parent\n (uiop:ensure-pathname\n (first (uiop:raw-command-line-arguments)) :truenamize t))))))\n (when (uiop:file-exists-p (uiop:merge-pathnames* \"nyxt.asd\" relative-dir))\n relative-dir))\n ;; Not found:\n #p\"\"))))\n\n(export-always '*source-directory*)\n(defvar *source-directory* (make-instance 'nyxt-source-directory)\n \"The directory where the source code is stored.\nThis is set globally so that it can be looked up if there is no\n`*browser*' instance.\")\n\n(define-class extensions-directory (files:data-file nyxt-file)\n ((files:base-path #p\"extensions/\")\n (files:name \"extensions\"))\n (:export-class-name-p t)\n (:documentation \"Nyxt data subdirectory for Lisp extensions.\"))\n\n(export-always '*extensions-directory*)\n(defvar *extensions-directory* (make-instance 'extensions-directory)\n \"The directory where extensions are stored.\nThis is set globally so that extensions can be loaded even if there is no\n`*browser*' instance.\")\n\n(export-always 'nyxt-source-registry)\n(defun nyxt-source-registry ()\n \"Return Nyxt-specific ASDF registry, with source and extension directories.\"\n (let ((source-dir (files:expand *source-directory*)))\n `(:source-registry\n (:tree ,(files:expand *extensions-directory*))\n ,@(unless (uiop:absolute-pathname-p source-dir)\n `((:tree ,source-dir))) ; Probably useless since systems are immutable.\n :inherit-configuration)))\n\n(defun set-nyxt-source-location (pathname) ; From `sb-ext:set-sbcl-source-location'.\n \"Initialize the NYXT logical host based on PATHNAME, which should be the\ntop-level directory of the Nyxt sources. This will replace any existing\ntranslations for \\\"NYXT:source;\\\" and \\\"NYXT:libraries;\\\". Other \\\"NYXT:\\\"\ntranslations are preserved.\"\n (let ((truename (truename pathname))\n (current-translations\n (remove-if (lambda (translation)\n (or (pathname-match-p \"NYXT:source;\" translation)\n (pathname-match-p \"NYXT:libraries;\" translation)))\n (logical-pathname-translations \"NYXT\")\n :key #'first)))\n (flet ((physical-target (component)\n (merge-pathnames\n (make-pathname :directory (list :relative component\n :wild-inferiors)\n :name :wild\n :type :wild)\n truename)))\n (setf (logical-pathname-translations \"NYXT\")\n `((\"NYXT:source;**;*.*.*\" ,(physical-target \"source\"))\n (\"NYXT:libraries;**;*.*.*\" ,(physical-target \"libraries\"))\n ,@current-translations)))))\n\n(define-class slot-form ()\n ((name\n nil\n :type symbol)\n (value\n nil\n :type t))\n (:export-class-name-p t)\n (:documentation \"A form to set slot with `name' to `value'.\"))\n\n(define-class class-form ()\n ((class-name\n nil\n :type symbol)\n (forms\n '()\n :type (maybe (cons (or cons slot-form) *))))\n (:export-class-name-p t)\n (:documentation \"A set of `forms' for class configuration.\"))\n\n(defun read-init-form-slot (class-name sexp)\n \"Return 2 values:\n- the slot name;\n- the slot value.\nReturn NIL if not a slot setting.\"\n (when (and (= 3 (length sexp))\n (eq (first sexp) 'setf)\n (eq (first (second sexp)) 'slot-value)\n (eq (second (second sexp)) class-name))\n (let ((slot-name (second (third (second sexp))))\n (slot-value (third sexp)))\n (values slot-name slot-value))))\n\n(defun write-init-form-slot (class-name slot-form)\n `(setf (slot-value ,class-name ',(name slot-form)) ,(value slot-form)))\n\n(defun read-init-form-class (form)\n \"Return:\n- the class name\n- the list of forms, either `slot-form' or a raw s-exp.\nReturn NIL if not a class form.\"\n (when-let ((class-name (when (and (eq (first form) 'defmethod)\n (eq (second form) 'customize-instance))\n (second (first (find-if #'consp form))))))\n (let ((body (alex:parse-body (sera:nlet lp ((sexp form))\n (if (consp (first sexp))\n (rest sexp)\n (lp (rest sexp))))\n :documentation t)))\n (values class-name\n (mapcar (lambda (sexp)\n (multiple-value-bind (name value)\n (read-init-form-slot class-name sexp)\n (if name\n (make-instance 'slot-form\n :name name\n :value value)\n sexp)))\n body)))))\n\n(defun write-init-form-class (class-form)\n `(defmethod customize-instance ((,(class-name class-form) ,(class-name class-form)) &key)\n ,@(mapcar (lambda (form)\n (if (slot-form-p form)\n (write-init-form-slot (class-name class-form) form)\n form))\n (forms class-form))))\n\n;; TODO: Instantiate directly in read-init-*?\n(defmethod files:deserialize ((profile nyxt-profile) (file auto-config-file) raw-content &key)\n (flet ((make-init-form (form)\n (multiple-value-bind (name forms)\n (read-init-form-class form)\n (if name\n (make-instance 'class-form\n :class-name name\n :forms forms)\n form))))\n (mapcar #'make-init-form\n (uiop:slurp-stream-forms raw-content))))\n\n(defmethod files:serialize ((profile nyxt-profile) (file auto-config-file) stream &key)\n (loop for form in (files:content file)\n for i from 0\n do (when (> i 0) (terpri stream))\n (write\n (if (class-form-p form)\n (write-init-form-class form)\n form)\n :stream stream)\n (fresh-line stream)))\n\n(defmethod files:write-file ((profile nyxt-profile) (file auto-config-file) &key &allow-other-keys)\n (let ((*print-case* :downcase)\n (*package* (find-package :nyxt-user)))\n (log:info \"Writing auto configuration to ~s.\" (files:expand file))\n (call-next-method)))\n\n(defun auto-configure (&key form class-name slot (slot-value nil slot-value-supplied-p))\n (files:with-file-content (config *auto-config-file*)\n (if class-name\n (flet ((ensure-class-form (class-name)\n (or (when config\n (find-if (sera:eqs class-name) (sera:filter #'class-form-p config) :key #'class-name))\n (sera:lret ((form (make-instance 'class-form :class-name class-name)))\n (alex:appendf config (list form)))))\n (ensure-slot-form (class-form slot)\n (or (find-if (sera:eqs slot) (sera:filter #'slot-form-p (forms class-form)) :key #'name)\n (sera:lret ((form (make-instance 'slot-form :name slot)))\n (alex:appendf (forms class-form) (list form)))))\n (delete-slot-form (class-form slot)\n (delete-if (sera:eqs slot) (sera:filter #'slot-form-p (forms class-form)) :key #'name)))\n (let ((class-form (ensure-class-form class-name)))\n (if slot\n (if slot-value-supplied-p\n (sera:lret ((slot-form (ensure-slot-form class-form slot)))\n (setf (value slot-form) slot-value))\n (setf (forms class-form) (delete-slot-form class-form slot)))\n (alex:appendf (forms class-form) (list form)))))\n (alex:appendf config (list form))))\n (echo \"Updated configuration in ~s.\" (files:expand *auto-config-file*)))\n\n(export-always '%slot-value%)\n(defvar %slot-value% nil\n \"Holds the value of the slot being configured when in `define-configuration'.\")\n\n(export-always '%slot-default%)\n(defvar %slot-default% nil\n \"Holds the default value of the slot being configured when in `define-configuration'.\")\n\n(export-always 'define-configuration)\n(defmacro define-configuration (classes &body slots-and-values)\n \"Helper macro to customize the class slots of the CLASSES.\n\nCLASSES is either a symbol or a list of symbols. Only user-configurable classes\nare valid, such as `browser', `buffer', `prompt-buffer', `window' or modes such\nas `nyxt/mode/hint:hint-mode'.\n\nSLOTS-AND-VALUES is a list of slot re-definitions, optionally preceded by a\ndocstring. The `%slot-default%' variable is replaced by the slot's initform,\nwhile `%slot-value%' is replaced by the slot's current value .\n\nExample:\n\n\\(define-configuration web-buffer\n ((default-modes (pushnew 'nyxt/mode/force-https:force-https-mode %slot-value%))))\n\nExample to get the `blocker-mode' command to use a new default hostlists:\n\n\\(define-configuration nyxt/mode/blocker:blocker-mode\n ((nyxt/mode/blocker:hostlists (append (list *my-blocked-hosts*) %slot-default%)\n :doc \\\"You have to define *my-blocked-hosts* first.\\\")))\n\nTo discover the default value of a slot or all slots of a class, use the\n`describe-slot' or `describe-class' commands, respectively.\"\n (alex:with-gensyms (handler hook)\n `(progn\n ,@(loop\n ;; Strip off the docstring, it's merely cosmetic\n with slots-and-values = (if (stringp (first slots-and-values))\n (rest slots-and-values)\n slots-and-values)\n for class-name in (uiop:ensure-list classes)\n ;; NOTE: `or' here because `sym:resolve-symbol' only searches through\n ;; Nyxt packages, while one may try to configure the\n ;; extension/application-specific class too. If `sym:resolve-symbol'\n ;; fails, then hope that `find-class' will either work or highlight\n ;; the problem.\n for class = (resolve-user-symbol class-name :class)\n append (loop for ((slot-name value . rest)) on (first slots-and-values)\n ;; FIXME: It's alarming that we resolve the slot name at\n ;; compile-time instead of run-time. Move to the handler\n ;; body maybe?\n for slot = (find (symbol-name slot-name) (mopu:slot-names class)\n :key #'symbol-name :test #'equal)\n ;; TODO: Shall we really make the name unique? Since we\n ;; are configuring slots, maybe not.\n for handler-name = (gensym (format nil \"CONFIGURE-~a-~a\" class slot))\n when slot\n collect\n `(let ((,hook (slot-value (find-class (quote ,class)) 'nyxt::customize-hook))\n (,handler (make-instance\n 'hooks:handler\n :fn (lambda (object)\n ,@(when (or (getf rest :documentation)\n (getf rest :doc))\n (list (or (getf rest :documentation)\n (getf rest :doc))))\n (declare (ignorable object))\n (setf (slot-value object (quote ,slot))\n (let* ((%slot-value% (slot-value object (quote ,slot)))\n (%slot-default%\n ,(if (c2mop:class-finalized-p (find-class class))\n (getf (mopu:slot-properties class slot) :initform)\n (progn\n (echo-warning\n \"Slot default not found for slot ~a of class ~a, falling back to its current value\"\n slot class)\n '%slot-value%))))\n (declare (ignorable %slot-value% %slot-default%))\n ,value)))\n :name (quote ,handler-name))))\n (hooks:add-hook ,hook ,handler :append t))\n else\n do (log:warn \"Not found slot ~a in class ~a, generating the wrapper method for configuration.\"\n slot-name class)\n and collect `(handler-bind ((warning #'muffle-warning))\n (defmethod ,slot-name :around ((object ,class))\n (let* ((%slot-value% (call-next-method))\n (%slot-default% %slot-value%))\n ,value))))))))\n\n\n(defparameter %buffer nil) ; TODO: Make a monad?\n\n(export-always 'current-buffer)\n(defun current-buffer (&optional window)\n \"Get the active buffer for WINDOW, or the active window otherwise.\"\n (or %buffer\n (if-let ((w (or window (current-window))))\n (active-buffer w)\n (when *browser*\n (log:debug \"No active window, picking last active buffer.\")\n (last-active-buffer)))))\n\n(export-always 'with-current-buffer)\n(defmacro with-current-buffer (buffer &body body)\n \"Execute BODY in a context in which `current-buffer' returns BUFFER.\"\n ;; We `unwind-protect' to restore the right buffer when nesting this macro.\n `(let ((old-%buffer %buffer))\n (if (buffer-p ,buffer)\n (unwind-protect\n (let ((%buffer ,buffer))\n ,@body)\n (setf %buffer old-%buffer))\n ;; TODO: Raise error instead?\n (log:warn \"Expected buffer, got ~a\" ,buffer))))\n\n;; TODO: Disallow canceling the prompt? Allow changing order of YES and NO so\n;; that one makes a conscious effort to choose a YES?\n;; TODO: Add an \"always (yes|no)\" answers/clauses and do something with those?\n;; - Remembering prompt answers in history.\n;; - Serializing thing (like notification permissions) to disk.\n;; - Or simply leaving the interpretation of this clause to the user.\n;; But maybe that's beyond if-confirm.\n(export-always 'if-confirm)\n(defmacro if-confirm ((prompt &key (yes \"yes\" yes-supplied-p) (no \"no\" no-supplied-p))\n &optional (yes-form t) no-form)\n \"Ask the user for confirmation before executing either YES-FORM or NO-FORM.\nYES-FORM is executed on YES answer, NO-FORM -- otherwise (including NO and\nprompt cancellation).\nPROMPT should evaluate to a string.\n\nExamples:\n\n;; Return t/nil on user decision.\n\\(if-confirm (\\\"you agree?\\\"))\n\n;; Customize the yes/no answers, and get the mood of the user as boolean.\n\\(if-confirm ((format nil \\\"How are you?\\\") :yes \\\"Good!\\\" :no \\\"Don't even ask...\\\"))\n\n;; Commit an action in case of yes, clean up on no\n\\(if-confirm (\\\"Overwrite the file?\\\" :no \\\"cancel\\\")\n (overwrite-file-because-confirmed)\n (clean-up/abort/stop))\"\n `(let ((answer (handler-case\n (prompt1\n :prompt ,prompt\n :sources (make-instance 'prompter:yes-no-source\n ,@(when yes-supplied-p\n (list :yes yes))\n ,@(when no-supplied-p\n (list :no no)))\n :hide-suggestion-count-p t)\n (prompt-buffer-canceled () nil))))\n (if answer\n ,yes-form\n ,no-form)))\n\n(defun set-as-default-browser (&key (name \"nyxt\")\n (targets\n (list (uiop:xdg-config-home \"mimeapps.list\")\n (uiop:xdg-data-home \"applications/mimeapps.list\"))))\n \"Return the modified MIME apps list.\nReturn the persisted file as second value.\"\n (declare (ignorable name targets))\n #+(and unix (not darwin))\n (let* ((target (or (first (sera:filter #'uiop:file-exists-p targets))\n (first targets)))\n (config (py-configparser:read-files (py-configparser:make-config)\n (list target)))\n (desktop-file (uiop:strcat name \".desktop\")))\n (dolist (section '(\"Added Associations\" \"Default Applications\"))\n (dolist (key '(\"text/html\"\n \"text/gemini\"\n \"x-scheme-handler/http\"\n \"x-scheme-handler/https\"\n \"x-scheme-handler/chrome\"\n \"application/x-extension-htm\"\n \"application/x-extension-html\"\n \"application/x-extension-shtml\"\n \"application/xhtml+xml\"\n \"application/x-extension-xhtml\"\n \"application/x-extension-xht\"))\n (py-configparser:set-option config section key desktop-file)))\n (with-open-file (s target\n :direction :output\n :if-does-not-exist :create\n :if-exists :supersede)\n (py-configparser:write-stream config s))\n\n (values config target))\n #-(and unix (not darwin))\n (log:warn \"Only supported on GNU / BSD systems running XDG-compatible desktop environments.\"))\n\n\n;; TODO: Report compilation errors.\n\n(export-always 'nyxt-user-system)\n(defclass nyxt-user-system (asdf:system)\n ;; We cannot use :pathname because ASDF forces its value.\n ((config-directory\n :initarg :config-directory\n :initform nil\n :accessor config-directory))\n (:documentation \"Specialized systems for Nyxt users.\nThis automatically defaults :pathname to the `*config-file*' directory unless\noverridden by the `:config-directory' option.\nSee `define-nyxt-user-system' and `define-nyxt-user-system-and-load'.\"))\n\n(defvar *nyxt-user-systems-with-missing-dependencies* '())\n\n(defmethod asdf:component-pathname ((system nyxt-user-system))\n \"Default to `config-directory-file'.\"\n (or (config-directory system)\n (files:expand (make-instance 'config-directory-file))) )\n\n(export-always 'load-system*)\n(defun load-system* (system &rest keys &key force force-not verbose version &allow-other-keys)\n \"Like `asdf:load-system' but, instead of signaling an error on missing\ndependency, it warns the user, skips the load gracefully and returns NIL.\n\nWhen loading succeeds, it goes through the list of all the systems that failed\nto load and attempts to load them if their dependencies now seem to be met.\"\n ;; TODO: Ideally we would make this the default behavior of\n ;; `nyxt-user-system' by specializing a method Unfortunately\n ;; `resolve-dependency-name' is a function and `find-component' is called\n ;; against the `depends-on' element but not the system itself.\n (declare (ignore force force-not verbose version))\n (block done\n (flet ((report (c)\n (pushnew (asdf:coerce-name system) *nyxt-user-systems-with-missing-dependencies*\n :test #'string=)\n (log:warn \"Could not load system ~a: ~a\" system c)\n (return-from done nil)))\n (handler-bind ((asdf:missing-dependency #'report)\n (asdf:missing-dependency-of-version #'report))\n (prog1 (apply #'asdf:load-system system keys)\n (alex:removef *nyxt-user-systems-with-missing-dependencies*\n system\n :test #'string=)\n (dolist (system *nyxt-user-systems-with-missing-dependencies*)\n (when (every (rcurry #'asdf:find-system nil) (asdf:system-depends-on (asdf:find-system system)))\n (log:info \"Load system ~s\" system)\n (load-system* system))))))))\n\n(defun ensure-component (component-designator)\n (if (consp component-designator)\n component-designator\n (list :file (sera:drop-suffix \".lisp\" component-designator :test #'string-equal))))\n\n(asdf:defsystem \"nyxt-user\") ; Dummy parent needs to exist for `define-nyxt-user-system' to define subsystems.\n\n(export-always 'define-nyxt-user-system)\n(defmacro define-nyxt-user-system (name &rest args &key depends-on components\n &allow-other-keys)\n \"Define a user system, usually meant to load configuration files.\nExample to load the \\\"my-slynk-config\\\" file in your configuration directory.\n\n (define-nyxt-user-system nyxt-user/slynk\n :components (\\\"my-slynk-config\\\"))\n (asdf:load-system :nyxt-user/slynk)\n\nSee also `define-nyxt-user-system-and-load'.\n\nIt catches potential load dependency cycles.\n\nArguments are the same as for `asdf:defsystem'.\nFor convenience, we also support `string's or `pathname's directly in COMPONENTS.\nSo instead of\n\n:components `((:file \\\"foo\\\")\n (:file #p\\\"bar\\\"))\n\nyou can write\n\n:components `(\\\"foo\\\" #p\\\"bar\\\")\n\nIt only works for top-level components, so if you introduce a module you'll have\nto use the full syntax.\n\nTo change the base directory, pass the `:config-directory' option.\"\n ;; We specify DEPENDS-ON to emphasize its availability.\n (declare (ignore depends-on))\n (unless (sera:string-prefix-p \"nyxt-user/\" (string name) )\n (error \"User system name must start with 'nyxt-user/'.\"))\n ;; We cannot call `make-instance 'asdf:system' because we need to register the\n ;; system, and `register-system' is unexported.\n `(asdf:defsystem ,name\n :class nyxt-user-system\n ,@(uiop:remove-plist-key :components args)\n :components ,(mapcar #'ensure-component\n components)))\n\n(export-always 'define-nyxt-user-system-and-load)\n(defmacro define-nyxt-user-system-and-load (name &rest args &key depends-on components\n &allow-other-keys)\n \"Like `define-nyxt-user-system' but schedule to load the system when all\nDEPENDS-ON packages are loaded.\nIf they already are, load the system now.\nReturn the system.\"\n ;; We specify DEPENDS-ON and COMPONENTS to emphasize their availability.\n (declare (ignore depends-on components))\n `(prog1 (define-nyxt-user-system ,name ,@args)\n (load-system* ',name)))\n" }, { "path": "source/describe.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(in-package :nyxt)\n\n(defun description-constructor (lister &key (test #'eql))\n \"LISTER is a function that returns a list of symbols or objects representing them\nfrom the given packages. TEST is a function that checks for equality for the purpose of\ndeduplicating the result.\nSee `sym:package-functions' for an example of LISTER.\"\n (lambda (source)\n (delete-duplicates\n (append\n (funcall lister (packages source) (visibility source))\n (funcall lister (internal-visibility-packages source) :internal)\n (funcall lister (external-visibility-packages source) :external)\n (funcall lister (inherited-visibility-packages source) :inherited))\n :test test)))\n\n(define-class describe-nyxt-source (prompter:source)\n ((visibility\n :any\n :type (member :internal :external :inherited :any)\n :documentation \"Include symbol of this visibility from `packages'.\")\n (packages\n (nyxt-user-packages)\n :type (maybe (list-of package))\n :documentation \"Include symbols of `visibility' from the given packages.\")\n (internal-visibility-packages\n nil\n :type (maybe (list-of package))\n :documentation \"Include internal symbols from the given packages.\")\n (external-visibility-packages\n (nyxt-packages)\n :type (maybe (list-of package))\n :documentation \"Include internal symbols from the given packages.\")\n (inherited-visibility-packages\n nil\n :type (maybe (list-of package))\n :documentation \"Include internal symbols from the given packages.\")\n (prompter:name (alex:required-argument 'prompter:name))\n (prompter:constructor (alex:required-argument 'prompter:constructor))\n (prompter:filter-preprocessor #'prompter:filter-exact-matches))\n (:export-class-name-p nil) ; Internal class.\n (:export-accessor-names-p t))\n\n(define-class describe-non-nyxt-source (describe-nyxt-source)\n ((packages\n nil\n :type (maybe (list-of package))\n :documentation \"Include symbols of `visibility' from the given packages.\")\n (external-visibility-packages\n (non-nyxt-packages)\n :type (maybe (list-of package))\n :documentation \"Include internal symbols from the given packages.\"))\n (:export-class-name-p nil) ; Internal class.\n (:export-accessor-names-p t))\n\n(define-class describe-internal-source (describe-nyxt-source)\n ((packages\n nil\n :type (maybe (list-of package))\n :documentation \"Include symbols of `visibility' from the given packages.\")\n (internal-visibility-packages\n (nyxt-packages)\n :type (maybe (list-of package))\n :documentation \"Include internal symbols from the given packages.\")\n (external-visibility-packages\n nil\n :type (maybe (list-of package))\n :documentation \"Include internal symbols from the given packages.\"))\n (:export-class-name-p nil) ; Internal class.\n (:export-accessor-names-p t))\n\n(define-class function-source (describe-nyxt-source)\n ((prompter:name \"Functions\")\n (prompter:constructor (description-constructor #'sym:package-functions)))\n (:export-accessor-names-p t))\n\n(define-class function-non-nyxt-source (function-source describe-non-nyxt-source)\n ((prompter:name \"Non-Nyxt Functions\")))\n\n(define-class function-internal-source (function-source describe-internal-source)\n ((prompter:name \"Internal Functions\")))\n\n(defun first-line (string)\n \"Return first non-empty line in STRING.\"\n (find-if (complement #'uiop:emptyp) (sera:lines string)))\n\n(defmethod prompter:object-attributes ((symbol symbol) (source prompter:source))\n (declare (ignore source))\n `((\"Name\" ,(prini-to-string symbol) (:width 1))\n (\"Documentation\" ,(or (cond\n ((fboundp symbol)\n (first-line (documentation symbol 'function)))\n ((and (find-class symbol nil)\n (mopu:subclassp (find-class symbol)\n (find-class 'standard-object)))\n (first-line (documentation symbol 'type)))\n ((find-package symbol)\n (first-line (documentation (find-package symbol) t)))\n (t\n (first-line (documentation symbol 'variable))))\n \"\")\n (:width 4))\n (\"Visibility\" ,(prini-to-string (sym:symbol-visibility symbol)) (:width 1))))\n\n;; Note that `package-source' is populated by symbols, not packages.\n(defmethod prompter:object-attributes ((package package) (source prompter:source))\n (declare (ignore source))\n `((\"Name\" ,(package-name package) (:width 1))\n (\"Documentation\" ,(or (first-line (documentation package t)) \"\") (:width 4))\n (\"Nicknames\" ,(append (package-nicknames package)\n ;; Old ASDF/UIOP don't know about package-local-nicknames.\n (ignore-errors (uiop:symbol-call\n :uiop :package-local-nicknames package)))\n (:width 1))))\n\n(define-class class-source (describe-nyxt-source)\n ((prompter:name \"Classes\")\n (prompter:constructor (description-constructor #'sym:package-classes)))\n (:export-accessor-names-p t))\n\n(define-class class-non-nyxt-source (class-source describe-non-nyxt-source)\n ((prompter:name \"Non-Nyxt Classes\")))\n\n(define-class class-internal-source (class-source describe-internal-source)\n ((prompter:name \"Internal Classes\")))\n\n(define-class slot-source (describe-nyxt-source)\n ((prompter:name \"Slots\")\n (prompter:constructor\n (description-constructor #'package-slots\n :test (lambda (slot-a slot-b)\n (equal `(,(name slot-a) ,(class-sym slot-a))\n `(,(name slot-b) ,(class-sym slot-b)))))))\n (:export-accessor-names-p t))\n\n(define-class slot-non-nyxt-source (slot-source describe-non-nyxt-source)\n ((prompter:name \"Non-Nyxt Slots\")))\n\n(define-class slot-internal-source (slot-source describe-internal-source)\n ((prompter:name \"Internal Slots\")))\n\n(defun non-keyword-package-variables (packages visibility)\n (remove-if #'keywordp (sym:package-variables packages visibility)))\n\n(define-class variable-source (describe-nyxt-source)\n ((prompter:name \"Variables\")\n (prompter:constructor (description-constructor #'non-keyword-package-variables)))\n (:export-accessor-names-p t))\n\n(define-class variable-non-nyxt-source (variable-source describe-non-nyxt-source)\n ((prompter:name \"Non-Nyxt Variables\")))\n\n(define-class variable-internal-source (variable-source describe-internal-source)\n ((prompter:name \"Internal Variables\")))\n\n(define-class package-source (prompter:source)\n ((prompter:name \"Packages\")\n (prompter:constructor (mapcar (compose #'intern #'package-name) (list-all-packages)))\n (prompter:filter-preprocessor #'prompter:filter-exact-matches)))\n\n(define-internal-page-command-global describe-any (&key input)\n (buffer (format nil \"*Describe-~a*\" input) 'nyxt/mode/help:help-mode)\n \"Inspect anything and show it in a help buffer.\nWhen input exists, list all the symbols that may match it.\nOtherwise prompt for matches.\"\n (when (symbolp input)\n (spinneret:with-html-string\n (:h1 (princ-to-string input))\n (:p (princ-to-string input)\n \" may refer to several things. Please choose the one that you need.\")\n (:dl\n (when (boundp input)\n (:dt \"Variable\")\n (:dd (:nxref :variable input)))\n (cond\n ((sym:mode-symbol-p input)\n (:dt \"Mode\")\n (:dd (:nxref :mode input)))\n ((sym:class-symbol-p input)\n (:dt \"Class\")\n (:nxref :class-name input))\n (t nil))\n (cond\n ((sym:command-symbol-p input)\n (:dt \"Command\")\n (:dd (:nxref :command input)))\n ((sym:macro-symbol-p input)\n (:dt \"Macro\")\n (:dd (:nxref :macro input)))\n ((sym:function-symbol-p input)\n (:dt \"Function\")\n (:dd (:nxref :function input))))\n (when (find-package input)\n (:dt \"Package\")\n (:dd (:nxref :package input)))\n (dolist (class (sym:package-classes (union (nyxt-packages) (list (symbol-package input)))\n :external))\n (when (find input (class-slots class))\n (:dt \"Slot in \" (:nxref :class-name class))\n (:dd (:nxref :class-name class :slot input))))))))\n\n(defmethod describe-any :around (&key (input nil input-supplied-p)\n %buffer%)\n (declare (ignorable input %buffer%))\n (cond\n ((and input-supplied-p (symbolp input))\n (call-next-method))\n (t\n (let ((sources\n (list (make-instance\n 'command-source\n :actions-on-return (lambda-command describe-command* (commands)\n (describe-command :command (name (first commands)))))\n (make-instance\n 'mode-source\n :actions-on-return (lambda-command describe-command* (modes)\n (describe-mode :mode (first modes))))\n (make-instance\n 'variable-source\n :actions-on-return (lambda-command describe-variable* (variables)\n (describe-variable :variable (first variables))))\n (make-instance\n 'function-source\n :actions-on-return (lambda-command describe-function* (functions)\n (describe-function :fn (first functions))))\n (make-instance\n 'class-source\n :actions-on-return (lambda-command describe-class* (classes)\n (describe-class :class (first classes))))\n (make-instance\n 'slot-source\n :actions-on-return (lambda-command describe-slot** (slots)\n (describe-slot :class (class-sym (first slots))\n :name (name (first slots)))))\n (make-instance\n 'variable-non-nyxt-source\n :actions-on-return (lambda-command describe-variable* (variables)\n (describe-variable :variable (first variables))))\n (make-instance\n 'function-non-nyxt-source\n :actions-on-return (lambda-command describe-function* (functions)\n (describe-function :fn (first functions))))\n (make-instance\n 'class-non-nyxt-source\n :actions-on-return (lambda-command describe-class* (classes)\n (describe-class :class (first classes))))\n (make-instance\n 'slot-non-nyxt-source\n :actions-on-return (lambda-command describe-slot** (slots)\n (describe-slot :class (class-sym (first slots))\n :name (name (first slots)))))\n (make-instance\n 'variable-internal-source\n :actions-on-return (lambda-command describe-variable* (variables)\n (describe-variable :variable (first variables))))\n (make-instance\n 'function-internal-source\n :actions-on-return (lambda-command describe-function* (functions)\n (describe-function :fn (first functions))))\n (make-instance\n 'class-internal-source\n :actions-on-return (lambda-command describe-class* (classes)\n (describe-class :class (first classes))))\n (make-instance\n 'slot-internal-source\n :actions-on-return (lambda-command describe-slot** (slots)\n (describe-slot :class (class-sym (first slots))\n :name (name (first slots))))))))\n (prompt\n :prompt \"Describe\"\n :input input\n :sources sources)))))\n\n(define-internal-page describe-value\n (&key id)\n (:title \"*Help-value*\" :page-mode 'nyxt/mode/help:help-mode)\n \"Inspect value under ID and show it in a help buffer.\"\n (and-let* ((id id)\n (value (inspected-value id)))\n (spinneret:with-html-string\n (:h1 (:raw (escaped-literal-print value)))\n (:dl\n (:dt \"Type\")\n (:dd (:pre (if (sym:class-symbol-p (type-of value))\n (:nxref :class-name (type-of value))\n (prini-to-string (type-of value))))))\n (:p (:raw (value->html value))))))\n\n(define-internal-page-command-global describe-package\n (&key (package\n (prompt1 :prompt \"Describe package\"\n :sources 'package-source)))\n (buffer (str:concat \"*Help-\" (package-name (find-package package)) \"*\") 'nyxt/mode/help:help-mode)\n \"Inspect a package and show it in a help buffer.\"\n (let* ((package (find-package package))\n (total-symbols (sym:package-symbols (list package)))\n (external-symbols (sym:package-symbols (list package) :visibility :external)))\n (flet ((package-markup (package)\n (spinneret:with-html\n (:a :href (nyxt-url 'describe-package :package (package-name package))\n (package-name package)))))\n (spinneret:with-html-string\n (:nstyle (style buffer))\n (:h1 (package-name package))\n (:pre (:code (:raw (resolve-backtick-quote-links (documentation (find-package package) t) package))))\n (:h2 \"Symbols:\")\n (:ul\n (:li \"External: \" (length external-symbols))\n (:li \"Internal: \" (- (length total-symbols) (length external-symbols)))\n (:li \"Total: \" (length total-symbols)))\n (when (package-use-list package)\n (:h2 \"Use list:\")\n (:ul\n (dolist (use (safe-sort (package-use-list package) :key #'package-name))\n (:li (package-markup use)))))\n (when (package-used-by-list package)\n (:h2 \"Used by list:\")\n (:ul\n (dolist (use (safe-sort (package-used-by-list package) :key #'package-name))\n (:li (package-markup use)))))))))\n\n(define-internal-page-command-global describe-variable\n (&key\n (variable (prompt1 :prompt \"Describe variable\"\n :sources '(variable-source\n variable-non-nyxt-source\n variable-internal-source))))\n (buffer (str:concat \"*Help-\" (symbol-name variable) \"*\") 'nyxt/mode/help:help-mode)\n \"Inspect a variable and show it in a help buffer.\"\n (let ((*print-case* :downcase))\n (if (boundp variable)\n (spinneret:with-html-string\n (:nstyle (style buffer))\n (:h1 (format nil \"~s\" variable)) ; Use FORMAT to keep package prefix.\n (:pre (:code (:raw (resolve-backtick-quote-links (documentation variable 'variable)\n (symbol-package variable)))))\n (:h2 \"Type\")\n (:pre (princ-to-string (type-of (symbol-value variable))))\n (:h2 \"Current Value:\")\n (:p (:raw (value->html (symbol-value variable))))\n (:nsection\n :title \"Describe\"\n (:pre (:code (with-output-to-string (s) (describe variable s))))))\n (spinneret:with-html-string\n (:nstyle (style buffer))\n (:h1 (format nil \"~s\" variable))\n (:p \"Unbound\")))))\n\n(defun format-function-type (function-type)\n (match function-type\n ((list 'function argument-types return-types)\n (with-output-to-string (s)\n (format s \"Argument types: ~s~&\" argument-types)\n (format s \"Return types: ~s~&\" return-types)))))\n\n(define-internal-page-command-global describe-function\n (&key\n (fn (prompt1 :prompt \"Describe function\"\n :sources '(function-source\n function-non-nyxt-source\n function-internal-source)))\n ;; This is to have a full-word alternative to :fn for those that prefer it.\n (function fn))\n (buffer (str:concat \"*Help-\" (symbol-name function) \"*\") 'nyxt/mode/help:help-mode)\n \"Inspect a function and show it in a help buffer.\nFor generic functions, describe all the methods.\"\n (if function\n (let ((input function))\n (flet ((fun-desc (input)\n (spinneret:with-html-string\n (:pre (:code (:raw (resolve-backtick-quote-links (documentation input 'function) (symbol-package input)))))\n (when (sym:command-symbol-p input)\n (let* ((key-keymap-pairs (nth-value 1 (keymaps:pretty-binding-keys input (all-keymaps) :print-style (keymaps:name (keyscheme buffer)))))\n (key-keymapname-pairs (mapcar (lambda (pair)\n (list (first pair)\n (keymaps:name (second pair))))\n key-keymap-pairs)))\n (when key-keymapname-pairs\n (:nsection\n :title \"Bindings\"\n (:table\n (:tr\n (:th \"Binding\")\n (:th \"Keymap name\"))\n (loop for (binding keymapname) in key-keymapname-pairs\n collect (:tr (:td binding)\n (:td keymapname))))))))\n (:nsection\n :title \"Argument list\"\n (:pre (:code (prini-to-string (trivial-arguments:arglist input)\n :package (symbol-package input)))))\n #+sbcl\n (unless (or (macro-function input)\n (eq 'function (sb-introspect:function-type input)))\n (:nsection\n :title \"Type\"\n (:p (:pre (format-function-type (sb-introspect:function-type input))))))\n (:nsection\n :title \"Describe\"\n (:pre (:code (with-output-to-string (s) (describe (symbol-function input) s)))))))\n (method-desc (method)\n (spinneret:with-html-string\n (:details\n (:summary\n (:h3 :style \"display: inline\"\n (format nil \"~s\" input) \" \"\n (:raw (format\n nil \"(~{~a~^ ~})\"\n (mapcar (lambda (class)\n (cond\n ((ignore-errors (mopu:subclassp class 'standard-object))\n (spinneret:with-html-string\n (:a :href (nyxt-url 'describe-class\n :class (class-name class))\n (prini-to-string (class-name class)))))\n ((ignore-errors (eq t (class-name class)))\n \"t\")\n (t (nyxt::escaped-literal-print class))))\n (mopu:method-specializers method))))))\n (:button\n :class \"button\"\n :onclick (ps:ps (nyxt/ps:lisp-eval (:buffer buffer :title \"describe-function\")\n (remove-method (closer-mop:method-generic-function method)\n method)\n (reload-current-buffer)))\n \"Remove method\")\n (:pre (:code (:raw (resolve-backtick-quote-links\n (documentation method 't) (symbol-package (mopu:method-name method))))))\n (:nsection\n :level 4\n :title \"Argument list\"\n (:pre (:code (prini-to-string (closer-mop:method-lambda-list method)\n :package (symbol-package input)))))))))\n (spinneret:with-html-string\n (:nstyle (style buffer))\n (:h1 (format nil \"~s\" input) ; Use FORMAT to keep package prefix.\n (cond\n ((macro-function input) \" (macro)\")\n ((sym:command-symbol-p input)\n \" (command)\")\n ((typep (symbol-function input) 'generic-function)\n \" (generic function)\")))\n (cond\n ((not (fboundp input))\n (:p \"Unbound.\"))\n ((typep (symbol-function input) 'generic-function)\n (:raw (fun-desc input))\n (unless (sym:command-symbol-p input)\n (:nsection\n :title \"Methods\"\n (:raw (sera:string-join\n (mapcar #'method-desc\n (mopu:generic-function-methods\n (symbol-function input)))\n \"\")))))\n (t\n (:raw (fun-desc input)))))))\n (prompt :prompt \"Describe function\"\n :sources 'function-source)))\n\n(define-command-global describe-command\n (&key (command (name (prompt1 :prompt \"Describe command\"\n :sources 'command-source))))\n \"Inspect a command and show it in a help buffer.\nA command is a special kind of function that can be called with\n`execute-command' and can be bound to a key.\"\n (when command\n (describe-function :fn command)))\n\n(define-internal-page-command-global describe-slot\n (&key class name)\n (buffer (str:concat \"*Help-\" (symbol-name name) \"*\") 'nyxt/mode/help:help-mode)\n \"Inspect a slot and show it in a help buffer.\"\n (if (and class name)\n (describe-slot* name class :independent-p t)\n (let ((slot (prompt1\n :prompt \"Describe slot\"\n :sources '(slot-source\n slot-non-nyxt-source\n slot-internal-source))))\n (describe-slot :class (class-sym slot) :name (name slot))\n \"\")))\n\n(defun describe-slot* (slot class &key independent-p)\n \"Create the HTML that represents a slot.\"\n ;; TODO: Adapt HTML sections / lists to describe-slot and describe-class.\n ;; TODO: Parse docstrings and highlight code samples.\n (let ((props (mopu:slot-properties (find-class class) slot))\n (*package* (symbol-package slot)))\n (spinneret:with-html-string\n (if independent-p\n (:h1 (prini-to-string slot))\n (:h3 (prini-to-string slot)))\n (:dl\n (when independent-p\n (:dt \"Class\")\n (:dd (:pre (:a :href (nyxt-url 'describe-class :class class) class))))\n (when (getf props :type)\n (:dt \"Type \")\n (:dd (:pre (if (or (subtypep (getf props :type) 'standard-object)\n (subtypep (getf props :type) 'structure-object))\n (:a :href (nyxt-url 'describe-class\n :class (getf props :type))\n (prini-to-string (getf props :type)))\n (prini-to-string (getf props :type))))))\n (when (getf props :initform)\n (:dt \"Default value\")\n (:dd (:ncode (prini-to-string (getf props :initform)))))\n (when (getf props :documentation)\n (:dt \"Documentation\")\n (:dd (:pre (:code (:raw (resolve-backtick-quote-links\n (getf props :documentation) (symbol-package slot))))))))\n (unless independent-p\n (:br \"\")))))\n\n(define-internal-page-command-global describe-class\n (&key\n (class (prompt1\n :prompt \"Describe class\"\n :sources '(class-source\n class-non-nyxt-source\n class-internal-source))))\n (buffer (str:concat \"*Help-\" (symbol-name class) \"*\") 'nyxt/mode/help:help-mode)\n \"Inspect a class and show it in a help buffer.\"\n (if (find-class class nil)\n (let* ((slots (safe-sort (class-slots class :visibility :external)))\n (slot-descs (sera:string-join (mapcar (rcurry #'describe-slot* class) slots) \"\"))\n (*print-case* :downcase)\n (mode-p (subtypep class 'mode)))\n (spinneret:with-html-string\n (:nstyle (style buffer))\n (:h1 (symbol-name class) \" (\" (sera:class-name-of (find-class class)) \")\")\n (:pre (:code (:raw (resolve-backtick-quote-links (documentation class 'type) (symbol-package class)))))\n ;; TODO: Show mode keybindings for a better mode help (would be a\n ;; killer one)? We'd need to do some hack to inspect the keybindings\n ;; from the class somehow. Maybe :allocation :class so that keymap is\n ;; allocated/modified in place?\n ;; REVIEW: Maybe (make-instance MODE-NAME)?\n (:nsection\n :title \"Slots\"\n (:raw slot-descs))\n (when mode-p\n (:nsection\n :title \"Commands\"\n (:ul\n (dolist (command (sym:package-commands (symbol-package class)))\n (:li (:nxref :command command))))))\n (when-let ((methods (safe-sort\n (remove-if\n #'listp (mapcar #'mopu:generic-function-name\n (mopu:generic-functions class))))))\n (:nsection\n :title \"Methods\"\n (:ul (loop for method in methods\n collect (:li (:a :href (nyxt-url 'describe-function :fn method) method))))))\n (when (mopu:direct-superclasses class)\n (:nsection\n :title \"Direct superclasses\"\n (:ul (loop for class-name in (mapcar #'class-name (mopu:direct-superclasses class))\n collect (:li (:a :href (nyxt-url 'describe-class :class class-name) class-name))))))\n (when (mopu:direct-subclasses class)\n (:nsection\n :title \"Direct subclasses\"\n (:ul (loop for class-name in (safe-sort (mapcar #'class-name (mopu:direct-subclasses class)))\n collect (:li (:a :href (nyxt-url 'describe-class :class class-name) class-name))))))\n (:nsection\n :title \"Describe\"\n (:pre (:code (with-output-to-string (s) (describe class s)))))))\n (spinneret:with-html-string\n (:nstyle (style buffer))\n (:h2 (format nil \"~s\" class))\n (:p \"Unbound.\"))))\n\n(define-command-global describe-mode (&key (mode (prompt1 :prompt \"Describe mode\"\n :sources 'mode-source)))\n \"Inspect a mode and show it in a help buffer.\"\n (when mode\n (describe-class :class mode)))\n\n;; Buffers can't be passed as argument since Nyxt URLs don't handle unreadable\n;; objects.\n(define-internal-page describe-bindings (&key (buffer-id (id (current-buffer))))\n (:title \"*Help-bindings*\" :page-mode 'nyxt/mode/help:help-mode)\n \"Show a list of all available keybindings for buffer corresponding to BUFFER-ID.\"\n (if-let ((buffer (nyxt::buffer-get buffer-id)))\n (spinneret:with-html-string\n (:h1 \"Bindings\")\n (:p (loop for keymap in (current-keymaps buffer)\n collect (:div\n (:h2 (keymaps:name keymap))\n (:table\n (:tr\n (:th \"Command\")\n (:th \"Documentation\"))\n (loop for keyspec being the hash-keys\n in (keymaps:keymap-with-parents->map keymap)\n using (hash-value bound-value)\n collect (:tr\n (:td (typecase bound-value\n (sym:command-symbol (:nxref :command bound-value))\n (command (:nxref :command (name bound-value)))\n (t (prini-to-string bound-value))))\n (:td (documentation-line bound-value 'function \"\")))))))))\n (spinneret:with-html-string\n (:h1 \"Bindings\")\n (:p (format nil \"Buffer with ID ~a does not exist.\" buffer-id)))))\n\n(define-command-global describe-bindings (&key (buffer (current-buffer)))\n \"Show a list of all available keybindings in the current buffer.\"\n (buffer-load-internal-page-focus 'describe-bindings :buffer-id (id buffer)))\n\n(defun describe-key-dispatch (command)\n ;; TODO: Show when something is NOT bound!\n (unwind-protect (describe-command :command (typecase command\n (symbol command)\n (command (name command))))\n (setf (command-dispatcher *browser*) #'dispatch-command)\n (echo-dismiss)))\n\n(define-command describe-key ()\n \"Display binding of user-inputted keys.\"\n (setf (command-dispatcher *browser*) #'describe-key-dispatch)\n (echo \"Press a key sequence to describe:\"))\n\n(export-always 'system-information)\n(defun system-information ()\n (str:concat\n \"Nyxt version: \" +version+ +newline+\n \"Web Renderer: \" (name *renderer*) +newline+\n \"OS: \" (software-type) \" \" (software-version) +newline+\n \"Lisp implementation: \" (lisp-implementation-type) \" \" (lisp-implementation-version)\n #+sbcl\n (format nil \" (Dynamic space: ~aMB)~%\" (/ (sb-ext:dynamic-space-size) 1024 1024))\n \"ASDF version: \" (asdf:asdf-version) +newline+\n \"Features: \" (prin1-to-string *features*)))\n" }, { "path": "source/dom.lisp", "content": ";;;; SPDX-FileCopyrightText: Atlas Engineer LLC\n;;;; SPDX-License-Identifier: BSD-3-Clause\n\n(nyxt:define-package :nyxt/dom\n (:documentation \"Nyxt-specific DOM classes and functions operating on them.\n\nThe classes are generated for every HTML element, including `h1-element',\n`div-element', `img-element' and others.\n\nClasses corresponding to non-HTML elements, such as `text-element',\n`semantic-element', or `h-element', act as higher hierarchical entities of\nelement classes. For instance, every `h-element' inherits from `h-element'.\n\nThe most useful functions are:\n- `named-html-parse' and `named-json-parse' to turn HTML and JSON documents into\n a representation of type `plump:root', converting elements into its matching\n classes.\n- `copy' to produce a full recursive copy of a DOM.\n- `parents', `url' and `body' to access element-specific features in a unified\n fashion.\n- `click-element', `focus-select-element', `select-option-element' and others to\n interact with the page using `nyxt/dom' elements as representations of the\n actual DOM elements.\"))\n(in-package :nyxt/dom)\n\n;; TODO: Factor out into a library?\n\n(defvar *nyxt-dom-classes* (make-hash-table :test #'equalp)\n \"A table associating the HTML tag name (e.g., \\\"a\\\") with the corresponding\n nyxt/dom class.\")\n\n(defmacro define-element-classes (&body names)\n (loop for name in names\n collect (let* ((class-name (alex:ensure-car name))\n (tag (str:replace-all \"-element\" \"\" (str:downcase (symbol-name class-name))))\n (additional-superclasses (when (listp name) (rest name))))\n `(progn\n (define-class ,class-name (,@(if additional-superclasses\n additional-superclasses\n '(plump:element)))\n ()\n (:export-class-name-p t)\n (:export-accessor-names-p t)\n (:export-predicate-name-p t)\n (:documentation ,(format nil \"An autogenerated class for <~a> HTML tag.\" tag)))\n (setf (gethash ,tag *nyxt-dom-classes*)\n (quote ,class-name))))\n into classes\n finally (return `(progn ,@classes))))\n\n\n(define-element-classes\n ;; All HTML5 tags, including experimental ones. Scraped with:\n ;;\n ;; (format t \"~{~a-element~^ ~}\"\n ;; (map 'list (lambda (item)\n ;; (slot-value (elt (slot-value item 'plump-dom::%children) 0)\n ;; 'plump-dom::%text))\n ;; (clss:select \".item-name\" (plump:parse (dex:get \"https://htmlreference.io/\")))))\n ;; Pseudo-tags:\n text-element (h-element text-element) list-element structure-element semantic-element\n (checkbox-element input-element) (radio-element input-element) (file-chooser-element input-element)\n ;; HTML5 elements:\n (a-element text-element) abbr-element address-element area-element\n (article-element semantic-element) (aside-element semantic-element)\n audio-element (b-element text-element) base-element bdi-element bdo-element\n blockquote-element body-element br-element button-element canvas-element\n caption-element (cite-element text-element) (code-element text-element) col-element\n colgroup-element data-element datalist-element (dd-element list-element)\n (del-element text-element) details-element dfn-element div-element (dl-element list-element)\n (dt-element list-element) em-element embed-element fieldset-element\n (figcaption-element semantic-element) figure-element (footer-element semantic-element)\n form-element (h1-element h-element) (h2-element h-element) (h3-element h-element)\n (h4-element h-element) (h5-element h-element) (h6-element h-element) head-element\n (header-element semantic-element) hr-element html-element (i-element text-element) iframe-element\n img-element input-element ins-element kbd-element label-element legend-element\n (li-element list-element) link-element (main-element semantic-element) map-element\n (mark-element semantic-element) meta-element meter-element (nav-element semantic-element)\n (noscript-element plump:fulltext-element) object-element (ol-element list-element) optgroup-element\n (option-element text-element) output-element (p-element text-element) param-element\n (pre-element text-element) progress-element q-element rp-element rt-element rtc-element\n ruby-element samp-element (script-element plump:fulltext-element)\n (section-element semantic-element) select-element small-element source-element\n (span-element text-element) (strong-element text-element) (style-element plump:fulltext-element)\n (sub-element text-element) summary-element (sup-element text-element) table-element\n tbody-element td-element textarea-element tfoot-element th-element thead-element\n (time-element semantic-element) title-element tr-element track-element (ul-element list-element)\n var-element video-element\n ;; obsolete elements (from https://www.w3.org/TR/2010/WD-html5-20100304/obsolete.html):\n applet-element acronym-element bgsound-element dir-element frame-element frameset-element\n noframes-element isindex-element (listing-element text-element) (xmp-element text-element)\n nextid-element noembed-element (plaintext-element text-element) (rb-element ruby-element)\n (basefont-element text-element) (big-element text-element) (blink-element text-element)\n (center-element text-element) (font-element text-element) (marquee-element text-element)\n (multicol-element text-element) (nobr-element text-element) (s-element text-element)\n (spacer-element text-element) (strike-element text-element) (tt-element text-element)\n (u-element text-element)\n ;; Experimental elements:\n dialog-element hgroup-element picture-element slot-element template-element\n (wbr-element text-element))\n\n(defmethod name-dom-elements ((node plump:node))\n (when-let* ((tag-p (plump:element-p node))\n (class (gethash (plump:tag-name node) *nyxt-dom-classes*)))\n (change-class node class))\n (when (plump:nesting-node-p node)\n (loop for child across (plump:children node)\n do (name-dom-elements child)))\n node)\n\n(export-always 'named-html-parse)\n(-> named-parse (string) (values (or plump-dom:root null) &optional))\n(defun named-html-parse (input)\n \"Assign tag classes (e.g., `input-element') to the nodes in the `plump:parse'-d input.\"\n (name-dom-elements (plump:parse input)))\n\n(define-parenscript get-document-body-json ()\n (defun process-element (element)\n (let ((object (ps:create :name (ps:@ element node-name)))\n (attributes (ps:chain element attributes)))\n (unless (or (ps:undefined attributes)\n (= 0 (ps:@ attributes length)))\n (setf (ps:@ object :attributes) (ps:create))\n (loop for i from 0 below (ps:@ attributes length)\n do (setf (ps:@ object :attributes (ps:chain attributes (item i) name))\n (ps:chain attributes (item i) value))))\n (unless (or (ps:undefined (ps:chain element child-nodes))\n (= 0 (ps:chain element child-nodes length)))\n (setf (ps:chain object :children)\n (loop for child in (ps:chain element child-nodes)\n collect (process-element child))))\n (when (and (ps:@ element shadow-root)\n (ps:@ element shadow-root first-child))\n (setf (ps:chain object :children)\n (loop for child in (ps:chain *array\n (from (ps:@ element shadow-root children))\n (concat (ps:chain *array (from (ps:@ element children)))))\n collect (process-element child))))\n (when (or (equal (ps:@ element node-name) \"#text\")\n (equal (ps:@ element node-name) \"#comment\")\n (equal (ps:@ element node-name) \"#cdata-section\"))\n (setf (ps:@ object :text) (ps:@ element text-content)))\n object))\n (ps:chain -j-s-o-n (stringify (process-element (nyxt/ps:qs document \"html\")))))\n\n(export-always 'named-json-parse)\n(-> named-json-parse (string) (values (or plump-dom:root null) &optional))\n(defun named-json-parse (json)\n \"Return a `plump:root' of a DOM-tree produced from the JSON.\n\nJSON should have the format like what `get-document-body-json' produces:\n- A nested hierarchy of objects (with only one root object), where\n - Every object has a 'name' (usually a tag name or '#text'/'#comment').\n - Some objects can have 'attributes' (a string->string dictionary).\n - Some objects have a subarray ('children') of objects working by these three\n rules.\"\n (labels ((json-to-plump (json parent)\n (let ((element\n (cond\n ((string-equal (j:get \"name\" json) \"#text\")\n (plump:make-text-node parent (j:get \"text\" json)))\n ((string-equal (j:get \"name\" json) \"#cdata-section\")\n (plump:make-cdata parent :text (j:get \"text\" json)))\n ((string-equal (j:get \"name\" json) \"#comment\")\n (plump:make-comment parent (j:get \"text\" json)))\n (t (plump:make-element parent (str:downcase\n (j:get \"name\" json)))))))\n (when (typep element 'plump:nesting-node)\n (setf (plump:children element)\n (plump:ensure-child-array\n (map 'vector (rcurry #'json-to-plump element)\n (let ((children (j:get \"children\" json)))\n (if (stringp children)\n (j:decode children)\n children))))))\n (when (typep element 'plump:element)\n (setf (plump:attributes element)\n (sera:lret ((map (plump:make-attribute-map)))\n (when (j:get \"attributes\" json)\n (maphash (lambda (key val)\n (setf (gethash key map) val))\n (j:get \"attributes\" json))))))\n element)))\n (let ((json (j:decode json))\n (root (plump:make-root)))\n (json-to-plump json root)\n (name-dom-elements root))))\n\n(export-always 'copy)\n(defgeneric copy (node &optional parent)\n (:method ((element plump:root) &optional parent)\n (declare (ignore parent))\n (serapeum:lret ((copy (plump:make-root)))\n (map nil (lambda (c) (plump:append-child copy (copy c copy))) (plump:children element))))\n (:method ((element plump:element) &optional parent)\n (serapeum:lret ((copy (make-instance\n 'plump:element\n :parent parent\n :attributes (alex:copy-hash-table (plump:attributes element))\n :tag-name (plump:tag-name element))))\n (map nil (lambda (c) (plump:append-child copy (copy c copy))) (plump:children element))))\n (:method ((element plump:text-node) &optional parent)\n (make-instance 'plump:text-node\n :parent parent\n :text (plump:text element)))\n (:method ((element plump:comment) &optional parent)\n (make-instance 'plump:comment\n :parent parent\n :text (plump:text element)))\n (:method ((element plump:doctype) &optional parent)\n (make-instance 'plump:doctype\n :parent parent\n :doctype (plump:doctype element)))\n (:method ((element plump:xml-header) &optional parent)\n (make-instance 'plump:xml-header\n :parent parent\n :attributes (alex:copy-hash-table (plump:attributes element))))\n (:method ((element plump:cdata) &optional parent)\n (make-instance 'plump:cdata\n :parent parent\n :text (plump:text element)))\n (:method ((element plump:processing-instruction) &optional parent)\n (make-instance 'plump:processing-instruction\n :parent parent\n :text (plump:text element)\n :tag-name (plump:tag-name element)))\n (:documentation \"Produce a full copy of NODE as belonging to the PARENT node.\nFull copy means recursively descending to the children of the NODE too.\"))\n\n(export-always 'parents)\n(defgeneric parents (node)\n (:method ((node plump:node)) nil)\n (:method ((node plump:child-node))\n (let ((parent (plump:parent node)))\n (cons parent (parents parent))))\n (:documentation \"Get the recursive parents of the NODE.\nThe closest parent goes first, the furthest one goes last.\"))\n\n(defmethod url :around ((element plump:element))\n (when-let* ((result (call-next-method))\n (url (url result)))\n (if (valid-url-p url)\n url\n (quri:merge-uris url (url (current-buffer))))))\n\n(defmethod url ((element plump:element))\n (when (plump:has-attribute element \"href\")\n (quri:uri (plump:get-attribute element \"href\"))))\n\n(defmethod url ((img img-element))\n (when (plump:has-attribute img \"src\")\n (quri:uri (plump:get-attribute img \"src\"))))\n\n;; REVIEW: Export to :nyxt? We are forced to use it with nyxt/dom: prefix.\n(export-always 'body)\n(defgeneric body (element)\n (:method ((element plump:element))\n (when (plump:children element)\n (plump:text element)))\n (:method :around (element)\n (declare (ignorable element))\n (let ((result (call-next-method)))\n (when result\n (sera:collapse-whitespace (sera:trim-whitespace result)))))\n (:documentation \"Return the textual contents of the ELEMENT and its recursive children.\"))\n\n(defun label-of (element)\n (let ((label-for (and (plump:has-attribute element \"name\")\n (ignore-errors\n (elt (clss:select (format nil \"label[for=\\\"~a\\\"]\"\n (plump:attribute element \"name\"))\n (alex:lastcar (parents element)))\n 0)))))\n (cond\n ((label-element-p (plump:parent element)) (body (plump:parent element)))\n (label-for (body label-for))\n (t nil))))\n\n(defun fallback-body (element)\n (when-let ((body (or (plump:get-attribute element \"value\")\n (plump:get-attribute element \"placeholder\"))))\n body))\n\n(defmethod body ((input input-element))\n (or (label-of input) (fallback-body input)))\n\n(defmethod body ((textarea textarea-element))\n (or (label-of textarea) (fallback-body textarea)))\n\n(defmethod body ((details details-element))\n (let ((summary (clss:select \"summary\" details)))\n (unless (uiop:emptyp summary)\n (plump:text (elt summary 0)))))\n\n(defmethod body ((select select-element))\n (or (label-of select)\n (str:join \", \" (map 'list #'plump:text\n (clss:select \"option\" select)))))\n\n(defmethod body ((img img-element))\n (when (plump:has-attribute img \"alt\")\n (plump:attribute img \"alt\")))\n\n(export-always 'get-nyxt-id)\n(defmethod get-nyxt-id ((element plump:element))\n \"Get the nyxt-identifier of the page element matching ELEMENT.\"\n (plump:attribute element \"nyxt-identifier\"))\n\n(export-always 'click-element)\n(define-parenscript click-element (element)\n \"Click the ELEMENT (Lisp object) on the page with JS.\"\n (ps:chain (nyxt/ps:rqs-nyxt-id document (ps:lisp (get-nyxt-id element))) (click)))\n\n(export-always 'focus-select-element)\n(define-parenscript focus-select-element (element)\n \"Focus the element matching ELEMENT on the page.\"\n (let ((element (nyxt/ps:rqs-nyxt-id document (ps:lisp (get-nyxt-id element)))))\n (unless (nyxt/ps:element-in-view-port-p element)\n (ps:chain element (scroll-into-view)))\n (ps:chain element (focus))\n (when (functionp (ps:chain element select))\n (ps:chain element (select)))))\n\n(export-always 'check-element)\n(define-parenscript check-element (element &key (value t))\n \"Toggle (to VALUE) the checkbox/radio button matching ELEMENT on the page.\"\n (let ((element (nyxt/ps:rqs-nyxt-id document (ps:lisp (get-nyxt-id element)))))\n (unless (nyxt/ps:element-in-view-port-p element)\n (ps:chain element (scroll-into-view)))\n (ps:chain element (set-attribute \"checked\" (ps:lisp value)))))\n\n(export-always 'toggle-details-element)\n(define-parenscript toggle-details-element (element)\n \"Open/close the
element matching ELEMENT on the page.\"\n (ps:let ((element (nyxt/ps:rqs-nyxt-id document (ps:lisp (get-nyxt-id element)))))\n (unless (nyxt/ps:element-in-view-port-p element)\n (ps:chain element (scroll-into-view)))\n (if (ps:chain element (get-attribute \"open\"))\n (ps:chain element (remove-attribute \"open\"))\n (ps:chain element (set-attribute \"open\" t)))))\n\n(export-always 'select-option-element)\n(define-parenscript select-option-element (element parent)\n \"Select one of the