[ { "path": ".dir-locals.el", "content": ";;; Directory Local Variables\n;;; For more information see (info \"(emacs) Directory Variables\")\n\n((emacs-lisp-mode . ((fill-column . 90)\n\t\t (indent-tabs-mode . nil))))\n" }, { "path": ".elpaignore", "content": ".github/\nimages/\nLICENSE\nMakefile\nmakem.sh\nNOTES.org\nscreenshots/\n" }, { "path": ".github/ISSUE_TEMPLATE/bug_report.yml", "content": "name: Bug Report\ndescription: File a bug report\nlabels: [\"bug\"]\nassignees:\n - alphapapa\nbody:\n - type: markdown\n attributes:\n value: |\n Thanks for taking the time to fill out this bug report!\n - type: input\n id: os-platform\n attributes:\n label: OS/platform\n description: What operating system or platform are you running Emacs on?\n validations:\n required: true\n - type: textarea\n id: emacs-provenance\n attributes:\n label: Emacs version and provenance\n description: What version of Emacs are you using, where did you acquire it, and how did you install it?\n validations:\n required: true\n - type: input\n id: emacs-command\n attributes:\n label: Emacs command\n description: By what method did you run Emacs? (i.e. what command did you run?)\n validations:\n required: true\n - type: input\n id: emacs-frame\n attributes:\n label: Emacs frame type\n description: Did the problem happen on a GUI or tty Emacs frame?\n validations:\n required: true\n - type: input\n id: package-provenance\n attributes:\n label: Ement package version and provenance\n description: What version of Ement.el are you using, where did you acquire it, and how did you install it?\n validations:\n required: true\n - type: textarea\n id: actions\n attributes:\n label: Actions taken\n description: What actions did you take, step-by-step, in order, before the problem was noticed?\n validations:\n required: true\n - type: textarea\n id: results\n attributes:\n label: Observed results\n description: What behavior did you observe that seemed wrong?\n validations:\n required: true\n - type: textarea\n id: expected\n attributes:\n label: Expected results\n description: What behavior did you expect to observe?\n validations:\n required: true\n - type: textarea\n id: backtrace\n attributes:\n label: Backtrace\n description: If an error was signaled, please use `M-x toggle-debug-on-error RET` and cause the error to happen again, then paste the contents of the `*Backtrace*` buffer here.\n render: elisp\n - type: textarea\n id: etc\n attributes:\n label: Etc.\n description: Any other information that seems relevant\n\n" }, { "path": ".github/ISSUE_TEMPLATE/config.yml", "content": "blank_issues_enabled: true\n" }, { "path": ".github/workflows/test.yml", "content": "# * test.yml --- Test Emacs packages using makem.sh on GitHub Actions\n\n# URL: https://github.com/alphapapa/makem.sh\n# Version: 0.4.2\n\n# * Commentary:\n\n# Based on Steve Purcell's examples at\n# ,\n# .\n\n# * License:\n\n# This program is free software; you can redistribute it and/or modify\n# it under the terms of the GNU General Public License as published by\n# the Free Software Foundation, either version 3 of the License, or\n# (at your option) any later version.\n\n# This program is distributed in the hope that it will be useful,\n# but WITHOUT ANY WARRANTY; without even the implied warranty of\n# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n# GNU General Public License for more details.\n\n# You should have received a copy of the GNU General Public License\n# along with this program. If not, see .\n\n# * Code:\n\nname: \"CI\"\non:\n pull_request:\n push:\n # Comment out this section to enable testing of all branches.\n branches:\n - master\n\njobs:\n build:\n runs-on: ubuntu-latest\n strategy:\n fail-fast: false\n matrix:\n emacs_version:\n - 27.2\n - 28.2\n - 29.1\n - snapshot\n steps:\n - uses: purcell/setup-emacs@master\n with:\n version: ${{ matrix.emacs_version }}\n\n - uses: actions/checkout@v2\n\n - name: Install Ispell\n run: |\n sudo apt-get install ispell\n\n - name: Initialize sandbox\n run: |\n SANDBOX_DIR=$(mktemp -d) || exit 1\n echo \"SANDBOX_DIR=$SANDBOX_DIR\" >> $GITHUB_ENV\n ./makem.sh -vv --sandbox=$SANDBOX_DIR --install-deps --install-linters\n\n # The \"all\" rule is not used, because it treats compilation warnings\n # as failures, so linting and testing are run as separate steps.\n\n - name: Lint\n # NOTE: Uncomment this line to treat lint failures as passing\n # so the job doesn't show failure.\n # continue-on-error: true\n run: ./makem.sh -vv --sandbox=$SANDBOX_DIR lint\n\n - name: Test\n if: always() # Run test even if linting fails.\n run: ./makem.sh -vv --sandbox=$SANDBOX_DIR test\n\n# Local Variables:\n# eval: (outline-minor-mode)\n# End:\n" }, { "path": ".gitignore", "content": "/.sandbox/\n*.elc\n/worktrees/\n/.#*\n" }, { "path": "LICENSE", "content": " GNU GENERAL PUBLIC LICENSE\n Version 3, 29 June 2007\n\n Copyright (C) 2007 Free Software Foundation, Inc. \n Everyone is permitted to copy and distribute verbatim copies\n of this license document, but changing it is not allowed.\n\n Preamble\n\n The GNU General Public License is a free, copyleft license for\nsoftware and other kinds of works.\n\n The licenses for most software and other practical works are designed\nto take away your freedom to share and change the works. By contrast,\nthe GNU General Public License is intended to guarantee your freedom to\nshare and change all versions of a program--to make sure it remains free\nsoftware for all its users. We, the Free Software Foundation, use the\nGNU General Public License for most of our software; it applies also to\nany other work released this way by its authors. You can apply it to\nyour programs, too.\n\n When we speak of free software, we are referring to freedom, not\nprice. Our General Public Licenses are designed to make sure that you\nhave the freedom to distribute copies of free software (and charge for\nthem if you wish), that you receive source code or can get it if you\nwant it, that you can change the software or use pieces of it in new\nfree programs, and that you know you can do these things.\n\n To protect your rights, we need to prevent others from denying you\nthese rights or asking you to surrender the rights. Therefore, you have\ncertain responsibilities if you distribute copies of the software, or if\nyou modify it: responsibilities to respect the freedom of others.\n\n For example, if you distribute copies of such a program, whether\ngratis or for a fee, you must pass on to the recipients the same\nfreedoms that you received. You must make sure that they, too, receive\nor can get the source code. And you must show them these terms so they\nknow their rights.\n\n Developers that use the GNU GPL protect your rights with two steps:\n(1) assert copyright on the software, and (2) offer you this License\ngiving you legal permission to copy, distribute and/or modify it.\n\n For the developers' and authors' protection, the GPL clearly explains\nthat there is no warranty for this free software. For both users' and\nauthors' sake, the GPL requires that modified versions be marked as\nchanged, so that their problems will not be attributed erroneously to\nauthors of previous versions.\n\n Some devices are designed to deny users access to install or run\nmodified versions of the software inside them, although the manufacturer\ncan do so. This is fundamentally incompatible with the aim of\nprotecting users' freedom to change the software. The systematic\npattern of such abuse occurs in the area of products for individuals to\nuse, which is precisely where it is most unacceptable. Therefore, we\nhave designed this version of the GPL to prohibit the practice for those\nproducts. If such problems arise substantially in other domains, we\nstand ready to extend this provision to those domains in future versions\nof the GPL, as needed to protect the freedom of users.\n\n Finally, every program is threatened constantly by software patents.\nStates should not allow patents to restrict development and use of\nsoftware on general-purpose computers, but in those that do, we wish to\navoid the special danger that patents applied to a free program could\nmake it effectively proprietary. To prevent this, the GPL assures that\npatents cannot be used to render the program non-free.\n\n The precise terms and conditions for copying, distribution and\nmodification follow.\n\n TERMS AND CONDITIONS\n\n 0. Definitions.\n\n \"This License\" refers to version 3 of the GNU General Public License.\n\n \"Copyright\" also means copyright-like laws that apply to other kinds of\nworks, such as semiconductor masks.\n\n \"The Program\" refers to any copyrightable work licensed under this\nLicense. Each licensee is addressed as \"you\". \"Licensees\" and\n\"recipients\" may be individuals or organizations.\n\n To \"modify\" a work means to copy from or adapt all or part of the work\nin a fashion requiring copyright permission, other than the making of an\nexact copy. The resulting work is called a \"modified version\" of the\nearlier work or a work \"based on\" the earlier work.\n\n A \"covered work\" means either the unmodified Program or a work based\non the Program.\n\n To \"propagate\" a work means to do anything with it that, without\npermission, would make you directly or secondarily liable for\ninfringement under applicable copyright law, except executing it on a\ncomputer or modifying a private copy. Propagation includes copying,\ndistribution (with or without modification), making available to the\npublic, and in some countries other activities as well.\n\n To \"convey\" a work means any kind of propagation that enables other\nparties to make or receive copies. Mere interaction with a user through\na computer network, with no transfer of a copy, is not conveying.\n\n An interactive user interface displays \"Appropriate Legal Notices\"\nto the extent that it includes a convenient and prominently visible\nfeature that (1) displays an appropriate copyright notice, and (2)\ntells the user that there is no warranty for the work (except to the\nextent that warranties are provided), that licensees may convey the\nwork under this License, and how to view a copy of this License. If\nthe interface presents a list of user commands or options, such as a\nmenu, a prominent item in the list meets this criterion.\n\n 1. Source Code.\n\n The \"source code\" for a work means the preferred form of the work\nfor making modifications to it. \"Object code\" means any non-source\nform of a work.\n\n A \"Standard Interface\" means an interface that either is an official\nstandard defined by a recognized standards body, or, in the case of\ninterfaces specified for a particular programming language, one that\nis widely used among developers working in that language.\n\n The \"System Libraries\" of an executable work include anything, other\nthan the work as a whole, that (a) is included in the normal form of\npackaging a Major Component, but which is not part of that Major\nComponent, and (b) serves only to enable use of the work with that\nMajor Component, or to implement a Standard Interface for which an\nimplementation is available to the public in source code form. A\n\"Major Component\", in this context, means a major essential component\n(kernel, window system, and so on) of the specific operating system\n(if any) on which the executable work runs, or a compiler used to\nproduce the work, or an object code interpreter used to run it.\n\n The \"Corresponding Source\" for a work in object code form means all\nthe source code needed to generate, install, and (for an executable\nwork) run the object code and to modify the work, including scripts to\ncontrol those activities. However, it does not include the work's\nSystem Libraries, or general-purpose tools or generally available free\nprograms which are used unmodified in performing those activities but\nwhich are not part of the work. For example, Corresponding Source\nincludes interface definition files associated with source files for\nthe work, and the source code for shared libraries and dynamically\nlinked subprograms that the work is specifically designed to require,\nsuch as by intimate data communication or control flow between those\nsubprograms and other parts of the work.\n\n The Corresponding Source need not include anything that users\ncan regenerate automatically from other parts of the Corresponding\nSource.\n\n The Corresponding Source for a work in source code form is that\nsame work.\n\n 2. Basic Permissions.\n\n All rights granted under this License are granted for the term of\ncopyright on the Program, and are irrevocable provided the stated\nconditions are met. This License explicitly affirms your unlimited\npermission to run the unmodified Program. The output from running a\ncovered work is covered by this License only if the output, given its\ncontent, constitutes a covered work. This License acknowledges your\nrights of fair use or other equivalent, as provided by copyright law.\n\n You may make, run and propagate covered works that you do not\nconvey, without conditions so long as your license otherwise remains\nin force. You may convey covered works to others for the sole purpose\nof having them make modifications exclusively for you, or provide you\nwith facilities for running those works, provided that you comply with\nthe terms of this License in conveying all material for which you do\nnot control copyright. Those thus making or running the covered works\nfor you must do so exclusively on your behalf, under your direction\nand control, on terms that prohibit them from making any copies of\nyour copyrighted material outside their relationship with you.\n\n Conveying under any other circumstances is permitted solely under\nthe conditions stated below. Sublicensing is not allowed; section 10\nmakes it unnecessary.\n\n 3. Protecting Users' Legal Rights From Anti-Circumvention Law.\n\n No covered work shall be deemed part of an effective technological\nmeasure under any applicable law fulfilling obligations under article\n11 of the WIPO copyright treaty adopted on 20 December 1996, or\nsimilar laws prohibiting or restricting circumvention of such\nmeasures.\n\n When you convey a covered work, you waive any legal power to forbid\ncircumvention of technological measures to the extent such circumvention\nis effected by exercising rights under this License with respect to\nthe covered work, and you disclaim any intention to limit operation or\nmodification of the work as a means of enforcing, against the work's\nusers, your or third parties' legal rights to forbid circumvention of\ntechnological measures.\n\n 4. Conveying Verbatim Copies.\n\n You may convey verbatim copies of the Program's source code as you\nreceive it, in any medium, provided that you conspicuously and\nappropriately publish on each copy an appropriate copyright notice;\nkeep intact all notices stating that this License and any\nnon-permissive terms added in accord with section 7 apply to the code;\nkeep intact all notices of the absence of any warranty; and give all\nrecipients a copy of this License along with the Program.\n\n You may charge any price or no price for each copy that you convey,\nand you may offer support or warranty protection for a fee.\n\n 5. Conveying Modified Source Versions.\n\n You may convey a work based on the Program, or the modifications to\nproduce it from the Program, in the form of source code under the\nterms of section 4, provided that you also meet all of these conditions:\n\n a) The work must carry prominent notices stating that you modified\n it, and giving a relevant date.\n\n b) The work must carry prominent notices stating that it is\n released under this License and any conditions added under section\n 7. This requirement modifies the requirement in section 4 to\n \"keep intact all notices\".\n\n c) You must license the entire work, as a whole, under this\n License to anyone who comes into possession of a copy. This\n License will therefore apply, along with any applicable section 7\n additional terms, to the whole of the work, and all its parts,\n regardless of how they are packaged. This License gives no\n permission to license the work in any other way, but it does not\n invalidate such permission if you have separately received it.\n\n d) If the work has interactive user interfaces, each must display\n Appropriate Legal Notices; however, if the Program has interactive\n interfaces that do not display Appropriate Legal Notices, your\n work need not make them do so.\n\n A compilation of a covered work with other separate and independent\nworks, which are not by their nature extensions of the covered work,\nand which are not combined with it such as to form a larger program,\nin or on a volume of a storage or distribution medium, is called an\n\"aggregate\" if the compilation and its resulting copyright are not\nused to limit the access or legal rights of the compilation's users\nbeyond what the individual works permit. Inclusion of a covered work\nin an aggregate does not cause this License to apply to the other\nparts of the aggregate.\n\n 6. Conveying Non-Source Forms.\n\n You may convey a covered work in object code form under the terms\nof sections 4 and 5, provided that you also convey the\nmachine-readable Corresponding Source under the terms of this License,\nin one of these ways:\n\n a) Convey the object code in, or embodied in, a physical product\n (including a physical distribution medium), accompanied by the\n Corresponding Source fixed on a durable physical medium\n customarily used for software interchange.\n\n b) Convey the object code in, or embodied in, a physical product\n (including a physical distribution medium), accompanied by a\n written offer, valid for at least three years and valid for as\n long as you offer spare parts or customer support for that product\n model, to give anyone who possesses the object code either (1) a\n copy of the Corresponding Source for all the software in the\n product that is covered by this License, on a durable physical\n medium customarily used for software interchange, for a price no\n more than your reasonable cost of physically performing this\n conveying of source, or (2) access to copy the\n Corresponding Source from a network server at no charge.\n\n c) Convey individual copies of the object code with a copy of the\n written offer to provide the Corresponding Source. This\n alternative is allowed only occasionally and noncommercially, and\n only if you received the object code with such an offer, in accord\n with subsection 6b.\n\n d) Convey the object code by offering access from a designated\n place (gratis or for a charge), and offer equivalent access to the\n Corresponding Source in the same way through the same place at no\n further charge. You need not require recipients to copy the\n Corresponding Source along with the object code. If the place to\n copy the object code is a network server, the Corresponding Source\n may be on a different server (operated by you or a third party)\n that supports equivalent copying facilities, provided you maintain\n clear directions next to the object code saying where to find the\n Corresponding Source. Regardless of what server hosts the\n Corresponding Source, you remain obligated to ensure that it is\n available for as long as needed to satisfy these requirements.\n\n e) Convey the object code using peer-to-peer transmission, provided\n you inform other peers where the object code and Corresponding\n Source of the work are being offered to the general public at no\n charge under subsection 6d.\n\n A separable portion of the object code, whose source code is excluded\nfrom the Corresponding Source as a System Library, need not be\nincluded in conveying the object code work.\n\n A \"User Product\" is either (1) a \"consumer product\", which means any\ntangible personal property which is normally used for personal, family,\nor household purposes, or (2) anything designed or sold for incorporation\ninto a dwelling. In determining whether a product is a consumer product,\ndoubtful cases shall be resolved in favor of coverage. For a particular\nproduct received by a particular user, \"normally used\" refers to a\ntypical or common use of that class of product, regardless of the status\nof the particular user or of the way in which the particular user\nactually uses, or expects or is expected to use, the product. A product\nis a consumer product regardless of whether the product has substantial\ncommercial, industrial or non-consumer uses, unless such uses represent\nthe only significant mode of use of the product.\n\n \"Installation Information\" for a User Product means any methods,\nprocedures, authorization keys, or other information required to install\nand execute modified versions of a covered work in that User Product from\na modified version of its Corresponding Source. The information must\nsuffice to ensure that the continued functioning of the modified object\ncode is in no case prevented or interfered with solely because\nmodification has been made.\n\n If you convey an object code work under this section in, or with, or\nspecifically for use in, a User Product, and the conveying occurs as\npart of a transaction in which the right of possession and use of the\nUser Product is transferred to the recipient in perpetuity or for a\nfixed term (regardless of how the transaction is characterized), the\nCorresponding Source conveyed under this section must be accompanied\nby the Installation Information. But this requirement does not apply\nif neither you nor any third party retains the ability to install\nmodified object code on the User Product (for example, the work has\nbeen installed in ROM).\n\n The requirement to provide Installation Information does not include a\nrequirement to continue to provide support service, warranty, or updates\nfor a work that has been modified or installed by the recipient, or for\nthe User Product in which it has been modified or installed. Access to a\nnetwork may be denied when the modification itself materially and\nadversely affects the operation of the network or violates the rules and\nprotocols for communication across the network.\n\n Corresponding Source conveyed, and Installation Information provided,\nin accord with this section must be in a format that is publicly\ndocumented (and with an implementation available to the public in\nsource code form), and must require no special password or key for\nunpacking, reading or copying.\n\n 7. Additional Terms.\n\n \"Additional permissions\" are terms that supplement the terms of this\nLicense by making exceptions from one or more of its conditions.\nAdditional permissions that are applicable to the entire Program shall\nbe treated as though they were included in this License, to the extent\nthat they are valid under applicable law. If additional permissions\napply only to part of the Program, that part may be used separately\nunder those permissions, but the entire Program remains governed by\nthis License without regard to the additional permissions.\n\n When you convey a copy of a covered work, you may at your option\nremove any additional permissions from that copy, or from any part of\nit. (Additional permissions may be written to require their own\nremoval in certain cases when you modify the work.) You may place\nadditional permissions on material, added by you to a covered work,\nfor which you have or can give appropriate copyright permission.\n\n Notwithstanding any other provision of this License, for material you\nadd to a covered work, you may (if authorized by the copyright holders of\nthat material) supplement the terms of this License with terms:\n\n a) Disclaiming warranty or limiting liability differently from the\n terms of sections 15 and 16 of this License; or\n\n b) Requiring preservation of specified reasonable legal notices or\n author attributions in that material or in the Appropriate Legal\n Notices displayed by works containing it; or\n\n c) Prohibiting misrepresentation of the origin of that material, or\n requiring that modified versions of such material be marked in\n reasonable ways as different from the original version; or\n\n d) Limiting the use for publicity purposes of names of licensors or\n authors of the material; or\n\n e) Declining to grant rights under trademark law for use of some\n trade names, trademarks, or service marks; or\n\n f) Requiring indemnification of licensors and authors of that\n material by anyone who conveys the material (or modified versions of\n it) with contractual assumptions of liability to the recipient, for\n any liability that these contractual assumptions directly impose on\n those licensors and authors.\n\n All other non-permissive additional terms are considered \"further\nrestrictions\" within the meaning of section 10. If the Program as you\nreceived it, or any part of it, contains a notice stating that it is\ngoverned by this License along with a term that is a further\nrestriction, you may remove that term. If a license document contains\na further restriction but permits relicensing or conveying under this\nLicense, you may add to a covered work material governed by the terms\nof that license document, provided that the further restriction does\nnot survive such relicensing or conveying.\n\n If you add terms to a covered work in accord with this section, you\nmust place, in the relevant source files, a statement of the\nadditional terms that apply to those files, or a notice indicating\nwhere to find the applicable terms.\n\n Additional terms, permissive or non-permissive, may be stated in the\nform of a separately written license, or stated as exceptions;\nthe above requirements apply either way.\n\n 8. Termination.\n\n You may not propagate or modify a covered work except as expressly\nprovided under this License. Any attempt otherwise to propagate or\nmodify it is void, and will automatically terminate your rights under\nthis License (including any patent licenses granted under the third\nparagraph of section 11).\n\n However, if you cease all violation of this License, then your\nlicense from a particular copyright holder is reinstated (a)\nprovisionally, unless and until the copyright holder explicitly and\nfinally terminates your license, and (b) permanently, if the copyright\nholder fails to notify you of the violation by some reasonable means\nprior to 60 days after the cessation.\n\n Moreover, your license from a particular copyright holder is\nreinstated permanently if the copyright holder notifies you of the\nviolation by some reasonable means, this is the first time you have\nreceived notice of violation of this License (for any work) from that\ncopyright holder, and you cure the violation prior to 30 days after\nyour receipt of the notice.\n\n Termination of your rights under this section does not terminate the\nlicenses of parties who have received copies or rights from you under\nthis License. If your rights have been terminated and not permanently\nreinstated, you do not qualify to receive new licenses for the same\nmaterial under section 10.\n\n 9. Acceptance Not Required for Having Copies.\n\n You are not required to accept this License in order to receive or\nrun a copy of the Program. Ancillary propagation of a covered work\noccurring solely as a consequence of using peer-to-peer transmission\nto receive a copy likewise does not require acceptance. However,\nnothing other than this License grants you permission to propagate or\nmodify any covered work. These actions infringe copyright if you do\nnot accept this License. Therefore, by modifying or propagating a\ncovered work, you indicate your acceptance of this License to do so.\n\n 10. Automatic Licensing of Downstream Recipients.\n\n Each time you convey a covered work, the recipient automatically\nreceives a license from the original licensors, to run, modify and\npropagate that work, subject to this License. You are not responsible\nfor enforcing compliance by third parties with this License.\n\n An \"entity transaction\" is a transaction transferring control of an\norganization, or substantially all assets of one, or subdividing an\norganization, or merging organizations. If propagation of a covered\nwork results from an entity transaction, each party to that\ntransaction who receives a copy of the work also receives whatever\nlicenses to the work the party's predecessor in interest had or could\ngive under the previous paragraph, plus a right to possession of the\nCorresponding Source of the work from the predecessor in interest, if\nthe predecessor has it or can get it with reasonable efforts.\n\n You may not impose any further restrictions on the exercise of the\nrights granted or affirmed under this License. For example, you may\nnot impose a license fee, royalty, or other charge for exercise of\nrights granted under this License, and you may not initiate litigation\n(including a cross-claim or counterclaim in a lawsuit) alleging that\nany patent claim is infringed by making, using, selling, offering for\nsale, or importing the Program or any portion of it.\n\n 11. Patents.\n\n A \"contributor\" is a copyright holder who authorizes use under this\nLicense of the Program or a work on which the Program is based. The\nwork thus licensed is called the contributor's \"contributor version\".\n\n A contributor's \"essential patent claims\" are all patent claims\nowned or controlled by the contributor, whether already acquired or\nhereafter acquired, that would be infringed by some manner, permitted\nby this License, of making, using, or selling its contributor version,\nbut do not include claims that would be infringed only as a\nconsequence of further modification of the contributor version. For\npurposes of this definition, \"control\" includes the right to grant\npatent sublicenses in a manner consistent with the requirements of\nthis License.\n\n Each contributor grants you a non-exclusive, worldwide, royalty-free\npatent license under the contributor's essential patent claims, to\nmake, use, sell, offer for sale, import and otherwise run, modify and\npropagate the contents of its contributor version.\n\n In the following three paragraphs, a \"patent license\" is any express\nagreement or commitment, however denominated, not to enforce a patent\n(such as an express permission to practice a patent or covenant not to\nsue for patent infringement). To \"grant\" such a patent license to a\nparty means to make such an agreement or commitment not to enforce a\npatent against the party.\n\n If you convey a covered work, knowingly relying on a patent license,\nand the Corresponding Source of the work is not available for anyone\nto copy, free of charge and under the terms of this License, through a\npublicly available network server or other readily accessible means,\nthen you must either (1) cause the Corresponding Source to be so\navailable, or (2) arrange to deprive yourself of the benefit of the\npatent license for this particular work, or (3) arrange, in a manner\nconsistent with the requirements of this License, to extend the patent\nlicense to downstream recipients. \"Knowingly relying\" means you have\nactual knowledge that, but for the patent license, your conveying the\ncovered work in a country, or your recipient's use of the covered work\nin a country, would infringe one or more identifiable patents in that\ncountry that you have reason to believe are valid.\n\n If, pursuant to or in connection with a single transaction or\narrangement, you convey, or propagate by procuring conveyance of, a\ncovered work, and grant a patent license to some of the parties\nreceiving the covered work authorizing them to use, propagate, modify\nor convey a specific copy of the covered work, then the patent license\nyou grant is automatically extended to all recipients of the covered\nwork and works based on it.\n\n A patent license is \"discriminatory\" if it does not include within\nthe scope of its coverage, prohibits the exercise of, or is\nconditioned on the non-exercise of one or more of the rights that are\nspecifically granted under this License. You may not convey a covered\nwork if you are a party to an arrangement with a third party that is\nin the business of distributing software, under which you make payment\nto the third party based on the extent of your activity of conveying\nthe work, and under which the third party grants, to any of the\nparties who would receive the covered work from you, a discriminatory\npatent license (a) in connection with copies of the covered work\nconveyed by you (or copies made from those copies), or (b) primarily\nfor and in connection with specific products or compilations that\ncontain the covered work, unless you entered into that arrangement,\nor that patent license was granted, prior to 28 March 2007.\n\n Nothing in this License shall be construed as excluding or limiting\nany implied license or other defenses to infringement that may\notherwise be available to you under applicable patent law.\n\n 12. No Surrender of Others' Freedom.\n\n If conditions are imposed on you (whether by court order, agreement or\notherwise) that contradict the conditions of this License, they do not\nexcuse you from the conditions of this License. If you cannot convey a\ncovered work so as to satisfy simultaneously your obligations under this\nLicense and any other pertinent obligations, then as a consequence you may\nnot convey it at all. For example, if you agree to terms that obligate you\nto collect a royalty for further conveying from those to whom you convey\nthe Program, the only way you could satisfy both those terms and this\nLicense would be to refrain entirely from conveying the Program.\n\n 13. Use with the GNU Affero General Public License.\n\n Notwithstanding any other provision of this License, you have\npermission to link or combine any covered work with a work licensed\nunder version 3 of the GNU Affero General Public License into a single\ncombined work, and to convey the resulting work. The terms of this\nLicense will continue to apply to the part which is the covered work,\nbut the special requirements of the GNU Affero General Public License,\nsection 13, concerning interaction through a network will apply to the\ncombination as such.\n\n 14. Revised Versions of this License.\n\n The Free Software Foundation may publish revised and/or new versions of\nthe GNU General Public License from time to time. Such new versions will\nbe similar in spirit to the present version, but may differ in detail to\naddress new problems or concerns.\n\n Each version is given a distinguishing version number. If the\nProgram specifies that a certain numbered version of the GNU General\nPublic License \"or any later version\" applies to it, you have the\noption of following the terms and conditions either of that numbered\nversion or of any later version published by the Free Software\nFoundation. If the Program does not specify a version number of the\nGNU General Public License, you may choose any version ever published\nby the Free Software Foundation.\n\n If the Program specifies that a proxy can decide which future\nversions of the GNU General Public License can be used, that proxy's\npublic statement of acceptance of a version permanently authorizes you\nto choose that version for the Program.\n\n Later license versions may give you additional or different\npermissions. However, no additional obligations are imposed on any\nauthor or copyright holder as a result of your choosing to follow a\nlater version.\n\n 15. Disclaimer of Warranty.\n\n THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY\nAPPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT\nHOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY\nOF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,\nTHE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR\nPURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM\nIS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF\nALL NECESSARY SERVICING, REPAIR OR CORRECTION.\n\n 16. Limitation of Liability.\n\n IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING\nWILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS\nTHE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY\nGENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE\nUSE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF\nDATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD\nPARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),\nEVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF\nSUCH DAMAGES.\n\n 17. Interpretation of Sections 15 and 16.\n\n If the disclaimer of warranty and limitation of liability provided\nabove cannot be given local legal effect according to their terms,\nreviewing courts shall apply local law that most closely approximates\nan absolute waiver of all civil liability in connection with the\nProgram, unless a warranty or assumption of liability accompanies a\ncopy of the Program in return for a fee.\n\n END OF TERMS AND CONDITIONS\n\n How to Apply These Terms to Your New Programs\n\n If you develop a new program, and you want it to be of the greatest\npossible use to the public, the best way to achieve this is to make it\nfree software which everyone can redistribute and change under these terms.\n\n To do so, attach the following notices to the program. It is safest\nto attach them to the start of each source file to most effectively\nstate the exclusion of warranty; and each file should have at least\nthe \"copyright\" line and a pointer to where the full notice is found.\n\n \n Copyright (C) \n\n This program is free software: you can redistribute it and/or modify\n it under the terms of the GNU General Public License as published by\n the Free Software Foundation, either version 3 of the License, or\n (at your option) any later version.\n\n This program is distributed in the hope that it will be useful,\n but WITHOUT ANY WARRANTY; without even the implied warranty of\n MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n GNU General Public License for more details.\n\n You should have received a copy of the GNU General Public License\n along with this program. If not, see .\n\nAlso add information on how to contact you by electronic and paper mail.\n\n If the program does terminal interaction, make it output a short\nnotice like this when it starts in an interactive mode:\n\n Copyright (C) \n This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.\n This is free software, and you are welcome to redistribute it\n under certain conditions; type `show c' for details.\n\nThe hypothetical commands `show w' and `show c' should show the appropriate\nparts of the General Public License. Of course, your program's commands\nmight be different; for a GUI interface, you would use an \"about box\".\n\n You should also get your employer (if you work as a programmer) or school,\nif any, to sign a \"copyright disclaimer\" for the program, if necessary.\nFor more information on this, and how to apply and follow the GNU GPL, see\n.\n\n The GNU General Public License does not permit incorporating your program\ninto proprietary programs. If your program is a subroutine library, you\nmay consider it more useful to permit linking proprietary applications with\nthe library. If this is what you want to do, use the GNU Lesser General\nPublic License instead of this License. But first, please read\n.\n" }, { "path": "Makefile", "content": "# * makem.sh/Makefile --- Script to aid building and testing Emacs Lisp packages\n\n# URL: https://github.com/alphapapa/makem.sh\n# Version: 0.5\n\n# * Arguments\n\n# For consistency, we use only var=val options, not hyphen-prefixed options.\n\n# NOTE: I don't like duplicating the arguments here and in makem.sh,\n# but I haven't been able to find a way to pass arguments which\n# conflict with Make's own arguments through Make to the script.\n# Using -- doesn't seem to do it.\n\nifdef install-deps\n\tINSTALL_DEPS = \"--install-deps\"\nendif\nifdef install-linters\n\tINSTALL_LINTERS = \"--install-linters\"\nendif\n\nifdef sandbox\n\tifeq ($(sandbox), t)\n\t\tSANDBOX = --sandbox\n\telse\n\t\tSANDBOX = --sandbox=$(sandbox)\n\tendif\nendif\n\nifdef debug\n\tDEBUG = \"--debug\"\nendif\n\n# ** Verbosity\n\n# Since the \"-v\" in \"make -v\" gets intercepted by Make itself, we have\n# to use a variable.\n\nverbose = $(v)\n\nifneq (,$(findstring vvv,$(verbose)))\n\tVERBOSE = \"-vvv\"\nelse ifneq (,$(findstring vv,$(verbose)))\n\tVERBOSE = \"-vv\"\nelse ifneq (,$(findstring v,$(verbose)))\n\tVERBOSE = \"-v\"\nendif\n\n# * Rules\n\n# TODO: Handle cases in which \"test\" or \"tests\" are called and a\n# directory by that name exists, which can confuse Make.\n\n%:\n\t@./makem.sh $(DEBUG) $(VERBOSE) $(SANDBOX) $(INSTALL_DEPS) $(INSTALL_LINTERS) $(@)\n\n.DEFAULT: init\ninit:\n\t@./makem.sh $(DEBUG) $(VERBOSE) $(SANDBOX) $(INSTALL_DEPS) $(INSTALL_LINTERS)\n" }, { "path": "README.org", "content": "#+TITLE: Ement.el\n\n#+PROPERTY: LOGGING nil\n\n# Export options.\n#+OPTIONS: broken-links:t *:t num:1 toc:1\n\n# Info export options.\n#+EXPORT_FILE_NAME: ement.texi\n#+TEXINFO_DIR_CATEGORY: Emacs\n#+TEXINFO_DIR_TITLE: Ement: (ement)\n#+TEXINFO_DIR_DESC: Matrix client for Emacs\n\n# Note: This readme works with the org-make-toc package, which automatically updates the table of contents.\n\n#+HTML: \n\n# ELPA badge image.\n[[https://elpa.gnu.org/packages/ement.html][https://elpa.gnu.org/packages/ement.svg]]\n\nEment.el is a [[http://www.matrix.org/][Matrix]] client for [[https://www.gnu.org/software/emacs/][GNU Emacs]]. It aims to be simple, fast, featureful, and reliable, while integrating naturally with Emacs.\n\nFeel free to join us in the chat room: [[https://matrix.to/#/#ement.el:matrix.org][https://img.shields.io/matrix/ement.el:matrix.org.svg?label=%23ement.el:matrix.org]]\n\n* Contents :noexport:\n:PROPERTIES:\n:TOC: :include siblings\n:END:\n:CONTENTS:\n- [[#installation][Installation]]\n- [[#usage][Usage]]\n - [[#bindings][Bindings]]\n - [[#tips][Tips]]\n - [[#encrypted-room-support-through-pantalaimon][Encrypted room support through Pantalaimon]]\n- [[#changelog][Changelog]]\n- [[#development][Development]]\n:END:\n\n* Screenshots :noexport:\n:PROPERTIES:\n:ID: d818f690-5f22-4eb0-83e1-4d8ce16c9e5b\n:END:\n\nThe default formatting style resembles IRC clients, with each message being prefixed by the username (which enables powerful Emacs features, like using Occur to show all messages from or mentioning a user). Alternative, built-in styles include an Element-like one with usernames above groups of messages, as well as a classic, no-margins IRC style. Messages may be optionally displayed with unique colors for each user (with customizable contrast), making it easier to follow conversations. Timestamp headers are optionally displayed where a certain amount of time passes between events, as well as where the date changes.\n\n[[images/ement-for-twim.png]]\n\n/Two rooms shown in side-by-side buffers, showing inline images, reactions, date/time headings, room avatars, and messages colored by user (using the modus-vivendi Emacs theme)./\n\n[[images/emacs-with-fully-read-line.png]]\n\n/#emacs:libera.chat showing colored text from IRC users, replies with quoted parts, messages colored by user, addressed usernames colored by their user color, highlighted mentions, and the fully-read marker line (using the modus-vivendi Emacs theme)./\n\n[[images/screenshot5.png]]\n\n/Four rooms shown at once, with messages colored by user, in the default Emacs theme./\n\n[[images/screenshot2.png]]\n\n/A room at the top in the \"Elemental\" display style, with sender names displayed over groups of messages, and only self-messages in an alternate color. The lower window shows an earlier version of the rooms list./\n\n[[images/reactions.png]]\n\n/Reactions displayed as color emojis (may need [[#displaying-symbols-and-emojis][proper Emacs configuration]])./\n\n* Installation\n:PROPERTIES:\n:TOC: :depth 0\n:END:\n\n** GNU ELPA\n\nEment.el is published in [[http://elpa.gnu.org/][GNU ELPA]] as [[https://elpa.gnu.org/packages/ement.html][ement]], so it may be installed in Emacs with the command ~M-x package-install RET ement RET~. This is the recommended way to install Ement.el, as it will install the current stable release.\n\nThe latest development build may be installed from [[https://elpa.gnu.org/devel/ement.html][ELPA-devel]] or from Git (see below).\n\n** GNU Guix\n\nEment.el is available in [[https://guix.gnu.org/][GNU Guix]] as [[https://packages.guix.gnu.org/packages/emacs-ement/][emacs-ement]].\n\n** Debian, Ubuntu\n\nEment.el is available in [[https://packages.debian.org/elpa-ement][Debian as elpa-ement]] and in [[https://packages.ubuntu.com/search?suite=default§ion=all&arch=any&keywords=elpa-ement&searchon=names][Ubuntu as elpa-ement]].\n\n** Nix\n\nEment.el is available in [[https://nixos.org/][NixOS]] as [[https://search.nixos.org/packages?channel=23.05&show=emacsPackages.ement&from=0&size=50&sort=relevance&type=packages&query=ement][emacsPackages.ement]].\n\n** Other distributions\n\nEment.el is also available in some other distributions. See [[https://repology.org/project/emacs:ement/related][Repology]] for details.\n\n** Git master\n\nThe ~master~ branch of the Git repository is intended to be usable at all times; only minor bugs are expected to be found in it before a new stable release is made.\n\nTo install, it is recommended to use [[https://github.com/quelpa/quelpa-use-package][quelpa-use-package]], like this (using [[https://github.com/alphapapa/unpackaged.el#upgrade-a-quelpa-use-package-forms-package][this helpful command]] for upgrading versions):\n\n#+BEGIN_SRC elisp\n ;; Install and load `quelpa-use-package'.\n (package-install 'quelpa-use-package)\n (require 'quelpa-use-package)\n\n ;; Install Ement.\n (use-package ement\n :quelpa (ement :fetcher github :repo \"alphapapa/ement.el\"))\n#+END_SRC\n\nOne might also use systems like [[https://github.com/progfolio/elpaca][Elpaca]] or [[https://github.com/radian-software/straight.el][Straight]] (which is also used by [[https://github.com/doomemacs/doomemacs][DOOM]]), but the author cannot offer support for them.\n\n** Manual\n\nEment.el is intended to be installed with Emacs's package system, which will ensure that the required autoloads are generated, etc. If you choose to install it manually, you're on your own.\n\n* Usage\n:PROPERTIES:\n:TOC: :include descendants :depth 1\n:END:\n:CONTENTS:\n- [[#bindings][Bindings]]\n- [[#tips][Tips]]\n- [[#encrypted-room-support-through-pantalaimon][Encrypted room support through Pantalaimon]]\n:END:\n\n1. Call command ~ement-connect~ to connect. Multiple sessions are supported: call the command again with a ~C-u~ universal prefix to connect to another account.\n2. Wait for initial sync to complete (which can take a few moments--initial sync JSON responses can be large).\n3. Use these commands (room-related commands may be called with universal prefix to prompt for the room):\n - ~ement-list-rooms~ to view the list of joined rooms.\n - ~ement-view-room~ to view a room's buffer, selected with completion.\n - ~ement-create-room~ to create a new room.\n - ~ement-create-space~ to create a space.\n - ~ement-invite-user~ to invite a user to a room.\n - ~ement-join-room~ to join a room.\n - ~ement-leave-room~ to leave a room.\n - ~ement-forget-room~ to forget a room.\n - ~ement-tag-room~ to toggle a tag on a room (including favorite/low-priority status).\n - ~ement-list-members~ to list members in a room.\n - ~ement-send-direct-message~ to send a direct message to a user (in an existing direct room, or creating a new one automatically).\n - ~ement-room-edit-message~ to edit a message at point.\n - ~ement-room-send-file~ to send a file.\n - ~ement-room-send-image~ to send an image.\n - ~ement-room-set-topic~ to set a room's topic.\n - ~ement-room-occur~ to search in a room's known events.\n - ~ement-room-override-name~ to override a room's display name.\n - ~ement-ignore-user~ to ignore a user (or with interactive prefix, un-ignore).\n - ~ement-room-set-message-format~ to set a room's message format buffer-locally.\n - ~ement-room-toggle-space~ to toggle a room's membership in a space (a way to group rooms in Matrix).\n - ~ement-directory~ to view a room directory.\n - ~ement-directory-search~ to search a room directory.\n4. Use these special buffers to see events from multiple rooms (you can also reply to messages from these buffers!):\n - See all new events that mention you in the =*Ement Mentions*= buffer.\n - See all new events in rooms that have open buffers in the =*Ement Notifications*= buffer.\n\n** Bindings\n\nThese bindings are common to all of the following buffer types:\n\n+ Switch to a room buffer: ~M-g M-r~\n+ Switch to the room list buffer: ~M-g M-l~\n+ Switch to the mentions buffer: ~M-g M-m~\n+ Switch to the notifications buffer: ~M-g M-n~\n\n*** Room buffers\n\nNote that if global minor mode ~ement-room-self-insert-mode~ is enabled (by default it is disabled), typing any of the common printable ascii characters (such as letters) in a room buffer will start a new message, and most of the following bindings are instead accessed via a prefix key. See the minor mode docstring for details. (The ~?~ binding is an exception; by default it opens the command menu regardless of this minor mode.)\n\n+ Show command menu: ~?~\n\n[[images/transient.png]]\n\n*Movement*\n\n+ Next event: ~n~\n+ Previous event: ~p~\n+ End of buffer: ~N~\n+ Scroll up and mark read: ~SPC~\n+ Scroll down: ~S-SPC~\n+ Jump to fully-read marker: ~M-g M-p~\n+ Move read markers to point: ~m~\n+ Load older messages: at top of buffer, scroll contents up (i.e. ~S-SPC~, ~M-v~ or ~mwheel-scroll~)\n\n*Switching*\n\n+ List rooms: ~M-g M-l~\n+ Switch to other room: ~M-g M-r~\n+ Switch to mentions buffer: ~M-g M-m~\n+ Switch to notifications buffer: ~M-g M-n~\n+ Quit window: ~q~\n\n*Messages*\n\n+ Write message: ~RET~\n+ Compose message in buffer: ~M-RET~ (while writing in minibuffer: ~C-c '‍~). Customize the option ~ement-room-compose-method~ to make ~RET~ and the other message bindings use a compose buffer by default. Use command ~ement-room-compose-org~ to activate Org mode in the compose buffer.\n+ Write reply to event at point: ~S-~\n+ Edit message: ~~\n+ Delete message: ~C-k~\n+ Send reaction to event at point, or send same reaction at point: ~s r~\n+ Send emote: ~s e~\n+ Send file: ~s f~\n+ Send image: ~s i~\n+ View event source: ~v~\n+ Complete members and rooms at point: ~C-M-i~ (standard ~completion-at-point~ command). (Type an ~@~ prefix for a member mention, a ~#~ prefix for a room alias, or a ~!~ prefix for a room ID.)\n\n*Images*\n\n+ Toggle scale of image (between fit-to-window and thumbnail): ~mouse-1~\n+ Show image in new buffer at full size: ~double-mouse-1~\n\n*Users*\n\n+ Send direct message: ~u RET~\n+ Invite user: ~u i~\n+ Ignore user: ~u I~\n\n*Room*\n\n+ Occur search in room: ~M-s o~\n+ List members: ~r m~\n+ Set topic: ~r t~\n+ Set message format: ~r f~\n+ Set notification rules: ~r n~\n+ Override display name: ~r N~\n+ Tag/untag room: ~r T~\n\n*Room membership*\n\n+ Create room: ~R c~\n+ Join room: ~R j~\n+ Leave room: ~R l~\n+ Forget room: ~R F~\n+ Toggle room's spaces: ~R s~\n\n*Other*\n\n+ Sync new messages (not necessary if auto sync is enabled; with prefix to force new sync): ~g~\n\n*** Room list buffer\n\n+ Show buffer of room at point: ~RET~\n+ Show buffer of next unread room: ~SPC~\n+ Move between room names: ~TAB~ / ~~\n\n+ Kill room's buffer: ~k~\n+ Toggle room's membership in a space: ~s~\n\n*** Directory buffers\n\n+ View/join a room: ~RET~ / ~mouse-1~\n+ Load next batch of rooms: ~+~\n\n*** Mentions/notifications buffers\n\n+ Move between events: ~TAB~ / ~~\n+ Go to event at point in its room buffer: ~RET~\n+ Write reply to event at point (shows the event in its room while writing): ~S-~\n\n** Tips\n\n# TODO: Show sending messages in Org format.\n\n+ Desktop notifications are enabled by default for events that mention the local user. They can also be shown for all events in rooms with open buffers.\n+ Send messages in Org mode format by customizing the option ~ement-room-send-message-filter~ (which enables Org format by default), or by calling ~ement-room-compose-org~ in a compose buffer (which enables it for a single message). Then Org-formatted messages are automatically converted and sent as HTML-formatted messages (with the Org syntax as the plain-text fallback). You can send syntax such as:\n - Bold, italic, underline, strikethrough\n - Links\n - Tables\n - Source blocks (including results with ~:exports both~)\n - Footnotes (okay, that might be pushing it, but you can!)\n - And, generally, anything that Org can export to HTML\n - Note that the default ~org-export-preserve-breaks~ value causes singular line breaks to be exported as spaces. To preserve the line breaks, indentation, and blank lines in a region, but otherwise use normal formatting, you can use the ~verse~ block type. Refer to ~(info \"(org) Paragraphs\")~ and ~(info \"(org) Structure Templates\")~ for details.\n+ Starting in the room list buffer, by pressing ~SPC~ repeatedly, you can cycle through and read all rooms with unread buffers. (If a room doesn't have a buffer, it will not be included.)\n+ Room buffers and the room-list buffer can be bookmarked in Emacs, i.e. using =C-x r m=. This is especially useful with [[https://github.com/alphapapa/burly.el][Burly]]: you can arrange an Emacs frame with several room buffers displayed at once, use =burly-bookmark-windows= to bookmark the layout, and then you can restore that layout and all of the room buffers by opening the bookmark, rather than having to manually arrange them every time you start Emacs or change the window configuration.\n+ Images and other files can be uploaded to rooms using drag-and-drop.\n+ Mention members by typing a ~@~ followed by their displayname or Matrix ID. (Members' names and rooms' aliases/IDs may be completed with ~completion-at-point~ commands.)\n+ Customize ~ement-room-use-variable-pitch~ to render messages using proportional fonts.\n+ You can customize settings in the ~ement~ group.\n - *Note:* ~setq~ should not be used for certain options, because it will not call the associated setter function. Users who have an aversion to the customization system may experience problems.\n\n*** Displaying symbols and emojis\n\nEmacs may not display certain symbols and emojis well by default. Based on [[https://emacs.stackexchange.com/questions/62049/override-the-default-font-for-emoji-characters][this question and answer]], you may find that the simplest way to fix this is to install an appropriate font, like [[https://www.google.com/get/noto/#emoji-zsye][Noto Emoji]], and then use this Elisp code:\n\n#+BEGIN_SRC elisp\n (setf use-default-font-for-symbols nil)\n (set-fontset-font t 'unicode \"Noto Emoji\" nil 'append)\n#+END_SRC\n\n** Encrypted room support through Pantalaimon\n\nEment.el doesn't support encrypted rooms natively, but it can be used transparently with the E2EE-aware reverse proxy daemon [[https://github.com/matrix-org/pantalaimon/][Pantalaimon]]. After configuring it according to its documentation, call ~ement-connect~ with the appropriate hostname and port, like:\n\n#+BEGIN_SRC elisp\n (ement-connect :uri-prefix \"http://localhost:8009\")\n#+END_SRC\n\n* Changelog\n:PROPERTIES:\n:TOC: :depth 0\n:END:\n\n** 0.18-pre\n\nNothing new yet.\n\n** 0.17\n\n*Additions*\n\n+ Command ~ement-room-download-file~, which downloads the file in the event at point (for image, audio, video, and file messages). ([[https://github.com/alphapapa/ement.el/pull/323][#323]]. Thanks to [[https://github.com/viiru-][Arto Jantunen]].)\n+ Customization groups for faces. (Thanks to [[https://github.com/phil-s][Phil Sainty]].)\n+ Option ~ement-room-hide-redacted-message-content~, which hides the content of redacted messages by default. It may be disabled to keep redacted content visible with a strikethrough face, which may be useful for room moderators, but users should keep in mind that doing so will leave unpleasant content visible in the current session, even after being redacted by moderators.\n+ Option ~ement-room-list-avatar-generation~: if disabled, SVG-based room avatars are not generated. This option automatically tests whether SVG support is available in Emacs, and should allow use with builds of Emacs that lack =librsvg= support. \n\n*Changes*\n\n+ Disable underline for faces ~ement-room-list-direct~ and ~ement-room-list-name~ (in case a face they inherit from enables it, e.g. when themed).\n\n*Fixes*\n\n+ Call ~eww-browse-url~ instead of ~browse-url~ in ~ement-room-browse-mxc~ (because the latter is not useful for authenticated media if the user has configured it to use a different browser). ([[https://github.com/alphapapa/ement.el/pull/323][#323]]. Thanks to [[https://github.com/viiru-][Arto Jantunen]].)\n+ Workaround change in ~magit-section~ that broke fontification in room-list and directory buffers. (See [[https://github.com/alphapapa/ement.el/issues/331][#331]].)\n+ Handle non-symbol commands in ~command-history~. ([[https://github.com/alphapapa/ement.el/issues/330][#330]]. Thanks to [[https://github.com/stsquad][Alex Bennée]] for reporting.)\n\n** 0.16\n\n*Compatibility*\n\n+ Use authenticated media requests (part of Matrix 1.11; see [[https://github.com/matrix-org/matrix-spec-proposals/pull/3916][MSC3916]] and [[https://matrix.org/blog/2024/06/26/sunsetting-unauthenticated-media/][matrix.org's sunsetting unauthenticated media]]).\n\n*Additions*\n\n+ When option ~ement-room-images~ is disabled (preventing automatic download and display of images), individual images may be shown by clicking the button in their events.\n\n*Changes*\n\n+ Option ~ement-room-coalesce-events~ may now be set to (and defaults to) a maximum number of events to coalesce together. (This avoids potential performance problems in rare cases. See [[https://github.com/alphapapa/ement.el/issues/247][#247]]. Thanks to [[https://github.com/viiru-][Arto Jantunen]] for reporting and [[https://github.com/sergiodj][Sergio Durigan Junior]] for testing.)\n\n*Fixes*\n+ Replies to edited messages are correctly sent to the original event (whereas previously they were sent to the edit, which caused reactions to not be shown). ([[https://github.com/alphapapa/ement.el/issues/230][#230]], [[https://github.com/alphapapa/ement.el/issues/277][#277]]. Thanks to [[https://github.com/phil-s][Phil Sainty]] for suggesting, and to [[https://github.com/dionisos2][dionisos]] for reporting.)\n+ Set ~filter-buffer-substring-function~ in room buffers to prevent undesired text properties from being included in copied text. ([[https://github.com/alphapapa/ement.el/pull/278][#278]]. Thanks to [[https://github.com/phil-s][Phil Sainty]].)\n+ Command ~ement-disconnect~ no longer shows an error message. ([[https://github.com/alphapapa/ement.el/issues/208][#208]].)\n+ Retrieval of earlier events in a just-joined room. ([[https://github.com/alphapapa/ement.el/issues/148][#148]]. Thanks to [[https://github.com/MagicRB][Richard Brežák]] for reporting, and to [[https://github.com/phil-s][Phil Sainty]] for testing.)\n+ Cache computed displaynames in rooms (avoiding unnecessary reiteration and recalculation). ([[https://github.com/alphapapa/ement.el/issues/298][#298]]. Thanks to [[https://github.com/Rutherther][Rutherther]] for reporting and testing, and to [[https://github.com/phil-s][Phil Sainty]].)\n+ Customization group for options ~ement-room-mode-hook~ and ~ement-room-self-insert-mode~. (Thanks to [[https://github.com/phil-s][Phil Sainty]].)\n+ Inheritance for some faces. ([[https://github.com/alphapapa/ement.el/pull/303][#303]]. Thanks to [[https://github.com/tarsius][Jonas Bernoulli]].) \n\n** 0.15.1\n\n*Fixes*\n+ Handle unnamed rooms in ~ement-directory~ list. (See [[https://github.com/alphapapa/ement.el/issues/248][#248]]. Thanks to [[https://github.com/hjozwiak][Hunter Jozwiak]] and [[https://github.com/bmp][Bharath Palavalli]] for reporting.)\n+ Don't use ~cl-type~ ~pcase~ form in Emacs versions before 28. ([[https://github.com/alphapapa/ement.el/issues/279][#279]]. Thanks to [[https://github.com/AdamBark][Adam Bark]] for reporting.)\n\n** 0.15\n:PROPERTIES:\n:ID: 81b48364-56a7-4903-b354-b79905edb039\n:END:\n\n*Additions*\n\n+ Configurable emoji picker for sending reactions. ([[https://github.com/alphapapa/ement.el/issues/199][#199]], [[https://github.com/alphapapa/ement.el/pull/201][#201]]. Thanks to [[https://github.com/oantolin][Omar Antolín Camarena]].) ::\n - Option ~ement-room-reaction-picker~ sets the default picker. Within that, the user may press ~C-g~ to choose a different one with a key bound in ~ement-room-reaction-map~.\n\n+ A variety of enhancements for using compose buffers. ([[https://github.com/alphapapa/ement.el/issues/140][#140]]. Thanks to [[https://github.com/phil-s][Phil Sainty]].) :: Chiefly, messages can now be composed in small windows below room windows, rather than in the minibuffer or a full-sized window. A variety of options and commands are available related to these features. See [[#compose-buffer-enhancements][compose buffer enhancements]].\n\n+ Global minor mode ~ement-room-self-insert-mode~ enables \"just typing\" to start a message. (Thanks to [[https://github.com/phil-s][Phil Sainty]].) :: See [[#ement-room-self-insert-mode][ement-room-self-insert-mode]].\n\n+ Options affecting how images are displayed in room buffers. :: See [[#image-display][image display]].\n\n*Changes*\n\n+ Improve prompt used when viewing a room that is not joined. ([[https://github.com/alphapapa/ement.el/issues/241][#241]]. Thanks to [[https://github.com/phil-s][Phil Sainty]].)\n+ Format \"was kicked and rejoined\" membership event pairs.\n+ Enclose reasons for membership events in quotes for clarity.\n+ Improve default room list grouping.\n+ When editing or replying to a message in a compose buffer, the related room event is highlighted persistently until the compose buffer is killed. (Thanks to [[https://github.com/phil-s][Phil Sainty]].)\n+ In compose buffers ~dabbrev~ will prioritise firstly the associated room, and secondly all other rooms, before looking to other buffers for completions. (Thanks to [[https://github.com/phil-s][Phil Sainty]].)\n+ Aborted messages are now added to ~ement-room-message-history~ rather than the kill-ring. (Thanks to [[https://github.com/phil-s][Phil Sainty]].)\n+ Prefix bindings in ~ement-room-mode-map~ now have named labels in ~which-key~ and similar. (Thanks to [[https://github.com/phil-s][Phil Sainty]].)\n+ Option: ~ement-room-use-variable-pitch~ (previously named ~ement-room-shr-use-fonts~) enables variable-pitch fonts for all message types. (This option previously supported formatted messages, but now works for plain text messages as well.) Note: users who have customized the ~ement-room-message-text~ face to be variable-pitch should revert that change, as it causes problems for formatted messages, and is no longer necessary. ([[https://github.com/alphapapa/ement.el/issues/174][#174]]. Thanks to [[https://github.com/phil-s][Phil Sainty]].)\n\n*Fixes*\n\n+ Edits to previous edit events are correctly sent to the server as edits to the original message event. ([[https://github.com/alphapapa/ement.el/issues/230][#230]]. Thanks to [[https://github.com/phil-s][Phil Sainty]].)\n+ Completion at point works more reliably in compose buffers. (Thanks to [[https://github.com/phil-s][Phil Sainty]].)\n+ Toggling images to fill the window body no longer triggers unintended scrolling. (Thanks to [[https://github.com/phil-s][Phil Sainty]].)\n+ Recognition of mentions after a newline. ([[https://github.com/alphapapa/ement.el/issues/267][#267]]. Thanks to [[https://github.com/phil-s][Phil Sainty]].)\n+ Newlines in ~ement-room-message-format-spec~ are considered when calculating the wrap-prefix. (Thanks to [[https://github.com/phil-s][Phil Sainty]].)\n+ Weight of face ~ement-room-list-direct~ (now correctly bold in room list heading).\n\n*** Compose buffer enhancements\n:PROPERTIES:\n:CUSTOM_ID: compose-buffer-enhancements\n:END:\n\n- Option ~ement-room-compose-buffer-display-action~ declares how and where a new compose buffer window should be displayed. (By default, in a new window below the associated room buffer.)\n- Option ~ement-room-compose-buffer-window-dedicated~ determines whether compose buffers will have dedicated windows.\n- Option ~ement-room-compose-buffer-window-auto-height~ causes dynamic scaling of the compose buffer window height so that the full message is visible at all times.\n- Option ~ement-room-compose-buffer-window-auto-height-min~ specifies the minimum window height when ~ement-room-compose-buffer-window-auto-height~ is enabled.\n- Option ~ement-room-compose-buffer-window-auto-height-max~ specifies the maximum window height when ~ement-room-compose-buffer-window-auto-height~ is enabled.\n- Option ~ement-room-compose-method~ chooses between minibuffer-centric or compose-buffer-centric behaviour.\n- Command ~ement-room-dispatch-new-message~ starts writing a new message using your chosen ~ement-room-compose-method~. (Bound to ~RET~ in room buffers.)\n- Command ~ement-room-dispatch-new-message-alt~ starts writing a new message using the alternative method. (Bound to ~M-RET~ in room buffers.)\n- Command ~ement-room-dispatch-edit-message~ edits a message using your chosen ~ement-room-compose-method~. (Bound to ~~ in room buffers.)\n- Command ~ement-room-dispatch-reply-to-message~ replies to a message using your chosen ~ement-room-compose-method~. (Bound to ~S-~ in room buffers.)\n- Command ~ement-room-compose-edit~ edits a message using a compose buffer.\n- Command ~ement-room-compose-reply~ replies to a message using a compose buffer.\n- Command ~ement-room-compose-send-direct~ sends a message directly from a compose buffer (without the minibuffer). (Bound to ~C-x C-s~ in compose buffers.)\n- Command ~ement-room-compose-abort~ kills the compose buffer and delete its window. (Bound to ~C-c C-k~ in compose buffers.)\n- Command ~ement-room-compose-abort-no-history~ does the same without adding to ~ement-room-message-history~. (Equivalent to ~C-u C-c C-k~.)\n- Command ~ement-room-compose-history-prev-message~ cycles backwards through ~ement-room-message-history~. (Bound to ~M-p~ in compose buffers.)\n- Command ~ement-room-compose-history-next-message~ cycles forwards through ~ement-room-message-history~. (Bound to ~M-n~ in compose buffers.)\n- Command ~ement-room-compose-history-isearch-backward~ initiates an isearch through ~ement-room-message-history~. (Bound to ~M-r~ in compose buffers; continue searching with ~C-r~ or ~C-s~.)\n- Command ~ement-room-compose-history-isearch-backward-regexp~ initiates a regexp isearch through ~ement-room-message-history~. (Bound to ~C-M-r~ in compose buffers; continue searching with ~C-r~ or ~C-s~.)\n\n*** ~ement-room-self-insert-mode~\n:PROPERTIES:\n:CUSTOM_ID: ement-room-self-insert-mode\n:END:\n\n- Option ~ement-room-self-insert-commands~ determines which commands will start a new message when ~ement-room-self-insert-mode~ is enabled (defaulting to ~self-insert-command~ and ~yank~).\n- Option ~ement-room-self-insert-chars~ determines which typed characters will start a new message when ~ement-room-self-insert-mode~ is enabled (regardless of whether they are bound to ~self-insert-command~).\n- Option ~ement-room-mode-map-prefix-key~ defines a prefix key for accessing the full ~ement-room-mode-map~ when ~ement-room-self-insert-mode~ is enabled. (By default this key is ~DEL~.)\n \n*** Image display\n:PROPERTIES:\n:CUSTOM_ID: image-display\n:END:\n\n- Option ~ement-room-image-margin~ is the number of pixels of margin around image thumbnails.\n- Option ~ement-room-image-relief~ is the number of pixels of shadow rectangle around image thumbnails.\n- Option ~ement-room-image-thumbnail-height~ is the window body height multiple to use when toggling full-sized images to thumbnails (by default, 0.2).\n- Option ~ement-room-image-thumbnail-height-min~ is the minimum pixel height for thumbnail images (by default, 30 pixels).\n\n\n\n** 0.14\n\n*Additions*\n\n+ Audio events are rendered as a link to the audio file. (Thanks to [[https://github.com/viiru-][Arto Jantunen]].)\n+ Customization group ~ement-room-list~.\n+ Option ~ement-room-list-space-prefix~ is applied to space names in the room list (e.g. set to empty string for cleaner appearance).\n+ Option ~ement-room-reaction-names-limit~ sets how many senders of a reaction are shown in the buffer (more than that many are shown in the tooltip).\n\n*Changes*\n\n+ Bind ~TAB~ / ~BACKTAB~ to move between links in room and like buffers. ([[https://github.com/alphapapa/ement.el/issues/113][#113]]. Thanks to [[https://github.com/ericsfraga][Eric S. Fraga]] for suggesting.)\n\n*Fixes*\n\n+ Insertion of sender headers (when using \"Elemental\" message format). (Refactoring contributed by [[https://github.com/Stebalien][Steven Allen]].)\n+ Some room event data was being unintentionally serialized to disk when caching the room list visibility state. ([[https://github.com/alphapapa/ement.el/issues/256][#256]])\n+ Notifications buffer restores properly when bookmarked.\n+ Command ~ement-room-send-reaction~ checks for an event at point. (Thanks to [[https://github.com/phil-s][Phil Sainty]].)\n\n** 0.13\n\n*Additions*\n\n+ Group joined direct rooms in directory buffers.\n+ Command ~end-of-buffer~ is bound to ~N~ in room buffers.\n\n*Changes*\n\n+ Command ~ement-room-image-show~ use frame parameters to maximize the frame, making it easier for users to override. ([[https://github.com/alphapapa/ement.el/issues/223][#223]]. Thanks to [[https://github.com/progfolio][Nicholas Vollmer]].)\n\n*Fixes*\n\n+ Name for direct rooms in directory buffers.\n+ Editing a message from the compose buffer would be sent as a reply to the edited message. (Fixes [[https://github.com/alphapapa/ement.el/issues/189][#189]]. Thanks to [[https://github.com/phil-s][Phil Sainty]] for reporting.)\n+ Editing an already-edited message. ([[https://github.com/alphapapa/ement.el/issues/226][#226]]. Thanks to [[https://github.com/phil-s][Phil Sainty]] for reporting.)\n+ Replying to an already-edited message. ([[https://github.com/alphapapa/ement.el/issues/227][#227]]. Thanks to [[https://github.com/phil-s][Phil Sainty]] for reporting.)\n+ Rendering redactions of edited messages. ([[https://github.com/alphapapa/ement.el/issues/228][#228]]. Thanks to [[https://github.com/phil-s][Phil Sainty]] for reporting.)\n+ Redacting an edited message. ([[https://github.com/alphapapa/ement.el/issues/228][#228]]. Thanks to [[https://github.com/phil-s][Phil Sainty]] for reporting.)\n+ Command ~ement-room-flush-colors~ maintains point position.\n\n** 0.12\n\n*Additions*\n\n+ Command ~ement-notifications~ shows recent notifications, similar to the pane in the Element client. (This new command fetches recent notifications from the server and allows scrolling up to retrieve older ones. Newly received notifications, as configured in the ~ement-notify~ options, are displayed in the same buffer. This functionality will be consolidated in the future.)\n+ Face ~ement-room-quote~, applied to quoted parts of replies.\n\n*Changes*\n+ Commands ~ement-room-goto-next~ and ~ement-room-goto-prev~ work more usefully at the end of a room buffer. (Now pressing ~n~ on the last event moves point to the end of the buffer so it will scroll automatically for new messages, and then pressing ~p~ skips over any read marker to the last event.)\n+ Room buffer bindings:\n + ~ement-room-goto-next~ and ~ement-room-goto-prev~ are bound to ~n~ and ~p~, respectively.\n + ~ement-room-goto-fully-read-marker~ is bound to ~M-g M-p~ (the mnemonic being \"go to previously read\").\n+ The quoted part of a reply now omits the face applied to the rest of the message, helping to distinguish them.\n+ Commands that read a string from the minibuffer in ~ement-room~ buffers and ~ement-connect~ user ID prompts use separate history list variables.\n+ Use Emacs's Jansson-based JSON-parsing functions when available. (This results in a 3-5x speed improvement for parsing JSON responses, which can be significant for large initial sync responses. Thanks to [[https://github.com/rrix/][Ryan Rix]] for discovering this!)\n\n*Fixes*\n\n+ File event formatter assumed that file size metadata would be present (a malformed, e.g. spam, event might not have it).\n+ Send correct file size when sending files/images.\n+ Underscores are no longer interpreted as denoting subscripts when sending messages in Org format. (Thanks to [[https://github.com/phil-s][Phil Sainty]].)\n+ Add workaround for ~savehist-mode~'s serializing of the ~command-history~ variable's arguments. (For ~ement-~ commands, that may include large data structures, like ~ement-session~ structs, which should never be serialized or reused, and ~savehist~'s doing so could cause noticeable delays for users who enabled it). (See [[https://github.com/alphapapa/ement.el/issues/216][#216]]. Thanks to [[https://github.com/phil-s][Phil Sainty]] and other users who helped to discover this problem.)\n\n** 0.11\n\n*Additions*\n+ Commands ~ement-room-image-show~ and ~ement-room-image-scale~ (bound to ~RET~ and ~M-RET~ when point is at an image) view and scale images. (Thanks to [[https://github.com/Stebalien][Steven Allen]] for these and other image-related improvements.)\n+ Command ~ement-room-image-show-mouse~ is used to show an image with the mouse.\n\n*Changes*\n+ Enable ~image-mode~ when showing images in a new buffer. (Thanks to [[https://github.com/Stebalien][Steven Allen]].)\n+ Command ~ement-room-image-show~ is not used for mouse events.\n+ Show useful message in SSO login page.\n\n*Fixes*\n+ Allow editing of already-edited events.\n+ Push rules' actions may be listed in any order. (Fixes compatibility with [[https://spec.matrix.org/v1.7/client-server-api/#actions][v1.7 of the spec]]. Thanks to [[https://github.com/Stebalien][Steven Allen]].)\n+ Call external browser for SSO login page. (JavaScript is usually required, which EWW doesn't support, and loading the page twice seems to change state on the server that causes the SSO login to fail, so it's best to load the page in the external browser directly).\n+ Clean up SSO server process after two minutes in case SSO login fails.\n+ Don't stop syncing if an error is signaled while sending a notification.\n+ Command ~ement-room-list-next-unread~ could enter an infinite loop. (Thanks to [[https://github.com/vizs][Visuwesh]] and ~@mrtnmrtn:matrix.org~.)\n+ Events in notifications buffer could appear out-of-order. ([[https://github.com/alphapapa/ement.el/issues/191][#191]]. Thanks to [[https://github.com/phil-s][Phil Sainty]].)\n\n*Internal*\n+ The ~ement-read-receipt-idle-timer~ could be duplicated when using multiple sessions. ([[https://github.com/alphapapa/ement.el/issues/196][#196]]. Thanks to [[https://github.com/phil-s][Phil Sainty]].)\n\n** 0.10\n\n*Security Fixes*\n+ When uploading a GPG-encrypted file (i.e. one whose filename ends in ~.gpg~), if the recipient's private key or the symmetric encryption key were cached by Emacs (or a configured agent, like ~gpg-agent~), Emacs would automatically decrypt the file while reading its contents and then upload the decrypted contents. (This happened because the function ~insert-file-contents~ was used, which does many things automatically, some of which are not even mentioned in its docstring; refer to its entry in the Elisp Info manual for details. The fix is to use ~insert-file-contents-literally~ instead.) Thanks to ~@welkinsl:matrix.org~ for reporting.\n\n*Additions*\n+ Support for Single Sign-On (SSO) authentication. ([[https://github.com/alphapapa/ement.el/issues/24][#24]]. Thanks to [[https://github.com/Necronian][Jeffrey Stoffers]] for development, and to [[https://github.com/phil-s][Phil Sainty]], [[https://github.com/FrostyX][Jakub Kadlčík]], and [[https://github.com/oneingan][Juanjo Presa]] for testing.)\n+ Bind ~m~ in room buffers to ~ement-room-mark-read~ (which moves read markers to point).\n\n*Changes*\n\n+ Activating a space in the room list uses ~ement-view-space~ (which shows a directory of rooms in the space) instead of ~ement-view-room~ (which shows events in the space, which is generally not useful).\n+ Command ~ement-view-room~, when used for a space, shows a footer explaining that the buffer is showing a space rather than a normal room, with a button to call ~ement-view-space~ for it (which lists rooms in the space).\n+ Command ~ement-describe-room~ shows whether a room is a space or a normal room.\n+ Command ~ement-view-space~ shows the space's name and alias.\n+ Command ~ement-room-scroll-up-mark-read~ moves the fully read marker to the top of the window (when the marker's position is within the range of known events), rather than only moving it when at the end of the buffer. (This eases the process of gradually reading a long backlog of messages.)\n+ Improve readme export settings.\n\n*Fixes*\n+ Extra indentation of some membership events. (Thanks to [[https://github.com/Stebalien][Steven Allen]].)\n+ Customization group for faces.\n+ Don't reinitialize ~ement-room-list-mode~ when room list buffer is refreshed. ([[https://github.com/alphapapa/ement.el/issues/146][#146]]. Thanks to [[https://github.com/treed][Ted Reed]] for reporting.)\n+ Don't fetch old events when scrolling to the bottom of a room buffer (only when scrolling to the top). (Thanks to [[https://github.com/Stebalien][Steven Allen]].)\n+ Minor improvements to auto-detection of homeserver URIs. (See [[https://github.com/alphapapa/ement.el/issues/24#issuecomment-1569518713][#24]]. Thanks to [[https://github.com/phil-s][Phil Sainty]].)\n+ Uploading of certain filetypes (e.g. Emacs would decompress some archives before uploading). Thanks to ~@welkinsl:matrix.org~ for reporting.\n+ Messages edited multiple times sometimes weren't correctly replaced.\n\n** 0.9.3\n\n*Fixes*\n+ Another attempt at restoring position in room list when refreshing.\n+ Command ~ement-room-list-next-unread~.\n\n** 0.9.2\n\n*Fixes*\n+ Restore position in room list when refreshing.\n+ Completion in minibuffer.\n\n** 0.9.1\n\n*Fixes*\n+ Error in ~ement-room-list~ command upon initial sync.\n\n** 0.9\n\n*Additions*\n\n+ Option ~ement-room-timestamp-header-align~ controls how timestamp headers are aligned in room buffers.\n+ Option ~ement-room-view-hook~ runs functions when ~ement-room-view~ is called. (By default, it refreshes the room list buffer.)\n+ In the room list, middle-clicking a room which has a buffer closes its buffer.\n+ Basic support for video events. (Thanks to [[https://github.com/viiru-][Arto Jantunen]].)\n\n*Changes*\n\n+ Using new option ~ement-room-timestamp-header-align~, timestamp headers default to right-aligned. (With default settings, this keeps them near message timestamps and makes for a cleaner appearance.)\n\n*Fixes*\n\n+ Recognition of certain MXID or displayname forms in outgoing messages when linkifying (aka \"pilling\") them.\n+ Unreadable room avatar images no longer cause errors. (Fixes [[https://github.com/alphapapa/ement.el/issues/147][#147]]. Thanks to [[https://github.com/jgarte][@jgarte]] for reporting.)\n+ Don't error in ~ement-room-list~ when no rooms are joined. (Fixes [[https://github.com/alphapapa/ement.el/issues/123][#123]]. Thanks to [[https://github.com/Kabouik][@Kabouik]] and [[https://github.com/oantolin][Omar Antolín Camarena]] for reporting.)\n+ Enable member/room completion in compose buffers. (Fixes [[https://github.com/alphapapa/ement.el/issues/115][#115]]. Thanks to Thanks to [[https://github.com/piater][Justus Piater]] and [[https://github.com/chasecaleb][Caleb Chase]] for reporting.)\n\n** 0.8.3\n\n*Fixes*\n\n+ Avoid use of ~pcase~'s ~(map :KEYWORD)~ form. (This can cause a broken installation on older versions of Emacs that have an older version of the ~map~ library loaded, such as Emacs 27.2 included in Debian 11. Since there's no way to force Emacs to actually load the version of ~map~ required by this package before installing it (which would naturally happen upon restarting Emacs), we can only avoid using such forms while these versions of Emacs are widely used.)\n\n** 0.8.2\n\n*Fixes*\n\n+ Deduplicate grouped membership events.\n\n** 0.8.1\n\nAdded missing changelog entry (of course).\n\n** 0.8\n\n*Additions*\n+ Command ~ement-create-space~ creates a new space.\n+ Command ~ement-room-toggle-space~ toggles a room's membership in a space (a way to group rooms in Matrix).\n+ Visibility of sections in the room list is saved across sessions.\n+ Command ~ement-room-list-kill-buffer~ kills a room's buffer from the room list.\n+ Set ~device_id~ and ~initial_device_display_name~ upon login (e.g. =Ement.el: username@hostname=). ([[https://github.com/alphapapa/ement.el/issues/134][#134]]. Thanks to [[https://github.com/viiru-][Arto Jantunen]] for reporting.)\n\n*Changes*\n\n+ Room-related commands may be called interactively with a universal prefix to prompt for the room/session (allowing to send events or change settings in rooms other than the current one).\n+ Command ~ement-room-list~ reuses an existing window showing the room list when possible. ([[https://github.com/alphapapa/ement.el/issues/131][#131]]. Thanks to [[https://github.com/jeffbowman][Jeff Bowman]] for suggesting.)\n+ Command ~ement-tag-room~ toggles tags (rather than adding by default and removing when called with a prefix).\n+ Default room grouping now groups \"spaced\" rooms separately.\n\n*Fixes*\n\n+ Message format filter works properly when writing replies.\n+ Improve insertion of sender name headers when using the \"Elemental\" message format.\n+ Prompts in commands ~ement-leave-room~ and ~ement-forget-room~.\n\n** 0.7\n\n*Additions*\n\n+ Command ~ement-room-override-name~ sets a local override for a room's display name. (Especially helpful for 1:1 rooms and bridged rooms. See [[https://github.com/matrix-org/matrix-spec-proposals/pull/3015#issuecomment-1451017296][MSC3015]].)\n\n*Changes*\n\n+ Improve display of room tombstones (displayed at top and bottom of buffer, and new room ID is linked to join).\n+ Use descriptive prompts in ~ement-leave-room~ and ~ement-forget-room~ commands.\n\n*Fixes*\n\n+ Command ~ement-view-space~ when called from a room buffer. (Thanks to [[https://github.com/MagicRB][Richard Brežák]] for reporting.)\n+ Don't call ~display-buffer~ when reverting room list buffer. (Fixes [[https://github.com/alphapapa/ement.el/issues/121][#121]]. Thanks to [[https://github.com/mekeor][mekeor]] for reporting.)\n+ Retry sync for network timeouts. (Accidentally broken in v0.6.)\n\n*Internal*\n\n+ Function ~ement-put-account-data~ accepts ~:room~ argument to put on a room's account data.\n\n** 0.6\n\n*Additions*\n+ Command ~ement-view-space~ to view a space's rooms in a directory buffer.\n\n*Changes*\n+ Improve ~ement-describe-room~ command (formatting, bindings).\n\n*Fixes*\n+ Retry sync for HTTP 502 \"Bad Gateway\" errors.\n+ Formatting of unban events.\n+ Update password authentication according to newer Matrix spec. (Fixes compatibility with Conduit servers. [[https://github.com/alphapapa/ement.el/issues/66][#66]]. Thanks to [[https://github.com/tpeacock19][Travis Peacock]], [[https://github.com/viiru-][Arto Jantunen]], and [[https://github.com/scd31][Stephen D]].)\n+ Image scaling issues. (Thanks to [[https://github.com/vizs][Visuwesh]].)\n\n** 0.5.2\n\n*Fixes*\n+ Apply ~ement-initial-sync-timeout~ properly (important for when the homeserver is slow to respond).\n\n** 0.5.1\n\n*Fixes*\n+ Autoload ~ement-directory~ commands.\n+ Faces in ~ement-directory~ listings.\n\n** 0.5\n\n*Additions*\n+ Present \"joined-and-left\" and \"rejoined-and-left\" membership event pairs as such.\n+ Process and show rooms' canonical alias events.\n\n*Changes*\n+ The [[https://github.com/alphapapa/taxy.el][taxy.el]]-based room list, with programmable, smart grouping, is now the default ~ement-room-list~. (The old, ~tabulated-list-mode~-based room list is available as ~ement-tabulated-room-list~.)\n+ When selecting a room to view with completion, don't offer spaces.\n+ When selecting a room with completion, empty aliases and topics are omitted instead of being displayed as nil.\n\n*Fixes*\n+ Use of send-message filter when replying.\n+ Replies may be written in compose buffers.\n\n** 0.4.1\n\n*Fixes*\n+ Don't show \"curl process interrupted\" message when updating a read marker's position again.\n\n** 0.4\n\n*Additions*\n+ Option ~ement-room-unread-only-counts-notifications~, now enabled by default, causes rooms' unread status to be determined only by their notification counts (which are set by the server and depend on rooms' notification settings).\n+ Command ~ement-room-set-notification-state~ sets a room's notification state (imitating Element's user-friendly presets).\n+ Room buffers' Transient menus show the room's notification state (imitating Element's user-friendly presets).\n+ Command ~ement-set-display-name~ sets the user's global displayname.\n+ Command ~ement-room-set-display-name~ sets the user's displayname in a room (which is also now displayed in the room's Transient menu).\n+ Column ~Notifications~ in the ~ement-taxy-room-list~ buffer shows rooms' notification state.\n+ Option ~ement-interrupted-sync-hook~ allows customization of how sync interruptions are handled. (Now, by default, a warning is displayed instead of merely a message.)\n\n*Changes*\n+ When a room's read receipt is updated, the room's buffer is also marked as unmodified. (In concert with the new option, this makes rooms' unread status more intuitive.)\n\n*Fixes*\n+ Binding of command ~ement-forget-room~ in room buffers.\n+ Highlighting of ~@room~ mentions.\n\n** 0.3.1\n\n*Fixes*\n+ Room unread status (when the last event in a room is sent by the local user, the room is considered read).\n\n** 0.3\n\n*Additions*\n+ Command ~ement-directory~ shows a server's room directory.\n+ Command ~ement-directory-search~ searches a server's room directory.\n+ Command ~ement-directory-next~ fetches the next batch of rooms in a directory.\n+ Command ~ement-leave-room~ accepts a ~FORCE-P~ argument (interactively, with prefix) to leave a room without prompting.\n+ Command ~ement-forget-room~ accepts a ~FORCE-P~ argument (interactively, with prefix) to also leave the room, and to forget it without prompting.\n+ Option ~ement-notify-mark-frame-urgent-predicates~ marks the frame as urgent when (by default) a message mentions the local user or \"@room\" and the message's room has an open buffer.\n\n*Changes*\n+ Minor improvements to date/time headers.\n\n*Fixes*\n+ Command ~ement-describe-room~ for rooms without topics.\n+ Improve insertion of old messages around existing timestamp headers.\n+ Reduce D-Bus notification system check timeout to 2 seconds (from the default of 25).\n+ Compatibility with Emacs 27.\n\n** 0.2.1\n\n*Fixes*\n+ Info manual export filename.\n\n** 0.2\n\n*Changes*\n+ Read receipts are re-enabled. (They're now implemented with a global idle timer rather than ~window-scroll-functions~, which sometimes caused a strange race condition that could cause Emacs to become unresponsive or crash.)\n+ When determining whether a room is considered unread, non-message events like membership changes, reactions, etc. are ignored. This fixes a bug that caused certain rooms that had no message events (like some bridged rooms) to appear as unread when they shouldn't have. But it's unclear whether this is always preferable (e.g. one might want a member leaving a room to cause it to be marked unread), so this is classified as a change rather than simply a fix, and more improvements may be made to this in the future. (Fixes [[https://github.com/alphapapa/ement.el/issues/97][#97]]. Thanks to [[https://github.com/MrRoy][Julien Roy]] for reporting and testing.)\n+ The ~ement-taxy-room-list~ view no longer automatically refreshes the list if the region is active in the buffer. (This allows the user to operate on multiple rooms without the contents of the buffer changing before completing the process.)\n\n*Fixes*\n+ Links to only rooms (as opposed to links to events in rooms) may be activated to join them.\n+ Read receipts mark the last completely visible event (rather than one that's only partially displayed).\n+ Prevent error when a room avatar image fails to load.\n\n** 0.1.4\n\n*Fixed*\n+ Info manual directory headers.\n\n** 0.1.3\n\n*Fixed*\n# + Read receipt-sending function was called too many times when scrolling.\n# + Send read receipts even when the last receipt is outside the range of retrieved events.\n+ Temporarily disable sending of read receipts due to an unusual bug that could cause Emacs to become unresponsive. (The feature will be re-enabled in a future release.)\n\n** 0.1.2\n\n*Fixed*\n+ Function ~ement-room-sync~ correctly updates room-list buffers. (Thanks to [[https://github.com/vizs][Visuwesh]].)\n+ Only send D-Bus notifications when supported. (Fixes [[https://github.com/alphapapa/ement.el/issues/83][#83]]. Thanks to [[https://github.com/tsdh][Tassilo Horn]].)\n\n** 0.1.1\n\n*Fixed*\n+ Function ~ement-room-scroll-up-mark-read~ selects the correct room window.\n+ Option ~ement-room-list-avatars~ defaults to what function ~display-images-p~ returns.\n\n** 0.1\n\nAfter almost two years of development, the first tagged release. Submitted to GNU ELPA.\n\n* Development\n:PROPERTIES:\n:TOC: :include this :ignore descendants\n:END:\n\nBug reports, feature requests, suggestions — /oh my/!\n\n** Copyright Assignment\n:PROPERTIES:\n:TOC: :ignore (this)\n:END:\n\nEment.el is published in GNU ELPA and is considered part of GNU Emacs. Therefore, cumulative contributions of more than 15 lines of code require that the author assign copyright of such contributions to the FSF. Authors who are interested in doing so may contact [[mailto:assign@gnu.org][assign@gnu.org]] to request the appropriate form.\n\n** Matrix spec in Org format\n:PROPERTIES:\n:TOC: :ignore (this)\n:END:\n\nAn Org-formatted version of the Matrix spec is available in the [[https://github.com/alphapapa/ement.el/tree/meta/spec][meta/spec]] branch.\n\n** Rationale\n\n/This section is preserved for posterity. As it says, Ement.el has long since surpassed ~matrix-client~, which should no longer be used./\n\nWhy write a new Emacs Matrix client when there is already [[https://github.com/alphapapa/matrix-client.el][matrix-client.el]], by the same author, no less? A few reasons:\n\n- ~matrix-client~ uses an older version of the Matrix spec, r0.3.0, with a few elements of r0.4.0 grafted in. Bringing it up to date with the current version of the spec, r0.6.1, would be more work than to begin with the current version. Ement.el targets r0.6.1 from the beginning.\n- ~matrix-client~ does not use Matrix's lazy-loading feature (which was added to the specification later), so initial sync requests can take a long time for the server to process and can be large (sometimes tens of megabytes of JSON for the client to process!). Ement.el uses lazy-loading, which significantly improves performance.\n- ~matrix-client~ automatically makes buffers for every room a user has joined, even if the user doesn't currently want to watch a room. Ement.el opens room buffers on-demand, improving performance by not having to insert events into buffers for rooms the user isn't watching.\n- ~matrix-client~ was developed without the intention of publishing it to, e.g. MELPA or ELPA. It has several dependencies, and its code does not always install or compile cleanly due to macro-expansion issues (apparently depending on the user's Emacs config). Ement.el is designed to have minimal dependencies outside of Emacs (currently only one, ~plz~, which could be imported into the project), and every file is linted and compiles cleanly using [[https://github.com/alphapapa/makem.sh][makem.sh]].\n- ~matrix-client~ uses EIEIO, probably unnecessarily, since few, if any, of the benefits of EIEIO are realized in it. Ement.el uses structs instead.\n- ~matrix-client~ uses bespoke code for inserting messages into buffers, which works pretty well, but has a few minor bugs which are difficult to track down. Ement.el uses Emacs's built-in (and perhaps little-known) ~ewoc~ library, which makes it much simpler and more reliable to insert and update messages in buffers, and enables the development of advanced UI features more easily.\n- ~matrix-client~ was, to a certain extent, designed to imitate other messaging apps. The result is, at least when used with the ~matrix-client-frame~ command, fairly pleasing to use, but isn't especially \"Emacsy.\" Ement.el is intended to better fit into Emacs's paradigms.\n- ~matrix-client~'s long name makes for long symbol names, which makes for tedious, verbose code. ~ement~ is easy to type and makes for concise, readable code.\n- The author has learned much since writing ~matrix-client~ and hopes to write simpler, more readable, more maintainable code in Ement.el. It's hoped that this will enable others to contribute more easily.\n\nNote that, while ~matrix-client~ remains usable, and probably will for some time to come, Ement.el has now surpassed it in every way. The only reason to choose ~matrix-client~ instead is if one is using an older version of Emacs that isn't supported by Ement.el.\n\n* License\n:PROPERTIES:\n:TOC: :ignore (this)\n:END:\n\nGPLv3\n\n* COMMENT Config :noexport:\n:PROPERTIES:\n:TOC: :ignore (this descendants)\n:END:\n\n# NOTE: The #+OPTIONS: and other keywords did not take effect when in this section (perhaps due to file size or to changes in Org), so they were moved to the top of the file.\n\n** File-local variables\n\n# Local Variables:\n# eval: (require 'org-make-toc)\n# before-save-hook: org-make-toc\n# org-export-with-properties: ()\n# org-export-with-title: t\n# End:\n" }, { "path": "ement-api.el", "content": ";;; ement-api.el --- Matrix API library -*- lexical-binding: t; -*-\n\n;; Copyright (C) 2022-2023 Free Software Foundation, Inc.\n\n;; Author: Adam Porter \n;; Maintainer: Adam Porter \n\n;; This program is free software; you can redistribute it and/or modify\n;; it under the terms of the GNU General Public License as published by\n;; the Free Software Foundation, either version 3 of the License, or\n;; (at your option) any later version.\n\n;; This program is distributed in the hope that it will be useful,\n;; but WITHOUT ANY WARRANTY; without even the implied warranty of\n;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n;; GNU General Public License for more details.\n\n;; You should have received a copy of the GNU General Public License\n;; along with this program. If not, see .\n\n;;; Commentary:\n\n;;\n\n;;; Code:\n\n;;;; Debugging\n\n;; NOTE: Uncomment this form and `emacs-lisp-byte-compile-and-load' the file to enable\n;; `ement-debug' messages. This is commented out by default because, even though the\n;; messages are only displayed when `warning-minimum-log-level' is `:debug' at runtime, if\n;; that is so at expansion time, the expanded macro calls format the message and check the\n;; log level at runtime, which is not zero-cost.\n\n;; (eval-and-compile\n;; (setq-local warning-minimum-log-level nil)\n;; (setq-local warning-minimum-log-level :debug))\n\n;;;; Requirements\n\n(require 'json)\n(require 'url-parse)\n(require 'url-util)\n\n(require 'plz)\n\n(require 'ement-macros)\n(require 'ement-structs)\n\n;;;; Variables\n\n\n;;;; Customization\n\n\n;;;; Commands\n\n\n;;;; Functions\n\n(cl-defun ement-api (session endpoint\n &key then data params queue\n (content-type \"application/json\")\n (data-type 'text)\n (else #'ement-api-error) (method 'get)\n ;; FIXME: What's the right term for the URL part after \"/_matrix/\"?\n (endpoint-category \"client\")\n (json-read-fn #'json-read)\n ;; NOTE: Hard to say what the default timeouts\n ;; should be. Sometimes the matrix.org homeserver\n ;; can get slow and respond a minute or two later.\n (connect-timeout 10) (timeout 60)\n (version \"r0\"))\n \"Make API request on SESSION to ENDPOINT.\nThe request automatically uses SESSION's server, URI prefix, and\naccess token.\n\nThese keyword arguments are passed to `plz', which see: THEN,\nDATA (passed as BODY), QUEUE (passed to `plz-queue', which see),\nDATA-TYPE (passed as BODY-TYPE), ELSE, METHOD,\nJSON-READ-FN (passed as AS), CONNECT-TIMEOUT, TIMEOUT.\n\nOther arguments include PARAMS (used as the URL's query\nparameters), ENDPOINT-CATEGORY (added to the endpoint URL), and\nVERSION (added to the endpoint URL).\n\nNote that most Matrix requests expect JSON-encoded data, so\nusually the DATA argument should be passed through\n`json-encode'.\"\n (declare (indent defun))\n (pcase-let* (((cl-struct ement-session server token) session)\n ((cl-struct ement-server uri-prefix) server)\n ((cl-struct url type host portspec) (url-generic-parse-url uri-prefix))\n (path (format \"/_matrix/%s/%s/%s\" endpoint-category version endpoint))\n (query (url-build-query-string params))\n (filename (concat path \"?\" query))\n (url (url-recreate-url\n (url-parse-make-urlobj type nil nil host portspec filename nil data t)))\n (headers (ement-alist \"Content-Type\" content-type))\n (plz-args))\n (when token\n ;; Almost every request will require a token (only a few, like checking login flows, don't),\n ;; so we simplify the API by using the token automatically when the session has one.\n (push (cons \"Authorization\" (concat \"Bearer \" token)) headers))\n (setf plz-args (list method url :headers headers :body data :body-type data-type\n :as json-read-fn :then then :else else\n :connect-timeout connect-timeout :timeout timeout :noquery t))\n ;; Omit `then' from debugging because if it's a partially applied\n ;; function on the session object, which may be very large, it\n ;; will take a very long time to print into the warnings buffer.\n ;; (ement-debug (current-time) method url headers)\n (if queue\n (plz-run\n (apply #'plz-queue queue plz-args))\n (apply #'plz plz-args))))\n\n(define-error 'ement-api-error \"Ement API error\" 'error)\n\n(defun ement-api-error (plz-error)\n \"Signal an Ement API error for PLZ-ERROR.\"\n ;; This feels a little messy, but it seems to be reasonable.\n (pcase-let* (((cl-struct plz-error response\n (message plz-message) (curl-error `(,curl-exit-code . ,curl-message)))\n plz-error)\n (status (when (plz-response-p response)\n (plz-response-status response)))\n (body (when (plz-response-p response)\n (plz-response-body response)))\n (json-object (when body\n (ignore-errors\n (json-read-from-string body))))\n (error-message (format \"%S: %s\"\n (or curl-exit-code status)\n (or (when json-object\n (alist-get 'error json-object))\n curl-message\n plz-message))))\n\n (signal 'ement-api-error (list error-message))))\n\n;;;; Footer\n\n(provide 'ement-api)\n\n;;; ement-api.el ends here\n" }, { "path": "ement-directory.el", "content": ";;; ement-directory.el --- Public room directory support -*- lexical-binding: t; -*-\n\n;; Copyright (C) 2022-2023 Free Software Foundation, Inc.\n\n;; Author: Adam Porter \n;; Maintainer: Adam Porter \n\n;; This program is free software; you can redistribute it and/or modify\n;; it under the terms of the GNU General Public License as published by\n;; the Free Software Foundation, either version 3 of the License, or\n;; (at your option) any later version.\n\n;; This program is distributed in the hope that it will be useful,\n;; but WITHOUT ANY WARRANTY; without even the implied warranty of\n;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n;; GNU General Public License for more details.\n\n;; You should have received a copy of the GNU General Public License\n;; along with this program. If not, see .\n\n;;; Commentary:\n\n;; This library provides support for viewing and searching public room directories on\n;; Matrix homeservers.\n\n;; To make rendering the list flexible and useful, we'll use `taxy-magit-section'.\n\n;;; Code:\n\n;;;; Requirements\n\n(require 'ement)\n(require 'ement-room-list)\n\n(require 'taxy)\n(require 'taxy-magit-section)\n\n;;;; Variables\n\n(defvar ement-directory-mode-map\n (let ((map (make-sparse-keymap)))\n (define-key map (kbd \"RET\") #'ement-directory-RET)\n (define-key map [mouse-1] #'ement-directory-mouse-1)\n (define-key map (kbd \"+\") #'ement-directory-next)\n map))\n\n(defgroup ement-directory nil\n \"Options for room directories.\"\n :group 'ement)\n\n;;;; Mode\n\n(define-derived-mode ement-directory-mode magit-section-mode \"Ement-Directory\"\n :global nil)\n\n(defvar-local ement-directory-etc nil\n \"Alist storing information in `ement-directory' buffers.\")\n\n;;;;; Keys\n\n(eval-and-compile\n (taxy-define-key-definer ement-directory-define-key\n ement-directory-keys \"ement-directory-key\" \"FIXME: Docstring.\"))\n\n;; TODO: Other keys like guest_can_join, world_readable, etc. (Last-updated time would be\n;; nice, but the server doesn't include that in the results.)\n\n(ement-directory-define-key joined-p ()\n (pcase-let (((map ('room_id id)) item)\n ((map session) ement-directory-etc))\n (when (cl-find id (ement-session-rooms session)\n :key #'ement-room-id :test #'equal)\n \"Joined\")))\n\n(ement-directory-define-key size (&key < >)\n (pcase-let (((map ('num_joined_members size)) item))\n (cond ((and < (< size <))\n (format \"< %s members\" <))\n ((and > (> size >))\n (format \"> %s members\" >)))))\n\n(ement-directory-define-key space-p ()\n \"Groups rooms that are themselves spaces.\"\n (pcase-let (((map ('room_type type)) item))\n (when (equal \"m.space\" type)\n \"Spaces\")))\n\n(ement-directory-define-key people-p ()\n (pcase-let (((map ('room_id id) ('room_type type)) item)\n ((map session) ement-directory-etc))\n (pcase type\n (\"m.space\" nil)\n (_ (when-let ((room (cl-find id (ement-session-rooms session)\n :key #'ement-room-id :test #'equal))\n ((ement--room-direct-p room session)))\n (ement-propertize \"People\"\n 'face 'ement-room-list-direct))))))\n\n(defcustom ement-directory-default-keys\n '((joined-p\n (people-p)\n (and :name \"Rooms\"\n :keys ((not people-p))))\n (space-p)\n ((size :> 10000))\n ((size :> 1000))\n ((size :> 100))\n ((size :> 10))\n ((size :< 11)))\n \"Default keys.\"\n :type 'sexp)\n\n;;;; Columns\n\n(defvar-local ement-directory-room-avatar-cache (make-hash-table)\n ;; Use a buffer-local variable so that the cache is cleared when the buffer is closed.\n \"Hash table caching room avatars for the `ement-directory' room list.\")\n\n(eval-and-compile\n (taxy-magit-section-define-column-definer \"ement-directory\"))\n\n;; TODO: Fetch avatars (with queueing and async updating/insertion?).\n\n(ement-directory-define-column #(\"✓\" 0 1 (help-echo \"Joined\")) ()\n (pcase-let (((map ('room_id id)) item)\n ((map session) ement-directory-etc))\n (if (cl-find id (ement-session-rooms session)\n :key #'ement-room-id :test #'equal)\n \"✓\"\n \" \")))\n\n(ement-directory-define-column \"Name\" (:max-width 25)\n (pcase-let* (((map name ('room_id id) ('room_type type)\n ('canonical_alias canonical-alias))\n item)\n ((map session) ement-directory-etc)\n (room)\n (face (pcase type\n (\"m.space\" 'ement-room-list-space)\n (_ (if (and (setf room (cl-find id (ement-session-rooms session)\n :key #'ement-room-id :test #'equal))\n (ement--room-direct-p room session))\n 'ement-room-list-direct\n 'ement-room-list-name)))))\n ;; NOTE: We can't use `ement--room-display-name' because these aren't room structs,\n ;; and we don't have membership data.\n (ement-propertize (or name canonical-alias \"[unnamed]\")\n 'face face)))\n\n(ement-directory-define-column \"Alias\" (:max-width 25)\n (pcase-let (((map ('canonical_alias alias)) item))\n (or alias \"\")))\n\n(ement-directory-define-column \"Size\" (:align 'right)\n (pcase-let (((map ('num_joined_members size)) item))\n (number-to-string size)))\n\n(ement-directory-define-column \"Topic\" (:max-width 50)\n (pcase-let (((map topic) item))\n (if topic\n (replace-regexp-in-string \"\\n\" \" | \" topic nil t)\n \"\")))\n\n(ement-directory-define-column \"ID\" ()\n (pcase-let (((map ('room_id id)) item))\n id))\n\n(unless ement-directory-columns\n ;; TODO: Automate this or document it\n (setq-default ement-directory-columns\n '(\"Name\" \"Alias\" \"Size\" \"Topic\" \"ID\")))\n\n;;;; Commands\n\n;; TODO: Pagination of results.\n\n;;;###autoload\n(cl-defun ement-directory (&key server session since (limit 100))\n \"View the public room directory on SERVER with SESSION.\nShow up to LIMIT rooms. Interactively, with prefix, prompt for\nserver and LIMIT.\n\nSINCE may be a next-batch token.\"\n (interactive (let* ((session (ement-complete-session :prompt \"Search on session: \"))\n (server (if current-prefix-arg\n (read-string \"Search on server: \" nil nil\n (ement-server-name (ement-session-server session)))\n (ement-server-name (ement-session-server session))))\n (args (list :server server :session session)))\n (when current-prefix-arg\n (cl-callf plist-put args\n :limit (read-number \"Limit number of rooms: \" 100)))\n args))\n (pcase-let ((revert-function (lambda (&rest _ignore)\n (interactive)\n (ement-directory :server server :session session :limit limit)))\n (endpoint \"publicRooms\")\n (params (list (list \"limit\" limit))))\n (when since\n (cl-callf append params (list (list \"since\" since))))\n (ement-api session endpoint :params params\n :then (lambda (results)\n (pcase-let (((map ('chunk rooms) ('next_batch next-batch)\n ('total_room_count_estimate remaining))\n results))\n (ement-directory--view rooms :append-p since\n :buffer-name (format \"*Ement Directory: %s*\" server)\n :root-section-name (format \"Ement Directory: %s\" server)\n :init-fn (lambda ()\n (setf (alist-get 'server ement-directory-etc) server\n (alist-get 'session ement-directory-etc) session\n (alist-get 'next-batch ement-directory-etc) next-batch\n (alist-get 'limit ement-directory-etc) limit)\n (setq-local revert-buffer-function revert-function)\n (when remaining\n ;; FIXME: The server seems to report all of the rooms on\n ;; the server as remaining even when searching for a\n ;; specific term like \"emacs\".\n ;; TODO: Display this in a more permanent place (like a\n ;; header or footer).\n (message\n (substitute-command-keys\n \"%s rooms remaining (use \\\\[ement-directory-next] to fetch more)\")\n remaining)))))))\n (ement-message \"Listing %s rooms on %s...\" limit server)))\n\n;;;###autoload\n(cl-defun ement-directory-search (query &key server session since (limit 1000))\n \"View public rooms on SERVER matching QUERY.\nQUERY is a string used to filter results.\"\n (interactive (let* ((session (ement-complete-session :prompt \"Search on session: \"))\n (server (if current-prefix-arg\n (read-string \"Search on server: \" nil nil\n (ement-server-name (ement-session-server session)))\n (ement-server-name (ement-session-server session))))\n (query (read-string (format \"Search for rooms on %s matching: \" server)))\n (args (list query :server server :session session)))\n (when current-prefix-arg\n (cl-callf plist-put (cdr args)\n :limit (read-number \"Limit number of rooms: \" 1000)))\n args))\n ;; TODO: Handle \"include_all_networks\" and \"third_party_instance_id\". See § 10.5.4.\n (pcase-let* ((revert-function (lambda (&rest _ignore)\n (interactive)\n (ement-directory-search query :server server :session session)))\n (endpoint \"publicRooms\")\n (data (rassq-delete-all nil\n (ement-alist \"limit\" limit\n \"filter\" (ement-alist \"generic_search_term\" query)\n \"since\" since))))\n (ement-api session endpoint :method 'post :data (json-encode data)\n :then (lambda (results)\n (pcase-let (((map ('chunk rooms) ('next_batch next-batch)\n ('total_room_count_estimate remaining))\n results))\n (ement-directory--view rooms :append-p since\n :buffer-name (format \"*Ement Directory: \\\"%s\\\" on %s*\" query server)\n :root-section-name (format \"Ement Directory: \\\"%s\\\" on %s\" query server)\n :init-fn (lambda ()\n (setf (alist-get 'server ement-directory-etc) server\n (alist-get 'session ement-directory-etc) session\n (alist-get 'next-batch ement-directory-etc) next-batch\n (alist-get 'limit ement-directory-etc) limit\n (alist-get 'query ement-directory-etc) query)\n (setq-local revert-buffer-function revert-function)\n (when remaining\n (message\n (substitute-command-keys\n \"%s rooms remaining (use \\\\[ement-directory-next] to fetch more)\")\n remaining)))))))\n (ement-message \"Searching for %S on %s...\" query server)))\n\n(defun ement-directory-next ()\n \"Fetch next batch of results in `ement-directory' buffer.\"\n (interactive)\n (pcase-let (((map next-batch query limit server session) ement-directory-etc))\n (unless next-batch\n (user-error \"No more results\"))\n (if query\n (ement-directory-search query :server server :session session :limit limit :since next-batch)\n (ement-directory :server server :session session :limit limit :since next-batch))))\n\n(defun ement-directory-mouse-1 (event)\n \"Call `ement-directory-RET' at EVENT.\"\n (interactive \"e\")\n (mouse-set-point event)\n (call-interactively #'ement-directory-RET))\n\n(defun ement-directory-RET ()\n \"View or join room at point, or cycle section at point.\"\n (interactive)\n (cl-etypecase (oref (magit-current-section) value)\n (null nil)\n (list (pcase-let* (((map ('name name) ('room_id room-id)) (oref (magit-current-section) value))\n ((map session) ement-directory-etc)\n (room (cl-find room-id (ement-session-rooms session)\n :key #'ement-room-id :test #'equal)))\n (if room\n (ement-view-room room session)\n ;; Room not joined: prompt to join. (Don't use the alias in the prompt,\n ;; because multiple rooms might have the same alias, e.g. when one is\n ;; upgraded or tombstoned.)\n (when (yes-or-no-p (format \"Join room \\\"%s\\\" <%s>? \" name room-id))\n (ement-join-room room-id session)))))\n (taxy-magit-section (call-interactively #'magit-section-cycle))))\n\n;;;; Functions\n\n(cl-defun ement-directory--view (rooms &key init-fn append-p\n (buffer-name \"*Ement Directory*\")\n (root-section-name \"Ement Directory\")\n (keys ement-directory-default-keys)\n (display-buffer-action '(display-buffer-same-window)))\n \"View ROOMS in an `ement-directory-mode' buffer.\nROOMS should be a list of rooms from an API request. Calls\nINIT-FN immediately after activating major mode. Sets\nBUFFER-NAME and ROOT-SECTION-NAME, and uses\nDISPLAY-BUFFER-ACTION. KEYS are a list of `taxy' keys. If\nAPPEND-P, add ROOMS to buffer rather than replacing existing\ncontents. To be called by `ement-directory-search'.\"\n (declare (indent defun))\n (let (column-sizes window-start)\n (cl-labels ((format-item (item)\n ;; NOTE: We use the buffer-local variable `ement-directory-etc' rather\n ;; than a closure variable because the taxy-magit-section struct's format\n ;; table is not stored in it, and we can't reuse closures' variables.\n ;; (It would be good to store the format table in the taxy-magit-section\n ;; in the future, to make this cleaner.)\n (gethash item (alist-get 'format-table ement-directory-etc)))\n ;; NOTE: Since these functions take an \"item\" (which is a [room session]\n ;; vector), they're prefixed \"item-\" rather than \"room-\".\n (size (item)\n (pcase-let (((map ('num_joined_members size)) item))\n size))\n (tnil (a b) (and (not a) b))\n (make-fn (&rest args)\n (apply #'make-taxy-magit-section\n :make #'make-fn\n :format-fn #'format-item\n ;; FIXME: Should we reuse `ement-room-list-level-indent' here?\n :level-indent ement-room-list-level-indent\n ;; :visibility-fn #'visible-p\n ;; :heading-indent 2\n :item-indent 2\n ;; :heading-face-fn #'heading-face\n args)))\n (with-current-buffer (get-buffer-create buffer-name)\n (unless (eq 'ement-directory-mode major-mode)\n ;; Don't obliterate buffer-local variables.\n (ement-directory-mode))\n (when init-fn\n (funcall init-fn))\n (pcase-let* ((taxy (if append-p\n (alist-get 'taxy ement-directory-etc)\n (make-fn\n :name root-section-name\n :take (taxy-make-take-function keys ement-directory-keys))))\n (taxy-magit-section-insert-indent-items nil)\n (inhibit-read-only t)\n (pos (point))\n (section-ident (when (magit-current-section)\n (magit-section-ident (magit-current-section))))\n (format-cons))\n (setf taxy (thread-last taxy\n (taxy-fill (cl-coerce rooms 'list))\n (taxy-sort #'> #'size)\n (taxy-sort* #'string> #'taxy-name))\n (alist-get 'taxy ement-directory-etc) taxy\n format-cons (taxy-magit-section-format-items\n ement-directory-columns ement-directory-column-formatters taxy)\n (alist-get 'format-table ement-directory-etc) (car format-cons)\n column-sizes (cdr format-cons)\n header-line-format (taxy-magit-section-format-header\n column-sizes ement-directory-column-formatters)\n window-start (if (get-buffer-window buffer-name)\n (window-start (get-buffer-window buffer-name))\n 0))\n (delete-all-overlays)\n (erase-buffer)\n (save-excursion\n (taxy-magit-section-insert taxy :items 'first\n ;; :blank-between-depth bufler-taxy-blank-between-depth\n :initial-depth 0))\n (goto-char pos)\n (when (and section-ident (magit-get-section section-ident))\n (goto-char (oref (magit-get-section section-ident) start)))))\n (display-buffer buffer-name display-buffer-action)\n (when (get-buffer-window buffer-name)\n (set-window-start (get-buffer-window buffer-name) window-start))\n ;; NOTE: In order for `bookmark--jump-via' to work properly, the restored buffer\n ;; must be set as the current buffer, so we have to do this explicitly here.\n (set-buffer buffer-name))))\n\n;;;; Spaces\n\n;; Viewing spaces and the rooms in them.\n\n;;;###autoload\n(defun ement-view-space (space session)\n ;; TODO: Use this for spaces instead of `ement-view-room' (or something like that).\n ;; TODO: Display space's topic in the header or something.\n \"View child rooms in SPACE on SESSION.\nSPACE may be a room ID or an `ement-room' struct.\"\n ;; TODO: \"from\" query parameter.\n (interactive (ement-complete-room :predicate #'ement--space-p\n :prompt \"Space: \"))\n (pcase-let* ((id (cl-typecase space\n (string space)\n (ement-room (ement-room-id space))))\n (endpoint (format \"rooms/%s/hierarchy\" id))\n (revert-function (lambda (&rest _ignore)\n (interactive)\n (ement-view-space space session))))\n (ement-api session endpoint :version \"v1\"\n :then (lambda (results)\n (pcase-let (((map rooms ('next_batch next-batch))\n results))\n (ement-directory--view rooms ;; :append-p since\n ;; TODO: Use space's alias where possible.\n :buffer-name (format \"*Ement Directory: space %s\" (ement--format-room space session))\n :root-section-name (format \"*Ement Directory: rooms in %s %s\"\n (ement-propertize \"space\"\n 'face 'font-lock-type-face)\n (ement--format-room space session))\n :init-fn (lambda ()\n (setf (alist-get 'session ement-directory-etc) session\n (alist-get 'next-batch ement-directory-etc) next-batch\n ;; (alist-get 'limit ement-directory-etc) limit\n (alist-get 'space ement-directory-etc) space)\n (setq-local revert-buffer-function revert-function)\n ;; TODO: Handle next batches.\n ;; (when remaining\n ;; (message\n ;; (substitute-command-keys\n ;; \"%s rooms remaining (use \\\\[ement-directory-next] to fetch more)\")\n ;; remaining))\n )))))))\n\n;;;; Footer\n\n(provide 'ement-directory)\n;;; ement-directory.el ends here\n" }, { "path": "ement-lib.el", "content": ";;; ement-lib.el --- Library of Ement functions -*- lexical-binding: t; -*-\n\n;; Copyright (C) 2022-2023 Free Software Foundation, Inc.\n\n;; Author: Adam Porter \n;; Maintainer: Adam Porter \n\n;; This program is free software; you can redistribute it and/or modify\n;; it under the terms of the GNU General Public License as published by\n;; the Free Software Foundation, either version 3 of the License, or\n;; (at your option) any later version.\n\n;; This program is distributed in the hope that it will be useful,\n;; but WITHOUT ANY WARRANTY; without even the implied warranty of\n;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n;; GNU General Public License for more details.\n\n;; You should have received a copy of the GNU General Public License\n;; along with this program. If not, see .\n\n;;; Commentary:\n\n;; This library provides functions used in other Ement libraries. It exists so they may\n;; be required where needed, without causing circular dependencies.\n\n;;; Code:\n\n;;;; Requirements\n\n(eval-when-compile\n (require 'eieio)\n (require 'ewoc)\n (require 'pcase)\n (require 'subr-x)\n \n (require 'taxy-magit-section)\n\n (require 'ement-macros))\n\n(require 'cl-lib)\n\n(require 'button)\n(require 'color)\n(require 'map)\n(require 'seq)\n(require 'xml)\n\n(require 'ement-api)\n(require 'ement-structs)\n\n;;;; Variables\n\n(defvar ement-sessions)\n(defvar ement-users)\n(defvar ement-ewoc)\n(defvar ement-room)\n(defvar ement-session)\n\n(defvar ement-room-buffer-name-prefix)\n(defvar ement-room-buffer-name-suffix)\n(defvar ement-room-leave-kill-buffer)\n(defvar ement-room-prism)\n(defvar ement-room-prism-color-adjustment)\n(defvar ement-room-prism-minimum-contrast)\n(defvar ement-room-unread-only-counts-notifications)\n\n;;;; Function declarations\n\n;; Instead of using top-level `declare-function' forms (which can easily become obsolete\n;; if not kept with the code that needs them), this allows the use of `(declare (function\n;; ...))' forms in each function definition, so that if a function is moved or removed,\n;; the `declare-function' goes with it.\n\n;; TODO: Propose this upstream.\n\n(eval-and-compile\n (defun ement--byte-run--declare-function (_name _args &rest values)\n \"Return a `declare-function' form with VALUES.\nAllows the use of a form like:\n\n (declare (function FN FILE ...))\n\ninside of a function definition, effectively keeping its\n`declare-function' form inside the function definition, ensuring\nthat stray such forms don't remain if the function is removed.\"\n `(declare-function ,@values))\n\n (cl-pushnew '(function ement--byte-run--declare-function) defun-declarations-alist :test #'equal)\n (cl-pushnew '(function ement--byte-run--declare-function) macro-declarations-alist :test #'equal))\n\n;;;; Compatibility\n\n;; These workarounds should be removed when they aren't needed.\n\n(defalias 'ement--json-parse-buffer\n ;; For non-libjansson builds (those that do have libjansson will see a 4-5x improvement\n ;; in the time needed to parse JSON responses).\n\n ;; TODO: Suggest mentioning in manual and docstrings that `json-read', et al do not use\n ;; libjansson, while `json-parse-buffer', et al do.\n (if (fboundp 'json-parse-buffer)\n (lambda ()\n (condition-case err\n (json-parse-buffer :object-type 'alist :null-object nil :false-object :json-false)\n (json-parse-error\n (ement-message \"`json-parse-buffer' signaled `json-parse-error'; falling back to `json-read'... (%S)\"\n (error-message-string err))\n (goto-char (point-min))\n (json-read))))\n 'json-read))\n\n;;;;; Emacs 28 color features.\n\n;; Copied from Emacs 28. See .\n\n;; TODO(future): Remove these workarounds when dropping support for Emacs <28.\n\n(eval-and-compile\n (unless (boundp 'color-luminance-dark-limit)\n (defconst ement--color-luminance-dark-limit 0.325\n \"The relative luminance below which a color is considered \\\"dark.\\\"\nA \\\"dark\\\" color in this sense provides better contrast with\nwhite than with black; see `color-dark-p'. This value was\ndetermined experimentally.\")))\n\n(defalias 'ement--color-dark-p\n (if (fboundp 'color-dark-p)\n 'color-dark-p\n (with-suppressed-warnings ((free-vars ement--color-luminance-dark-limit))\n (lambda (rgb)\n \"Whether RGB is more readable against white than black.\nRGB is a 3-element list (R G B), each component in the range [0,1].\nThis predicate can be used both for determining a suitable (black or white)\ncontrast colour with RGB as background and as foreground.\"\n (unless (<= 0 (apply #'min rgb) (apply #'max rgb) 1)\n (error \"RGB components %S not in [0,1]\" rgb))\n ;; Compute the relative luminance after gamma-correcting (assuming sRGB),\n ;; and compare to a cut-off value determined experimentally.\n ;; See https://en.wikipedia.org/wiki/Relative_luminance for details.\n (let* ((sr (nth 0 rgb))\n (sg (nth 1 rgb))\n (sb (nth 2 rgb))\n ;; Gamma-correct the RGB components to linear values.\n ;; Use the power 2.2 as an approximation to sRGB gamma;\n ;; it should be good enough for the purpose of this function.\n (r (expt sr 2.2))\n (g (expt sg 2.2))\n (b (expt sb 2.2))\n (y (+ (* r 0.2126) (* g 0.7152) (* b 0.0722))))\n (< y ement--color-luminance-dark-limit))))))\n\n;;;; Functions\n\n;;;;; Commands\n\n(cl-defun ement-create-room\n (session &key name alias topic invite direct-p creation-content\n (then (lambda (data)\n (message \"Created new room: %s\" (alist-get 'room_id data))))\n (visibility 'private))\n \"Create new room on SESSION.\nThen call function THEN with response data. Optional string\narguments are NAME, ALIAS, and TOPIC. INVITE may be a list of\nuser IDs to invite. If DIRECT-P, set the \\\"is_direct\\\" flag in\nthe request. CREATION-CONTENT may be an alist of extra keys to\ninclude with the request (see Matrix spec).\"\n ;; TODO: Document other arguments.\n ;; SPEC: 10.1.1.\n (declare (indent defun))\n (interactive (list (ement-complete-session)\n\t\t :name (read-string \"New room name: \")\n\t\t :alias (read-string \"New room alias (e.g. \\\"foo\\\" for \\\"#foo:matrix.org\\\"): \")\n\t\t :topic (read-string \"New room topic: \")\n\t\t :visibility (completing-read \"New room visibility: \" '(private public))))\n (cl-labels ((given-p (var) (and var (not (string-empty-p var)))))\n (pcase-let* ((endpoint \"createRoom\")\n\t\t (data (ement-aprog1\n\t\t\t (ement-alist \"visibility\" visibility)\n\t\t\t (when (given-p alias)\n\t\t\t (push (cons \"room_alias_name\" alias) it))\n\t\t\t (when (given-p name)\n\t\t\t (push (cons \"name\" name) it))\n\t\t\t (when (given-p topic)\n\t\t\t (push (cons \"topic\" topic) it))\n\t\t\t (when invite\n\t\t\t (push (cons \"invite\" invite) it))\n\t\t\t (when direct-p\n\t\t\t (push (cons \"is_direct\" t) it))\n (when creation-content\n (push (cons \"creation_content\" creation-content) it)))))\n (ement-api session endpoint :method 'post :data (json-encode data)\n :then then))))\n\n(cl-defun ement-create-space\n (session &key name alias topic\n (then (lambda (data)\n (message \"Created new space: %s\" (alist-get 'room_id data))))\n (visibility 'private))\n \"Create new space on SESSION.\nThen call function THEN with response data. Optional string\narguments are NAME, ALIAS, and TOPIC.\"\n (declare (indent defun))\n (interactive (list (ement-complete-session)\n\t\t :name (read-string \"New space name: \")\n\t\t :alias (read-string \"New space alias (e.g. \\\"foo\\\" for \\\"#foo:matrix.org\\\"): \")\n\t\t :topic (read-string \"New space topic: \")\n\t\t :visibility (completing-read \"New space visibility: \" '(private public))))\n (ement-create-room session :name name :alias alias :topic topic :visibility visibility\n :creation-content (ement-alist \"type\" \"m.space\") :then then))\n\n(defun ement-room-leave (room session &optional force-p)\n \"Leave ROOM on SESSION.\nIf FORCE-P, leave without prompting. ROOM may be an `ement-room'\nstruct, or a room ID or alias string.\"\n ;; TODO: Rename `room' argument to `room-or-id'.\n (interactive\n (ement-with-room-and-session\n :prompt-form (ement-complete-room :prompt \"Leave room: \")\n (list ement-room ement-session)))\n (cl-etypecase room\n (ement-room)\n (string (setf room (ement-afirst (or (equal room (ement-room-canonical-alias it))\n (equal room (ement-room-id it)))\n (ement-session-rooms session)))))\n (when (or force-p (yes-or-no-p (format \"Leave room %s? \" (ement--format-room room))))\n (pcase-let* (((cl-struct ement-room id) room)\n (endpoint (format \"rooms/%s/leave\" (url-hexify-string id))))\n (ement-api session endpoint :method 'post :data \"\"\n :then (lambda (_data)\n (when ement-room-leave-kill-buffer\n ;; NOTE: This generates a symbol and sets its function value to a lambda\n ;; which removes the symbol from the hook, removing itself from the hook.\n ;; TODO: When requiring Emacs 27, use `letrec'.\n (let* ((leave-fn-symbol (gensym (format \"ement-leave-%s\" room)))\n (leave-fn (lambda (_session)\n (remove-hook 'ement-sync-callback-hook leave-fn-symbol)\n ;; FIXME: Probably need to unintern the symbol.\n (when-let ((buffer (map-elt (ement-room-local room) 'buffer)))\n (when (buffer-live-p buffer)\n (kill-buffer buffer))))))\n (setf (symbol-function leave-fn-symbol) leave-fn)\n (add-hook 'ement-sync-callback-hook leave-fn-symbol)))\n (ement-message \"Left room: %s\" (ement--format-room room)))\n :else (lambda (plz-error)\n (pcase-let* (((cl-struct plz-error response) plz-error)\n ((cl-struct plz-response status body) response)\n ((map error) (json-read-from-string body)))\n (pcase status\n (429 (error \"Unable to leave room %s: %s\" room error))\n (_ (error \"Unable to leave room %s: %s %S\" room status plz-error)))))))))\n(defalias 'ement-leave-room #'ement-room-leave)\n\n(defun ement-forget-room (room session &optional force-p)\n \"Forget ROOM on SESSION.\nIf FORCE-P (interactively, with prefix), prompt to leave the room\nwhen necessary, and forget the room without prompting.\"\n (interactive\n (ement-with-room-and-session\n :prompt-form (ement-complete-room :prompt \"Forget room: \")\n (list ement-room ement-session current-prefix-arg)))\n (pcase-let* (((cl-struct ement-room id display-name status) room)\n (endpoint (format \"rooms/%s/forget\" (url-hexify-string id))))\n (pcase status\n ('join (if (and force-p\n (yes-or-no-p (format \"Leave and forget room %s? (WARNING: You will not be able to rejoin the room to access its content.) \"\n (ement--format-room room))))\n (progn\n ;; TODO: Use `letrec'.\n (let* ((forget-fn-symbol (gensym (format \"ement-forget-%s\" room)))\n (forget-fn (lambda (_session)\n (when (equal 'leave (ement-room-status room))\n (remove-hook 'ement-sync-callback-hook forget-fn-symbol)\n ;; FIXME: Probably need to unintern the symbol.\n (ement-forget-room room session 'force)))))\n (setf (symbol-function forget-fn-symbol) forget-fn)\n (add-hook 'ement-sync-callback-hook forget-fn-symbol))\n (ement-leave-room room session 'force))\n (user-error \"Room %s is joined (must be left before forgetting)\"\n (ement--format-room room))))\n ('leave (when (or force-p (yes-or-no-p (format \"Forget room \\\"%s\\\" (%s)? \" display-name id)))\n (ement-api session endpoint :method 'post :data \"\"\n :then (lambda (_data)\n ;; NOTE: The spec does not seem to indicate that the action of forgetting\n ;; a room is synced to other clients, so it seems that we need to remove\n ;; the room from the session here.\n (setf (ement-session-rooms session)\n (cl-remove room (ement-session-rooms session)))\n ;; TODO: Indicate forgotten in footer in room buffer.\n (ement-message \"Forgot room: %s.\" (ement--format-room room)))))))))\n\n(defun ement-ignore-user (user-id session &optional unignore-p)\n \"Ignore USER-ID on SESSION.\nIf UNIGNORE-P (interactively, with prefix), un-ignore USER.\"\n (interactive (list (ement-complete-user-id)\n (ement-complete-session)\n current-prefix-arg))\n (pcase-let* (((cl-struct ement-session account-data) session)\n ;; TODO: Store session account-data events in an alist keyed on type.\n ((map ('content (map ('ignored_users ignored-users))))\n (cl-find \"m.ignored_user_list\" account-data\n :key (lambda (event) (alist-get 'type event)) :test #'equal)))\n (if unignore-p\n ;; Being map keys, the user IDs have been interned by `json-read'.\n (setf ignored-users (map-delete ignored-users (intern user-id)))\n ;; Empty maps are used to list ignored users.\n (setf (map-elt ignored-users user-id) nil))\n (ement-put-account-data session \"m.ignored_user_list\" (ement-alist \"ignored_users\" ignored-users)\n :then (lambda (data)\n (ement-debug \"PUT successful\" data)\n (message \"Ement: User %s %s.\" user-id (if unignore-p \"unignored\" \"ignored\"))))))\n\n(defun ement-invite-user (user-id room session)\n \"Invite USER-ID to ROOM on SESSION.\nInteractively, with prefix, prompt for room and session,\notherwise use current room.\"\n ;; SPEC: 10.4.2.1.\n (interactive\n (ement-with-room-and-session\n (list (ement-complete-user-id) ement-room ement-session)))\n (pcase-let* ((endpoint (format \"rooms/%s/invite\"\n (url-hexify-string (ement-room-id room))))\n (data (ement-alist \"user_id\" user-id) ))\n (ement-api session endpoint :method 'post :data (json-encode data)\n ;; TODO: Handle error codes.\n :then (lambda (_data)\n (message \"User %s invited to room \\\"%s\\\" (%s)\" user-id\n (ement-room-display-name room)\n (ement-room-id room))))))\n\n(defun ement-list-members (room session bufferp)\n \"Show members of ROOM on SESSION.\nInteractively, with prefix, prompt for room and session,\notherwise use current room. If BUFFERP (interactively, with\nprefix), or if there are many members, show in a new buffer;\notherwise show in echo area.\"\n (interactive\n (ement-with-room-and-session\n (list ement-room ement-session current-prefix-arg)))\n (pcase-let* (((cl-struct ement-room members (local (map fetched-members-p))) room)\n (list-members\n (lambda (&optional _)\n (cond ((or bufferp (> (hash-table-count members) 51))\n ;; Show in buffer.\n (let* ((buffer (get-buffer-create (format \"*Ement members: %s*\" (ement-room-display-name room))))\n (members (cl-sort (cl-loop for user being the hash-values of members\n for id = (ement-user-id user)\n for displayname = (ement--user-displayname-in room user)\n collect (cons displayname id))\n (lambda (a b) (string-collate-lessp a b nil t)) :key #'car))\n (displayname-width (cl-loop for member in members\n maximizing (string-width (car member))))\n (format-string (format \"%%-%ss <%%s>\" displayname-width)))\n (with-current-buffer buffer\n (erase-buffer)\n (save-excursion\n (dolist (member members)\n (insert (format format-string (car member) (cdr member)) \"\\n\"))))\n (pop-to-buffer buffer)))\n (t\n ;; Show in echo area.\n (message \"Members of %s (%s): %s\" (ement--room-display-name room)\n (hash-table-count members)\n (string-join (map-apply (lambda (_id user)\n (ement--user-displayname-in room user))\n members)\n \", \")))))))\n (if fetched-members-p\n (funcall list-members)\n (ement--get-joined-members room session\n :then list-members))\n (message \"Listing members of %s...\" (ement--format-room room))))\n\n(defun ement-send-direct-message (session user-id message)\n \"Send a direct MESSAGE to USER-ID on SESSION.\nUses the latest existing direct room with the user, or creates a\nnew one automatically if necessary.\"\n ;; SPEC: 13.23.2.\n (interactive\n (let* ((session (ement-complete-session))\n\t (user-id (ement-complete-user-id))\n\t (message (read-string \"Message: \")))\n (list session user-id message)))\n (if-let* ((seen-user (gethash user-id ement-users))\n\t (existing-direct-room (ement--direct-room-for-user seen-user session)))\n (progn\n (ement-send-message existing-direct-room session :body message)\n (message \"Message sent to %s <%s> in room %S <%s>.\"\n (ement--user-displayname-in existing-direct-room seen-user)\n user-id\n (ement-room-display-name existing-direct-room) (ement-room-id existing-direct-room)))\n ;; No existing room for user: make new one.\n (message \"Creating new room for user %s...\" user-id)\n (ement-create-room session :direct-p t :invite (list user-id)\n :then (lambda (data)\n (let* ((room-id (alist-get 'room_id data))\n\t (room (or (cl-find room-id (ement-session-rooms session)\n :key #'ement-room-id)\n\t\t ;; New room hasn't synced yet: make a temporary struct.\n\t\t (make-ement-room :id room-id)))\n (direct-rooms-account-data-event-content\n ;; FIXME: Make account-data a map.\n (alist-get 'content (cl-find-if (lambda (event)\n (equal \"m.direct\" (alist-get 'type event)))\n (ement-session-account-data session)))))\n ;; Mark new room as direct: add the room to the account-data event, then\n ;; put the new account data to the server. (See also:\n ;; ).\n (setf (map-elt direct-rooms-account-data-event-content user-id) (vector room-id))\n (ement-put-account-data session \"m.direct\" direct-rooms-account-data-event-content)\n ;; Send message to new room.\n (ement-send-message room session :body message)\n (message \"Room \\\"%s\\\" created for user %s. Sending message...\"\n\t room-id user-id))))))\n\n(defun ement-tag-room (tag room session)\n \"Toggle TAG for ROOM on SESSION.\"\n (interactive\n (ement-with-room-and-session\n (let* ((prompt (format \"Toggle tag (%s): \" (ement--format-room ement-room)))\n (default-tags\n (ement-alist (propertize \"Favourite\"\n 'face (when (ement--room-tagged-p \"m.favourite\" ement-room)\n 'transient-value))\n \"m.favourite\"\n (propertize \"Low-priority\"\n 'face (when (ement--room-tagged-p \"m.lowpriority\" ement-room)\n 'transient-value))\n \"m.lowpriority\"))\n (input (completing-read prompt default-tags))\n (tag (alist-get input default-tags (concat \"u.\" input) nil #'string=)))\n (list tag ement-room ement-session))))\n (pcase-let* (((cl-struct ement-session user) session)\n ((cl-struct ement-user (id user-id)) user)\n ((cl-struct ement-room (id room-id)) room)\n (endpoint (format \"user/%s/rooms/%s/tags/%s\"\n (url-hexify-string user-id) (url-hexify-string room-id) (url-hexify-string tag)))\n (method (if (ement--room-tagged-p tag room) 'delete 'put)))\n ;; TODO: \"order\".\n ;; FIXME: Removing a tag on a left room doesn't seem to work (e.g. to unfavorite a room after leaving it, but not forgetting it).\n (ement-api session endpoint :version \"v3\" :method method :data (pcase method ('put \"{}\"))\n :then (lambda (_)\n (ement-message \"%s tag %S on %s\"\n (pcase method\n ('delete \"Removed\")\n ('put \"Added\"))\n tag (ement--format-room room)) ))))\n\n(defun ement-set-display-name (display-name session)\n \"Set DISPLAY-NAME for user on SESSION.\nSets global displayname.\"\n (interactive\n (let* ((session (ement-complete-session))\n (display-name (read-string \"Set display-name to: \" nil nil\n (ement-user-displayname (ement-session-user session)))))\n (list display-name session)))\n (pcase-let* (((cl-struct ement-session user) session)\n ((cl-struct ement-user (id user-id)) user)\n (endpoint (format \"profile/%s/displayname\" (url-hexify-string user-id))))\n (ement-api session endpoint :method 'put :version \"v3\"\n :data (json-encode (ement-alist \"displayname\" display-name))\n :then (lambda (_data)\n (message \"Ement: Display name set to %S for <%s>\" display-name\n (ement-user-id (ement-session-user session)))))))\n\n(defun ement-room-set-display-name (display-name room session)\n \"Set DISPLAY-NAME for user in ROOM on SESSION.\nInteractively, with prefix, prompt for room and session,\notherwise use current room. Sets the name only in ROOM, not\nglobally.\"\n (interactive\n (ement-with-room-and-session\n (let* ((prompt (format \"Set display-name in %S to: \"\n (ement--format-room ement-room)))\n (display-name (read-string prompt nil nil\n (ement-user-displayname (ement-session-user ement-session)))))\n (list display-name ement-room ement-session))))\n ;; NOTE: This does not seem to be documented in the spec, so we imitate the\n ;; \"/myroomnick\" command in SlashCommands.tsx from matrix-react-sdk.\n (pcase-let* (((cl-struct ement-room state) room)\n ((cl-struct ement-session user) session)\n ((cl-struct ement-user id) user)\n (member-event (cl-find-if (lambda (event)\n (and (equal id (ement-event-state-key event))\n (equal \"m.room.member\" (ement-event-type event))\n (equal \"join\" (alist-get 'membership (ement-event-content event)))))\n state)))\n (cl-assert member-event)\n (setf (alist-get 'displayname (ement-event-content member-event)) display-name)\n (ement-put-state room \"m.room.member\" id (ement-event-content member-event) session\n :then (lambda (_data)\n (message \"Ement: Display name set to %S for <%s> in %S\" display-name\n (ement-user-id (ement-session-user session))\n (ement--format-room room))))))\n\n;;;;;; Describe room\n\n(defvar ement-describe-room-mode-map\n (let ((map (make-sparse-keymap)))\n (define-key map (kbd \"q\") #'quit-window)\n map)\n \"Keymap for `ement-describe-room-mode' buffers.\")\n\n(define-derived-mode ement-describe-room-mode read-only-mode\n \"Ement-Describe-Room\" \"Major mode for `ement-describe-room' buffers.\")\n\n(defun ement-describe-room (room session)\n \"Describe ROOM on SESSION.\nInteractively, with prefix, prompt for room and session,\notherwise use current room.\"\n (interactive (ement-with-room-and-session (list ement-room ement-session)))\n (cl-labels ((heading (string)\n (propertize (or string \"\") 'face 'font-lock-builtin-face))\n (id (string)\n (propertize (or string \"\") 'face 'font-lock-constant-face))\n (member<\n (a b) (string-collate-lessp (car a) (car b) nil t)))\n (pcase-let* (((cl-struct ement-room (id room-id) avatar display-name canonical-alias members timeline status topic\n (local (map fetched-members-p)))\n room)\n ((cl-struct ement-session user) session)\n ((cl-struct ement-user (id user-id)) user)\n (inhibit-read-only t))\n (if (not fetched-members-p)\n ;; Members not fetched: fetch them and re-call this command.\n (ement--get-joined-members room session\n :then (lambda (_) (ement-room-describe room session)))\n (with-current-buffer (get-buffer-create (format \"*Ement room description: %s*\" (or display-name canonical-alias room-id)))\n (let ((inhibit-read-only t))\n (erase-buffer)\n ;; We avoid looping twice by doing a bit more work here and\n ;; returning a cons which we destructure.\n (pcase-let* ((`(,member-pairs . ,name-width)\n (cl-loop for user being the hash-values of members\n for formatted = (ement--format-user user room session)\n for id = (format \"<%s>\" (id (ement-user-id user)))\n collect (cons formatted id)\n into pairs\n maximizing (string-width id) into width\n finally return (cons (cl-sort pairs #'member<) width)))\n ;; We put the MXID first, because users may use Unicode characters\n ;; in their displayname, which `string-width' does not always\n ;; return perfect results for, and putting it last prevents\n ;; alignment problems.\n (spec (format \"%%-%ss %%s\" name-width)))\n (save-excursion\n (insert \"\\\"\" (propertize (or display-name canonical-alias room-id) 'face 'font-lock-doc-face) \"\\\"\" \" is a \"\n (propertize (if (ement--space-p room)\n \"space\"\n \"room\")\n 'face 'font-lock-type-face)\n \" \"\n (propertize (pcase status\n ('invite \"invited\")\n ('join \"joined\")\n ('leave \"left\")\n (_ (symbol-name status)))\n 'face 'font-lock-comment-face)\n \" on session <\" (id user-id) \">.\\n\\n\"\n (heading \"Avatar: \") (or avatar \"\") \"\\n\\n\"\n (heading \"ID: \") \"<\" (id room-id) \">\" \"\\n\"\n (heading \"Alias: \") \"<\" (id canonical-alias) \">\" \"\\n\\n\"\n (heading \"Topic: \") (propertize (or topic \"[none]\") 'face 'font-lock-comment-face) \"\\n\\n\"\n (heading \"Retrieved events: \") (number-to-string (length timeline)) \"\\n\"\n (heading \" spanning: \")\n (format-time-string \"%Y-%m-%d %H:%M:%S\"\n (/ (ement-event-origin-server-ts\n (car (cl-sort (copy-sequence timeline) #'< :key #'ement-event-origin-server-ts)))\n 1000))\n (heading \" to \")\n (format-time-string \"%Y-%m-%d %H:%M:%S\\n\\n\"\n (/ (ement-event-origin-server-ts\n (car (cl-sort (copy-sequence timeline) #'> :key #'ement-event-origin-server-ts)))\n 1000))\n (heading \"Members\") \" (\" (number-to-string (hash-table-count members)) \"):\\n\")\n (pcase-dolist (`(,formatted . ,id) member-pairs)\n (insert \" \" (format spec id formatted) \"\\n\")))))\n (unless (eq major-mode 'ement-describe-room-mode)\n ;; Without this check, activating the mode again causes a \"Cyclic keymap\n ;; inheritance\" error.\n (ement-describe-room-mode))\n (pop-to-buffer (current-buffer)))))))\n\n(defalias 'ement-room-describe #'ement-describe-room)\n\n;;;;;; Push rules\n\n;; NOTE: Although v1.4 of the spec is available and describes setting the push rules using\n;; the \"v3\" API endpoint, the Element client continues to use the \"r0\" endpoint, which is\n;; slightly different. This implementation will follow Element's initially, because the\n;; spec is not simple, and imitating Element's requests will make it easier.\n\n(defun ement-room-notification-state (room session)\n \"Return notification state for ROOM on SESSION.\nReturns one of nil (meaning default rules are used), `all-loud',\n`all', `mentions-and-keywords', or `none'.\"\n ;; Following the implementation of getRoomNotifsState() in RoomNotifs.ts in matrix-react-sdk.\n\n ;; TODO: Guest support (in which case the state should be `all').\n ;; TODO: Store account data as a hash table of event types.\n (let ((push-rules (cl-find-if (lambda (alist)\n (equal \"m.push_rules\" (alist-get 'type alist)))\n (ement-session-account-data session))))\n (cl-labels ((override-mute-rule-for-room-p (room)\n ;; Following findOverrideMuteRule() in RoomNotifs.ts.\n (when-let ((overrides (map-nested-elt push-rules '(content global override))))\n (cl-loop for rule in overrides\n when (and (alist-get 'enabled rule)\n (rule-for-room-p rule room))\n return rule)))\n (rule-for-room-p (rule room)\n ;; Following isRuleForRoom() in RoomNotifs.ts.\n (and (/= 1 (length (alist-get 'conditions rule)))\n (pcase-let* ((condition (elt (alist-get 'conditions rule) 0))\n ((map kind key pattern) condition))\n (and (equal \"event_match\" kind)\n (equal \"room_id\" key)\n (equal (ement-room-id room) pattern)))))\n (mute-rule-p (rule)\n (when-let ((actions (alist-get 'actions rule)))\n (seq-contains-p actions \"dont_notify\")))\n ;; NOTE: Although v1.7 of the spec says that \"dont_notify\" is\n ;; obsolete, the latest revision of matrix-react-sdk (released last week\n ;; as v3.77.1) still works as modeled here.\n (tweak-rule-p (type rule)\n (when-let ((actions (alist-get 'actions rule)))\n (and (seq-contains-p actions \"notify\")\n (seq-contains-p actions `(set_tweak . ,type) 'seq-contains-p)))))\n ;; If none of these match, nil is returned, meaning that the default rule is used\n ;; for the room.\n (if (override-mute-rule-for-room-p room)\n 'none\n (when-let ((room-rule (cl-find-if (lambda (rule)\n (equal (ement-room-id room) (alist-get 'rule_id rule)))\n (map-nested-elt push-rules '(content global room)))))\n (cond ((not (alist-get 'enabled room-rule))\n ;; NOTE: According to comment in getRoomNotifsState(), this assumes that\n ;; the default is to notify for all messages, which \"will be 'wrong' for\n ;; one to one rooms because they will notify loudly for all messages.\"\n 'all)\n ((mute-rule-p room-rule)\n ;; According to comment, a room-level mute still allows mentions to\n ;; notify. NOTE: See note above.\n 'mentions-and-keywords)\n ((tweak-rule-p \"sound\" room-rule) 'all-loud)))))))\n\n(defun ement-room-set-notification-state (state room session)\n \"Set notification STATE for ROOM on SESSION.\nInteractively, with prefix, prompt for room and session,\notherwise use current room. STATE may be nil to set the rules to\ndefault, `all', `mentions-and-keywords', or `none'.\"\n ;; This merely attempts to reproduce the behavior of Element's simple notification\n ;; options. It does not attempt to offer all of the features defined in the spec. And,\n ;; yes, it is rather awkward, having to sometimes* make multiple requests of different\n ;; \"kinds\" to set the rules for a single room, but that is how the API works.\n ;;\n ;; * It appears that Element only makes multiple requests of different kinds when\n ;; strictly necessary, but coding that logic now would seem likely to be a waste of\n ;; time, given that Element doesn't even use the latest version of the spec yet. So\n ;; we'll just do the \"dumb\" thing and always send requests of both \"override\" and\n ;; \"room\" kinds, which appears to Just Work™.\n ;;\n ;; TODO: Match rules to these user-friendly notification states for presentation. See\n ;; .\n\n ;; TODO: Support `all-loud' (\"all_messages_loud\").\n (interactive\n (ement-with-room-and-session\n (let* ((prompt (format \"Set notification rules for %s: \" (ement--format-room ement-room)))\n (available-states (ement-alist \"Default\" nil\n \"All messages\" 'all\n \"Mentions and keywords\" 'mentions-and-keywords\n \"None\" 'none))\n (selected-rule (completing-read prompt (mapcar #'car available-states) nil t))\n (state (alist-get selected-rule available-states nil nil #'equal)))\n (list state ement-room ement-session))))\n (cl-labels ((set-rule (kind rule queue message-fn)\n (pcase-let* (((cl-struct ement-room (id room-id)) room)\n (rule-id (url-hexify-string room-id))\n (endpoint (format \"pushrules/global/%s/%s\" kind rule-id))\n (method (if rule 'put 'delete))\n (then (if rule\n ;; Setting rules requires PUTting the rules, then making a second\n ;; request to enable them.\n (lambda (_data)\n (ement-api session (concat endpoint \"/enabled\") :queue queue :version \"r0\"\n :method 'put :data (json-encode (ement-alist 'enabled t))\n :then message-fn))\n message-fn)))\n (ement-api session endpoint :queue queue :method method :version \"r0\"\n :data (json-encode rule)\n :then then\n :else (lambda (plz-error)\n (pcase-let* (((cl-struct plz-error response) plz-error)\n ((cl-struct plz-response status) response))\n (pcase status\n (404 (pcase rule\n (`nil\n ;; Room already had no rules, so none being found is not an\n ;; error.\n nil)\n (_ ;; Unexpected error: re-signal.\n (ement-api-error plz-error))))\n (_ ;; Unexpected error: re-signal.\n (ement-api-error plz-error)))))))))\n (pcase-let* ((available-states\n (ement-alist\n nil (ement-alist\n \"override\" nil\n \"room\" nil)\n 'all (ement-alist\n \"override\" nil\n \"room\" (ement-alist\n 'actions (vector \"notify\" (ement-alist\n 'set_tweak \"sound\"\n 'value \"default\"))))\n 'mentions-and-keywords (ement-alist\n \"override\" nil\n \"room\" (ement-alist\n 'actions (vector \"dont_notify\")))\n 'none (ement-alist\n \"override\" (ement-alist\n 'actions (vector \"dont_notify\")\n 'conditions (vector (ement-alist\n 'kind \"event_match\"\n 'key \"room_id\"\n 'pattern (ement-room-id room))))\n \"room\" nil)))\n (kinds-and-rules (alist-get state available-states nil nil #'equal)))\n (cl-loop with queue = (make-plz-queue :limit 1)\n with total = (1- (length kinds-and-rules))\n for count from 0\n for message-fn = (if (equal count total)\n (lambda (_data)\n (message \"Set notification rules for room: %s\" (ement--format-room room)))\n #'ignore)\n for (kind . state) in kinds-and-rules\n do (set-rule kind state queue message-fn)))))\n\n;;;;; Public functions\n\n;; These functions could reasonably be called by code in other packages.\n\n(cl-defun ement-put-state\n (room type key data session\n &key (then (lambda (response-data)\n (ement-debug \"State data put on room\" response-data data room session))))\n \"Put state event of TYPE with KEY and DATA on ROOM on SESSION.\nDATA should be an alist, which will become the JSON request\nbody.\"\n (declare (indent defun))\n (pcase-let* ((endpoint (format \"rooms/%s/state/%s/%s\"\n (url-hexify-string (ement-room-id room))\n type key)))\n (ement-api session endpoint :method 'put :data (json-encode data)\n ;; TODO: Handle error codes.\n :then then)))\n\n(defun ement-message (format-string &rest args)\n \"Call `message' on FORMAT-STRING prefixed with \\\"Ement: \\\".\"\n ;; TODO: Use this function everywhere we use `message'.\n (apply #'message (concat \"Ement: \" format-string) args))\n\n(cl-defun ement-upload (session &key data filename then else\n (content-type \"application/octet-stream\"))\n \"Upload DATA with FILENAME to content repository on SESSION.\nTHEN and ELSE are passed to `ement-api', which see.\"\n (declare (indent defun))\n (ement-api session \"upload\" :method 'post :endpoint-category \"media\"\n ;; NOTE: Element currently uses \"r0\" not \"v3\", so so do we.\n :params (when filename\n (list (list \"filename\" filename)))\n :content-type content-type :data data :data-type 'binary\n :then then :else else))\n\n(cl-defun ement-complete-session (&key (prompt \"Session: \"))\n \"Return an Ement session selected with completion.\"\n (pcase (length ement-sessions)\n (0 (user-error \"No active sessions. Call `ement-connect' to log in\"))\n (1 (cdar ement-sessions))\n (_ (let* ((ids (mapcar #'car ement-sessions))\n (selected-id (completing-read prompt ids nil t)))\n (alist-get selected-id ement-sessions nil nil #'equal)))))\n\n(declare-function ewoc-locate \"ewoc\")\n(defun ement-complete-user-id ()\n \"Return a user-id selected with completion.\nSelects from seen users on all sessions. If point is on an\nevent, suggests the event's sender as initial input. Allows\nunseen user IDs to be input as well.\"\n (cl-labels ((format-user (user)\n ;; FIXME: Per-room displaynames are now stored in room structs\n ;; rather than user structs, so to be complete, this needs to\n ;; iterate over all known rooms, looking for the user's\n ;; displayname in that room.\n (format \"%s <%s>\"\n (ement-user-displayname user)\n\t\t\t(ement-user-id user))))\n (let* ((display-to-id\n\t (cl-loop for key being the hash-keys of ement-users\n\t\t using (hash-values value)\n\t\t collect (cons (format-user value) key)))\n (user-at-point (when (equal major-mode 'ement-room-mode)\n (when-let ((node (ewoc-locate ement-ewoc)))\n (when (ement-event-p (ewoc-data node))\n (format-user (ement-event-sender (ewoc-data node)))))))\n\t (selected-user (completing-read \"User: \" (mapcar #'car display-to-id)\n nil nil user-at-point)))\n (or (alist-get selected-user display-to-id nil nil #'equal)\n\t selected-user))))\n\n(cl-defun ement-put-account-data\n (session type data &key room\n (then (lambda (received-data)\n ;; Handle echoed-back account data event (the spec does not explain this,\n ;; but see ).\n ;; FIXME: Make session account-data a map instead of a list of events.\n (if room\n (push received-data (ement-room-account-data room))\n (push received-data (ement-session-account-data session)))\n\n ;; NOTE: Commenting out this ement-debug form because a bug in Emacs\n ;; causes this long string to be interpreted as the function's\n ;; docstring and cause a too-long-docstring warning.\n\n ;; (ement-debug \"Account data put and received back on session %s: PUT(json-encoded):%S RECEIVED:%S\"\n ;; (ement-user-id (ement-session-user session)) (json-encode data) received-data)\n )))\n \"Put account data of TYPE with DATA on SESSION.\nIf ROOM, put it on that room's account data. Also handle the\nechoed-back event.\"\n (declare (indent defun))\n (pcase-let* (((cl-struct ement-session (user (cl-struct ement-user (id user-id)))) session)\n (room-part (if room (format \"/rooms/%s\" (ement-room-id room)) \"\"))\n (endpoint (format \"user/%s%s/account_data/%s\" (url-hexify-string user-id) room-part type)))\n (ement-api session endpoint :method 'put :data (json-encode data)\n :then then)))\n\n(defun ement-redact (event room session &optional reason)\n \"Redact EVENT in ROOM on SESSION, optionally for REASON.\"\n (pcase-let* (((cl-struct ement-event (id event-id)) event)\n ((cl-struct ement-room (id room-id)) room)\n (endpoint (format \"rooms/%s/redact/%s/%s\"\n room-id event-id (ement--update-transaction-id session)))\n (content (ement-alist \"reason\" reason)))\n (ement-api session endpoint :method 'put :data (json-encode content)\n :then (lambda (_data)\n (message \"Event %s redacted.\" event-id)))))\n\n;;;;; Inline functions\n\n(defsubst ement--user-color (user)\n \"Return USER's color, setting it if necessary.\nUSER is an `ement-user' struct.\"\n (or (ement-user-color user)\n (setf (ement-user-color user)\n (ement--prism-color (ement-user-id user)))))\n\n;;;;; Private functions\n\n;; These functions aren't expected to be called by code in other packages (but if that\n;; were necessary, they could be renamed accordingly).\n\n;; (defun ement--room-routing (room)\n;; \"Return a list of servers to route to ROOM through.\"\n;; ;; See .\n;; ;; FIXME: Ensure highest power level user is at least level 50.\n;; ;; FIXME: Ignore servers blocked due to server ACLs.\n;; ;; FIXME: Ignore servers which are IP addresses.\n;; (cl-labels ((most-powerful-user-in\n;; (room))\n;; (servers-by-population-in\n;; (room))\n;; (server-of (user)))\n;; (let (first-server-by-power-level)\n;; (delete-dups\n;; (remq nil\n;; (list\n;; ;; 1.\n;; (or (when-let ((user (most-powerful-user-in room)))\n;; (setf first-server-by-power-level t)\n;; (server-of user))\n;; (car (servers-by-population-in room)))\n;; ;; 2.\n;; (if first-server-by-power-level\n;; (car (servers-by-population-in room))\n;; (cl-second (servers-by-population-in room)))\n;; ;; 3.\n;; (cl-third (servers-by-population-in room))))))))\n\n(defun ement--space-p (room)\n \"Return non-nil if ROOM is a space.\"\n (equal \"m.space\" (ement-room-type room)))\n\n(defun ement--room-in-space-p (room space)\n \"Return non-nil if ROOM is in SPACE on SESSION.\"\n ;; We could use `ement---room-spaces', but since that returns rooms by looking them up\n ;; by ID in the session's rooms list, this is more efficient.\n (pcase-let* (((cl-struct ement-room (id parent-id) (local (map children))) space)\n ((cl-struct ement-room (id child-id) (local (map parents))) room))\n (or (member parent-id parents)\n (member child-id children))))\n\n(defun ement--room-spaces (room session)\n \"Return list of ROOM's parent spaces on SESSION.\"\n ;; NOTE: This only looks in the room's parents list; it doesn't look in every space's children\n ;; list. This should be good enough, assuming we add to the lists correctly elsewhere.\n (pcase-let* (((cl-struct ement-session rooms) session)\n ((cl-struct ement-room (local (map parents))) room))\n (cl-remove-if-not (lambda (session-room-id)\n (member session-room-id parents))\n rooms :key #'ement-room-id)))\n\n(cl-defun ement--prism-color (string &key (contrast-with (face-background 'default nil 'default)))\n \"Return a computed color for STRING.\nThe color is adjusted to have sufficient contrast with the color\nCONTRAST-WITH (by default, the default face's background). The\ncomputed color is useful for user messages, generated room\navatars, etc.\"\n ;; TODO: Use this instead of `ement-room--user-color'. (Same algorithm ,just takes a\n ;; string as argument.)\n ;; TODO: Try using HSV somehow so we could avoid having so many strings return a\n ;; nearly-black color.\n (cl-labels ((relative-luminance (rgb)\n ;; Copy of `modus-themes-wcag-formula', an elegant\n ;; implementation by Protesilaos Stavrou. Also see\n ;; and\n ;; .\n (cl-loop for k in '(0.2126 0.7152 0.0722)\n for x in rgb\n sum (* k (if (<= x 0.03928)\n (/ x 12.92)\n (expt (/ (+ x 0.055) 1.055) 2.4)))))\n (contrast-ratio (a b)\n ;; Copy of `modus-themes-contrast'; see above.\n (let ((ct (/ (+ (relative-luminance a) 0.05)\n (+ (relative-luminance b) 0.05))))\n (max ct (/ ct))))\n (increase-contrast (color against target toward)\n (let ((gradient (cdr (color-gradient color toward 20)))\n new-color)\n (cl-loop do (setf new-color (pop gradient))\n while new-color\n until (>= (contrast-ratio new-color against) target)\n ;; Avoid infinite loop in case of weirdness\n ;; by returning color as a fallback.\n finally return (or new-color color)))))\n (let* ((id string)\n (id-hash (float (+ (abs (sxhash id)) ement-room-prism-color-adjustment)))\n ;; TODO: Wrap-around the value to get the color I want.\n (ratio (/ id-hash (float most-positive-fixnum)))\n (color-num (round (* (* 255 255 255) ratio)))\n (color-rgb (list (/ (float (logand color-num 255)) 255)\n (/ (float (ash (logand color-num 65280) -8)) 255)\n (/ (float (ash (logand color-num 16711680) -16)) 255)))\n (contrast-with-rgb (color-name-to-rgb contrast-with)))\n (when (< (contrast-ratio color-rgb contrast-with-rgb) ement-room-prism-minimum-contrast)\n (setf color-rgb (increase-contrast color-rgb contrast-with-rgb ement-room-prism-minimum-contrast\n (color-name-to-rgb\n ;; Ideally we would use the foreground color,\n ;; but in some themes, like Solarized Dark,\n ;; the foreground color's contrast is too low\n ;; to be effective as the value to increase\n ;; contrast against, so we use white or black.\n (pcase contrast-with\n ((or `nil \"unspecified-bg\")\n ;; The `contrast-with' color (i.e. the\n ;; default background color) is nil. This\n ;; probably means that we're displaying on\n ;; a TTY.\n (if (fboundp 'frame--current-backround-mode)\n ;; This function can tell us whether\n ;; the background color is dark or\n ;; light, but it was added in Emacs\n ;; 28.1.\n (pcase (frame--current-backround-mode (selected-frame))\n ('dark \"white\")\n ('light \"black\"))\n ;; Pre-28.1: Since faces' colors may be\n ;; \"unspecified\" on TTY frames, in which\n ;; case we have nothing to compare with, we\n ;; assume that the background color of such\n ;; a frame is black and increase contrast\n ;; toward white.\n \"white\"))\n (_\n ;; The `contrast-with` color is usable: test it.\n (if (ement--color-dark-p (color-name-to-rgb contrast-with))\n \"white\" \"black\")))))))\n (apply #'color-rgb-to-hex (append color-rgb (list 2))))))\n\n(cl-defun ement--format-user (user &optional (room ement-room) (session ement-session))\n \"Format `ement-user' USER for ROOM on SESSION.\nROOM defaults to the value of `ement-room'.\"\n (let ((face (cond ((equal (ement-user-id (ement-session-user session))\n (ement-user-id user))\n 'ement-room-self)\n (ement-room-prism\n `(:inherit ement-room-user :foreground ,(or (ement-user-color user)\n (setf (ement-user-color user)\n (ement--prism-color user)))))\n (t 'ement-room-user))))\n ;; FIXME: If a membership state event has not yet been received, this\n ;; sets the display name in the room to the user ID, and that prevents\n ;; the display name from being used if the state event arrives later.\n (propertize (ement--user-displayname-in room user)\n 'face face\n 'help-echo (ement-user-id user))))\n\n(cl-defun ement--format-body-mentions\n (body room &key (template \"%s\"))\n \"Return string for BODY with mentions in ROOM linkified with TEMPLATE.\nTEMPLATE is a format string in which the first \\\"%s\\\" is replaced\nwith the user's MXID and the second with the displayname. A\nmention is qualified by an \\\"@\\\"-prefixed displayname or\nMXID (optionally suffixed with a colon), or a colon-suffixed\ndisplayname, followed by a blank, question mark, comma, or\nperiod, anywhere in the body.\"\n ;; Examples:\n ;; \"@foo: hi\"\n ;; \"@foo:matrix.org: hi\"\n ;; \"foo: hi\"\n ;; \"@foo and @bar:matrix.org: hi\"\n ;; \"foo: how about you and @bar ...\"\n (declare (indent defun))\n (cl-labels ((members-having-displayname (name members)\n ;; Iterating over the hash table values isn't as efficient as a hash\n ;; lookup, but in most rooms it shouldn't be a problem.\n (cl-loop for user being the hash-values of members\n when (equal name (ement--user-displayname-in room user))\n collect user)))\n (pcase-let* (((cl-struct ement-room members) room)\n (regexp (rx (or bos bow blank \"\\n\")\n (or (seq (group\n ;; Group 1: full @-prefixed MXID.\n \"@\" (group\n ;; Group 2: displayname. (NOTE: Does not work\n ;; with displaynames containing spaces.)\n (1+ (seq (optional \".\") alnum)))\n (optional \":\" (1+ (seq (optional \".\") alnum))))\n (or \":\" eow eos (syntax punctuation)))\n (seq (group\n ;; Group 3: MXID username or displayname.\n (1+ (not blank)))\n \":\" (1+ blank)))))\n (pos 0) (replace-group) (replacement))\n (while (setf pos (string-match regexp body pos))\n (if (setf replacement\n (or (when-let (member (gethash (match-string 1 body) members))\n ;; Found user ID: use it as replacement.\n (setf replace-group 1)\n (format template (match-string 1 body)\n (ement--xml-escape-string (ement--user-displayname-in room member))))\n (when-let* ((name (or (when (match-string 2 body)\n (setf replace-group 1)\n (match-string 2 body))\n (prog1 (match-string 3 body)\n (setf replace-group 3))))\n (members (members-having-displayname name members))\n (member (when (= 1 (length members))\n ;; If multiple members are found with the same\n ;; displayname, do nothing.\n (car members))))\n ;; Found displayname: use it and MXID as replacement.\n (format template (ement-user-id member)\n (ement--xml-escape-string name)))))\n (progn\n ;; Found member: replace and move to end of replacement.\n (setf body (replace-match replacement t t body replace-group))\n (let ((difference (- (length replacement) (length (match-string 0 body)))))\n (setf pos (if (/= 0 difference)\n ;; Replacement of a different length: adjust POS accordingly.\n (+ pos difference)\n (match-end 0)))))\n ;; No replacement: move to end of match.\n (setf pos (match-end 0))))))\n body)\n\n(defun ement--event-mentions-room-p (event &rest _ignore)\n \"Return non-nil if EVENT mentions \\\"@room\\\".\"\n (pcase-let (((cl-struct ement-event (content (map body))) event))\n (when body\n (string-match-p (rx (or space bos) \"@room\" eow) body))))\n\n(cl-defun ement-complete-room (&key session (predicate #'identity)\n (prompt \"Room: \") (suggest t))\n \"Return a (room session) list selected from SESSION with completion.\nIf SESSION is nil, select from rooms in all of `ement-sessions'.\nWhen SUGGEST, suggest current buffer's room (or a room at point\nin a room list buffer) as initial input (i.e. it should be set to\nnil when switching from one room buffer to another). PROMPT may\noverride the default prompt. PREDICATE may be a function to\nselect which rooms are offered; it is also applied to the\nsuggested room.\"\n (declare (indent defun))\n (pcase-let* ((sessions (if session\n (list session)\n (mapcar #'cdr ement-sessions)))\n (name-to-room-session\n (cl-loop for session in sessions\n append (cl-loop for room in (ement-session-rooms session)\n when (funcall predicate room)\n collect (cons (ement--format-room room 'topic)\n (list room session)))))\n (names (mapcar #'car name-to-room-session))\n (selected-name (completing-read\n prompt names nil t\n (when suggest\n (when-let ((suggestion (ement--room-at-point)))\n (when (or (not predicate)\n (funcall predicate suggestion))\n (ement--format-room suggestion 'topic)))))))\n (alist-get selected-name name-to-room-session nil nil #'string=)))\n\n(cl-defun ement-send-message (room session\n &key body formatted-body replying-to-event filter then)\n \"Send message to ROOM on SESSION with BODY and FORMATTED-BODY.\nTHEN may be a function to call after the event is sent\nsuccessfully. It is called with keyword arguments for ROOM,\nSESSION, CONTENT, and DATA.\n\nREPLYING-TO-EVENT may be an event the message is\nin reply to; the message will reference it appropriately.\n\nFILTER may be a function through which to pass the message's\ncontent object before sending (see,\ne.g. `ement-room-send-org-filter').\"\n (declare (indent defun))\n (cl-assert (not (string-empty-p body)))\n (cl-assert (or (not formatted-body) (not (string-empty-p formatted-body))))\n (pcase-let* (((cl-struct ement-room (id room-id)) room)\n (endpoint (format \"rooms/%s/send/m.room.message/%s\" (url-hexify-string room-id)\n (ement--update-transaction-id session)))\n (formatted-body (when formatted-body\n (ement--format-body-mentions formatted-body room)))\n (content (ement-aprog1\n (ement-alist \"msgtype\" \"m.text\"\n \"body\" body)\n (when formatted-body\n (push (cons \"formatted_body\" formatted-body) it)\n (push (cons \"format\" \"org.matrix.custom.html\") it))))\n (then (or then #'ignore)))\n (when filter\n (setf content (funcall filter content room)))\n (when replying-to-event\n (setf replying-to-event (ement--original-event-for replying-to-event session)\n content (ement--add-reply content replying-to-event room)))\n (ement-api session endpoint :method 'put :data (json-encode content)\n :then (apply-partially then :room room :session session\n ;; Data is added when calling back.\n :content content :data))))\n\n(defalias 'ement--button-buttonize\n ;; This isn't nice, but what can you do.\n (cond ((version<= \"29.1\" emacs-version) #'buttonize)\n ((version<= \"28.1\" emacs-version) (with-suppressed-warnings ((obsolete button-buttonize))\n #'button-buttonize))\n ((version< emacs-version \"28.1\")\n ;; FIXME: This doesn't set the mouse-face to highlight, and it doesn't use the\n ;; default-button category. Neither does `button-buttonize', of course, but why?\n (lambda (string callback &optional data)\n \"Make STRING into a button and return it.\nWhen clicked, CALLBACK will be called with the DATA as the\nfunction argument. If DATA isn't present (or is nil), the button\nitself will be used instead as the function argument.\"\n (propertize string\n 'face 'button\n 'button t\n 'follow-link t\n 'category t\n 'button-data data\n 'keymap button-map\n 'action callback)))))\n\n(defun ement--add-reply (data replying-to-event room)\n \"Return DATA adding reply data for REPLYING-TO-EVENT in ROOM.\nDATA is an unsent message event's data alist.\"\n ;; SPEC: \"13.2.2.6.1 Rich replies\"\n ;; FIXME: Rename DATA.\n (pcase-let* (((cl-struct ement-event (id replying-to-event-id)\n content (sender replying-to-sender))\n replying-to-event)\n ((cl-struct ement-user (id replying-to-sender-id)) replying-to-sender)\n ((map ('body replying-to-body) ('formatted_body replying-to-formatted-body)) content)\n (replying-to-sender-name (ement--user-displayname-in ement-room replying-to-sender))\n (quote-string (format \"> <%s> %s\\n\\n\" replying-to-sender-name replying-to-body))\n (reply-body (alist-get \"body\" data nil nil #'string=))\n (reply-formatted-body (alist-get \"formatted_body\" data nil nil #'string=))\n (reply-body-with-quote (concat quote-string reply-body))\n (reply-formatted-body-with-quote\n (format \"\n
\n In reply to\n %s\n
\n %s\n
\n\n%s\"\n (ement-room-id room) replying-to-event-id replying-to-sender-id replying-to-sender-name\n ;; TODO: Encode HTML special characters. Not as straightforward in Emacs as one\n ;; might hope: there's `web-mode-html-entities' and `org-entities'. See also\n ;; .\n (or replying-to-formatted-body replying-to-body)\n (or reply-formatted-body reply-body))))\n ;; NOTE: map-elt doesn't work with string keys, so we use `alist-get'.\n (setf (alist-get \"body\" data nil nil #'string=) reply-body-with-quote\n (alist-get \"formatted_body\" data nil nil #'string=) reply-formatted-body-with-quote\n data (append (ement-alist \"m.relates_to\"\n (ement-alist \"m.in_reply_to\"\n (ement-alist \"event_id\" replying-to-event-id))\n \"format\" \"org.matrix.custom.html\")\n data))\n data))\n\n(defun ement--direct-room-for-user (user session)\n \"Return last-modified direct room with USER on SESSION, if one exists.\"\n ;; Loosely modeled on the Element function findDMForUser in createRoom.ts.\n (cl-labels ((membership-event-for-p (event user)\n (and (equal \"m.room.member\" (ement-event-type event))\n (equal (ement-user-id user) (ement-event-state-key event))))\n (latest-membership-for (user room)\n (when-let ((latest-membership-event\n (car\n (cl-sort\n ;; I guess we need to check both state and timeline events.\n (append (cl-remove-if-not (lambda (event)\n (membership-event-for-p event user))\n (ement-room-state room))\n (cl-remove-if-not (lambda (event)\n (membership-event-for-p event user))\n (ement-room-timeline room)))\n (lambda (a b)\n ;; Sort latest first so we can use the car.\n (> (ement-event-origin-server-ts a)\n (ement-event-origin-server-ts b)))))))\n (alist-get 'membership (ement-event-content latest-membership-event))))\n (latest-event-in (room)\n (car\n (cl-sort\n (append (ement-room-state room)\n (ement-room-timeline room))\n (lambda (a b)\n ;; Sort latest first so we can use the car.\n (> (ement-event-origin-server-ts a)\n (ement-event-origin-server-ts b)))))))\n (let* ((direct-rooms (cl-remove-if-not\n (lambda (room)\n (ement--room-direct-p room session))\n (ement-session-rooms session)))\n (direct-joined-rooms\n ;; Ensure that the local user is still in each room.\n (cl-remove-if-not\n (lambda (room)\n (equal \"join\" (latest-membership-for (ement-session-user session) room)))\n direct-rooms))\n ;; Since we don't currently keep a member list for each room, we look in the room's\n ;; join events to see if the user has joined or been invited.\n (direct-rooms-with-user\n (cl-remove-if-not\n (lambda (room)\n (member (latest-membership-for user room) '(\"invite\" \"join\")))\n direct-joined-rooms)))\n (car (cl-sort direct-rooms-with-user\n (lambda (a b)\n (> (latest-event-in a) (latest-event-in b))))))))\n\n(defun ement--event-replaces-p (a b)\n \"Return non-nil if event A replaces event B.\nThat is, if event A replaces B in their\n\\\"m.relates_to\\\"/\\\"m.relations\\\" and \\\"m.replace\\\" metadata.\"\n (pcase-let* (((cl-struct ement-event (id a-id) (origin-server-ts a-ts)\n (content (map ('m.relates_to\n (map ('rel_type a-rel-type)\n ('event_id a-replaces-event-id))))))\n a)\n ((cl-struct ement-event (id b-id) (origin-server-ts b-ts)\n (content (map ('m.relates_to\n (map ('rel_type b-rel-type)\n ('event_id b-replaces-event-id)))\n ('m.relations\n (map ('m.replace\n (map ('event_id b-replaced-by-event-id))))))))\n b))\n (or (equal a-id b-replaced-by-event-id)\n (and (equal \"m.replace\" a-rel-type)\n (or (equal a-replaces-event-id b-id)\n (and (equal \"m.replace\" b-rel-type)\n (equal a-replaces-event-id b-replaces-event-id)\n (>= a-ts b-ts)))))))\n\n(defun ement--events-equal-p (a b)\n \"Return non-nil if events A and B are essentially equal.\nThat is, A and B are either the same event (having the same event\nID), or one event replaces the other (in their m.relates_to and\nm.replace metadata).\"\n (or (equal (ement-event-id a) (ement-event-id b))\n (ement--event-replaces-p a b)\n (ement--event-replaces-p b a)))\n\n(defun ement--original-event-for (event session)\n \"Return the original of EVENT in SESSION.\nIf EVENT has metadata indicating that it replaces another event,\nreturn the replaced event; otherwise return EVENT. If a replaced\nevent can't be found in SESSION's events table, return an ersatz\none that has the expected ID and same sender.\"\n (pcase-let (((cl-struct ement-event sender\n (content (map ('m.relates_to\n (map ('event_id replaced-event-id)\n ('rel_type relation-type))))))\n event))\n (pcase relation-type\n (\"m.replace\" (or (gethash replaced-event-id (ement-session-events session))\n (make-ement-event :id replaced-event-id :sender sender)))\n (_ event))))\n\n(defun ement--format-room (room &optional topic)\n \"Return ROOM formatted with name, alias, ID, and optionally TOPIC.\nSuitable for use in completion, etc.\"\n (if topic\n (format \"%s%s(<%s>)%s\"\n (or (ement-room-display-name room)\n (setf (ement-room-display-name room)\n (ement--room-display-name room)))\n (if (ement-room-canonical-alias room)\n (format \" <%s> \" (ement-room-canonical-alias room))\n \" \")\n (ement-room-id room)\n (if (ement-room-topic room)\n (format \": \\\"%s\\\"\" (ement-room-topic room))\n \"\"))\n (format \"%s%s(<%s>)\"\n (or (ement-room-display-name room)\n (setf (ement-room-display-name room)\n (ement--room-display-name room)))\n (if (ement-room-canonical-alias room)\n (format \" <%s> \" (ement-room-canonical-alias room))\n \" \")\n (ement-room-id room))))\n\n(defun ement--members-alist (room)\n \"Return alist of member displaynames mapped to IDs seen in ROOM.\"\n ;; We map displaynames to IDs because `ement-room--format-body-mentions' needs to find\n ;; MXIDs from displaynames.\n (pcase-let* (((cl-struct ement-room timeline) room)\n (members-seen (mapcar #'ement-event-sender timeline))\n (members-alist))\n (dolist (member members-seen)\n ;; Testing with `benchmark-run-compiled', it appears that using `cl-pushnew' is\n ;; about 10x faster than using `delete-dups'.\n (cl-pushnew (cons (ement--user-displayname-in room member)\n (ement-user-id member))\n members-alist))\n members-alist))\n\n(defun ement--mxc-to-url (uri session)\n \"Return HTTPS URL for MXC URI accessed through SESSION.\"\n (pcase-let* (((cl-struct ement-session server) session)\n ((cl-struct ement-server uri-prefix) server)\n (server-name) (media-id))\n (string-match (rx \"mxc://\" (group (1+ (not (any \"/\"))))\n \"/\" (group (1+ anything))) uri)\n (setf server-name (match-string 1 uri)\n media-id (match-string 2 uri))\n (format \"%s/_matrix/media/r0/download/%s/%s\"\n uri-prefix server-name media-id)))\n\n(defun ement--mxc-to-endpoint (uri)\n \"Return API endpoint for MXC URI.\nReturns string suitable for the ENDPOINT argument to `ement-api'.\"\n (string-match (rx \"mxc://\" (group (1+ (not (any \"/\"))))\n \"/\" (group (1+ anything))) uri)\n (let ((server-name (match-string 1 uri))\n (media-id (match-string 2 uri)))\n (format \"media/download/%s/%s\" server-name media-id)))\n\n(defun ement--remove-face-property (string value)\n \"Remove VALUE from STRING's `face' properties.\nUsed to remove the `button' face from buttons, because that face\ncan cause undesirable underlining.\"\n (let ((pos 0))\n (cl-loop for next-face-change-pos = (next-single-property-change pos 'face string)\n for face-at = (get-text-property pos 'face string)\n when face-at\n do (put-text-property pos (or next-face-change-pos (length string))\n 'face (cl-typecase face-at\n (atom (if (equal value face-at)\n nil face-at))\n (list (remove value face-at)))\n string)\n while next-face-change-pos\n do (setf pos next-face-change-pos))))\n\n(cl-defun ement--text-property-search-forward (property predicate string &key (start 0))\n \"Return the position at which PROPERTY in STRING matches PREDICATE.\nReturn nil if not found. Searches forward from START.\"\n (declare (indent defun))\n (cl-loop for pos = start then (next-single-property-change pos property string)\n while pos\n when (funcall predicate (get-text-property pos property string))\n return pos))\n\n(cl-defun ement--text-property-search-backward (property predicate string &key (start 0))\n \"Return the position at which PROPERTY in STRING matches PREDICATE.\nReturn nil if not found. Searches backward from START.\"\n (declare (indent defun))\n (cl-loop for pos = start then (previous-single-property-change pos property string)\n while (and pos (> pos 1))\n when (funcall predicate (get-text-property (1- pos) property string))\n return pos))\n\n(defun ement--resize-image (image max-width max-height)\n \"Return a copy of IMAGE set to MAX-WIDTH and MAX-HEIGHT.\nIMAGE should be one as created by, e.g. `create-image'.\"\n (declare\n ;; This silences a lint warning on our GitHub CI runs, which use a build of Emacs\n ;; without image support.\n (function image-property \"image\"))\n ;; It would be nice if the image library had some simple functions to do this sort of thing.\n (let ((new-image (cl-copy-list image)))\n (when (fboundp 'imagemagick-types)\n ;; Only do this when ImageMagick is supported.\n ;; FIXME: When requiring Emacs 27+, remove this (I guess?).\n (setf (image-property new-image :type) 'imagemagick))\n (setf (image-property new-image :max-width) max-width\n (image-property new-image :max-height) max-height)\n new-image))\n\n(defun ement--room-alias (room)\n \"Return latest m.room.canonical_alias event in ROOM.\"\n ;; FIXME: This function probably needs to compare timestamps to ensure that older events\n ;; that are inserted at the head of the events lists aren't used instead of newer ones.\n (or (cl-loop for event in (ement-room-timeline room)\n when (equal \"m.room.canonical_alias\" (ement-event-type event))\n return (alist-get 'alias (ement-event-content event)))\n (cl-loop for event in (ement-room-state room)\n when (equal \"m.room.canonical_alias\" (ement-event-type event))\n return (alist-get 'alias (ement-event-content event)))))\n\n(declare-function magit-current-section \"magit-section\")\n(declare-function eieio-oref \"eieio-core\")\n(defun ement--room-at-point ()\n \"Return room at point.\nWorks in major-modes `ement-room-mode',\n`ement-tabulated-room-list-mode', and `ement-room-list-mode'.\"\n (pcase major-mode\n ('ement-room-mode ement-room)\n ('ement-tabulated-room-list-mode (tabulated-list-get-id))\n ('ement-room-list-mode\n (cl-typecase (oref (magit-current-section) value)\n (taxy-magit-section nil)\n (t (pcase (oref (magit-current-section) value)\n (`[,room ,_session] room)))))))\n\n(defun ement--room-direct-p (room session)\n \"Return non-nil if ROOM on SESSION is a direct chat.\"\n (cl-labels ((content-contains-room-id (content room-id)\n (cl-loop for (_user-id . room-ids) in content\n ;; NOTE: room-ids is a vector.\n thereis (seq-contains-p room-ids room-id))))\n (pcase-let* (((cl-struct ement-session account-data) session)\n ((cl-struct ement-room id) room))\n (or (cl-loop for event in account-data\n when (equal \"m.direct\" (alist-get 'type event))\n thereis (content-contains-room-id (alist-get 'content event) id))\n (cl-loop\n ;; Invited rooms have no account-data yet, and their\n ;; directness flag is in invite-state events.\n for event in (ement-room-invite-state room)\n thereis (alist-get 'is_direct (ement-event-content event)))))))\n\n(defun ement--room-display-name (room)\n \"Return the displayname for ROOM.\"\n ;; SPEC: .\n ;; NOTE: The spec seems incomplete, because the algorithm it recommends does not say how\n ;; or when to use \"m.room.member\" events for rooms without heroes (e.g. invited rooms).\n ;; TODO: Add SESSION argument and use it to remove local user from names.\n (cl-labels ((latest-event (type content-field)\n (or (cl-loop for event in (ement-room-timeline room)\n when (and (equal type (ement-event-type event))\n (not (string-empty-p (alist-get content-field (ement-event-content event)))))\n return (alist-get content-field (ement-event-content event)))\n (cl-loop for event in (ement-room-state room)\n when (and (equal type (ement-event-type event))\n (not (string-empty-p (alist-get content-field (ement-event-content event)))))\n return (alist-get content-field (ement-event-content event)))))\n (member-events-name ()\n (when-let ((member-events (cl-loop for accessor in '(ement-room-timeline ement-room-state ement-room-invite-state)\n append (cl-remove-if-not (apply-partially #'equal \"m.room.member\")\n (funcall accessor room)\n :key #'ement-event-type))))\n (string-join (delete-dups\n (mapcar (lambda (event)\n (ement--user-displayname-in room (ement-event-sender event)))\n member-events))\n \", \")))\n (heroes-name ()\n (pcase-let* (((cl-struct ement-room summary) room)\n ((map ('m.heroes hero-ids) ('m.joined_member_count joined-count)\n ('m.invited_member_count invited-count))\n summary))\n ;; TODO: Disambiguate hero display names.\n (when hero-ids\n (cond ((<= (+ joined-count invited-count) 1)\n ;; Empty room.\n (empty-room hero-ids joined-count))\n ((>= (length hero-ids) (1- (+ joined-count invited-count)))\n ;; Members == heroes.\n (hero-names hero-ids))\n ((and (< (length hero-ids) (1- (+ joined-count invited-count)))\n (> (+ joined-count invited-count) 1))\n ;; More members than heroes.\n (heroes-and-others hero-ids joined-count))))))\n (hero-names (heroes)\n (string-join (mapcar #'hero-name heroes) \", \"))\n (hero-name (id)\n (if-let ((user (gethash id ement-users)))\n (ement--user-displayname-in room user)\n id))\n (heroes-and-others (heroes joined)\n (format \"%s, and %s others\" (hero-names heroes)\n (- joined (length heroes))))\n (name-override ()\n (when-let ((event (alist-get \"org.matrix.msc3015.m.room.name.override\"\n (ement-room-account-data room)\n nil nil #'equal)))\n (map-nested-elt event '(content name))))\n (empty-room (heroes joined)\n (pcase (length heroes)\n (0 \"Empty room\")\n ((pred (>= 5)) (format \"Empty room (was %s)\"\n (hero-names heroes)))\n (_ (format \"Empty room (was %s)\"\n (heroes-and-others heroes joined))))))\n (or (name-override)\n (latest-event \"m.room.name\" 'name)\n (latest-event \"m.room.canonical_alias\" 'alias)\n (heroes-name)\n (member-events-name)\n (ement-room-id room))))\n(defun ement--room-favourite-p (room)\n \"Return non-nil if ROOM is tagged as favourite.\"\n (ement--room-tagged-p \"m.favourite\" room))\n\n(defun ement--room-low-priority-p (room)\n \"Return non-nil if ROOM is tagged as low-priority.\"\n (ement--room-tagged-p \"m.lowpriority\" room))\n\n(defun ement--room-tagged-p (tag room)\n \"Return non-nil if ROOM has TAG.\"\n ;; TODO: Use `make-ement-event' on account-data events.\n (pcase-let* (((cl-struct ement-room account-data) room)\n (tag-event (alist-get \"m.tag\" account-data nil nil #'equal)))\n (when tag-event\n (pcase-let (((map ('content (map tags))) tag-event))\n (cl-typecase tag\n ;; Tags are symbols internally, because `json-read' converts map keys to them.\n (string (setf tag (intern tag))))\n (assoc tag tags)))))\n\n(defun ement--room-unread-p (room session)\n \"Return non-nil if ROOM is considered unread for SESSION.\nThe room is unread if it has a modified, live buffer; if it has\nnon-zero unread notification counts; or if its fully-read marker\nis not at the latest known message event.\"\n ;; Roughly equivalent to the \"red/gray/bold/idle\" states listed in\n ;; .\n (pcase-let* (((cl-struct ement-room timeline account-data unread-notifications receipts\n (local (map buffer)))\n room)\n ((cl-struct ement-session user) session)\n ((cl-struct ement-user (id our-id)) user)\n ((map notification_count highlight_count) unread-notifications)\n (fully-read-event-id (map-nested-elt (alist-get \"m.fully_read\" account-data nil nil #'equal)\n '(content event_id))))\n ;; MAYBE: Ignore whether the buffer is modified. Since we have a better handle on how\n ;; Matrix does notifications/unreads/highlights, maybe that's not needed, and it would\n ;; be more consistent to ignore it.\n (or (and buffer (buffer-modified-p buffer))\n (and unread-notifications\n (or (not (zerop notification_count))\n (not (zerop highlight_count))))\n ;; NOTE: This is *WAY* too complicated, but it seems roughly equivalent to doesRoomHaveUnreadMessages() from\n ;; .\n (when (and (not ement-room-unread-only-counts-notifications)\n timeline)\n ;; A room should rarely, if ever, have a nil timeline, but in case it does\n ;; (which apparently can happen, given user reports), it should not be\n ;; considered unread.\n (cl-labels ((event-counts-toward-unread-p (event)\n ;; NOTE: We only consider message events, so membership, reaction,\n ;; etc. events will not mark a room as unread. Ideally, I think\n ;; that join/leave events should, at least optionally, mark a room\n ;; as unread (e.g. in a 1:1 room with a friend, if the other user\n ;; left, one would probably want to know, and marking the room\n ;; unread would help the user notice), but since membership events\n ;; have to be processed to understand their meaning, it's not\n ;; straightforward to know whether one should mark a room unread.\n\n ;; FIXME: Use code from `ement-room--format-member-event' to\n ;; distinguish ones that should count.\n (equal \"m.room.message\" (ement-event-type event))))\n (let ((our-read-receipt-event-id (car (gethash our-id receipts)))\n (first-counting-event (cl-find-if #'event-counts-toward-unread-p timeline)))\n (cond ((equal fully-read-event-id (ement-event-id (car timeline)))\n ;; The fully-read marker is at the last known event: the room is read.\n nil)\n ((and (not our-read-receipt-event-id)\n (when first-counting-event\n (and (not (equal fully-read-event-id (ement-event-id first-counting-event)))\n (not (equal our-id (ement-user-id (ement-event-sender first-counting-event)))))))\n ;; The room has no read receipt, and the latest message event is not\n ;; the event at which our fully-read marker is at, and it is not sent\n ;; by us: the room is unread. (This is a kind of failsafe to ensure\n ;; the user doesn't miss any messages, but it's unclear whether this\n ;; is really correct or best.)\n t)\n ((equal our-id (ement-user-id (ement-event-sender (car timeline))))\n ;; We sent the last event: the room is read.\n nil)\n ((and first-counting-event\n (equal our-id (ement-user-id (ement-event-sender first-counting-event))))\n ;; We sent the last message event: the room is read.\n nil)\n ((cl-loop for event in timeline\n when (event-counts-toward-unread-p event)\n return (and (not (equal our-read-receipt-event-id (ement-event-id event)))\n (not (equal fully-read-event-id (ement-event-id event)))))\n ;; The latest message event is not the event at which our\n ;; read-receipt or fully-read marker are at: the room is unread.\n t))))))))\n\n(defun ement--update-transaction-id (session)\n \"Return SESSION's incremented transaction ID formatted for sending.\nIncrements ID and appends current timestamp to avoid reuse\nproblems.\"\n ;; TODO: Naming things is hard.\n ;; In the event that Emacs isn't killed cleanly and the session isn't saved to disk, the\n ;; transaction ID would get reused the next time the user connects. To avoid that, we\n ;; append the current time to the ID. (IDs are just strings, and Element does something\n ;; similar, so this seems reasonable.)\n (format \"%s-%s\"\n (cl-incf (ement-session-transaction-id session))\n (format-time-string \"%s\")))\n\n(defun ement--user-displayname-in (room user &optional recalculatep)\n \"Return the displayname for USER in ROOM.\nIf RECALCULATEP, force recalculation; otherwise return a cached\nname if available.\"\n ;; SPEC: .\n ;; NOTE: Both state and timeline events must be searched. (A helpful user\n ;; in #matrix-dev:matrix.org, Michael (t3chguy), clarified this for me).\n (or (unless recalculatep\n (gethash user (ement-room-displaynames room)))\n (cl-labels ((event-sets-displayname (event)\n (and (eq user (ement-event-sender event))\n (equal \"m.room.member\" (ement-event-type event))\n (equal \"join\" (alist-get 'membership (ement-event-content event)))\n (alist-get 'displayname (ement-event-content event)))))\n ;; Search timeline events before state events, because IIUC they should be more\n ;; recent. Also, we assume that the timeline and state events are sorted\n ;; most-recent-first, so the first such event found is the one to use.\n (puthash user (or (cl-loop for event in (ement-room-timeline room)\n when (event-sets-displayname event)\n return it)\n (cl-loop for event in (ement-room-state room)\n when (event-sets-displayname event)\n return it)\n ;; FIXME: Add step 3 of the spec. For now we skip to step 4.\n ;; No membership state event: use pre-calculated displayname or ID.\n (ement-user-displayname user)\n (ement-user-id user))\n (ement-room-displaynames room)))))\n\n(defun ement--xml-escape-string (string)\n \"Return STRING having been escaped with `xml-escape-string'.\nBefore Emacs 28, ignores `xml-invalid-character' errors (and any\ninvalid characters cause STRING to remain unescaped). After\nEmacs 28, uses the NOERROR argument to `xml-escape-string'.\"\n (with-suppressed-warnings ((callargs xml-escape-string))\n (condition-case _\n (xml-escape-string string 'noerror)\n (wrong-number-of-arguments\n (condition-case _\n (xml-escape-string string)\n (xml-invalid-character\n ;; We still don't want to error on this, so just return the string.\n string))))))\n\n(defun ement--mark-room-direct (room session)\n \"Mark ROOM on SESSION as a direct room.\nThis may be used to mark rooms as direct which, for whatever\nreason (like a bug in your favorite client), were not marked as\nsuch when they were created.\"\n (pcase-let* (((cl-struct ement-room timeline (id room-id)) room)\n ((cl-struct ement-session (user local-user)) session)\n ((cl-struct ement-user (id local-user-id)) local-user)\n (direct-rooms-account-data-event-content\n (alist-get 'content\n (cl-find-if (lambda (event)\n (equal \"m.direct\" (alist-get 'type event)))\n (ement-session-account-data session))))\n (members (delete-dups (mapcar #'ement-event-sender timeline)))\n (other-users (cl-remove local-user-id members\n :key #'ement-user-id :test #'equal))\n ((cl-struct ement-user (id other-user-id)) (car other-users))\n ;; The alist keys are MXIDs as symbols.\n (other-user-id (intern other-user-id))\n (existing-direct-rooms-for-user (map-elt direct-rooms-account-data-event-content other-user-id)))\n (cl-assert (= 1 (length other-users)))\n (setf (map-elt direct-rooms-account-data-event-content other-user-id)\n (cl-coerce (append existing-direct-rooms-for-user (list room-id))\n 'vector))\n (ement-put-account-data session \"m.direct\" direct-rooms-account-data-event-content\n :then (lambda (_data)\n (message \"Ement: Room <%s> marked as direct for <%s>.\" room-id other-user-id)))\n (message \"Ement: Marking room as direct...\")))\n\n(cl-defun ement--get-joined-members (room session &key then else)\n \"Get joined members in ROOM on SESSION and call THEN with response data.\nOr call ELSE with error data if request fails. Also puts members\non `ement-users', updating their displayname and avatar URL\nslots, and puts them on ROOM's `members' table.\"\n (declare (indent defun))\n (pcase-let* (((cl-struct ement-room id members) room)\n (endpoint (format \"rooms/%s/joined_members\" (url-hexify-string id))))\n (ement-api session endpoint\n :else else\n :then (lambda (data)\n (clrhash members)\n (mapc (lambda (member)\n (pcase-let* ((`(,id-symbol\n . ,(map ('avatar_url avatar-url)\n ('display_name display-name)))\n member)\n (member-id (symbol-name id-symbol))\n (user (or (gethash member-id ement-users)\n (puthash member-id (make-ement-user :id member-id)\n ement-users))))\n (setf (ement-user-displayname user) display-name\n (ement-user-avatar-url user) avatar-url)\n (puthash member-id user members)))\n (alist-get 'joined data))\n (setf (alist-get 'fetched-members-p (ement-room-local room)) t)\n (when then\n ;; Finally, call the given callback.\n (funcall then data))))\n (message \"Ement: Getting joined members in %s...\" (ement--format-room room))))\n\n(cl-defun ement--human-format-duration (seconds &optional abbreviate)\n \"Return human-formatted string describing duration SECONDS.\nIf SECONDS is less than 1, returns \\\"0 seconds\\\". If ABBREVIATE\nis non-nil, return a shorter version, without spaces. This is a\nsimple calculation that does not account for leap years, leap\nseconds, etc.\"\n ;; Copied from `ts-human-format-duration' (same author).\n (if (< seconds 1)\n (if abbreviate \"0s\" \"0 seconds\")\n (cl-macrolet ((format> (place)\n ;; When PLACE is greater than 0, return formatted string using its symbol name.\n `(when (> ,place 0)\n (format \"%d%s%s\" ,place\n (if abbreviate \"\" \" \")\n (if abbreviate\n ,(substring (symbol-name place) 0 1)\n ,(symbol-name place)))))\n (join-places (&rest places)\n ;; Return string joining the names and values of PLACES.\n `(string-join (delq nil\n (list ,@(cl-loop for place in places\n collect `(format> ,place))))\n (if abbreviate \"\" \", \"))))\n (pcase-let ((`(,years ,days ,hours ,minutes ,seconds) (ement--human-duration seconds)))\n (join-places years days hours minutes seconds)))))\n\n(defun ement--human-duration (seconds)\n \"Return list describing duration SECONDS.\nList includes years, days, hours, minutes, and seconds. This is\na simple calculation that does not account for leap years, leap\nseconds, etc.\"\n ;; Copied from `ts-human-format-duration' (same author).\n (cl-macrolet ((dividef (place divisor)\n ;; Divide PLACE by DIVISOR, set PLACE to the remainder, and return the quotient.\n `(prog1 (/ ,place ,divisor)\n (setf ,place (% ,place ,divisor)))))\n (let* ((seconds (floor seconds))\n (years (dividef seconds 31536000))\n (days (dividef seconds 86400))\n (hours (dividef seconds 3600))\n (minutes (dividef seconds 60)))\n (list years days hours minutes seconds))))\n\n(defun ement--read-multiple-choice (prompt choices &optional help)\n \"Wrapper for `read-multiple-choice'.\"\n ;; Bypasses the hard-coded multi-column formatting in the help buffer\n ;; (which often doesn't wrap nicely) in favour of one option per line.\n (let ((help-format (if help\n (concat (replace-regexp-in-string \"%\" \"%%\" help)\n \"\\n\\n%s\")\n \"%s\"))\n (help-choices (mapconcat (lambda (c)\n (format \"%c: %s\\n\" (car c) (caddr c)))\n choices)))\n (read-multiple-choice prompt choices (format help-format help-choices))))\n\n(cl-defun ement--media-request\n (mxc session &key queue (then #'ignore) (else #'ement-api-error)\n (as 'binary) (authenticatedp t))\n \"Request media from MXC URL on SESSION.\nIf AUTHENTICATEDP, send authenticated request. Arguments THEN,\nELSE, and AS are passed to `ement-api' for authenticated media\nrequests, or to `plz' for unauthenticated ones, each which see.\nIf QUEUE, send request on it.\"\n (declare (indent defun))\n (if authenticatedp\n (ement-api session (ement--mxc-to-endpoint mxc) :version \"v1\"\n :json-read-fn as :then then :else else :queue queue)\n ;; Send unauthenticated request.\n (if queue\n (plz-run\n (plz-queue queue\n 'get (ement--mxc-to-url mxc session) :as as\n :then then :else else :noquery t))\n (plz 'get (ement--mxc-to-url mxc session) :as as\n :then then :else else :noquery t))))\n\n;;; Footer\n\n(provide 'ement-lib)\n\n;;; ement-lib.el ends here\n" }, { "path": "ement-macros.el", "content": ";;; ement-macros.el --- Ement macros -*- lexical-binding: t; -*-\n\n;; Copyright (C) 2022-2023 Free Software Foundation, Inc.\n\n;; Author: Adam Porter \n;; Maintainer: Adam Porter \n\n;; This program is free software; you can redistribute it and/or modify\n;; it under the terms of the GNU General Public License as published by\n;; the Free Software Foundation, either version 3 of the License, or\n;; (at your option) any later version.\n\n;; This program is distributed in the hope that it will be useful,\n;; but WITHOUT ANY WARRANTY; without even the implied warranty of\n;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n;; GNU General Public License for more details.\n\n;; You should have received a copy of the GNU General Public License\n;; along with this program. If not, see .\n\n;;; Commentary:\n\n;;\n\n;;; Code:\n\n;;;; Requirements\n\n(require 'map)\n\n;;;; Debugging\n\n(require 'warnings)\n\n;; NOTE: Uncomment this form and `emacs-lisp-byte-compile-and-load' the file to enable\n;; `ement-debug' messages. This is commented out by default because, even though the\n;; messages are only displayed when `warning-minimum-log-level' is `:debug' at runtime, if\n;; that is so at expansion time, the expanded macro calls format the message and check the\n;; log level at runtime, which is not zero-cost.\n\n;; (eval-and-compile\n;; (setq-local warning-minimum-log-level nil)\n;; (setq-local warning-minimum-log-level :debug))\n\n(cl-defmacro ement-debug (&rest args)\n \"Display a debug warning showing the runtime value of ARGS.\nThe warning automatically includes the name of the containing\nfunction, and it is only displayed if `warning-minimum-log-level'\nis `:debug' at expansion time (otherwise the macro expands to a\ncall to `ignore' with ARGS and is eliminated by the\nbyte-compiler). When debugging, the form also returns nil so,\ne.g. it may be used in a conditional in place of nil.\n\nEach of ARGS may be a string, which is displayed as-is, or a\nsymbol, the value of which is displayed prefixed by its name, or\na Lisp form, which is displayed prefixed by its first symbol.\n\nBefore the actual ARGS arguments, you can write keyword\narguments, i.e. alternating keywords and values. The following\nkeywords are supported:\n\n :buffer BUFFER Name of buffer to pass to `display-warning'.\n :level LEVEL Level passed to `display-warning', which see.\n Default is :debug.\"\n ;; TODO: Can we use a compiler macro to handle this more elegantly?\n (pcase-let* ((fn-name (when byte-compile-current-buffer\n (with-current-buffer byte-compile-current-buffer\n ;; This is a hack, but a nifty one.\n (save-excursion\n (beginning-of-defun)\n (cl-second (read (current-buffer)))))))\n (plist-args (cl-loop while (keywordp (car args))\n collect (pop args)\n collect (pop args)))\n ((map (:buffer buffer) (:level level)) plist-args)\n (level (or level :debug))\n (string (cl-loop for arg in args\n concat (pcase arg\n ((pred stringp) \"%S \")\n ((pred symbolp)\n (concat (upcase (symbol-name arg)) \":%S \"))\n ((pred listp)\n (concat \"(\" (upcase (symbol-name (car arg)))\n (pcase (length arg)\n (1 \")\")\n (_ \"...)\"))\n \":%S \"))))))\n (if (eq :debug warning-minimum-log-level)\n `(let ((fn-name ,(if fn-name\n `',fn-name\n ;; In an interpreted function: use `backtrace-frame' to get the\n ;; function name (we have to use a little hackery to figure out\n ;; how far up the frame to look, but this seems to work).\n `(cl-loop for frame in (backtrace-frames)\n for fn = (cl-second frame)\n when (not (or (subrp fn)\n (special-form-p fn)\n (eq 'backtrace-frames fn)))\n return (make-symbol (format \"%s [interpreted]\" fn))))))\n (display-warning fn-name (format ,string ,@args) ,level ,buffer)\n nil)\n `(ignore ,@args))))\n\n;;;; Macros\n\n(defmacro ement-alist (&rest pairs)\n \"Expand to an alist of the keys and values in PAIRS.\"\n `(list ,@(cl-loop for (key value) on pairs by #'cddr\n collect `(cons ,key ,value))))\n\n;;;;; Anaphoric\n\n;; We could just depend on dash.el and use --first, and anaphora.el (only\n;; on MELPA, not ELPA) has aprog1, but in order to reduce dependencies...\n\n(defmacro ement-afirst (form list)\n ;; Sometimes checkdoc is really annoying. If I use \"FORM returns\" or\n ;; \"FORM evaluates\", it complains, so I can't have a clean linting.\n \"Return the first element of LIST for which FORM is non-nil.\nIn FORM, `it' is bound to the element being tested.\"\n (declare (indent 1))\n `(cl-loop for it in ,list\n ;; Avoid the `when' clause's implicit binding of `it'.\n do (when ,form\n (cl-return it))))\n\n(defmacro ement-aprog1 (first &rest body)\n \"Like `prog1', but FIRST's value is bound to `it' around BODY.\"\n (declare (indent 1))\n `(let ((it ,first))\n ,@body\n it))\n\n(defmacro ement-singly (place-form &rest body)\n \"If PLACE-FORM is nil, set it non-nil and eval BODY.\nBODY should set PLACE-FORM to nil when BODY is eligible to run\nagain.\"\n (declare (indent defun))\n `(unless ,place-form\n (setf ,place-form t)\n ,@body))\n\n;;;;; Progress reporters\n\n;; MAYBE: Submit a `with-progress-reporter' macro to Emacs.\n\n(defalias 'ement-progress-update #'ignore\n \"By default, this function does nothing. But inside\n`ement-with-progress-reporter', it's bound to a function that\nupdates the current progress reporter.\")\n\n(defmacro ement-with-progress-reporter (args &rest body)\n \"Eval BODY with a progress reporter according to ARGS.\nARGS is a plist of these values:\n\n :when If specified, a form evaluated at runtime to determine\n whether to make and update a progress reporter. If not\n specified, the reporter is always made and updated.\n\n :reporter A list of arguments passed to\n `make-progress-reporter', which see.\n\nAround BODY, the function `ement-progress-update' is set to a\nfunction that calls `progress-reporter-update' on the progress\nreporter (or if the :when form evaluates to nil, the function is\nset to `ignore'). It optionally takes a VALUE argument, and\nwithout one, it automatically updates the value from the\nreporter's min-value to its max-value.\"\n (declare (indent defun))\n (pcase-let* ((progress-reporter-sym (gensym))\n (progress-value-sym (gensym))\n (start-time-sym (gensym))\n ((map (:when when-form) (:reporter reporter-args)) args)\n (`(,_message ,min-value ,_max-value) reporter-args)\n (update-fn `(cl-function\n (lambda (&optional (value (cl-incf ,progress-value-sym)))\n (ement-debug \"Updating progress reporter to\" value)\n (progress-reporter-update ,progress-reporter-sym value)))))\n `(let* ((,start-time-sym (current-time))\n (,progress-value-sym (or ,min-value 0))\n (,progress-reporter-sym ,(if when-form\n `(when ,when-form\n (make-progress-reporter ,@reporter-args))\n `(make-progress-reporter ,@reporter-args))))\n ;; We use `cl-letf' rather than `cl-labels', because labels expand to lambdas and funcalls,\n ;; so other functions that call `ement-progress-update' wouldn't call this definition.\n (cl-letf (((symbol-function 'ement-progress-update)\n ,(if when-form\n `(if ,when-form\n ,update-fn\n #'ignore)\n update-fn)))\n ,@body\n (ement-debug (format \"Ement: Progress reporter done (took %.2f seconds)\"\n (float-time (time-subtract (current-time) ,start-time-sym))))))))\n\n;;;;; Room-related macros\n\n;; Prevent compiler from complaining that `value' is an unknown slot.\n(require 'magit-section)\n\n(cl-defmacro ement-with-room-and-session (&rest body)\n \"Eval BODY with `ement-room' and `ement-session' bound.\nIf in an `ement-room-list-mode' buffer and `current-prefix-arg'\nis nil, use the room and session at point. If in an `ement-room'\nbuffer and `current-prefix-arg' is nil, use buffer-local value of\n`ement-room' and `ement-session'. Otherwise, prompt for them\nwith `ement-complete-room' or that given with :prompt-form.\n\nBODY may begin with property list arguments, including:\n\n :prompt-form A Lisp form evaluated for the binding of\n `ement-room'.\"\n (declare (indent defun))\n (pcase-let* ((plist (cl-loop while (keywordp (car body))\n append (list (car body) (cadr body))\n and do (setf body (cddr body))))\n (prompt-form (or (plist-get plist :prompt-form)\n '(ement-complete-room :suggest t))))\n `(pcase-let* ((`[,list-room ,list-session] (if (eq 'ement-room-list-mode major-mode)\n (oref (magit-current-section) value)\n [nil nil]))\n (ement-room (or list-room ement-room))\n (ement-session (or list-session ement-session)))\n (when (or current-prefix-arg (not ement-room))\n (pcase-let ((`(,room ,session) ,prompt-form))\n (setf ement-room room\n ement-session session)))\n ,@body)))\n\n(defmacro ement-propertize (string &rest properties)\n \"Like `propertize', but auto-set `font-lock-face' property.\nIf the `face' property is set, also set the `font-lock-face' property to\nthe same value.\"\n ;; This is a workaround for a change in `magit-section'; see\n ;; . By setting both face properties,\n ;; we should preserve backward compatibility. Someday this can be removed and we'll\n ;; just call `propertize' again.\n (declare (indent defun))\n (if (and (member ''face properties)\n (not (member ''font-lock-face properties)))\n (pcase (plist-get properties ''face #'equal)\n ((or (pred atom) `(quote ,(pred atom)))\n ;; Face property value is an atom: probably safe to just reuse the form.\n `(propertize ,string ,@properties\n 'font-lock-face ,(plist-get properties ''face #'equal)))\n (_\n ;; Not an atom: avoid evaluating the 'face property's form twice.\n (let ((value-form (plist-get properties ''face #'equal))\n (value-var (gensym \"ement-propertize-\")))\n (setf (plist-get properties ''face #'equal) value-var\n (plist-get properties ''font-lock-face #'equal) value-var)\n `(let ((,value-var ,value-form))\n (propertize ,string ,@properties)))))\n ;; Passthrough unchanged.\n `(propertize ,string ,@properties)))\n\n;;;; Variables\n\n\n;;;; Customization\n\n\n;;;; Commands\n\n\n;;;; Functions\n\n\n;;;; Footer\n\n(provide 'ement-macros)\n\n;;; ement-macros.el ends here\n" }, { "path": "ement-notifications.el", "content": ";;; ement-notifications.el --- Notifications support -*- lexical-binding: t; -*-\n\n;; Copyright (C) 2023 Free Software Foundation, Inc.\n\n;; Author: Adam Porter \n;; Maintainer: Adam Porter \n\n;; This program is free software; you can redistribute it and/or modify\n;; it under the terms of the GNU General Public License as published by\n;; the Free Software Foundation, either version 3 of the License, or\n;; (at your option) any later version.\n\n;; This program is distributed in the hope that it will be useful,\n;; but WITHOUT ANY WARRANTY; without even the implied warranty of\n;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n;; GNU General Public License for more details.\n\n;; You should have received a copy of the GNU General Public License\n;; along with this program. If not, see .\n\n;;; Commentary:\n\n;; This library implements support for Matrix notifications. It differs from\n;; `ement-notify', which implements a kind of bespoke notification system for events\n;; received via sync requests rather than Matrix's own notifications endpoint. These two\n;; libraries currently integrate somewhat, as newly arriving events are handled and\n;; notified about by `ement-notify', and old notifications are fetched and listed by\n;; `ement-notifications' in the same \"*Ement Notifications*\" buffer.\n\n;; In the future, these libraries will likely be consolidated and enhanced to more closely\n;; follow the Matrix API's and Element client's examples.\n\n;;; Code:\n\n;;;; Requirements\n\n(require 'cl-lib)\n(require 'map)\n\n(require 'ement-lib)\n(require 'ement-room)\n(require 'ement-notify)\n\n;;;; Structs\n\n(cl-defstruct ement-notification\n \"Represents a Matrix notification.\"\n room-id event readp)\n\n(defun ement-notifications--make (notification)\n \"Return an `ement-notification' struct for NOTIFICATION.\nNOTIFICATION is an alist representing a notification returned\nfrom the \\\"/notifications\\\" endpoint. The notification's event\nis passed through `ement--make-event'.\"\n (declare (function ement--make-event \"ement\"))\n (pcase-let (((map room_id _actions _ts event read) notification))\n (make-ement-notification :room-id room_id :readp read\n :event (ement--make-event event))))\n\n;;;; Variables\n\n(declare-function ement-room-list \"ement-room-list\")\n(defvar ement-notifications-mode-map\n (let ((map (make-sparse-keymap)))\n (define-key map (kbd \"\") #'ement-notifications-jump)\n (define-key map [mouse-1] #'ement-notifications-jump-mouse)\n (define-key map [mouse-2] #'ement-notifications-jump-mouse)\n (define-key map (kbd \"S-\") #'ement-notify-reply)\n (define-key map (kbd \"M-g M-l\") #'ement-room-list)\n (define-key map (kbd \"M-g M-m\") #'ement-notify-switch-to-mentions-buffer)\n (define-key map (kbd \"M-g M-n\") #'ement-notify-switch-to-notifications-buffer)\n (define-key map [remap scroll-down-command] #'ement-notifications-scroll-down-command)\n (define-key map [remap mwheel-scroll] #'ement-notifications-mwheel-scroll)\n (make-composed-keymap (list map) 'view-mode-map))\n \"Map for Ement notification buffers.\")\n\n(cl-defun ement-notifications-jump (&optional (pos (point)))\n \"Jump to Matrix event at POS.\"\n (interactive)\n (let ((session (get-text-property pos 'session))\n (room (get-text-property pos 'room))\n (event (get-text-property pos 'event)))\n (ement-view-room room session)\n (ement-room-goto-event event)))\n\n(defun ement-notifications-jump-mouse (event)\n \"Jump to Matrix event at EVENT.\"\n (interactive \"e\")\n (let ((pos (posn-point (event-start event))))\n (if (button-at pos)\n (push-button pos)\n (ement-notifications-jump pos))))\n\n(defvar ement-notifications-hook '(ement-notifications-log-to-buffer)\n \"Functions called for `ement-notifications' notifications.\nEach function is called with two arguments, the session and the\n`ement-notification' struct.\")\n\n(defvar-local ement-notifications-retro-loading nil\n \"Non-nil when earlier messages are being loaded.\nUsed to avoid overlapping requests.\")\n\n(defvar-local ement-notifications-metadata nil\n \"Metadata for `ement-notifications' buffers.\")\n\n;; Variables from other files.\n(defvar ement-ewoc)\n(defvar ement-session)\n(defvar ement-notify-prism-background)\n(defvar ement-room-message-format-spec)\n(defvar ement-room-sender-in-left-margin)\n\n;;;; Commands\n\n;;;###autoload\n(cl-defun ement-notifications\n (session &key from limit only\n (then (apply-partially #'ement-notifications-callback session)) else)\n \"Show the notifications buffer for SESSION.\nFROM may be a \\\"next_token\\\" token from a previous request.\nLIMIT may be a maximum number of events to return. ONLY may be\nthe string \\\"highlight\\\" to only return notifications that have\nthe highlight tweak set. THEN and ELSE may be callbacks passed\nto `ement-api', which see.\"\n (interactive (list (ement-complete-session)\n :only (when current-prefix-arg\n \"highlight\")))\n (if-let ((buffer (get-buffer \"*Ement Notifications*\")))\n (switch-to-buffer buffer)\n (let ((endpoint \"notifications\")\n (params (remq nil\n (list (when from\n (list \"from\" from))\n (when limit\n (list \"limit\" (number-to-string limit)))\n (when only\n (list \"only\" only))))))\n (ement-api session endpoint :params params :then then :else else)\n (ement-message \"Fetching notifications for <%s>...\" (ement-user-id (ement-session-user session))))))\n\n(cl-defun ement-notifications-callback (session data &key (buffer (ement-notifications--log-buffer)))\n \"Callback for `ement-notifications' on SESSION which receives DATA.\"\n (pcase-let (((map notifications next_token) data))\n (with-current-buffer buffer\n (setf (map-elt ement-notifications-metadata :next-token) next_token)\n (cl-loop for notification across notifications\n do (run-hook-with-args 'ement-notifications-hook\n session (ement-notifications--make notification)))\n ;; TODO: Pass start/end nodes to `ement-room--insert-ts-headers' if possible.\n (ement-room--insert-ts-headers)\n (switch-to-buffer (current-buffer)))))\n\n(defun ement-notifications-scroll-down-command ()\n \"Scroll down, and load NUMBER earlier messages when at top.\"\n (interactive)\n (condition-case _err\n (scroll-down nil)\n (beginning-of-buffer\n (call-interactively #'ement-notifications-retro))))\n\n(defun ement-notifications-mwheel-scroll (event)\n \"Scroll according to EVENT, loading earlier messages when at top.\"\n (interactive \"e\")\n (with-selected-window (posn-window (event-start event))\n (mwheel-scroll event)\n (when (= (point-min) (window-start))\n (call-interactively #'ement-notifications-retro))))\n\n(cl-defun ement-notifications-retro (session number)\n ;; FIXME: Naming things is hard.\n \"Retrieve NUMBER older notifications on SESSION.\"\n ;; FIXME: Support multiple sessions.\n (interactive (list (ement-complete-session)\n (cl-typecase current-prefix-arg\n (null 100)\n (list (read-number \"Number of messages: \"))\n (number current-prefix-arg))))\n (cl-assert (eq 'ement-notifications-mode major-mode))\n (cl-assert (map-elt ement-notifications-metadata :next-token) nil\n \"No more notifications for %s\" (ement-user-id (ement-session-user ement-session)))\n (let ((buffer (current-buffer)))\n (unless ement-notifications-retro-loading\n (ement-notifications\n session :limit number\n :from (map-elt ement-notifications-metadata :next-token)\n ;; TODO: Use a :finally for resetting `ement-notifications-retro-loading'?\n :then (lambda (data)\n (unwind-protect\n (ement-notifications-callback session data :buffer buffer)\n (setf (buffer-local-value 'ement-notifications-retro-loading buffer) nil)))\n :else (lambda (plz-error)\n (setf (buffer-local-value 'ement-notifications-retro-loading buffer) nil)\n (ement-api-error plz-error)))\n (ement-message \"Loading %s earlier messages...\" number)\n (setf ement-notifications-retro-loading t))))\n\n;;;; Functions\n\n(cl-defun ement-notifications-log-to-buffer (session notification &key (buffer-name \"*Ement Notifications*\"))\n \"Log EVENT in ROOM on SESSION to \\\"*Ement NOTIFICATIONS*\\\" buffer.\"\n (with-demoted-errors \"ement-notifications-log-to-buffer: %S\"\n (with-current-buffer (ement-notifications--log-buffer :name buffer-name)\n (save-window-excursion\n (when-let ((buffer-window (get-buffer-window (current-buffer))))\n ;; Select the buffer's window to avoid EWOC bug. (See #191.)\n (select-window buffer-window))\n ;; TODO: Use the :readp slot to mark unread events.\n (save-mark-and-excursion\n (pcase-let* (((cl-struct ement-notification room-id event) notification)\n (ement-session session)\n (ement-room (or (cl-find room-id (ement-session-rooms session)\n :key #'ement-room-id :test #'equal)\n (error \"ement-notifications-log-to-buffer: Can't find room <%s>; discarding notification\" room-id)))\n (ement-room-sender-in-left-margin nil)\n (ement-room-message-format-spec \"%o%O »%W %S> %B%R%t\")\n (new-node (ement-room--insert-event event))\n (inhibit-read-only t)\n (start) (end))\n (ewoc-goto-node ement-ewoc new-node)\n ;; Apply the button properties only to the room and sender names,\n ;; allowing buttons in the rest of the message to remain separate.\n (setf start (point)\n end (save-excursion\n (re-search-forward (rx \"> \"))))\n (add-text-properties start end '( button (t)\n category default-button\n action ement-notify-button-action))\n ;; Apply the session, room, and event properties to the whole event.\n (setf end (save-excursion\n (if-let ((next-node (ewoc-next ement-ewoc new-node)))\n (ewoc-location next-node)\n (point-max))))\n (add-text-properties start end\n (list 'session session\n 'room ement-room\n 'event event))\n ;; Remove button face property from the whole event.\n (alter-text-property start end 'face\n (lambda (face)\n (pcase face\n ('button nil)\n ((pred listp) (remq 'button face))\n (_ face))))\n (when ement-notify-prism-background\n (add-face-text-property start end (list :background (ement-notifications--room-background-color ement-room)\n :extend t)))))))))\n\n(defun ement-notifications--room-background-color (room)\n \"Return a background color on which to display ROOM's messages.\"\n (or (alist-get 'notify-background-color (ement-room-local room))\n (setf (alist-get 'notify-background-color (ement-room-local room))\n (let ((color (color-desaturate-name\n (ement--prism-color (ement-room-id room) :contrast-with (face-foreground 'default))\n 50)))\n (if (ement--color-dark-p (color-name-to-rgb (face-background 'default)))\n (color-darken-name color 25)\n (color-lighten-name color 25))))))\n\n(cl-defun ement-notifications--log-buffer (&key (name \"*Ement Notifications*\"))\n \"Return an Ement notifications buffer named NAME.\"\n (or (get-buffer name)\n (with-current-buffer (get-buffer-create name)\n (ement-notifications-mode)\n (current-buffer))))\n\n;;;; Mode\n\n(define-derived-mode ement-notifications-mode ement-room-mode \"Ement Notifications\"\n (setf ement-room-sender-in-left-margin nil\n left-margin-width 0\n right-margin-width 8)\n (setq-local ement-room-message-format-spec \"[%o%O] %S> %B%R%t\"\n bookmark-make-record-function #'ement-notifications-bookmark-make-record))\n\n;;;; Bookmark support\n\n(require 'bookmark)\n\n(defun ement-notifications-bookmark-make-record ()\n \"Return a bookmark record for the current `ement-notifications' buffer.\"\n (list (buffer-name)\n ;; It seems silly to have to record the buffer name twice, but the\n ;; `bookmark-make-record' function seems to override the bookmark name sometimes,\n ;; which makes the result useless unless we save the buffer name separately.\n (cons 'buffer-name (buffer-name))\n (cons 'handler #'ement-notifications-bookmark-handler)))\n\n(defun ement-notifications-bookmark-handler (_bookmark)\n \"Show `ement-notifications' buffer for BOOKMARK.\"\n ;; FIXME: Handle multiple sessions.\n ;; FIXME: This doesn't work quite correctly when the buffer isn't already open, because\n ;; the command is asynchronous in that case, so the buffer can be displayed in the wrong\n ;; window. Fixing this would be hacky and awkward, but a partial solution is probably\n ;; possible.\n (ement-notifications (ement-complete-session)))\n\n;;; Footer\n\n(provide 'ement-notifications)\n\n;;; ement-notifications.el ends here\n" }, { "path": "ement-notify.el", "content": ";;; ement-notify.el --- Notifications for Ement events -*- lexical-binding: t; -*-\n\n;; Copyright (C) 2022-2023 Free Software Foundation, Inc.\n\n;; Author: Adam Porter \n;; Maintainer: Adam Porter \n\n;; This program is free software; you can redistribute it and/or modify\n;; it under the terms of the GNU General Public License as published by\n;; the Free Software Foundation, either version 3 of the License, or\n;; (at your option) any later version.\n\n;; This program is distributed in the hope that it will be useful,\n;; but WITHOUT ANY WARRANTY; without even the implied warranty of\n;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n;; GNU General Public License for more details.\n\n;; You should have received a copy of the GNU General Public License\n;; along with this program. If not, see .\n\n;;; Commentary:\n\n;; This library implements notifications for Ement events.\n\n;;; Code:\n\n;;;; Requirements\n\n(require 'cl-lib)\n(require 'map)\n(require 'notifications)\n\n(require 'ement-lib)\n(require 'ement-room)\n\n(eval-when-compile\n (require 'ement-structs))\n\n;;;; Variables\n\n(defvar ement-notify-dbus-p\n (and (featurep 'dbusbind)\n (require 'dbus nil :no-error)\n (dbus-ignore-errors (dbus-get-unique-name :session))\n ;; By default, emacs waits up to 25 seconds for a PONG. Realistically, if there's\n ;; no pong after 2000ms, there's pretty sure no notification service connected or\n ;; the system's setup has issues.\n (dbus-ping :session \"org.freedesktop.Notifications\" 2000))\n \"Whether D-Bus notifications are usable.\")\n\n;;;; Customization\n\n(defgroup ement-notify nil\n \"Notification options.\"\n :group 'ement)\n\n(defcustom ement-notify-ignore-predicates\n '(ement-notify--event-not-message-p ement-notify--event-from-session-user-p)\n \"Display notification if none of these return non-nil for an event.\nEach predicate is called with three arguments: the event, the\nroom, and the session (each the respective struct).\"\n :type '(repeat (choice (function-item ement-notify--event-not-message-p)\n (function-item ement-notify--event-from-session-user-p)\n (function :tag \"Custom predicate\"))))\n\n(defcustom ement-notify-log-predicates\n '(ement-notify--event-mentions-session-user-p\n ement-notify--event-mentions-room-p\n ement-notify--room-buffer-live-p\n ement-notify--room-unread-p)\n \"Predicates to determine whether to log an event to the notifications buffer.\nIf one of these returns non-nil for an event, the event is logged.\"\n :type 'hook\n :options '(ement-notify--event-mentions-session-user-p\n ement-notify--event-mentions-room-p\n ement-notify--room-buffer-live-p\n ement-notify--room-unread-p))\n\n(defcustom ement-notify-mark-frame-urgent-predicates\n '(ement-notify--event-mentions-session-user-p\n ement-notify--event-mentions-room-p)\n \"Predicates to determine whether to mark a frame as urgent.\nIf one of these returns non-nil for an event, the frame that most\nrecently showed the event's room's buffer is marked\nurgent. (Only works on X, not other GUI platforms.)\"\n :type 'hook\n :options '(ement-notify--event-mentions-session-user-p\n ement-notify--event-mentions-room-p))\n\n(defcustom ement-notify-mention-predicates\n '(ement-notify--event-mentions-session-user-p\n ement-notify--event-mentions-room-p)\n \"Predicates to determine whether to log an event to the mentions buffer.\nIf one of these returns non-nil for an event, the event is logged.\"\n :type 'hook\n :options '(ement-notify--event-mentions-session-user-p\n ement-notify--event-mentions-room-p))\n\n(defcustom ement-notify-notification-predicates\n '(ement-notify--event-mentions-session-user-p\n ement-notify--event-mentions-room-p\n ement-notify--room-buffer-live-p\n ement-notify--room-unread-p)\n \"Predicates to determine whether to send a desktop notification.\nIf one of these returns non-nil for an event, the notification is sent.\"\n :type 'hook\n :options '(ement-notify--event-mentions-session-user-p\n ement-notify--event-mentions-room-p\n ement-notify--room-buffer-live-p\n ement-notify--room-unread-p))\n\n(defcustom ement-notify-sound nil\n \"Sound to play for notifications.\"\n :type '(choice (file :tag \"Sound file\")\n (string :tag \"XDG sound name\")\n (const :tag \"Default XDG message sound\" \"message-new-instant\")\n (const :tag \"Don't play a sound\" nil)))\n\n(defcustom ement-notify-limit-room-name-width nil\n \"Limit the width of room display names in mentions and notifications buffers.\nThis prevents the margin from being made excessively wide.\"\n :type '(choice (integer :tag \"Maximum width\")\n (const :tag \"Unlimited width\" nil)))\n\n(defcustom ement-notify-prism-background nil\n \"Add distinct background color by room to messages in notification buffers.\nThe color is specific to each room, generated automatically, and\ncan help distinguish messages by room.\"\n :type 'boolean)\n\n(defcustom ement-notify-room-avatars t\n \"Show room avatars in the notifications buffers.\nThis shows room avatars at the left of the window margin in\nnotification buffers. It's not customizable beyond that due to\nlimitations and complexities of displaying strings and images in\nmargins in Emacs. But it's useful, anyway.\"\n :type 'boolean)\n\n;;;; Commands\n\n(declare-function ement-room-goto-event \"ement-room\")\n(defun ement-notify-button-action (button)\n \"Show BUTTON's event in its room buffer.\"\n ;; TODO: Is `interactive' necessary here?\n (interactive)\n (let* ((session (button-get button 'session))\n (room (button-get button 'room))\n (event (button-get button 'event)))\n (ement-view-room room session)\n (ement-room-goto-event event)))\n\n(defun ement-notify-reply ()\n \"Send a reply to event at point.\"\n (interactive)\n (save-window-excursion\n ;; Not sure why `call-interactively' doesn't work for `push-button' but oh well.\n (push-button)\n (call-interactively #'ement-room-write-reply)))\n\n(defun ement-notify-switch-to-notifications-buffer ()\n \"Switch to \\\"*Ement Notifications*\\\" buffer.\"\n (declare (function ement-notifications \"ement-notifications\"))\n (interactive)\n (call-interactively #'ement-notifications))\n\n(defvar ement-notifications-mode-map)\n(defun ement-notify-switch-to-mentions-buffer ()\n \"Switch to \\\"*Ement Mentions*\\\" buffer.\"\n (declare (function ement-notifications--log-buffer \"ement-notifications\"))\n (interactive)\n (switch-to-buffer (ement-notifications--log-buffer :name \"*Ement Mentions*\"))\n ;; HACK: Undo remapping of scroll commands which don't apply in this buffer.\n (let ((map (copy-keymap ement-notifications-mode-map)))\n (define-key map [remap scroll-down-command] nil)\n (define-key map [remap mwheel-scroll] nil)\n (use-local-map map)))\n\n;;;; Functions\n\n(defun ement-notify (event room session)\n \"Send notifications for EVENT in ROOM on SESSION.\nSends if all of `ement-notify-ignore-predicates' return nil.\nDoes not do anything if session hasn't finished initial sync.\"\n (with-demoted-errors \"ement-notify: Error: %S\"\n (when (and (ement-session-has-synced-p session)\n (cl-loop for pred in ement-notify-ignore-predicates\n never (funcall pred event room session)))\n (when (and ement-notify-dbus-p\n (run-hook-with-args-until-success 'ement-notify-notification-predicates event room session))\n (ement-notify--notifications-notify event room session))\n (when (run-hook-with-args-until-success 'ement-notify-log-predicates event room session)\n (ement-notify--log-to-buffer event room session))\n (when (run-hook-with-args-until-success 'ement-notify-mention-predicates event room session)\n (ement-notify--log-to-buffer event room session :buffer-name \"*Ement Mentions*\"))\n (when (run-hook-with-args-until-success 'ement-notify-mark-frame-urgent-predicates event room session)\n (ement-notify--mark-frame-urgent event room session)))))\n\n(defun ement-notify--mark-frame-urgent (_event room _session)\n \"Mark frame showing ROOM's buffer as urgent.\nIf ROOM has no existing buffer, do nothing.\"\n (declare\n ;; These silence lint warnings on our GitHub CI runs, which use a build of Emacs\n ;; without GUI support.\n (function dbus-get-unique-name \"dbusbind.c\")\n (function x-change-window-property \"xfns.c\")\n (function x-window-property \"xfns.c\"))\n (cl-labels ((mark-frame-urgent (frame)\n (let* ((prop \"WM_HINTS\")\n (hints (cl-coerce\n (x-window-property prop frame prop nil nil t)\n 'list)))\n (setf (car hints) (logior (car hints) 256))\n (x-change-window-property prop hints nil prop 32 t))))\n (when-let* ((buffer (alist-get 'buffer (ement-room-local room)))\n (frames (cl-loop for frame in (frame-list)\n when (eq 'x (framep frame))\n collect frame))\n (frame (pcase (length frames)\n (1 (car frames))\n (_\n ;; Use the frame that most recently showed ROOM's buffer.\n (car (sort frames\n (lambda (frame-a frame-b)\n (let ((a-pos (cl-position buffer (buffer-list frame-a)))\n (b-pos (cl-position buffer (buffer-list frame-b))))\n (cond ((and a-pos b-pos)\n (< a-pos b-pos))\n (a-pos)\n (b-pos))))))))))\n (mark-frame-urgent frame))))\n\n(defun ement-notify--notifications-notify (event room _session)\n \"Call `notifications-notify' for EVENT in ROOM on SESSION.\"\n (pcase-let* (((cl-struct ement-event sender content) event)\n ((cl-struct ement-room avatar (display-name room-displayname)) room)\n ((map body) content)\n (room-name (or room-displayname (ement--room-display-name room)))\n (sender-name (ement--user-displayname-in room sender))\n (title (format \"%s in %s\" sender-name room-name)))\n ;; TODO: Encode HTML entities.\n (when (stringp body)\n ;; If event has no body, it was probably redacted or something, so don't notify.\n (truncate-string-to-width body 60)\n (notifications-notify :title title :body body\n :app-name \"Ement.el\"\n :app-icon (when avatar\n (ement-notify--temp-file\n (plist-get (cdr (get-text-property 0 'display avatar)) :data)))\n :category \"im.received\"\n :timeout 5000\n ;; FIXME: Using :sound-file seems to do nothing, ever. Maybe a bug in notifications-notify?\n :sound-file (when (and ement-notify-sound\n (file-name-absolute-p ement-notify-sound))\n ement-notify-sound)\n :sound-name (when (and ement-notify-sound\n (not (file-name-absolute-p ement-notify-sound)))\n ement-notify-sound)\n ;; TODO: Show when action used.\n ;; :actions '(\"default\" \"Show\")\n ;; :on-action #'ement-notify-show\n ))))\n\n(cl-defun ement-notify--temp-file (content &key (timeout 5))\n \"Return a filename holding CONTENT, and delete it after TIMEOUT seconds.\"\n (let ((filename (make-temp-file \"ement-notify--temp-file-\"))\n (coding-system-for-write 'no-conversion))\n (with-temp-file filename\n (insert content))\n (run-at-time timeout nil (lambda ()\n (delete-file filename)))\n filename))\n\n(cl-defun ement-notify--log-to-buffer (event room session &key (buffer-name \"*Ement Notifications*\"))\n \"Log EVENT in ROOM on SESSION to \\\"*Ement Notifications*\\\" buffer.\"\n (declare (function ement-notifications-log-to-buffer \"ement-notifications\")\n (function make-ement-notification \"ement-notifications\"))\n (pcase-let* (((cl-struct ement-room (id room-id)) room)\n (notification (make-ement-notification :room-id room-id :event event)))\n (ement-notifications-log-to-buffer session notification :buffer-name buffer-name)))\n\n;;;;; Predicates\n\n(defun ement-notify--event-mentions-session-user-p (event room session)\n \"Return non-nil if EVENT in ROOM mentions SESSION's user.\nIf EVENT's sender is SESSION's user, returns nil.\"\n (pcase-let* (((cl-struct ement-session user) session)\n ((cl-struct ement-event sender) event))\n (unless (equal (ement-user-id user) (ement-user-id sender))\n (ement-room--event-mentions-user-p event user room))))\n\n(defun ement-notify--room-buffer-live-p (_event room _session)\n \"Return non-nil if ROOM has a live buffer.\"\n (buffer-live-p (alist-get 'buffer (ement-room-local room))))\n\n(defun ement-notify--room-unread-p (_event room _session)\n \"Return non-nil if ROOM has unread notifications.\nAccording to the room's notification configuration on the server.\"\n (pcase-let* (((cl-struct ement-room unread-notifications) room)\n ((map notification_count highlight_count) unread-notifications))\n (not (and (equal 0 notification_count)\n (equal 0 highlight_count)))))\n\n(defun ement-notify--event-message-p (event _room _session)\n \"Return non-nil if EVENT is an \\\"m.room.message\\\" event.\"\n (equal \"m.room.message\" (ement-event-type event)))\n\n(defun ement-notify--event-not-message-p (event _room _session)\n \"Return non-nil if EVENT is not an \\\"m.room.message\\\" event.\"\n (not (equal \"m.room.message\" (ement-event-type event))))\n\n(defun ement-notify--event-from-session-user-p (event _room session)\n \"Return non-nil if EVENT is sent by SESSION's user.\"\n (equal (ement-user-id (ement-session-user session))\n (ement-user-id (ement-event-sender event))))\n\n(defalias 'ement-notify--event-mentions-room-p #'ement--event-mentions-room-p)\n\n;;;; Bookmark support\n\n;; Especially useful with Burly: \n\n(require 'bookmark)\n\n(defun ement-notify-bookmark-make-record ()\n \"Return a bookmark record for the current `ement-notify' buffer.\"\n (list (buffer-name)\n ;; It seems silly to have to record the buffer name twice, but the\n ;; `bookmark-make-record' function seems to override the bookmark name sometimes,\n ;; which makes the result useless unless we save the buffer name separately.\n (cons 'buffer-name (buffer-name))\n (cons 'handler #'ement-notify-bookmark-handler)))\n\n(defun ement-notify-bookmark-handler (bookmark)\n \"Show Ement notifications buffer for BOOKMARK.\"\n (pcase-let ((`(,_bookmark-name . ,(map buffer-name)) bookmark))\n (switch-to-buffer (ement-notifications--log-buffer :name buffer-name))))\n\n;;;; Footer\n\n(provide 'ement-notify)\n\n;;; ement-notify.el ends here\n" }, { "path": "ement-room-list.el", "content": ";;; ement-room-list.el --- List Ement rooms -*- lexical-binding: t; -*-\n\n;; Copyright (C) 2022-2023 Free Software Foundation, Inc.\n\n;; Author: Adam Porter \n;; Maintainer: Adam Porter \n\n;; This program is free software; you can redistribute it and/or modify\n;; it under the terms of the GNU General Public License as published by\n;; the Free Software Foundation, either version 3 of the License, or\n;; (at your option) any later version.\n\n;; This program is distributed in the hope that it will be useful,\n;; but WITHOUT ANY WARRANTY; without even the implied warranty of\n;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n;; GNU General Public License for more details.\n\n;; You should have received a copy of the GNU General Public License\n;; along with this program. If not, see .\n\n;;; Commentary:\n\n;; This library implements a room list view using `taxy' and `taxy-magit-section' for\n;; dynamic, programmable grouping.\n\n;;; Code:\n\n(require 'button)\n(require 'rx)\n\n(require 'persist)\n(require 'svg-lib)\n(require 'taxy)\n(require 'taxy-magit-section)\n\n(require 'ement-lib)\n\n;;;; Mouse commands\n\n;; Since mouse-activated commands must handle mouse events, we define a simple macro to\n;; wrap a command into a mouse-event-accepting one.\n\n(defmacro ement-room-list-define-mouse-command (command)\n \"Define a command that calls COMMAND interactively with point at mouse event.\nCOMMAND should be a form that evaluates to a function symbol; if\na symbol, it should be unquoted..\"\n (let ((docstring (format \"Call command `%s' interactively with point at EVENT.\" command))\n (name (intern (format \"ement-room-list-mouse-%s\" command))))\n `(defun ,name (event)\n ,docstring\n (interactive \"e\")\n (mouse-set-point event)\n (call-interactively #',command))))\n\n;;;; Types\n\n(defclass ement-room-list-section (magit-section)\n ;; We define this class so we can use it as the type of section we insert, so we can\n ;; define a method to return identifiers for our section type, so section visibility can\n ;; be cached concisely (i.e. without storing room event data in the values, which can\n ;; serialize to hundreds of megabytes after receiving many events).\n nil)\n\n(cl-defmethod magit-section-ident-value ((section ement-room-list-section))\n \"Return ident value for `ement-room-list-section' SECTION.\nUsed for caching section visibility.\"\n ;; FIXME: The name of each taxy could be ambiguous. Best would be to use the\n ;; hierarchical path, but since the taxys aren't doubly linked, that isn't easily done.\n ;; Could probably be worked around by binding a special variable around the creation of\n ;; the taxy hierarchy that would allow the path to be saved into each taxy.\n (pcase-exhaustive (oref section value)\n ;; FIXME(emacs-28): Use `(cl-type taxy-magit-section)' and `(cl-type ement-room)', et\n ;; al. when requiring Emacs 28. See\n ;; .\n ((and (pred taxy-magit-section-p) it)\n (taxy-name it))\n (`[,(and (pred ement-room-p) room)\n ,(and (pred ement-session-p) session)]\n (vector (ement-user-id (ement-session-user session))\n (ement-room-id room)))\n ((pred null) nil)))\n\n;;;; Variables\n\n(declare-function ement-room-toggle-space \"ement-room\")\n\n(defvar ement-room-list-mode-map\n (let ((map (make-sparse-keymap)))\n (define-key map (kbd \"RET\") #'ement-room-list-RET)\n (define-key map (kbd \"SPC\") #'ement-room-list-next-unread)\n (define-key map [tab] #'ement-room-list-section-toggle)\n (define-key map [mouse-1] (ement-room-list-define-mouse-command ement-room-list-RET))\n (define-key map [mouse-2] (ement-room-list-define-mouse-command ement-room-list-kill-buffer))\n (define-key map (kbd \"k\") #'ement-room-list-kill-buffer)\n (define-key map (kbd \"s\") #'ement-room-toggle-space)\n map)\n \"Keymap for `ement-room-list' buffers.\nSee also `ement-room-list-button-map'.\")\n\n(defvar ement-room-list-button-map\n ;; This map is needed because some columns are propertized as buttons, which override\n ;; the main keymap.\n ;; TODO: Is it possible to adjust the button properties to obviate this map?\n (let ((map (make-sparse-keymap)))\n (define-key map [mouse-1] (ement-room-list-define-mouse-command ement-room-list-RET))\n (define-key map [mouse-2] (ement-room-list-define-mouse-command ement-room-list-kill-buffer))\n map)\n \"Keymap for buttonized text in `ement-room-list' buffers.\")\n\n(defvar ement-room-list-timestamp-colors nil\n \"List of colors used for timestamps.\nSet automatically when `ement-room-list-mode' is activated.\")\n\n(defvar ement-room)\n(defvar ement-session)\n(defvar ement-sessions)\n(defvar ement-room-prism-minimum-contrast)\n\n;;;;; Persistent variables\n\n(persist-defvar ement-room-list-visibility-cache nil\n \"Applied to `magit-section-visibility-cache', which see.\")\n\n;;;; Customization\n\n(defgroup ement-room-list-faces nil\n \"Faces for room list buffers.\"\n :group 'ement-room-list\n :group 'ement-faces)\n\n(defgroup ement-room-list nil\n \"Options for room list buffers.\"\n :group 'ement)\n\n(defcustom ement-room-list-auto-update t\n \"Automatically update the taxy-based room list buffer.\"\n :type 'boolean)\n\n(defcustom ement-room-list-avatars (display-images-p)\n \"Show room avatars in the room list.\"\n :type 'boolean)\n\n(defcustom ement-room-list-avatar-generation (image-type-available-p 'svg)\n \"Generate SVG-based avatars for rooms that have none.\"\n :type 'boolean)\n\n(defcustom ement-room-list-space-prefix \"Space: \"\n \"Prefix applied to space names.\"\n :type 'string)\n\n;;;;; Faces\n\n;; TODO: Inherit from a single face to allow certain attributes to be disabled\n;; (e.g. underline), in case a face inherited from has such attributes.\n\n(defface ement-room-list-direct\n ;; We want to use `font-lock-constant-face' as the base face (because it seems to look\n ;; nice with most themes), but that face sometimes is defined as bold, which interferes\n ;; with our ability to use boldness to indicate unread rooms. But if we override the\n ;; weight to be normal, even the \"People\" heading in the room list will not be bold,\n ;; which group headings should be. So we make a copy of the face, unset its weight, and\n ;; inherit from that.\n (progn\n (copy-face 'font-lock-constant-face 'ement--font-lock-constant-face)\n (set-face-attribute 'ement--font-lock-constant-face nil :weight 'unspecified)\n '((t (:inherit (ement--font-lock-constant-face ement-room-list-name) :underline nil))))\n \"Direct rooms.\"\n :group 'ement-room-list-faces)\n\n(defface ement-room-list-favourite '((t (:inherit (font-lock-doc-face ement-room-list-name))))\n \"Favourite rooms.\"\n :group 'ement-room-list-faces)\n\n(defface ement-room-list-invited\n '((t (:inherit (italic ement-room-list-name))))\n \"Invited rooms.\"\n :group 'ement-room-list-faces)\n\n(defface ement-room-list-left\n '((t (:strike-through t :inherit ement-room-list-name)))\n \"Left rooms.\"\n :group 'ement-room-list-faces)\n\n(defface ement-room-list-low-priority '((t (:inherit (font-lock-comment-face ement-room-list-name))))\n \"Low-priority rooms.\"\n :group 'ement-room-list-faces)\n\n(defface ement-room-list-name\n '((t (:inherit (font-lock-function-name-face button) :underline nil)))\n \"Non-direct rooms.\"\n :group 'ement-room-list-faces)\n\n(defface ement-room-list-space '((t (:inherit (font-lock-regexp-grouping-backslash ement-room-list-name))))\n \"Space rooms.\"\n :group 'ement-room-list-faces)\n\n(defface ement-room-list-unread\n '((t (:inherit (bold ement-room-list-name))))\n \"Unread rooms.\"\n :group 'ement-room-list-faces)\n\n(defface ement-room-list-recent '((t (:inherit font-lock-warning-face)))\n \"Latest timestamp of recently updated rooms.\nThe foreground color is used to generate a gradient of colors\nfrom recent to non-recent for rooms updated in the past 24\nhours but at least one hour ago.\"\n :group 'ement-room-list-faces)\n\n(defface ement-room-list-very-recent '((t (:inherit error)))\n \"Latest timestamp of very recently updated rooms.\nThe foreground color is used to generate a gradient of colors\nfrom recent to non-recent for rooms updated in the past hour.\"\n :group 'ement-room-list-faces)\n\n;;;; Keys\n\n;; Since some of these keys need access to the session, and room\n;; structs don't include the session, we use a two-element vector in\n;; which the session is the second element.\n\n(eval-and-compile\n (taxy-define-key-definer ement-room-list-define-key\n ement-room-list-keys \"ement-room-list-key\" \"FIXME: Docstring.\"))\n\n(ement-room-list-define-key membership (&key name status)\n ;; FIXME: Docstring: status should be a symbol of either `invite', `join', `leave'.\n (cl-labels ((format-membership (membership)\n (pcase membership\n ('join \"Joined\")\n ('invite \"Invited\")\n ('leave \"[Left]\"))))\n (pcase-let ((`[,(cl-struct ement-room (status membership)) ,_session] item))\n (if status\n (when (equal status membership)\n (or name (format-membership membership)))\n (format-membership membership)))))\n\n(ement-room-list-define-key alias (&key name regexp)\n (pcase-let ((`[,(cl-struct ement-room canonical-alias) ,_session] item))\n (when canonical-alias\n (when (string-match-p regexp canonical-alias)\n name))))\n\n(ement-room-list-define-key buffer ()\n (pcase-let ((`[,(cl-struct ement-room (local (map buffer))) ,_session] item))\n (when buffer\n #(\"Buffers\" 0 7 (help-echo \"Rooms with open buffers\")))))\n\n(ement-room-list-define-key direct ()\n (pcase-let ((`[,room ,session] item))\n (when (ement--room-direct-p room session)\n \"Direct\")))\n\n(ement-room-list-define-key people ()\n (pcase-let ((`[,room ,session] item))\n (when (ement--room-direct-p room session)\n (ement-propertize \"People\" 'face 'ement-room-list-direct))))\n\n(ement-room-list-define-key space (&key name id)\n (pcase-let* ((`[,room ,session] item)\n ((cl-struct ement-session rooms) session)\n ((cl-struct ement-room type (local (map parents))) room))\n (cl-labels ((format-space (id)\n (let* ((parent-room (cl-find id rooms :key #'ement-room-id :test #'equal))\n (space-name (if parent-room\n (ement-room-display-name parent-room)\n id)))\n (concat ement-room-list-space-prefix space-name))))\n (when-let ((key (if id\n ;; ID specified.\n (cond ((or (member id parents)\n (equal id (ement-room-id room)))\n ;; Room is in specified space.\n (or name (format-space id)))\n ((and (equal type \"m.space\")\n (equal id (ement-room-id room)))\n ;; Room is a specified space.\n (or name (concat ement-room-list-space-prefix (ement-room-display-name room)))))\n ;; ID not specified.\n (pcase (length parents)\n (0 nil)\n (1\n ;; TODO: Make the rooms list a hash table to avoid this lookup.\n (format-space (car parents)))\n (_\n ;; TODO: How to handle this better? (though it should be very rare)\n (string-join (mapcar #'format-space parents) \", \"))))))\n (ement-propertize key 'face 'ement-room-list-space)))))\n\n(ement-room-list-define-key space-p ()\n \"Groups rooms that are themselves spaces.\"\n (pcase-let* ((`[,room ,_session] item)\n ((cl-struct ement-room type) room))\n (when (equal \"m.space\" type)\n \"Spaces\")))\n\n(ement-room-list-define-key name (&key name regexp)\n (pcase-let* ((`[,room ,_session] item)\n (display-name (ement--room-display-name room)))\n (when display-name\n (when (string-match-p regexp display-name)\n (or name regexp)))))\n\n(ement-room-list-define-key latest (&key name newer-than older-than)\n (pcase-let* ((`[,room ,_session] item)\n ((cl-struct ement-room latest-ts) room)\n (age))\n (when latest-ts\n (setf age (- (time-convert nil 'integer) (/ latest-ts 1000)))\n (cond (newer-than\n (when (<= age newer-than)\n (or name (format \"Newer than %s seconds\" newer-than))))\n (older-than\n (when (>= age older-than)\n (or name (format \"Older than %s seconds\" newer-than))))\n (t\n ;; Default to rooms with traffic in the last day.\n (if (<= age 86400)\n \"Last 24 hours\"\n \"Older than 24 hours\"))))))\n\n(ement-room-list-define-key freshness\n (&key (intervals '((86400 . \"Past 24h\")\n (604800 . \"Past week\")\n (2419200 . \"Past month\")\n (31536000 . \"Past year\"))))\n (pcase-let* ((`[,room ,_session] item)\n ((cl-struct ement-room latest-ts) room)\n (age))\n (when latest-ts\n (setf age (- (time-convert nil 'integer) (/ latest-ts 1000)))\n (or (alist-get age intervals nil nil #'>)\n \"Older than a year\"))))\n\n(ement-room-list-define-key session (&optional user-id)\n (pcase-let ((`[,_room ,(cl-struct ement-session\n (user (cl-struct ement-user id)))]\n item))\n (pcase user-id\n (`nil id)\n (_ (when (equal user-id id)\n user-id)))))\n\n(ement-room-list-define-key topic (&key name regexp)\n (pcase-let ((`[,(cl-struct ement-room topic) ,_session] item))\n (when (and topic (string-match-p regexp topic))\n name)))\n\n(ement-room-list-define-key unread ()\n (pcase-let ((`[,room ,session] item))\n (when (ement--room-unread-p room session)\n \"Unread\")))\n\n(ement-room-list-define-key favourite ()\n :then #'identity\n (pcase-let ((`[,room ,_session] item))\n (when (ement--room-favourite-p room)\n (ement-propertize \"Favourite\" 'face 'ement-room-list-favourite))))\n\n(ement-room-list-define-key low-priority ()\n :then #'identity\n (pcase-let ((`[,room ,_session] item))\n (when (ement--room-low-priority-p room)\n \"Low-priority\")))\n\n(defcustom ement-room-list-default-keys\n '(;; First, group all invitations (this group will appear first since the rooms are\n ;; already sorted first).\n ((membership :status 'invite))\n ;; Group all left rooms (this group will appear last, because the rooms are already\n ;; sorted last).\n ((membership :status 'leave))\n ;; Group all favorite rooms, which are already sorted first.\n (favourite)\n ;; Group other rooms which are opened in a buffer.\n (buffer)\n ;; Group other rooms which are unread.\n (unread)\n ;; Group all low-priority rooms, which are already sorted last, and within that group,\n ;; group them by their space, if any.\n (low-priority space)\n ;; Group other non-direct rooms which are in a space by freshness, then by space.\n ((and :name \"Spaced\"\n :keys ((not space-p)\n (not people)\n space))\n freshness space)\n ;; Group spaces themselves by their parent space (since space headers can't also be\n ;; items, we have to handle them separately; a bit of a hack, but not too bad).\n ((and :name \"Spaces\" :keys (space-p))\n space)\n ;; Group rooms which aren't in spaces by their freshness.\n ((and :name \"Unspaced\"\n :keys ((not space)\n (not people)))\n freshness)\n ;; Group direct rooms by freshness and space.\n (people freshness space))\n \"Default keys.\"\n :type 'sexp)\n\n;;;; Columns\n\n(eval-and-compile\n (taxy-magit-section-define-column-definer \"ement-room-list\"))\n\n(ement-room-list-define-column #(\"🐱\" 0 1 (help-echo \"Avatar\")) (:align 'right)\n (pcase-let* ((`[,room ,_session] item)\n ((cl-struct ement-room avatar display-name\n (local (map room-list-avatar)))\n room))\n (if ement-room-list-avatars\n (or room-list-avatar\n (let ((new-avatar\n (if avatar\n ;; NOTE: We resize every avatar to be suitable for this buffer, rather than using\n ;; the one cached in the room's struct. If the buffer's faces change height, this\n ;; will need refreshing, but it should be worth it to avoid resizing the images on\n ;; every update.\n (propertize \" \" 'display\n (ement--resize-image (get-text-property 0 'display avatar)\n nil (frame-char-height)))\n ;; Room has no avatar.\n (if ement-room-list-avatar-generation\n (let* ((string (or display-name (ement--room-display-name room)))\n (ement-room-prism-minimum-contrast 1)\n (color (ement--prism-color string :contrast-with \"white\")))\n (when (string-match (rx bos (or \"#\" \"!\" \"@\")) string)\n (setf string (substring string 1)))\n (propertize \" \" 'display (svg-lib-tag (substring string 0 1) nil\n :background color :foreground \"white\"\n :stroke 0)))\n ;; Avatar generation disabled: use a two-space string.\n \" \"))))\n (setf (alist-get 'room-list-avatar (ement-room-local room)) new-avatar)))\n ;; Avatars disabled: use a two-space string.\n \" \")))\n\n(ement-room-list-define-column \"Name\" (:max-width 25)\n (pcase-let* ((`[,room ,session] item)\n ((cl-struct ement-room type) room)\n (display-name (ement--room-display-name room))\n (face))\n (or (when display-name\n ;; TODO: Use code from ement-room-list and put in a dedicated function.\n (setf face (cl-copy-list '(:inherit (ement-room-list-name))))\n ;; In concert with the \"Unread\" column, this is roughly equivalent to the\n ;; \"red/gray/bold/idle\" states listed in .\n (when (ement--room-unread-p room session)\n ;; For some reason, `push' doesn't work with `map-elt'...or does it?\n (push 'ement-room-list-unread (map-elt face :inherit)))\n (when (equal \"m.space\" type)\n (push 'ement-room-list-space (map-elt face :inherit)))\n (when (ement--room-direct-p room session)\n (push 'ement-room-list-direct (map-elt face :inherit)))\n (when (ement--room-favourite-p room)\n (push 'ement-room-list-favourite (map-elt face :inherit)))\n (when (ement--room-low-priority-p room)\n (push 'ement-room-list-low-priority (map-elt face :inherit)))\n (pcase (ement-room-status room)\n ('invite\n (push 'ement-room-list-invited (map-elt face :inherit)))\n ('leave\n (push 'ement-room-list-left (map-elt face :inherit))))\n (ement-propertize display-name\n 'face face\n 'mouse-face 'highlight\n 'keymap ement-room-list-button-map))\n \"\")))\n\n(ement-room-list-define-column #(\"Unread\" 0 6 (help-echo \"Unread events (Notifications:Highlights)\")) (:align 'right)\n (pcase-let* ((`[,(cl-struct ement-room unread-notifications) ,_session] item)\n ((map notification_count highlight_count) unread-notifications))\n (if (or (not unread-notifications)\n (and (equal 0 notification_count)\n (equal 0 highlight_count)))\n \"\"\n (concat (ement-propertize (number-to-string notification_count)\n 'face (if (zerop highlight_count)\n 'default\n 'ement-room-mention))\n \":\"\n (ement-propertize (number-to-string highlight_count)\n 'face 'highlight)))))\n\n(ement-room-list-define-column \"Latest\" ()\n (pcase-let ((`[,(cl-struct ement-room latest-ts) ,_session] item))\n (if latest-ts\n (let* ((difference-seconds (- (float-time) (/ latest-ts 1000)))\n (n (cl-typecase difference-seconds\n ((number 0 3599) ;; <1 hour: 10-minute periods.\n (truncate (/ difference-seconds 600)))\n ((number 3600 86400) ;; 1 hour to 1 day: 24 1-hour periods.\n (+ 6 (truncate (/ difference-seconds 3600))))\n (otherwise ;; Difference in weeks.\n (min (/ (length ement-room-list-timestamp-colors) 2)\n (+ 24 (truncate (/ difference-seconds 86400 7)))))))\n (face (list :foreground (elt ement-room-list-timestamp-colors n)))\n (formatted-ts (ement--human-format-duration difference-seconds 'abbreviate)))\n (string-match (rx (1+ digit) (repeat 1 alpha)) formatted-ts)\n (ement-propertize (match-string 0 formatted-ts)\n 'face face\n 'help-echo formatted-ts))\n \"\")))\n\n(ement-room-list-define-column \"Topic\" (:max-width 35)\n (pcase-let ((`[,(cl-struct ement-room topic status) ,_session] item))\n ;; FIXME: Can the status and type unified, or is this inherent to the spec?\n (when topic\n (setf topic (replace-regexp-in-string \"\\n\" \" \" topic 'fixedcase 'literal)))\n (pcase status\n ('invite (concat (ement-propertize \"[invited]\"\n 'face 'ement-room-list-invited)\n \" \" topic))\n ('leave (concat (ement-propertize \"[left]\"\n 'face 'ement-room-list-left)\n \" \" topic))\n (_ (or topic \"\")))))\n\n(ement-room-list-define-column \"Members\" (:align 'right)\n (pcase-let ((`[,(cl-struct ement-room\n (summary (map ('m.joined_member_count member-count))))\n ,_session]\n item))\n (if member-count\n (number-to-string member-count)\n \"\")))\n\n(ement-room-list-define-column #(\"Notifications\" 0 5 (help-echo \"Notification state\")) ()\n (pcase-let* ((`[,room ,session] item))\n (pcase (ement-room-notification-state room session)\n ('nil \"default\")\n ('all-loud \"all (loud)\")\n ('all \"all\")\n ('mentions-and-keywords \"mentions\")\n ('none \"none\"))))\n\n(ement-room-list-define-column #(\"B\" 0 1 (help-echo \"Buffer exists for room\")) ()\n (pcase-let ((`[,(cl-struct ement-room (local (map buffer))) ,_session] item))\n (if buffer\n #(\"B\" 0 1 (help-echo \"Buffer exists for room\"))\n \" \")))\n\n(ement-room-list-define-column \"Session\" ()\n (pcase-let ((`[,_room ,(cl-struct ement-session (user (cl-struct ement-user id)))] item))\n id))\n\n(unless ement-room-list-columns\n ;; TODO: Automate this or document it\n (setq-default ement-room-list-columns\n (get 'ement-room-list-columns 'standard-value)))\n\n;;;; Bookmark support\n\n;; Especially useful with Burly: \n\n(require 'bookmark)\n\n(defun ement-room-list-bookmark-make-record ()\n \"Return a bookmark record for the `ement-room-list' buffer.\"\n (list \"*Ement Room List*\"\n (cons 'handler #'ement-room-list-bookmark-handler)))\n\n(defun ement-room-list-bookmark-handler (bookmark)\n \"Show `ement-room-list' room list buffer for BOOKMARK.\"\n (pcase-let* ((`(,_bookmark-name . ,_) bookmark))\n (unless ement-sessions\n ;; MAYBE: Automatically connect.\n (user-error \"No sessions connected: call `ement-connect' first\"))\n (ement-room-list)))\n\n;;;; Commands\n\n(defun ement-room-list-section-toggle ()\n \"Toggle the section at point.\"\n ;; HACK: For some reason, when a section's body is hidden, then the buffer is refreshed,\n ;; and then the section's body is shown again, the body is empty--but then, refreshing\n ;; the buffer shows its body. So we work around that by refreshing the buffer when a\n ;; section is toggled. In a way, it makes sense to do this anyway, so the user has the\n ;; most up-to-date information in the buffer. This hack also works around a minor\n ;; visual bug that sometimes causes room avatars to be displayed in a section heading\n ;; when a section is hidden.\n (interactive)\n (ignore-errors\n ;; Ignore an error in case point is past the top-level section.\n (cl-typecase (aref (oref (magit-current-section) value) 0)\n (ement-room\n ;; HACK: Don't hide rooms themselves (they end up permanently hidden).\n nil)\n (otherwise\n (call-interactively #'magit-section-toggle)\n (revert-buffer)))))\n\n;;;###autoload\n(defun ement-room-list--after-initial-sync (&rest _ignore)\n \"Call `ement-room-list', ignoring arguments.\nTo be called from `ement-after-initial-sync-hook'.\"\n (ement-room-list))\n\n;;;###autoload\n(defalias 'ement-list-rooms 'ement-room-list)\n\n;;;###autoload\n(cl-defun ement-room-list (&key (buffer-name \"*Ement Room List*\")\n (keys ement-room-list-default-keys)\n (display-buffer-action '((display-buffer-reuse-window display-buffer-same-window)))\n ;; visibility-fn\n )\n \"Show a buffer listing Ement rooms, grouped with Taxy KEYS.\nAfter showing it, its window is selected. The buffer is named\nBUFFER-NAME and is shown with DISPLAY-BUFFER-ACTION; or if\nDISPLAY-BUFFER-ACTION is nil, the buffer is not displayed.\"\n (interactive)\n (let ((window-start 0) (window-point 0)\n format-table column-sizes)\n (cl-labels (;; (heading-face\n ;; (depth) (list :inherit (list 'bufler-group (bufler-level-face depth))))\n (format-item (item) (gethash item format-table))\n ;; NOTE: Since these functions take an \"item\" (which is a [room session]\n ;; vector), they're prefixed \"item-\" rather than \"room-\".\n (item-latest-ts (item)\n (or (ement-room-latest-ts (elt item 0))\n ;; Room has no latest timestamp. FIXME: This shouldn't\n ;; happen, but it can, maybe due to oversights elsewhere.\n 0))\n (item-unread-p (item)\n (pcase-let ((`[,room ,session] item))\n (ement--room-unread-p room session)))\n (item-left-p (item)\n (pcase-let ((`[,(cl-struct ement-room status) ,_session] item))\n (equal 'leave status)))\n (item-buffer-p (item)\n (pcase-let ((`[,(cl-struct ement-room (local (map buffer))) ,_session] item))\n (buffer-live-p buffer)))\n (taxy-unread-p (taxy)\n (or (cl-some #'item-unread-p (taxy-items taxy))\n (cl-some #'taxy-unread-p (taxy-taxys taxy))))\n (item-space-p (item)\n (pcase-let ((`[,(cl-struct ement-room type) ,_session] item))\n (equal \"m.space\" type)))\n (item-favourite-p (item)\n (pcase-let ((`[,room ,_session] item))\n (ement--room-favourite-p room)))\n (item-low-priority-p (item)\n (pcase-let ((`[,room ,_session] item))\n (ement--room-low-priority-p room)))\n (visible-p (section)\n ;; This is very confusing and doesn't currently work.\n (let ((value (oref section value)))\n (if (cl-typecase value\n (taxy-magit-section (item-unread-p value))\n (ement-room nil))\n 'show\n 'hide)))\n (item-invited-p (item)\n (pcase-let ((`[,(cl-struct ement-room status) ,_session] item))\n (equal 'invite status)))\n (taxy-latest-ts (taxy)\n (apply #'max most-negative-fixnum\n (delq nil\n (list\n (when (taxy-items taxy)\n (item-latest-ts (car (taxy-items taxy))))\n (when (taxy-taxys taxy)\n (cl-loop for sub-taxy in (taxy-taxys taxy)\n maximizing (taxy-latest-ts sub-taxy)))))))\n (tnil (a b) (and (not a) b))\n (make-fn (&rest args)\n (apply #'make-taxy-magit-section\n :make #'make-fn\n :format-fn #'format-item\n :level-indent ement-room-list-level-indent\n ;; :visibility-fn #'visible-p\n ;; :heading-indent 2\n :item-indent 2\n ;; :heading-face-fn #'heading-face\n args)))\n ;; (when (get-buffer buffer-name)\n ;; (kill-buffer buffer-name))\n (unless ement-sessions\n (error \"Ement: Not connected. Use `ement-connect' to connect\"))\n (if (not (cl-loop for (_id . session) in ement-sessions\n thereis (ement-session-rooms session)))\n (ement-message \"No rooms have been joined\")\n (with-current-buffer (get-buffer-create buffer-name)\n (unless (eq 'ement-room-list-mode major-mode)\n (ement-room-list-mode))\n (let* ((room-session-vectors\n (cl-loop for (_id . session) in ement-sessions\n append (cl-loop for room in (ement-session-rooms session)\n collect (vector room session))))\n (taxy (cl-macrolet ((first-item\n (pred) `(lambda (taxy)\n (when (taxy-items taxy)\n (,pred (car (taxy-items taxy))))))\n (name= (name) `(lambda (taxy)\n (equal ,name (taxy-name taxy)))))\n (thread-last\n (make-fn\n :name \"Ement Rooms\"\n :take (taxy-make-take-function keys ement-room-list-keys))\n (taxy-fill room-session-vectors)\n (taxy-sort #'> #'item-latest-ts)\n (taxy-sort #'tnil #'item-low-priority-p)\n (taxy-sort #'tnil #'item-left-p)\n (taxy-sort* #'string< #'taxy-name)\n (taxy-sort* #'> #'taxy-latest-ts)\n (taxy-sort* #'tnil (first-item item-space-p))\n (taxy-sort* #'t>nil (name= \"Low-priority\"))\n (taxy-sort* #'t>nil (first-item item-left-p)))))\n (taxy-magit-section-insert-indent-items nil)\n (inhibit-read-only t)\n (format-cons (taxy-magit-section-format-items\n ement-room-list-columns ement-room-list-column-formatters taxy))\n (pos (point))\n (section-ident (when (magit-current-section)\n (magit-section-ident (magit-current-section)))))\n (setf format-table (car format-cons)\n column-sizes (cdr format-cons)\n header-line-format (taxy-magit-section-format-header\n column-sizes ement-room-list-column-formatters))\n (when-let ((window (get-buffer-window (current-buffer))))\n (setf window-point (window-point window)\n window-start (window-start window)))\n (when ement-room-list-visibility-cache\n (setf magit-section-visibility-cache ement-room-list-visibility-cache))\n (add-hook 'kill-buffer-hook #'ement-room-list--cache-visibility nil 'local)\n ;; Before this point, no changes have been made to the buffer's contents.\n (delete-all-overlays)\n (erase-buffer)\n (save-excursion\n (taxy-magit-section-insert taxy :items 'first\n ;; :blank-between-depth bufler-taxy-blank-between-depth\n :initial-depth 0 :section-class 'ement-room-list-section))\n (if-let* ((section-ident)\n (section (magit-get-section section-ident)))\n (goto-char (oref section start))\n (goto-char pos))))\n (when display-buffer-action\n (when-let ((window (display-buffer buffer-name display-buffer-action)))\n (select-window window)))\n (when-let ((window (get-buffer-window buffer-name)))\n (set-window-start window window-start)\n (set-window-point window window-point))\n ;; FIXME: Despite all this code to save and restore point and window point and\n ;; window start, when I send a message from the minibuffer, or when I abort\n ;; sending a message from the minibuffer, point is moved to the beginning of the\n ;; buffer. While the minibuffer is open (and the typing messages are being sent\n ;; to the server, causing it to repeatedly sync), the point stays in the correct\n ;; place. I can't find any reason why this happens. It makes no sense. And\n ;; while trying to debug the problem, somehow Emacs got put into an unbreakable,\n ;; infinite loop twice; even C-g and SIGUSR2 didn't stop it.\n\n ;; NOTE: In order for `bookmark--jump-via' to work properly, the restored buffer\n ;; must be set as the current buffer, so we have to do this explicitly here.\n (set-buffer buffer-name)))))\n\n(cl-defun ement-room-list-side-window (&key (side 'left))\n \"Show room list in side window on SIDE.\nInteractively, with prefix, show on right side; otherwise, on\nleft.\"\n (interactive (when current-prefix-arg\n (list :side 'right)))\n (let ((display-buffer-mark-dedicated t))\n ;; Not sure if binding `display-buffer-mark-dedicated' is still necessary.\n (ement-room-list\n :display-buffer-action `(display-buffer-in-side-window\n (dedicated . t)\n (side . ,side)\n (window-parameters\n\t\t\t (no-delete-other-windows . t))))))\n\n(defun ement-room-list-revert (&optional _ignore-auto _noconfirm)\n \"Revert current Ement-Room-List buffer.\"\n (interactive)\n (with-current-buffer \"*Ement Room List*\"\n ;; FIXME: This caching of the visibility only supports the main buffer with the\n ;; default name, not any special ones with different names.\n (setf ement-room-list-visibility-cache magit-section-visibility-cache))\n (ement-room-list :display-buffer-action nil))\n\n(defun ement-room-list-kill-buffer (room)\n \"Kill ROOM's buffer.\"\n (interactive\n (ement-with-room-and-session\n (ignore ement-session)\n (list ement-room)))\n (pcase-let (((cl-struct ement-room (local (map buffer))) room)\n (kill-buffer-query-functions))\n (when (buffer-live-p buffer)\n (kill-buffer buffer)\n (ement-room-list-revert))))\n\n(declare-function ement-view-room \"ement-room\")\n(defun ement-room-list-RET ()\n \"View room at point, or cycle section at point.\"\n (declare (function ement-view-space \"ement-room\"))\n (interactive)\n (cl-etypecase (oref (magit-current-section) value)\n (vector (pcase-let ((`[,room ,session] (oref (magit-current-section) value)))\n (if (ement--space-p room)\n (ement-view-space room session)\n (ement-view-room room session))))\n (taxy-magit-section (call-interactively #'ement-room-list-section-toggle))\n (null nil)))\n\n(declare-function ement-room-goto-fully-read-marker \"ement-room\")\n(defun ement-room-list-next-unread ()\n \"Show next unread room.\"\n (interactive)\n (when (eobp)\n (goto-char (point-min)))\n (unless (cl-loop with starting-line = (line-number-at-pos)\n for value = (oref (magit-current-section) value)\n if (and (vectorp value)\n (ement--room-unread-p (elt value 0) (elt value 1)))\n do (progn\n (ement-view-room (elt value 0) (elt value 1))\n (ement-room-goto-fully-read-marker)\n (cl-return t))\n else do (forward-line 1)\n while (and (not (eobp))\n (> (line-number-at-pos) starting-line)))\n ;; No more unread rooms.\n (message \"No more unread rooms\")))\n\n(define-derived-mode ement-room-list-mode magit-section-mode \"Ement-Room-List\"\n :global nil\n (setq-local bookmark-make-record-function #'ement-room-list-bookmark-make-record\n revert-buffer-function #'ement-room-list-revert\n ement-room-list-timestamp-colors (ement-room-list--timestamp-colors)))\n\n;;;; Functions\n\n(defun ement-room-list--cache-visibility ()\n \"Save visibility cache.\nSets `ement-room-list-visibility-cache' to the value of\n`magit-section-visibility-cache'. To be called in\n`kill-buffer-hook'.\"\n (ignore-errors\n (when magit-section-visibility-cache\n (setf ement-room-list-visibility-cache magit-section-visibility-cache))))\n\n;;;###autoload\n(defun ement-room-list-auto-update (_session)\n \"Automatically update the Taxy room list buffer.\n+Does so when variable `ement-room-list-auto-update' is non-nil.\n+To be called in `ement-sync-callback-hook'.\"\n (when (and ement-room-list-auto-update\n (buffer-live-p (get-buffer \"*Ement Room List*\")))\n (with-current-buffer (get-buffer \"*Ement Room List*\")\n (unless (region-active-p)\n ;; Don't refresh the list if the region is active (e.g. if the user is trying to\n ;; operate on multiple rooms).\n (revert-buffer)))))\n\n(defun ement-room-list--timestamp-colors ()\n \"Return a vector of generated latest-timestamp colors for rooms.\nUsed in `ement-tabulated-room-list' and `ement-room-list'.\"\n (if (or (equal \"unspecified-fg\" (face-foreground 'default nil 'default))\n (equal \"unspecified-bg\" (face-background 'default nil 'default)))\n ;; NOTE: On a TTY, the default face's foreground and background colors may be the\n ;; special values \"unspecified-fg\"/\"unspecified-bg\", in which case we can't generate\n ;; gradients, so we just return a vector of \"unspecified-fg\". See\n ;; .\n (make-vector 134 \"unspecified-fg\")\n (cl-coerce\n (append (mapcar\n ;; One face per 10-minute period, from \"recent\" to 1-hour.\n (lambda (rgb)\n (pcase-let ((`(,r ,g ,b) rgb))\n (color-rgb-to-hex r g b 2)))\n (color-gradient (color-name-to-rgb (face-foreground 'ement-room-list-very-recent\n nil 'default))\n (color-name-to-rgb (face-foreground 'ement-room-list-recent\n nil 'default))\n 6))\n (mapcar\n ;; One face per hour, from \"recent\" to default.\n (lambda (rgb)\n (pcase-let ((`(,r ,g ,b) rgb))\n (color-rgb-to-hex r g b 2)))\n (color-gradient (color-name-to-rgb (face-foreground 'ement-room-list-recent\n nil 'default))\n (color-name-to-rgb (face-foreground 'default nil 'default))\n 24))\n (mapcar\n ;; One face per week for the last year (actually we\n ;; generate colors for the past two years' worth so\n ;; that the face for one-year-ago is halfway to\n ;; invisible, and we don't use colors past that point).\n (lambda (rgb)\n (pcase-let ((`(,r ,g ,b) rgb))\n (color-rgb-to-hex r g b 2)))\n (color-gradient (color-name-to-rgb (face-foreground 'default nil 'default))\n (color-name-to-rgb (face-background 'default nil 'default))\n 104)))\n 'vector)))\n\n;;;; Footer\n\n(provide 'ement-room-list)\n\n;;; ement-room-list.el ends here\n" }, { "path": "ement-room.el", "content": ";;; ement-room.el --- Ement room buffers -*- lexical-binding: t; -*-\n\n;; Copyright (C) 2022-2023 Free Software Foundation, Inc.\n\n;; Author: Adam Porter \n;; Maintainer: Adam Porter \n\n;; This program is free software; you can redistribute it and/or modify\n;; it under the terms of the GNU General Public License as published by\n;; the Free Software Foundation, either version 3 of the License, or\n;; (at your option) any later version.\n\n;; This program is distributed in the hope that it will be useful,\n;; but WITHOUT ANY WARRANTY; without even the implied warranty of\n;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n;; GNU General Public License for more details.\n\n;; You should have received a copy of the GNU General Public License\n;; along with this program. If not, see .\n\n;;; Commentary:\n\n;; This library implements buffers displaying events in a room.\n\n;; EWOC is a great library. If I had known about it and learned it\n;; sooner, it would have saved me a lot of time in other projects.\n;; I'm glad I decided to try it for this one.\n\n;;; Code:\n\n;;;; Debugging\n\n;; NOTE: Uncomment this form and `emacs-lisp-byte-compile-and-load' the file to enable\n;; `ement-debug' messages. This is commented out by default because, even though the\n;; messages are only displayed when `warning-minimum-log-level' is `:debug' at runtime, if\n;; that is so at expansion time, the expanded macro calls format the message and check the\n;; log level at runtime, which is not zero-cost.\n\n;; (eval-and-compile\n;; (setq-local warning-minimum-log-level nil)\n;; (setq-local warning-minimum-log-level :debug))\n\n;;;; Requirements\n\n(require 'color)\n(require 'ewoc)\n(require 'mailcap)\n(require 'shr)\n(require 'subr-x)\n(require 'mwheel)\n(require 'dnd)\n\n(require 'ement-api)\n(require 'ement-lib)\n(require 'ement-macros)\n(require 'ement-structs)\n\n;;;; Structs\n\n(cl-defstruct ement-room-membership-events\n \"Struct grouping membership events.\nAfter adding events, use `ement-room-membership-events--update'\nto sort events and update other slots.\"\n (events nil :documentation \"Membership events, latest first.\")\n (earliest-ts nil :documentation \"Timestamp of earliest event.\")\n (latest-ts nil :documentation \"Timestamp of latest event.\"))\n\n(defun ement-room-membership-events--update (struct)\n \"Return STRUCT having sorted its events and updated its slots.\"\n ;; Like the room timeline slot, events are sorted latest-first. We also deduplicate\n ;; them , because it seems that we can end up with multiple copies of a membership event\n ;; (e.g. when loading old messages).\n (setf (ement-room-membership-events-events struct) (cl-delete-duplicates (ement-room-membership-events-events struct)\n :key #'ement-event-id :test #'equal)\n (ement-room-membership-events-events struct) (cl-sort (ement-room-membership-events-events struct) #'>\n :key #'ement-event-origin-server-ts)\n (ement-room-membership-events-earliest-ts struct) (ement-event-origin-server-ts\n (car (last (ement-room-membership-events-events struct))))\n (ement-room-membership-events-latest-ts struct) (ement-event-origin-server-ts\n (car (ement-room-membership-events-events struct))))\n struct)\n\n;;;; Variables\n\n(defvar-local ement-ewoc nil\n \"EWOC for Ement room buffers.\")\n\n(defvar-local ement-room nil\n \"Ement room for current buffer.\")\n\n(defvar-local ement-session nil\n \"Ement session for current buffer.\")\n\n;; TODO: Convert some of these buffer-local variables into keys in one buffer-local map variable.\n\n(defvar-local ement-room-retro-loading nil\n \"Non-nil when earlier messages are being loaded.\nUsed to avoid overlapping requests.\")\n\n(defvar-local ement-room-editing-event nil\n \"When non-nil, the user is editing this event.\nUsed by `ement-room-send-message'.\")\n\n(defvar-local ement-room-replying-to-event nil\n \"When non-nil, the user is replying to this event.\nUsed by `ement-room-send-message'.\")\n\n(defvar-local ement-room-replying-to-overlay nil\n \"Used by `ement-room-write-reply'.\")\n\n(defvar-local ement-room-read-receipt-request nil\n \"Maps event ID to request updating read receipt to that event.\nAn alist of one entry.\")\n\n(defvar ement-room-read-string-setup-hook nil\n \"Normal hook run by `ement-room-read-string' after switching to minibuffer.\nShould be used to, e.g. propagate variables to the minibuffer.\")\n\n(defvar ement-room-compose-hook nil\n \"Hook run in compose buffers when created.\nUsed to, e.g. call `ement-room-compose-org'.\")\n\n(declare-function ement-room-list \"ement-room-list.el\")\n(declare-function ement-notify-switch-to-mentions-buffer \"ement-notify\")\n(declare-function ement-notify-switch-to-notifications-buffer \"ement-notify\")\n\n(defvar ement-room-mode-self-insert-keymap (make-sparse-keymap)\n \"The `ement-room-mode' keymap under `ement-room-self-insert-mode'.\n\nSet as the parent keymap of `ement-room-mode-effective-keymap'\nwhen `ement-room-self-insert-mode' is enabled.\n\nThis keymap is derived from the `ement-room-self-insert-chars'\nand `ement-room-self-insert-commands' user options, along with\n`ement-room-mode-map-prefix-key' which provides access to the\nfull `ement-room-mode-map'. (Non-conflicting key bindings from\n`ement-room-mode-map' are also available directly).\n\nThis keymap is generated when `ement-room-self-insert-mode' is\nenabled, and after customizing any of the above options when the\nminor mode is enabled.\n\nThe hook `ement-room-mode-self-insert-keymap-update-hook' runs\nafter generating this keymap.\n\nNote: Emacs bug#66792 may cause `describe-keymap' to include\nunreachable key bindings from the parent `ement-room-mode-map' in\nits help output. This problem affects only the help, and we work\naround it for the `ement-room-mode' help; but when viewing the\nkeymap directly the issue may be visible.\")\n\n(defvar ement-room-mode-map\n (let ((map (make-sparse-keymap))\n (prefixes '((\"M-g\" . \"group:switching\")\n (\"s\" . \"group:messages\")\n (\"u\" . \"group:users\")\n (\"r\" . \"group:room\")\n (\"R\" . \"group:membership\"))))\n ;; Use symbols for prefix maps so that `which-key' can display their names.\n (dolist (prefix prefixes)\n (let ((cmd (define-prefix-command (make-symbol (cdr prefix)))))\n (define-key map (kbd (car prefix)) cmd)))\n\n ;; Menu\n (define-key map (kbd \"?\") #'ement-room-transient)\n\n ;; Movement\n (define-key map (kbd \"n\") #'ement-room-goto-next)\n (define-key map (kbd \"N\") #'end-of-buffer)\n (define-key map (kbd \"p\") #'ement-room-goto-prev)\n (define-key map (kbd \"SPC\") #'ement-room-scroll-up-mark-read)\n (define-key map (kbd \"S-SPC\") #'ement-room-scroll-down-command)\n (define-key map (kbd \"M-g M-p\") #'ement-room-goto-fully-read-marker)\n (define-key map (kbd \"m\") #'ement-room-mark-read)\n (define-key map [remap scroll-down-command] #'ement-room-scroll-down-command)\n (define-key map [remap mwheel-scroll] #'ement-room-mwheel-scroll)\n (define-key map (kbd \"\") #'forward-button)\n (define-key map (kbd \"\") #'backward-button)\n\n ;; Switching\n (define-key map (kbd \"M-g M-l\") #'ement-room-list)\n (define-key map (kbd \"M-g M-r\") #'ement-view-room)\n (define-key map (kbd \"M-g M-m\") #'ement-notify-switch-to-mentions-buffer)\n (define-key map (kbd \"M-g M-n\") #'ement-notify-switch-to-notifications-buffer)\n (define-key map (kbd \"q\") #'quit-window)\n\n ;; Messages\n (define-key map (kbd \"RET\") #'ement-room-dispatch-new-message)\n (define-key map (kbd \"M-RET\") #'ement-room-dispatch-new-message-alt)\n (define-key map (kbd \"S-\") #'ement-room-dispatch-reply-to-message)\n (define-key map (kbd \"\") #'ement-room-dispatch-edit-message)\n (define-key map (kbd \"C-k\") #'ement-room-delete-message)\n (define-key map (kbd \"s r\") #'ement-room-send-reaction)\n (define-key map (kbd \"s e\") #'ement-room-send-emote)\n (define-key map (kbd \"s f\") #'ement-room-send-file)\n (define-key map (kbd \"s i\") #'ement-room-send-image)\n (define-key map (kbd \"v\") #'ement-room-view-event)\n (define-key map (kbd \"D\") #'ement-room-download-file)\n\n ;; Users\n (define-key map (kbd \"u RET\") #'ement-send-direct-message)\n (define-key map (kbd \"u i\") #'ement-invite-user)\n (define-key map (kbd \"u I\") #'ement-ignore-user)\n\n ;; Room\n (define-key map (kbd \"M-s o\") #'ement-room-occur)\n (define-key map (kbd \"r d\") #'ement-describe-room)\n (define-key map (kbd \"r m\") #'ement-list-members)\n (define-key map (kbd \"r t\") #'ement-room-set-topic)\n (define-key map (kbd \"r f\") #'ement-room-set-message-format)\n (define-key map (kbd \"r n\") #'ement-room-set-notification-state)\n (define-key map (kbd \"r N\") #'ement-room-override-name)\n (define-key map (kbd \"r T\") #'ement-tag-room)\n\n ;; Room membership\n (define-key map (kbd \"R c\") #'ement-create-room)\n (define-key map (kbd \"R j\") #'ement-join-room)\n (define-key map (kbd \"R l\") #'ement-leave-room)\n (define-key map (kbd \"R F\") #'ement-forget-room)\n (define-key map (kbd \"R n\") #'ement-room-set-display-name)\n (define-key map (kbd \"R s\") #'ement-room-toggle-space)\n\n ;; Other\n (define-key map (kbd \"g\") #'ement-room-sync)\n map)\n \"Keymap for Ement room buffers.\")\n\n(defvar ement-room-mode-effective-keymap\n (let ((map (make-sparse-keymap)))\n (set-keymap-parent map ement-room-mode-map)\n map)\n \"The actual keymap used in `ement-room-mode'.\n\nThis keymap reflects the state of `ement-room-self-insert-mode',\nwith a parent of `ement-room-mode-map' when the mode is disabled,\nor `ement-room-mode-self-insert-keymap' when the mode is enabled.\")\n\n(defvar ement-room-mode--advertised-keymap ement-room-mode-map\n \"The keymap advertised by `ement-room-mode'.\n\nThis keymap should represent the functional behaviour of\n`ement-room-mode-effective-keymap' without the confusion arising\nfrom Emacs bug#66792 on account of the effective keymap having\n`ement-room-mode-map' as a parent if `ement-room-self-insert-mode'\nis enabled.\n\nBecause it does not always have `ement-room-mode-map' as a\nparent, it is possible for that map to get out of sync with the\nadvertised map, but `ement-room-mode-self-insert-keymap-update'\nmakes a best effort to keep it accurate.\")\n\n(defvar ement-room-minibuffer-map\n (let ((map (make-sparse-keymap)))\n (set-keymap-parent map minibuffer-local-map)\n (define-key map (kbd \"C-c '\") #'ement-room-compose-from-minibuffer)\n map)\n \"Keymap used in `ement-room-read-string'.\")\n\n(defvar ement-room-reaction-map\n (let ((map (make-sparse-keymap)))\n (define-key map \"c\" #'insert-char)\n (when (commandp 'emoji-insert)\n (define-key map \"i\" 'emoji-insert))\n (when (commandp 'emoji-search)\n (define-key map \"s\" 'emoji-search))\n (when (assoc \"emoji\" input-method-alist)\n (define-key map \"m\" 'ement-room-use-emoji-input-method))\n map)\n \"Keymap used in `ement-room-send-reaction'.\")\n\n(defvar ement-room-sender-in-headers nil\n \"Non-nil when sender is displayed in headers.\nIn that case, sender names are aligned to the margin edge.\")\n\n(defvar ement-room-messages-filter\n '((lazy_load_members . t))\n ;; NOTE: The confusing differences between what /sync and /messages\n ;; expect. See .\n \"Default RoomEventFilter for /messages requests.\")\n\n(defvar ement-room-typing-timer nil\n \"Timer used to send notifications while typing.\")\n\n(defvar ement-room-matrix.to-url-regexp\n (rx \"http\" (optional \"s\") \"://\"\n \"matrix.to\" \"/#/\"\n (group (or \"!\" \"#\") (1+ (not (any \"/\"))))\n (optional \"/\" (group \"$\" (1+ (not (any \"?\" \"/\")))))\n (optional \"?\" (group (1+ anything))))\n \"Regexp matching \\\"matrix.to\\\" URLs.\")\n\n(defvar ement-room-message-history nil\n \"History list of messages entered with `ement-room' commands.\nDoes not include filenames, emotes, etc.\")\n\n(defvar ement-room-emote-history nil\n \"History list of emotes entered with `ement-room' commands.\")\n\n;; Variables from other files.\n(defvar ement-sessions)\n(defvar ement-syncs)\n(defvar ement-auto-sync)\n(defvar ement-users)\n(defvar ement-images-queue)\n(defvar ement-notify-limit-room-name-width)\n(defvar ement-view-room-display-buffer-action)\n\n;; Defined in Emacs 28.1: silence byte-compilation warning in earlier versions.\n(defvar browse-url-handlers)\n\n;;;; Customization\n\n(defgroup ement-room-faces nil\n \"Faces for room buffers.\"\n :group 'ement-room\n :group 'ement-faces)\n\n(defgroup ement-room nil\n \"Options for room buffers.\"\n :group 'ement)\n\n(defcustom ement-room-timestamp-header-align 'right\n \"Where to align timestamp headers.\"\n :type '(choice (const :tag \"Left\" left)\n (const :tag \"Center\" center)\n (const :tag \"Right\" right)))\n\n(defcustom ement-room-view-hook\n '(ement-room-view-hook-room-list-auto-update)\n \"Functions called when `ement-room-view' is called.\nCalled with two arguments, the room and the session.\"\n :type 'hook)\n\n(defcustom ement-room-reaction-names-limit 3\n \"Up to this many users, show a reaction's senders' names.\nIf more than this many users have sent a reaction, show the\nnumber of senders instead (and the names in a tooltip).\"\n :type 'natnum)\n\n(defcustom ement-room-hide-redacted-message-content t\n \"Hide content in redacted messages.\nIf nil, redacted messages' content will remain visible with a\nstrikethrough face until the session is terminated (a new session\nwill not receive the redacted content).\n\nDisabling this option may be useful for room administrators and\nmoderators, so they can see content redacted by other users and\nhandle it appropriately. However, one should use this option\nwith caution, as it will keep unpleasant content visible even\nafter it has been redacted.\n\nAfter changing this option, a room's buffer must be killed and\nreopened for existing messages to be rendered accordingly.\"\n :type '(choice (const :tag \"Hide content\" t)\n (const :tag \"Strikethrough\" nil)))\n\n;;;;; Faces\n\n(defface ement-room-name\n '((t (:inherit font-lock-function-name-face)))\n \"Room name shown in header line.\"\n :group 'ement-room-faces)\n\n(defface ement-room-membership\n '((t (:height 0.8 :inherit font-lock-comment-face)))\n \"Membership events (join/part).\"\n :group 'ement-room-faces)\n\n(defface ement-room-reactions\n '((t (:inherit font-lock-comment-face :height 0.9)))\n \"Reactions to messages (including the user count).\"\n :group 'ement-room-faces)\n\n(defface ement-room-reactions-key\n '((t (:inherit ement-room-reactions :height 1.5)))\n \"Reactions to messages (the key, i.e. the emoji part).\nUses a separate face to allow the key to be shown at a different\nsize, because in some fonts, emojis are too small relative to\nnormal text.\"\n :group 'ement-room-faces)\n\n(defface ement-room-timestamp\n '((t (:inherit font-lock-comment-face)))\n \"Event timestamps.\"\n :group 'ement-room-faces)\n\n(defface ement-room-user\n '((t (:inherit font-lock-function-name-face :weight bold :overline t)))\n \"Usernames.\"\n :group 'ement-room-faces)\n\n(defface ement-room-self\n '((t (:inherit (font-lock-variable-name-face ement-room-user) :weight bold)))\n \"Own username.\"\n :group 'ement-room-faces)\n\n(defface ement-room-message-text\n '((t (:inherit default)))\n \"Text message bodies.\"\n :group 'ement-room-faces)\n\n(defface ement-room-message-emote\n '((t (:inherit italic)))\n \"Emote message bodies.\"\n :group 'ement-room-faces)\n\n(defface ement-room-quote\n '((t (:height 0.9 :inherit font-lock-comment-face)))\n \"Quoted parts of messages.\nAnything wrapped by HTML BLOCKQUOTE tag.\"\n :group 'ement-room-faces)\n\n(defface ement-room-redacted\n '((t (:strike-through t)))\n \"Redacted messages.\"\n :group 'ement-room-faces)\n\n(defface ement-room-self-message\n '((t (:inherit (font-lock-variable-name-face))))\n \"Oneself's message bodies.\nNote that this does not need to inherit\n`ement-room-message-text', because that face is combined with\nthis one automatically.\"\n :group 'ement-room-faces)\n\n(defface ement-room-timestamp-header\n '((t (:inherit header-line :weight bold :height 1.1)))\n \"Timestamp headers.\"\n :group 'ement-room-faces)\n\n(defface ement-room-mention\n ;; TODO(30.1): Remove when not supporting Emacs 27 anymore.\n (if (version< emacs-version \"27.1\")\n '((t (:inherit hl-line)))\n '((t (:inherit hl-line :extend t))))\n \"Messages that mention the local user.\"\n :group 'ement-room-faces)\n\n(defface ement-room-wrap-prefix\n `((t :inherit highlight))\n \"Face applied to `ement-room-wrap-prefix', which see.\"\n :group 'ement-room-faces)\n\n;;;;; Options\n\n(defcustom ement-room-ellipsis \"⋮\"\n \"String used when abbreviating certain strings.\"\n :type 'string)\n\n(defcustom ement-room-avatars (display-images-p)\n \"Show room avatars.\"\n :type 'boolean)\n\n(defcustom ement-room-avatar-max-width 32\n \"Maximum width in pixels of room avatars shown in header lines.\"\n :type 'integer)\n\n(defcustom ement-room-avatar-max-height 32\n \"Maximum height in pixels of room avatars shown in header lines.\"\n :type 'integer)\n\n(defcustom ement-room-coalesce-events 100\n \"Coalesce certain events in room buffers.\nFor example, membership events can be overwhelming in large\nrooms, especially ones bridged to IRC. This option groups them\ntogether so they take less space.\n\nThe current, naïve implementation re-renders events as they are\ncoalesced, which can cause a performance problem in unusual\ncircumstances, so the number of events coalesced into a single,\nrendered event may be limited.\"\n :type '(choice (integer :tag \"Up to this many events\")\n (const :tag \"An unlimited number of events\"\n ;; NOTE: As this docstring says, in most cases it should be fine,\n ;; but since in those rare cases the problem can be unusually bad\n ;; (e.g. taking 15 minutes to render a room's events in\n ;; ), we default\n ;; to a safer choice.\n :doc \"Note that this choice may cause performance problems in rooms with very large numbers of consecutive membership events, but in most cases it should be fine.\"\n t)\n (const :tag \"Don't coalesce\" nil)))\n\n(defcustom ement-room-header-line-format\n ;; TODO: Show in new screenshots.\n '(:eval (concat (if ement-room-avatars\n (or (ement-room-avatar ement-room)\n \"\")\n \"\")\n \" \" (propertize (ement-room--escape-%\n (or (ement-room-display-name ement-room)\n \"[no room name]\"))\n 'face 'ement-room-name)\n \": \" (propertize (ement-room--escape-%\n (or (ement-room-topic ement-room)\n \"[no topic]\"))\n ;; Also set help-echo in case the topic is too wide to fit.\n 'help-echo (ement-room-topic ement-room))))\n \"Header line format for room buffers.\nSee Info node `(elisp)Header lines'.\"\n :type 'sexp)\n(put 'ement-room-header-line-format 'risky-local-variable t)\n\n(defcustom ement-room-buffer-name-prefix \"*Ement Room: \"\n \"Prefix for Ement room buffer names.\"\n :type 'string)\n\n(defcustom ement-room-buffer-name-suffix \"*\"\n \"Suffix for Ement room buffer names.\"\n :type 'string)\n\n(defcustom ement-room-timestamp-format \"%H:%M:%S\"\n \"Format string for event timestamps.\nSee function `format-time-string'.\"\n :type '(choice (const \"%H:%M:%S\")\n (const \"%Y-%m-%d %H:%M:%S\")\n string))\n\n(defcustom ement-room-left-margin-width 0\n \"Width of left margin in room buffers.\nWhen using a non-graphical display, this should be set slightly\nwider than when using a graphical display, to prevent sender\ndisplay names from colliding with event text.\"\n :type 'integer)\n\n(defcustom ement-room-right-margin-width (length ement-room-timestamp-format)\n \"Width of right margin in room buffers.\"\n :type 'integer)\n\n(defcustom ement-room-sender-headers t\n \"Show sender headers.\nAutomatically set by setting `ement-room-message-format-spec',\nbut may be overridden manually.\"\n :type 'boolean)\n\n(defcustom ement-room-unread-only-counts-notifications t\n \"Only use notification counts to mark rooms unread.\nNotification counts are set by the server based on each room's\nnotification settings. Otherwise, whether a room is marked\nunread depends on the room's fully-read marker, read-receipt\nmarker, whether the local user sent the latest events, etc.\"\n :type 'boolean)\n\n(defcustom ement-room-compose-method 'minibuffer\n \"How to compose messages.\n\nThe value `minibuffer' means the minibuffer will be used to write\nand edit messages. You can use \\\n\\\\\\\\[ement-room-compose-from-minibuffer] \\\nto switch from the minibuffer\nto a separate compose buffer, and \\\\[save-buffer] in the compose buffer\nwill then return you to the minibuffer to confirm the message\nbefore sending.\n\nThe value `compose-buffer' means that the minibuffer is not used --\nmessages are written in a compose buffer by default, and \\\\[save-buffer]\nsends the composed message directly.\"\n :type '(choice (const :tag \"Minibuffer\" minibuffer)\n (const :tag \"Compose buffer\" compose-buffer)))\n\n(defcustom ement-room-compose-buffer-display-action\n (cons 'display-buffer-below-selected\n '((window-height . 3)\n (inhibit-same-window . t)\n (reusable-frames . nil)))\n \"`display-buffer' action for displaying compose buffers.\n\nSee also option `ement-room-compose-buffer-window-auto-height'\nand `ement-room-compose-buffer-window-dedicated'.\"\n :type display-buffer--action-custom-type\n :risky t)\n\n(defcustom ement-room-compose-buffer-window-dedicated 'created\n \"Whether windows for compose buffers should be dedicated.\n\nA dedicated compose buffer window will not be used to display any\nother buffer, and will be deleted once the message has been sent\nor aborted (see `ement-room-compose-buffer-quit-restore-window').\n\nThe values t and nil mean \\\"always\\\" and \\\"never\\\" respectively.\n\nThe value `created' means newly-created windows are dedicated.\n\\(The default `ement-room-compose-buffer-display-action' always\ncreates a new window.)\n\nThe value `auto-height' means that windows will be dedicated if\nthe option `ement-room-compose-buffer-window-auto-height' is\nenabled (this option generally keeps the windows too small to\nusefully display other buffers).\n\nThe value `delete' means that windows will not be dedicated, but\nthey will still be deleted once the message is sent or aborted\n\\(even when they have also been used to display other buffers).\n\nSee also `set-window-dedicated-p' and\n`switch-to-buffer-in-dedicated-window'.\"\n :type '(radio (const :tag \"Always\" t)\n (const :tag \"Never\" nil)\n (const :tag \"Never (but always delete window)\" delete)\n (const :tag \"Newly-created windows\" created)\n (const :tag \"When auto-height enabled\" auto-height)))\n\n(defcustom ement-room-compose-buffer-window-auto-height t\n \"Dynamically match the compose buffer window height to its contents.\nSee also `ement-room-compose-buffer-window-auto-height-max' and\n`ement-room-compose-buffer-window-auto-height-min'.\"\n :type 'boolean)\n\n;; Experimental. Disabled by default. Set to 'height to use this.\n(defvar ement-room-compose-buffer-window-auto-height-fixed nil\n \"The buffer-local `window-size-fixed' value in compose buffers.\")\n\n(defvar ement-room-compose-buffer-window-auto-height-pixelwise t\n \"Whether to adjust the window height for pixel-precise lines.\")\n\n;; This is a mutex to ensure that auto-height resizing cannot trigger itself\n;; recursively. This may prevent desirable resizing in certain cases, but we\n;; get the correct result in the majority of situations, and it is simple.\n(defvar ement-room-compose-buffer-window-auto-height-resizing-p)\n\n(defcustom ement-room-compose-buffer-window-auto-height-min nil\n \"If non-nil, limits the body height of the compose buffer window.\n\nSee also option `ement-room-compose-buffer-window-auto-height'\nand `ement-room-compose-buffer-window-auto-height-max'.\"\n :type '(choice (const :tag \"Default\" nil)\n (natnum :tag \"Lines\")))\n\n(defcustom ement-room-compose-buffer-window-auto-height-max nil\n \"If non-nil, limits the body height of the compose buffer window.\n\nSee also option `ement-room-compose-buffer-window-auto-height'\nand `ement-room-compose-buffer-window-auto-height-min'.\"\n :type '(choice (const :tag \"Default\" nil)\n (natnum :tag \"Lines\")))\n\n(defcustom ement-room-mode-self-insert-keymap-update-hook nil\n \"Hook run after rebuilding `ement-room-mode-self-insert-keymap'.\n\nThis happens at the time `ement-room-self-insert-mode' is\nenabled, and also if user options `ement-room-self-insert-chars',\n`ement-room-self-insert-commands', or\n`ement-room-mode-map-prefix-key' are customized while the mode is\nenabled.\n\nYou can use this hook to define any desired custom bindings which\nare not accounted for by those user options.\"\n :type 'hook)\n\n(defvar ement-room-self-insert-mode)\n(defvar ement-room-self-insert-chars)\n(defvar ement-room-self-insert-commands)\n(defun ement-room-mode-self-insert-keymap-update ()\n \"Rebuilds `ement-room-mode-self-insert-keymap'.\nAlso rebuilds `ement-room-mode--advertised-keymap'.\"\n ;; Must be defined ahead of `ement-room-self-insert-option-setter'.\n (let ((map (make-sparse-keymap)))\n ;; Ensure that `ement-room-self-insert-chars' start a message.\n (dolist (range ement-room-self-insert-chars)\n (if (consp range)\n ;; Process a range the same way that `global-map' does.\n (let ((vec1 (make-vector 1 nil))\n (from (car range))\n (to (cdr range)))\n (while (<= from to)\n (aset vec1 0 from)\n (define-key map vec1 #'ement-room-self-insert-new-message)\n (setq from (1+ from))))\n ;; Else `range' is a single character.\n (define-key map (vector range) #'ement-room-self-insert-new-message)))\n ;; Provide access to `ement-room-mode-map' via a prefix binding.\n (when (bound-and-true-p ement-room-mode-map-prefix-key)\n (define-key map ement-room-mode-map-prefix-key ement-room-mode-map))\n ;; This is now the basis for `ement-room-mode-self-insert-keymap' and also\n ;; `ement-room-mode--advertised-keymap' (when `ement-room-self-insert-mode'\n ;; is enabled), but we need to keep the remaining differences between them\n ;; separate. (We do still need some identical `remap' bindings for both\n ;; keymaps, but we can't do that just yet.)\n (setq ement-room-mode-self-insert-keymap (copy-keymap map))\n ;; To `ement-room-mode-self-insert-keymap', add `ement-room-mode-map'\n ;; as the keymap parent. (This is the keymap which is actually used.)\n (set-keymap-parent ement-room-mode-self-insert-keymap ement-room-mode-map)\n (if (not (bound-and-true-p ement-room-self-insert-mode))\n ;; Advertise the real `ement-room-mode-map'.\n (setq ement-room-mode--advertised-keymap ement-room-mode-map)\n ;; Otherwise we base `ement-room-mode--advertised-keymap' on the same base\n ;; map previously copied to `ement-room-mode-self-insert-keymap'.\n (setq ement-room-mode--advertised-keymap map)\n ;; To `ement-room-mode--advertised-keymap' (the keymap displayed when\n ;; `describe-mode' is called), rather than setting a parent we instead\n ;; copy the non-conflicting top-level bindings from `ement-room-mode-map'.\n ;; Not using a keymap parent means the advertised map doesn't see any\n ;; future changes to `ement-room-mode-map', but having a keymap parent\n ;; would make the `describe-mode' output very confusing on account of\n ;; Emacs bug#66792, so we accept potential inaccuracy as a trade-off for\n ;; showing more comprehensible help.\n ;;\n ;; The following will copy the `remap' keymap verbatim, clobbering any\n ;; pre-existing remappings; so we do this before we define other\n ;; remappings.\n (cl-labels ((copy-from (key definition)\n\t\t (unless (lookup-key ement-room-mode--advertised-keymap\n (vector key))\n\t\t (define-key ement-room-mode--advertised-keymap\n (vector key) definition))))\n ;; Copy from a copy of `ement-room-mode-map', otherwise the latter will\n ;; also acquire (share) the remap keybindings which are added below.\n (map-keymap #'copy-from (copy-keymap ement-room-mode-map))))\n ;; Now define our additional `remap' bindings in both keymaps.\n (let ((keymaps (if (bound-and-true-p ement-room-self-insert-mode)\n (list ement-room-mode-self-insert-keymap\n ement-room-mode--advertised-keymap)\n (list ement-room-mode-self-insert-keymap))))\n (dolist (keymap keymaps)\n ;; Make `self-insert-command' (and friends) start a new message.\n (dolist (cmd ement-room-self-insert-commands)\n (define-key keymap (vector 'remap cmd)\n #'ement-room-self-insert-new-message)))))\n (run-hooks 'ement-room-mode-self-insert-keymap-update-hook))\n\n(defun ement-room-mode-effective-keymap-update ()\n \"Sets the parent keymap for `ement-room-mode-effective-keymap'.\n\nEither `ement-room-mode-self-insert-keymap' or `ement-room-mode-map',\ndepending on `ement-room-self-insert-mode'.\"\n ;; Must be defined ahead of `ement-room-self-insert-option-setter'.\n (set-keymap-parent ement-room-mode-effective-keymap\n (if (bound-and-true-p ement-room-self-insert-mode)\n ement-room-mode-self-insert-keymap\n ement-room-mode-map)))\n\n(defun ement-room-self-insert-option-setter (option value)\n \"Setter for options affecting `ement-room-self-insert-mode'.\n\nThis is the setter function for `ement-room-self-insert-chars'\nand `ement-room-self-insert-commands'.\n\nSets the value with (set-default-toplevel-value OPTION VALUE),\nand then rebuilds `ement-room-mode-self-insert-keymap'.\"\n ;; Must be defined ahead of `ement-room-self-insert-chars' and\n ;; `ement-room-self-insert-commands'.\n ;;\n ;; Update the variable.\n (set-default-toplevel-value option value)\n ;; Update keymaps when necessary.\n (when (bound-and-true-p ement-room-self-insert-mode)\n (ement-room-mode-self-insert-keymap-update)\n (ement-room-mode-effective-keymap-update)))\n\n(defcustom ement-room-self-insert-chars\n '((33 . 62) (64 . 126))\n \"Characters handled by `ement-room-self-insert-mode'.\n\nThese are in addition to any `self-insert-command' key bindings\n-- this list is to ensure that certain keys will be treated this\nway even when they have `ement-room-mode-map' bindings.\n\nCons cell elements represent the range from the car to the cdr\n\\(inclusive). The default value covers the common \\\"printable\\\"\nASCII characters excluding SPC (32), ? (63), and DEL (127).\n\nCustomizing this option updates `ement-room-mode-self-insert-keymap'\nvia the setter function `ement-room-self-insert-option-setter'.\nTo do the same in lisp code, set the option with `setopt'.\n\nSee also `ement-room-self-insert-commands'.\"\n :type '(repeat (choice (character :tag \"Character\")\n (cons :tag \"Character range\"\n (character :tag \"From\")\n (character :tag \"To\"))))\n :set #'ement-room-self-insert-option-setter)\n\n(defcustom ement-room-self-insert-commands\n '(self-insert-command yank)\n \"Commands handled by `ement-room-self-insert-mode'.\n\nWhen the mode is enabled, the listed commands are remapped to\n`ement-room-self-insert-new-message' such that when one of those\ncommands is invoked in a room buffer, a new message will be\nstarted and the event which triggered the command (typically a\n`self-insert-command' key binding) will be re-issued in the\nmessage buffer.\n\nCustomizing this option updates `ement-room-mode-self-insert-keymap'\nvia the setter function `ement-room-self-insert-option-setter'.\nTo do the same in lisp code, set the option with `setopt'.\n\nSee also `ement-room-self-insert-chars'.\"\n :type '(repeat (function :tag \"Command\"))\n :set #'ement-room-self-insert-option-setter)\n\n(defcustom ement-room-mode-map-prefix-key (kbd \"DEL\")\n \"A prefix key sequence to access `ement-room-mode-map'.\nActive when `ement-room-self-insert-mode' is enabled.\n\nThe default key is DEL.\n\nCustomizing this option updates `ement-room-mode-self-insert-keymap'\nvia the setter function `ement-room-self-insert-option-setter'.\nTo do the same in lisp code, set the option with `setopt'.\"\n :type 'key-sequence\n :set #'ement-room-self-insert-option-setter)\n\n(defcustom ement-room-reaction-picker (if (commandp 'emoji-search)\n 'emoji-search\n #'insert-char)\n \"Command used to select a reaction by `ement-room-send-reaction'.\nShould be set to a command that somehow prompts the user for an\nemoji and inserts it into the current buffer. In Emacs 29\nreasonable choices include `emoji-insert' which uses a transient\ninterface, and `emoji-search' which uses `completing-read'. If\nthose are not available, one can use `insert-char'.\"\n :type `(choice\n (const :tag \"Complete unicode character name\" insert-char)\n ,@(when (commandp 'emoji-insert)\n '((const :tag \"Categorized emoji menu\" emoji-insert)))\n ,@(when (commandp 'emoji-search)\n '((const :tag \"Complete emoji name\" emoji-search)))\n ,@(when (assoc \"emoji\" input-method-alist)\n '((const :tag \"Emoji input method\"\n ement-room-use-emoji-input-method)))\n (const :tag \"Type an emoji without assistance\" ignore)\n (function :tag \"Use other command\")))\n\n(defvar ement-room-sender-in-left-margin nil\n \"Whether sender is shown in left margin.\nSet by `ement-room-message-format-spec-setter'.\")\n\n(defun ement-room-message-format-spec-setter (option value &optional local)\n \"Set relevant options for `ement-room-message-format-spec', which see.\nTo be used as that option's setter. OPTION and VALUE are\nreceived from setting the customization option. If LOCAL is\nnon-nil, set the variables buffer-locally (i.e. when called from\n`ement-room-set-message-format'.\"\n (cl-macrolet ((set-vars (&rest pairs)\n ;; Set variable-value pairs, locally if LOCAL is non-nil.\n `(progn\n ,@(cl-loop for (symbol value) on pairs by #'cddr\n collect `(if local\n (set (make-local-variable ',symbol) ,value)\n (set ',symbol ,value))))))\n (if local\n (set (make-local-variable option) value)\n (set-default option value))\n (pcase value\n ;; Try to set the margin widths smartly.\n (\"%B%r%R%t\" ;; \"Elemental\"\n (set-vars ement-room-left-margin-width 0\n ement-room-right-margin-width 8\n ement-room-sender-headers t\n ement-room-sender-in-headers t\n ement-room-sender-in-left-margin nil))\n (\"%S%L%B%r%R%t\" ;; \"IRC-style using margins\"\n (set-vars ement-room-left-margin-width 12\n ement-room-right-margin-width 8\n ement-room-sender-headers nil\n ement-room-sender-in-headers nil\n ement-room-sender-in-left-margin t))\n (\"[%t] %S> %B%r\" ;; \"IRC-style without margins\"\n (set-vars ement-room-left-margin-width 0\n ement-room-right-margin-width 0\n ement-room-sender-headers nil\n ement-room-sender-in-headers nil\n ement-room-sender-in-left-margin nil))\n (_ (set-vars ement-room-left-margin-width\n (if (string-match-p \"%L\" value)\n 12 0)\n ement-room-right-margin-width\n (if (string-match-p \"%R\" value)\n 8 0)\n ement-room-sender-in-left-margin\n (if (string-match-p (rx (1+ anything) (or \"%S\" \"%s\") (1+ anything) \"%L\") value)\n t nil)\n ;; NOTE: The following two variables may seem redundant, but one is an\n ;; option that the user may override, while the other is set\n ;; automatically.\n ement-room-sender-headers\n (if (string-match-p (or \"%S\" \"%s\") value)\n ;; If \"%S\" or \"%s\" isn't found, assume it's to be shown in headers.\n nil t)\n ement-room-sender-in-headers\n (if (string-match-p (rx (or \"%S\" \"%s\")) value)\n ;; If \"%S\" or \"%s\" isn't found, assume it's to be shown in headers.\n nil t))\n (message \"Ement: When using custom message format, setting margin widths may be necessary\")))\n (unless ement-room-sender-in-headers\n ;; HACK: Disable overline on sender face.\n (require 'face-remap)\n (if local\n (progn\n (face-remap-reset-base 'ement-room-user)\n (face-remap-add-relative 'ement-room-user '(:overline nil)))\n (set-face-attribute 'ement-room-user nil :overline nil)))\n (unless local\n (when (and (bound-and-true-p ement-sessions) (car ement-sessions))\n ;; Only display when a session is connected (not sure why `bound-and-true-p'\n ;; is required to avoid compilation warnings).\n (message \"Ement: Kill and reopen room buffers to display in new format\")))))\n\n(defcustom ement-room-message-format-spec \"%S%L%B%r%R%t\"\n \"Format messages according to this spec.\nIt may contain these specifiers:\n\n %L End of left margin\n %R Start of right margin\n %W End of wrap-prefix\n\n %b Message body (plain-text)\n %B Message body (formatted if available)\n %i Event ID\n %O Room display name (used for mentions buffer)\n %r Reactions\n %s Sender ID\n %S Sender display name\n %t Event timestamp, formatted according to\n `ement-room-timestamp-format'\n\nNote that margin sizes must be set manually with\n`ement-room-left-margin-width' and\n`ement-room-right-margin-width'.\"\n :type '(choice (const :tag \"IRC-style using margins\" \"%S%L%B%r%R%t\")\n (const :tag \"IRC-style without margins\" \"[%t] %S> %B%r\")\n (const :tag \"IRC-style without margins, with wrap-prefix\" \"[%t] %S> %W%B%r\")\n (const :tag \"IRC-style with right margin, with wrap-prefix\" \"%S> %W%B%r%R%t\")\n (const :tag \"Elemental\" \"%B%r%R%t\")\n (string :tag \"Custom format\"))\n :set #'ement-room-message-format-spec-setter\n :set-after '(ement-room-left-margin-width ement-room-right-margin-width\n ement-room-sender-headers)\n ;; This file must be loaded before calling the setter to define the\n ;; `ement-room-user' face used in it.\n :require 'ement-room)\n\n(defcustom ement-room-retro-messages-number 30\n \"Number of messages to retrieve when loading earlier messages.\"\n :type 'integer)\n\n(defcustom ement-room-timestamp-header-format \" %H:%M \"\n \"Format string for timestamp headers where date is unchanged.\nSee function `format-time-string'. If this string ends in a\nnewline, its background color will extend to the end of the\nline.\"\n :type '(choice (const :tag \"Time-only\" \" %H:%M \")\n (const :tag \"Always show date\" \" %Y-%m-%d %H:%M \")\n string))\n\n(defcustom ement-room-timestamp-header-with-date-format \" %Y-%m-%d (%A)\\n\"\n ;; FIXME: In Emacs 27+, maybe use :extend t instead of adding a newline.\n \"Format string for timestamp headers where date changes.\nSee function `format-time-string'. If this string ends in a\nnewline, its background color will extend to the end of the\nline.\"\n :type '(choice (const \" %Y-%m-%d (%A)\\n\")\n string))\n\n(defcustom ement-room-replace-edited-messages t\n \"Replace edited messages with their new content.\nWhen nil, edited messages are displayed as new messages, leaving\nthe original messages visible.\"\n :type 'boolean)\n\n(define-obsolete-variable-alias 'ement-room-shr-use-fonts\n 'ement-room-use-variable-pitch \"ement-0.14\")\n\n(defcustom ement-room-use-variable-pitch nil\n \"Use proportional fonts for message bodies.\nIf non-nil, plain text message bodies are displayed in a\nvariable-pitch font, and `shr-use-fonts' is enabled for rendering\nHTML-formatted message bodies (which includes most replies).\"\n :type '(choice (const :tag \"Disable variable-pitch fonts\" nil)\n (const :tag \"Enable variable-pitch fonts\" t)))\n\n(defcustom ement-room-username-display-property '(raise -0.25)\n \"Display property applied to username strings.\nSee Info node `(elisp)Other Display Specs'.\"\n :type '(choice (list :tag \"Raise\" (const :tag \"Raise\" raise) (number :tag \"Factor\"))\n (list :tag \"Height\" (const height)\n (choice (list :tag \"Larger\" (const :tag \"Larger\" +) (number :tag \"Steps\"))\n (list :tag \"Smaller\" (const :tag \"Smaller\" -) (number :tag \"Steps\"))\n (number :tag \"Factor\")\n (function :tag \"Function\")\n (sexp :tag \"Form\"))) ))\n\n(defcustom ement-room-event-separator-display-property '(space :ascent 50)\n \"Display property applied to invisible space string after events.\nAllows visual separation between events without, e.g. inserting\nnewlines.\n\nSee Info node `(elisp)Specified Space'.\"\n :type 'sexp)\n\n(defcustom ement-room-timestamp-header-delta 600\n \"Show timestamp header where events are at least this many seconds apart.\"\n :type 'integer)\n\n(defcustom ement-room-send-message-filter nil\n \"Function through which to pass message content before sending.\nUsed to, e.g. send an Org-formatted message by exporting it to\nHTML first.\"\n :type '(choice (const :tag \"Send messages as-is\" nil)\n (const :tag \"Send messages in Org format\" ement-room-send-org-filter)\n (function :tag \"Custom filter function\"))\n :set (lambda (option value)\n (set-default option value)\n (pcase value\n ('ement-room-send-org-filter\n ;; Activate in compose buffer by default.\n (add-hook 'ement-room-compose-hook #'ement-room-compose-org))\n (_ (remove-hook 'ement-room-compose-hook #'ement-room-compose-org)))))\n\n(defcustom ement-room-mark-rooms-read t\n \"Mark rooms as read automatically.\nMoves read and fully-read markers in rooms on the server when\n`ement-room-scroll-up-mark-read' is called at the end of a\nbuffer. When `send', also marks room as read when sending a\nmessage in it. When disabled, rooms may still be marked as read\nmanually by calling `ement-room-mark-read'. Note that this is\nnot strictly the same as read receipts.\"\n :type '(choice (const :tag \"When scrolling past end of buffer\" t)\n (const :tag \"Also when sending\" send)\n (const :tag \"Never\" nil)))\n\n(defcustom ement-room-send-typing t\n \"Send typing notifications to the server while typing a message.\"\n :type 'boolean)\n\n(defcustom ement-room-join-view-buffer t\n \"View room buffer when joining a room.\"\n :type 'boolean)\n\n(defcustom ement-room-leave-kill-buffer t\n \"Kill room buffer when leaving a room.\nWhen disabled, the room's buffer will remain open, but\nMatrix-related commands in it will fail.\"\n :type 'boolean)\n\n(defcustom ement-room-warn-for-already-seen-messages nil\n \"Warn when a sent message has already been seen.\nSuch a case could very rarely indicate a reused transaction ID,\nwhich would prevent further messages from being sent (and would\nbe solved by logging in with a new session, generating a new\ntoken), but most often it happens when the server echoes back a\nsent message before acknowledging the sending of the\nmessage (which is harmless and can be ignored).\"\n :type 'boolean)\n\n(defcustom ement-room-wrap-prefix\n (concat (propertize \" \"\n 'face 'ement-room-wrap-prefix)\n \" \")\n \"String prefixing certain events in room buffers.\nEvents include membership events, image attachments, etc.\nGenerally users should prefer to customize the face\n`ement-room-wrap-prefix' rather than this option, because this\noption's default value has that face applied to it where\nappropriate; if users customize this option, they will need to\napply the face to the string themselves, if desired.\"\n :type 'string)\n\n(defgroup ement-room-prism nil\n \"Colorize usernames and messages in rooms.\"\n :group 'ement-room)\n\n(defcustom ement-room-prism 'name\n \"Display users' names and messages in unique colors.\"\n :type '(choice (const :tag \"Name only\" name)\n (const :tag \"Name and message\" both)\n (const :tag \"Neither\" nil)))\n\n(defcustom ement-room-prism-addressee t\n \"Show addressees' names in their respective colors.\nApplies to room member names at the beginning of messages,\npreceded by a colon or comma.\n\nNote that a limitation applies to the current implementation: if\na message from the addressee is not yet visible in a room at the\ntime the addressed message is formatted, the color may not be\napplied.\"\n ;; FIXME: When we keep a hash table of members in a room, make this\n ;; smarter.\n :type 'boolean)\n\n(defcustom ement-room-prism-color-adjustment 0\n \"Number used to tweak computed username colors.\nThis may be used to adjust your favorite users' colors if you\ndon't like the default ones. (The only way to do it is by\nexperimentation--there is no direct mapping available, nor a\nper-user setting.)\n\nThe number is added to the hashed user ID before converting it to\na color. Note that, since user ID hashes are ratioed against\n`most-positive-fixnum', this number must be very large in order\nto have any effect; it should be at least 1e13.\n\nAfter changing this option, a room's buffer must be killed and\nrecreated to see the effect.\"\n :type 'number\n :set (lambda (option value)\n (unless (or (= 0 value) (>= value 1e13))\n (user-error \"This option must be a very large number, at least 1e13\"))\n (set-default option value)))\n\n(defcustom ement-room-prism-minimum-contrast 6\n \"Attempt to enforce this minimum contrast ratio for user faces.\nThis should be a reasonable number from, e.g. 0-7 or so.\"\n ;; Prot would almost approve of this default. :) I would go all the way\n ;; to 7, but 6 already significantly dilutes the colors in some cases.\n :type 'number)\n\n(defcustom ement-room-prism-message-desaturation 25\n \"Desaturate user colors by this percent for message bodies.\nMakes message bodies a bit less intense.\"\n :type 'integer)\n\n(defcustom ement-room-prism-message-lightening 10\n \"Lighten user colors by this percent for message bodies.\nMakes message bodies a bit less intense.\n\nWhen using a light theme, it may be necessary to use a negative\nnumber (to darken rather than lighten).\"\n :type 'integer)\n\n;;;; Macros\n\n(defmacro ement-room-with-highlighted-event-at (position &rest body)\n \"Highlight event at POSITION while evaluating BODY.\"\n ;; MAYBE: Accept a marker for POSITION.\n (declare (indent 1))\n `(let (ement-room-replying-to-overlay)\n (unwind-protect\n (progn\n (ement-room-highlight-event-at ,position)\n ,@body)\n (ement-room-unhighlight-event))))\n\n(defmacro ement-room-with-typing (&rest body)\n \"Send typing notifications around BODY.\nWhen `ement-room-send-typing' is enabled, typing notifications\nare sent while BODY is executing. BODY is wrapped in an\n`unwind-protect' form that cancels `ement-room-typing-timer' and\nsends a not-typing notification.\"\n (declare (indent defun))\n `(unwind-protect\n (progn\n (when ement-room-send-typing\n (when ement-room-typing-timer\n ;; In case there are any stray ones (e.g. a user typing in\n ;; more than room at once, which is possible but unlikely).\n (cancel-timer ement-room-typing-timer))\n (setf ement-room-typing-timer (run-at-time nil 15 #'ement-room--send-typing ement-session ement-room)))\n ,@body)\n (when ement-room-send-typing\n (when ement-room-typing-timer\n (cancel-timer ement-room-typing-timer)\n (setf ement-room-typing-timer nil))\n ;; Cancel typing notifications after sending a message. (The\n ;; spec doesn't say whether this is needed, but it seems to be.)\n (ement-room--send-typing ement-session ement-room :typing nil))))\n\n(defmacro ement-room-wrap-prefix (string-form &rest properties)\n \"Wrap STRING-FORM with `ement-room-wrap-prefix'.\nConcats `ement-room-wrap-prefix' to STRING-FORM and applies it as\nthe `wrap-prefix' property. Also applies any PROPERTIES.\"\n (declare (indent defun))\n `(concat ement-room-wrap-prefix\n (propertize ,string-form\n 'wrap-prefix ement-room-wrap-prefix\n ,@properties)))\n\n(defsubst ement-room--concat-property (string property value &optional append)\n \"Return STRING having concatted VALUE with PROPERTY on it.\nIf APPEND, append it; otherwise prepend. Assumes PROPERTY is\nconstant throughout STRING.\"\n (declare (indent defun))\n (let* ((old-value (get-text-property 0 property string))\n (new-value (if append\n (concat old-value value)\n (concat value old-value))))\n (propertize string property new-value)))\n\n;;;;; Event highlighting\n\n(defun ement-room-highlight-event-at (position)\n \"Highlight event at POSITION using `ement-room-replying-to-overlay'.\nSee `ement-room-with-highlighted-event-at'.\"\n ;; MAYBE: Accept a marker for POSITION.\n (let* ((node (ewoc-locate ement-ewoc position))\n (event (ewoc-data node)))\n (unless (and (ement-event-p event)\n (ement-event-id event))\n (error \"No event at point\"))\n (setf ement-room-replying-to-overlay\n (make-overlay (ewoc-location node)\n ;; NOTE: It doesn't seem possible to get the end position of\n ;; a node, so if there is no next node, we use point-max.\n ;; But this might break if we were to use an EWOC footer.\n (if (ewoc-next ement-ewoc node)\n (ewoc-location (ewoc-next ement-ewoc node))\n (point-max))))\n (overlay-put ement-room-replying-to-overlay 'face 'highlight)))\n\n(defun ement-room-unhighlight-event ()\n \"Delete overlay in `ement-room-replying-to-overlay'.\nSee `ement-room-with-highlighted-event-at'.\"\n (when (overlayp ement-room-replying-to-overlay)\n (delete-overlay ement-room-replying-to-overlay))\n (setf ement-room-replying-to-overlay nil))\n\n(defun ement-room-compose-highlight (compose-buffer)\n \"Make `ement-room-with-highlighted-event-at' persistent while COMPOSE-BUFFER exists.\"\n (when-let ((overlay ement-room-replying-to-overlay))\n ;; Prevent `ement-room-with-highlighted-event-at' from deleting the overlay:\n (setq ement-room-replying-to-overlay nil)\n ;; Instead, make it exist for the lifetime of the compose buffer:\n (cl-flet ((delete-overlay ()\n (when (overlayp overlay)\n (delete-overlay overlay))))\n (with-current-buffer compose-buffer\n (add-hook 'kill-buffer-hook #'delete-overlay nil :local)))))\n\n;;;;; Event formatting\n\n;; NOTE: When adding specs, also add them to docstring\n;; for `ement-room-message-format-spec'.\n\n(defvar ement-room-event-formatters nil\n \"Alist mapping characters to event-formatting functions.\nEach function is called with three arguments: the event, the\nroom, and the session. See macro\n`ement-room-define-event-formatter'.\")\n\n(defvar ement-room--format-message-margin-p nil\n \"Set by margin-related event formatters.\")\n\n(defvar ement-room--format-message-wrap-prefix nil\n \"Set by margin-related event formatters.\")\n\n(defmacro ement-room-define-event-formatter (char docstring &rest body)\n \"Define an event formatter for CHAR with DOCSTRING and BODY.\nBODY is wrapped in a lambda form that binds `event', `room', and\n`session', and the lambda is added to the variable\n`ement-room-event-formatters', which see.\"\n (declare (indent defun)\n (debug (characterp stringp def-body)))\n `(setf (alist-get ,char ement-room-event-formatters nil nil #'equal)\n (lambda (event room session)\n ,docstring\n ,@body)))\n\n(ement-room-define-event-formatter ?L\n \"Text before this is shown in the left margin.\"\n (ignore event room session)\n (setf ement-room--format-message-margin-p t)\n (propertize \" \" 'left-margin-end t))\n\n(ement-room-define-event-formatter ?R\n \"Text after this is shown in the right margin.\"\n (ignore event room session)\n (setf ement-room--format-message-margin-p t)\n (propertize \" \" 'right-margin-start t))\n\n(ement-room-define-event-formatter ?W\n \"Text before this is the length of the event's wrap-prefix.\nThis emulates the effect of using the left margin (the \\\"%L\\\"\nspec) without requiring all events to use the same margin width.\"\n (ignore event room session)\n (setf ement-room--format-message-wrap-prefix t)\n (propertize \" \" 'wrap-prefix-end t))\n\n;; FIXME(v0.12): The quote-end may be detected in the wrong position when, e.g. a link is\n;; in the middle of the quoted part. We need to search backward from the end to find\n;; where the quote face finally ends.\n\n(ement-room-define-event-formatter ?b\n \"Plain-text body content.\"\n ;; NOTE: `save-match-data' is required around calls to `ement-room--format-message-body'.\n (let* ((body (save-match-data\n (ement-room--format-message-body event session :formatted-p nil)))\n (body-length (length body))\n (face (ement-room--event-body-face event room session))\n (quote-start (ement--text-property-search-forward 'face\n (lambda (value)\n (pcase value\n ('ement-room-quote t)\n ((pred listp) (member 'ement-room-quote value))))\n body))\n (quote-end (when quote-start\n (ement--text-property-search-backward 'face\n (lambda (value)\n (pcase value\n ('ement-room-quote t)\n ((pred listp) (member 'ement-room-quote value))))\n body))))\n (add-face-text-property (or quote-end 0) body-length face 'append body)\n (when ement-room-prism-addressee\n (ement-room--add-member-face body room))\n body))\n\n(ement-room-define-event-formatter ?B\n \"Formatted body content (i.e. rendered HTML).\"\n (let* ((body (save-match-data\n (ement-room--format-message-body event session)))\n (body-length (length body))\n (face (ement-room--event-body-face event room session))\n (quote-start (ement--text-property-search-forward 'face\n (lambda (value)\n (pcase value\n ('ement-room-quote t)\n ((pred listp) (member 'ement-room-quote value))))\n body))\n (quote-end (when quote-start\n (ement--text-property-search-backward 'face\n (lambda (value)\n (pcase value\n ('ement-room-quote t)\n ((pred listp) (member 'ement-room-quote value))))\n body :start (length body)))))\n (add-face-text-property (or quote-end 0) body-length face 'append body)\n (when ement-room-prism-addressee\n (ement-room--add-member-face body room))\n body))\n\n(ement-room-define-event-formatter ?i\n \"Event ID.\"\n ;; Probably only useful for debugging, so might remove later.\n (ignore room session)\n (ement-event-id event))\n\n(ement-room-define-event-formatter ?o\n \"Room avatar.\"\n (ignore event session)\n (or (alist-get 'room-list-avatar (ement-room-local room)) \"\"))\n\n(ement-room-define-event-formatter ?O\n \"Room display name.\"\n (ignore event session)\n (let ((room-name (propertize (or (ement-room-display-name room)\n (ement--room-display-name room))\n 'face 'ement-room-name\n 'help-echo (or (ement-room-canonical-alias room)\n (ement-room-id room)))))\n ;; HACK: This will probably only be used in the notifications buffers, anyway.\n (when ement-notify-limit-room-name-width\n (setf room-name (truncate-string-to-width room-name ement-notify-limit-room-name-width\n nil nil ement-room-ellipsis)))\n room-name))\n\n;; NOTE: In ?s and ?S, we add nearly-invisible ASCII unit-separator characters (\"​\")\n;; to prevent, e.g. `dabbrev-expand' from expanding display names with body text.\n\n(ement-room-define-event-formatter ?s\n \"Sender MXID.\"\n (ignore room session)\n (concat (propertize (ement-user-id (ement-event-sender event))\n 'face 'ement-room-user)\n \"​\"))\n\n(ement-room-define-event-formatter ?S\n \"Sender display name.\"\n (ignore session)\n (pcase-let ((sender (ement--format-user (ement-event-sender event) room))\n ((cl-struct ement-room (local (map buffer))) room))\n ;; NOTE: When called from an `ement-notify' function, ROOM may have no buffer. In\n ;; that case, just use the current buffer (which should be a temp buffer used to\n ;; format the event).\n (with-current-buffer (or buffer (current-buffer))\n (when ement-room-sender-in-left-margin\n ;; Sender in left margin: truncate/pad appropriately.\n (setf sender\n (if (< (string-width sender) ement-room-left-margin-width)\n ;; Using :align-to or :width space display properties doesn't\n ;; seem to have any effect in the margin, so we make a string.\n (concat (make-string (- ement-room-left-margin-width (string-width sender))\n ? )\n sender)\n ;; String wider than margin: truncate it.\n (ement-room--concat-property\n (truncate-string-to-width sender ement-room-left-margin-width nil nil \"…\")\n 'help-echo (concat sender \" \"))))))\n ;; NOTE: I'd like to add a help-echo function to display the sender ID, but the Emacs\n ;; manual says that there is currently no way to make text in the margins mouse-sensitive.\n ;; So `ement--format-user' returns a string propertized with `help-echo' as a string.\n (concat sender \"​\")))\n\n(ement-room-define-event-formatter ?r\n \"Reactions.\"\n (ignore session)\n (ement-room--format-reactions event room))\n\n(ement-room-define-event-formatter ?t\n \"Timestamp.\"\n (ignore room session)\n (propertize (format-time-string ement-room-timestamp-format ;; Timestamps are in milliseconds.\n (/ (ement-event-origin-server-ts event) 1000))\n 'face 'ement-room-timestamp\n 'help-echo (format-time-string \"%Y-%m-%d %H:%M:%S\"\n (/ (ement-event-origin-server-ts event) 1000))))\n\n(defconst ement-room-variable-pitch-face (or (and (facep 'shr-text) 'shr-text)\n 'variable-pitch)\n \"May be used when formatting plain-text messages.\n\nIf user option `ement-room-use-variable-pitch' is non-nil, this\nface is applied to plain-text messages for visual consistency\nwith HTML messages (which will be rendered by shr.el with\n`shr-use-fonts' enabled).\n\nThe `shr-text' face was added in Emacs 29.1. Prior to that,\nshr.el used the `variable-pitch' face directly.\")\n\n(defun ement-room--event-body-face (event room session)\n \"Return face definition for EVENT in ROOM on SESSION.\"\n (ignore room) ;; Unused for now, but keeping for consistency.\n ;; This used to be a macro in --format-message, which is probably better for\n ;; performance, but using a function is clearer, and avoids premature optimization.\n (pcase-let* (((cl-struct ement-event sender\n (content (map msgtype format ('m.new_content new-content)))\n (unsigned (map ('redacted_by unsigned-redacted-by)))\n (local (map ('redacted-by local-redacted-by))))\n event)\n ((cl-struct ement-user (id sender-id)) sender)\n ((cl-struct ement-session user) session)\n ((cl-struct ement-user (id user-id)) user)\n (self-message-p (equal sender-id user-id))\n (type-face (pcase msgtype\n (\"m.emote\" 'ement-room-message-emote)\n (_ 'ement-room-message-text)))\n (context-face (cond (self-message-p\n 'ement-room-self-message)\n ((or (ement-room--event-mentions-user-p event user)\n (ement--event-mentions-room-p event))\n 'ement-room-mention)))\n (prism-color (unless self-message-p\n (when (eq 'both ement-room-prism)\n (or (ement-user-message-color sender)\n (setf (ement-user-message-color sender)\n (let ((message-color (color-desaturate-name (ement--user-color sender)\n ement-room-prism-message-desaturation)))\n (if (ement--color-dark-p (color-name-to-rgb (face-background 'default)))\n (color-lighten-name message-color ement-room-prism-message-lightening)\n (color-darken-name message-color ement-room-prism-message-lightening))))))))\n (redacted-face (when (or local-redacted-by unsigned-redacted-by)\n 'ement-room-redacted))\n ;; For visual consistency, apply the variable-pitch `shr-text' face to\n ;; non-HTML messages when `ement-room-use-variable-pitch' is non-nil.\n ;; (HTML messages are fontified by shr itself.)\n (shr-text-face (when (and ement-room-use-variable-pitch\n (not (equal (or format (alist-get 'format new-content))\n \"org.matrix.custom.html\")))\n ement-room-variable-pitch-face))\n (body-face (list :inherit (delq nil (list redacted-face context-face type-face shr-text-face)))))\n (if prism-color\n (plist-put body-face :foreground prism-color)\n body-face)))\n\n(defun ement-room--add-member-face (string room)\n \"Add member faces in ROOM to STRING.\nIf STRING begins with the name of a member in ROOM followed by a\ncolon or comma (as if STRING is a message addressing that\nmember), apply that member's displayname color face to that part\nof the string.\n\nNote that, if ROOM has no buffer, STRING is returned unchanged.\"\n ;; This only looks for a member name at the beginning of the string. It would be neat to add\n ;; colors to every member mentioned in a message, but that would probably not perform well.\n\n ;; NOTE: This function may be called by `ement-notify' functions even when the room has\n ;; no buffer, and this function is designed to use events in a room buffer to more\n ;; quickly find the data it needs, so, for now, if the room has no buffer, we return\n ;; STRING unchanged.\n (pcase-let (((cl-struct ement-room (local (map buffer))) room))\n (if (buffer-live-p buffer)\n (save-match-data\n ;; This function may be called from a chain of others that use the match data, so\n ;; rather than depending on all of them to save the match data, we do it here.\n ;; FIXME: Member names containing spaces aren't matched. Can this even be fixed reasonably?\n (when (string-match (rx bos (group (1+ (not blank))) (or \":\" \",\") (1+ blank)) string)\n (when-let* ((member-name (match-string 1 string))\n ;; HACK: Since we don't currently keep a list of all\n ;; members in a room, we look to see if this displayname\n ;; has any mentions in the room so far.\n (user (save-match-data\n (with-current-buffer buffer\n (save-excursion\n (goto-char (point-min))\n (cl-labels ((found-sender-p (ewoc-data)\n (when (ement-event-p ewoc-data)\n (equal member-name\n (gethash (ement-event-sender ewoc-data) (ement-room-displaynames room))))))\n (cl-loop with regexp = (regexp-quote member-name)\n while (re-search-forward regexp nil t)\n ;; NOTE: I don't know why, but sometimes the regexp\n ;; search ends on a non-event line, like a timestamp\n ;; header, so for now we just try to handle that case.\n for maybe-event = (ewoc-data (ewoc-locate ement-ewoc))\n when (found-sender-p maybe-event)\n return (ement-event-sender maybe-event)))))))\n (prism-color (or (ement-user-color user)\n (setf (ement-user-color user)\n (ement-room--user-color user)))))\n (add-face-text-property (match-beginning 1) (match-end 1)\n (list :foreground prism-color) nil string))))\n ;; Room has no buffer: return STRING as-is.\n string)))\n\n;;;; Bookmark support\n\n;; Especially useful with Burly: \n\n(require 'bookmark)\n\n(defun ement-room-bookmark-make-record ()\n \"Return a bookmark record for the current `ement-room' buffer.\"\n (pcase-let* (((cl-struct ement-room (id room-id) canonical-alias display-name) ement-room)\n ((cl-struct ement-session user) ement-session)\n ((cl-struct ement-user (id session-id)) user))\n ;; MAYBE: Support bookmarking specific events in a room.\n (list (concat \"Ement room: \" display-name \" (\" canonical-alias \")\")\n (cons 'session-id session-id)\n (cons 'room-id room-id)\n (cons 'handler #'ement-room-bookmark-handler))))\n\n(defun ement-room-bookmark-handler (bookmark)\n \"Show Ement room buffer for BOOKMARK.\"\n (pcase-let* ((`(,_name . ,(map session-id room-id)) bookmark)\n (session (ement-aprog1\n (alist-get session-id ement-sessions nil nil #'equal)\n (unless it\n ;; MAYBE: Automatically connect.\n (user-error \"Session %s not connected: call `ement-connect' first\" session-id))))\n (room (ement-aprog1\n (ement-afirst (equal room-id (ement-room-id it))\n (ement-session-rooms session))\n (cl-assert it nil \"Room %S not found on session %S\" room-id session-id))))\n (ement-view-room room session)\n ;; HACK: Put point at the end of the room buffer. This seems unusually difficult,\n ;; apparently because the bookmark library itself moves point after jumping to a\n ;; bookmark. My attempts at setting the buffer's and window's points after calling\n ;; `ement-view-room' have had no effect. `bookmark-after-jump-hook' sounds ideal, but\n ;; it does not seem to actually get run, so we use a timer that runs immediately after\n ;; `bookmark-jump' returns.\n (run-at-time nil nil (lambda ()\n (goto-char (point-max))))))\n\n;;;; Commands\n\n(defun ement-room-override-name (name room session)\n \"Set display NAME override for ROOM on SESSION.\nInteractively, with prefix, prompt for room and session,\notherwise use current room. If NAME is the empty string, remove\nthe override.\n\nSets account-data event of type\n\\\"org.matrix.msc3015.m.room.name.override\\\". This name is only\nused by clients that respect this proposed override. See\n.\"\n (interactive\n (ement-with-room-and-session\n (let* ((prompt (format \"Set name override (%s): \" (ement--format-room ement-room)))\n (name (read-string prompt nil nil (ement-room-display-name ement-room))))\n (list name ement-room ement-session))))\n (ement-put-account-data session \"org.matrix.msc3015.m.room.name.override\"\n (if (string-empty-p name)\n ;; `json-encode' wants an empty hash table to represent an empty map. And\n ;; apparently there's no way to DELETE account-data events, so we have to re-PUT\n ;; it with empty content.\n (make-hash-table)\n (ement-alist \"name\" name))\n :room room))\n\n(defun ement-room-flush-colors ()\n \"Flush generated username/message colors.\nAlso, redisplay events in all open buffers. The colors will be\nregenerated according to the current background color. Helpful\nwhen switching themes or adjusting `ement-prism' options.\"\n (interactive)\n (cl-loop for user being the hash-values of ement-users\n do (setf (ement-user-color user) nil\n (ement-user-message-color user) nil))\n (dolist (buffer (buffer-list))\n (when (eq 'ement-room-mode (buffer-local-value 'major-mode buffer))\n (with-current-buffer buffer\n (let ((window-start (when (get-buffer-window buffer)\n (window-start (get-buffer-window buffer)))))\n (save-excursion\n (ewoc-refresh ement-ewoc))\n (when window-start\n (setf (window-start (get-buffer-window buffer)) window-start))))))\n ;; Flush notify-background-color colors.\n (cl-loop for (_id . session) in ement-sessions\n do (cl-loop for room in (ement-session-rooms session)\n do (setf (alist-get 'notify-background-color (ement-room-local room)) nil)))\n ;; NOTE: The notifications buffer can't be refreshed because each event is from a\n ;; different room, and the `ement-room' variable is unset in the buffer.\n\n ;; (when-let (buffer (get-buffer \"*Ement Notifications*\"))\n ;; (with-current-buffer buffer\n ;; (ewoc-refresh ement-ewoc)))\n )\n\n(defun ement-room-browse-url (url &rest args)\n \"Browse URL, using Ement for matrix.to URLs when possible.\nOtherwise, fall back to `browse-url'. When called outside of an\n`ement-room' buffer, the variable `ement-session' must be bound\nto the session in which to look for URL's room and event. ARGS\nare passed to `browse-url'.\"\n (interactive)\n (when (string-match ement-room-matrix.to-url-regexp url)\n (let* ((room-id (when (string-prefix-p \"!\" (match-string 1 url))\n (match-string 1 url)))\n (room-alias (when (string-prefix-p \"#\" (match-string 1 url))\n (match-string 1 url)))\n (event-id (match-string 2 url))\n (room (when (or\n ;; Compare with current buffer's room.\n (and room-id (equal room-id (ement-room-id ement-room)))\n (and room-alias (equal room-alias (ement-room-canonical-alias ement-room)))\n ;; Compare with other rooms on session.\n (and room-id (cl-find room-id (ement-session-rooms ement-session)\n :key #'ement-room-id))\n (and room-alias (cl-find room-alias (ement-session-rooms ement-session)\n :key #'ement-room-canonical-alias)))\n ement-room)))\n (if room\n (progn\n ;; Found room in current session: view it and find the event.\n (ement-view-room room ement-session)\n (when event-id\n (ement-room-find-event event-id)))\n ;; Room not joined: offer to join it or load link in browser.\n (pcase-exhaustive\n (cadr (ement--read-multiple-choice\n (format \"Room <%s> not joined on current session. Join it, or load link with browser?\"\n (or room-alias room-id))\n '((?j \"join\" \"Join room in ement.el\")\n (?w \"web browser\" \"Open URL in web browser\"))\n \"\\\nYou are not currently joined to that room. You can either join the room\nin ement.el, or visit the link URL in your web browser.\"))\n (\"join\"\n (ement-join-room (or room-alias room-id) ement-session\n :then (when event-id\n (lambda (room session)\n (ement-view-room room session)\n (ement-room-find-event event-id)))))\n (\"web browser\"\n (let ((handler (cons ement-room-matrix.to-url-regexp #'ement-room-browse-url)))\n ;; Note that `browse-url-handlers' was added in 28.1;\n ;; prior to that `browse-url-browser-function' served double-duty.\n ;; TODO: Remove compat code when requiring Emacs >=28.\n ;; (See also `ement-room-mode'.)\n (cond ((boundp 'browse-url-handlers)\n (let ((browse-url-handlers (remove handler browse-url-handlers)))\n (apply #'browse-url url args)))\n ((consp browse-url-browser-function)\n (let ((browse-url-browser-function (remove handler browse-url-browser-function)))\n (apply #'browse-url url args)))\n (t\n (apply #'browse-url url args))))))))))\n\n(defun ement-room-find-event (event-id)\n \"Go to EVENT-ID in current buffer.\"\n (interactive)\n (cl-labels ((goto-event (event-id)\n (push-mark)\n (goto-char\n (ewoc-location\n (ement-room--ewoc-last-matching ement-ewoc\n (lambda (data)\n (and (ement-event-p data)\n (equal event-id (ement-event-id data)))))))))\n (if (or (cl-find event-id (ement-room-timeline ement-room)\n :key #'ement-event-id :test #'equal)\n (cl-find event-id (ement-room-state ement-room)\n :key #'ement-event-id :test #'equal))\n ;; Found event in timeline: it should be in the EWOC, so go to it.\n (goto-event event-id)\n ;; Event not found in timeline: try to retro-load it.\n (message \"Event %s not seen in current room. Looking in history...\" event-id)\n (let ((room ement-room))\n (ement-room-retro-to ement-room ement-session event-id\n ;; TODO: Add an ELSE argument to `ement-room-retro-to' and use it to give\n ;; a useful error here.\n :then (lambda ()\n (with-current-buffer (alist-get 'buffer (ement-room-local room))\n (goto-event event-id))))))))\n\n(defun ement-room-set-composition-format (&optional localp)\n \"Set message composition format.\nIf LOCALP (interactively, with prefix), set in current room's\nbuffer. Sets `ement-room-send-message-filter'.\"\n (interactive (list current-prefix-arg))\n (let* ((formats (list (cons \"Plain-text\" nil)\n (cons \"Org-mode\" #'ement-room-send-org-filter)))\n (selected-name (completing-read \"Composition format: \" formats nil 'require-match nil nil\n ement-room-send-message-filter))\n (selected-filter (alist-get selected-name formats nil nil #'equal)))\n (if localp\n (setq-local ement-room-send-message-filter selected-filter)\n (setq ement-room-send-message-filter selected-filter))))\n\n(defun ement-room-set-message-format (format-spec)\n \"Set `ement-room-message-format-spec' in current buffer to FORMAT-SPEC.\nInteractively, prompts for the spec using suggested values of the\noption.\"\n (interactive (list (let* ((choices (thread-last\n (get 'ement-room-message-format-spec 'custom-type)\n cdr\n (seq-filter (lambda (it)\n (eq (car it) 'const)))\n (mapcar (lambda (it)\n (cons (nth 2 it) (nth 3 it))))))\n (choice (completing-read \"Format: \" (mapcar #'car choices))))\n (or (alist-get choice choices nil nil #'equal)\n choice))))\n (cl-assert ement-ewoc)\n (ement-room-message-format-spec-setter 'ement-room-message-format-spec format-spec 'local)\n (setf left-margin-width ement-room-left-margin-width\n right-margin-width ement-room-right-margin-width)\n (set-window-margins nil left-margin-width right-margin-width)\n (if ement-room-sender-in-headers\n (ement-room--insert-sender-headers ement-ewoc)\n (ewoc-filter ement-ewoc (lambda (node-data)\n ;; Return non-nil for nodes that should stay.\n (not (ement-user-p node-data)))))\n (ewoc-refresh ement-ewoc))\n\n(defun ement-room-set-topic (session room topic)\n \"Set ROOM's TOPIC on SESSION.\nInteractively, with prefix, prompt for room and session,\notherwise use current room.\"\n (interactive\n (ement-with-room-and-session\n (list ement-session ement-room\n (read-string (format \"New topic (%s): \"\n (ement-room-display-name ement-room))\n (ement-room-topic ement-room) nil nil 'inherit-input-method))))\n (pcase-let* (((cl-struct ement-room (id room-id) display-name) room)\n (endpoint (format \"rooms/%s/state/m.room.topic\" (url-hexify-string room-id)))\n (data (ement-alist \"topic\" topic)))\n (ement-api session endpoint :method 'put :data (json-encode data)\n :then (lambda (_data)\n (message \"Topic set (%s): %s\" display-name topic)))))\n\n(cl-defun ement-room-send-file (file body room session &key (msgtype \"m.file\"))\n \"Send FILE to ROOM on SESSION, using message BODY and MSGTYPE.\nInteractively, with prefix, prompt for room and session,\notherwise use current room.\"\n ;; TODO: Support URLs to remote files.\n (interactive\n (ement-with-room-and-session\n (ement-room-with-typing\n (let* ((file (read-file-name (format \"Send file (%s): \" (ement-room-display-name ement-room))\n nil nil 'confirm))\n (body (ement-room-read-string\n (format \"Message body (%s): \" (ement-room-display-name ement-room))\n (file-name-nondirectory file) 'file-name-history nil 'inherit-input-method)))\n (list file body ement-room ement-session)))))\n ;; NOTE: The typing notification won't be quite right, because it'll be canceled while waiting\n ;; for the file to upload. It would be awkward to handle that, so this will do for now.\n (when (yes-or-no-p (format \"Upload file %S to room %S? \"\n file (ement-room-display-name room)))\n (pcase-let* ((filename (file-name-nondirectory file))\n (extension (or (file-name-extension file) \"\"))\n (mime-type (mailcap-extension-to-mime extension))\n (data `(file ,file))\n (size (file-attribute-size (file-attributes file))))\n (ement-upload session :data data :filename filename :content-type mime-type\n :then (lambda (data)\n (message \"Uploaded file %S. Sending message...\" file)\n (pcase-let* (((map ('content_uri content-uri)) data)\n ((cl-struct ement-room (id room-id)) room)\n (endpoint (format \"rooms/%s/send/%s/%s\" (url-hexify-string room-id)\n \"m.room.message\" (ement--update-transaction-id session)))\n ;; TODO: Image height/width (maybe not easy to get in Emacs).\n (content (ement-alist \"msgtype\" msgtype\n \"url\" content-uri\n \"body\" body\n \"filename\" filename\n \"info\" (ement-alist \"mimetype\" mime-type\n \"size\" size))))\n (ement-api session endpoint :method 'put :data (json-encode content)\n :then (apply-partially #'ement-room-send-event-callback\n :room room :session session :content content :data))))))))\n\n(defun ement-room-send-image (file body room session)\n \"Send image FILE to ROOM on SESSION, using message BODY.\nInteractively, with prefix, prompt for room and session,\notherwise use current room.\"\n ;; TODO: Support URLs to remote files.\n (interactive\n (ement-with-room-and-session\n (ement-room-with-typing\n (let* ((file (read-file-name (format \"Send image file (%s): \" (ement-room-display-name ement-room))\n nil nil 'confirm))\n (body (ement-room-read-string\n (format \"Message body (%s): \" (ement-room-display-name ement-room))\n (file-name-nondirectory file) 'file-name-history nil 'inherit-input-method)))\n (list file body ement-room ement-session)))))\n (ement-room-send-file file body room session :msgtype \"m.image\"))\n\n(defun ement-room-dnd-upload-file (uri _action)\n \"Upload the file as specified by URI to the current room.\"\n (when-let ((file (dnd-get-local-file-name uri t)))\n (ement-room-send-file file (file-name-nondirectory file) ement-room ement-session\n :msgtype (if (string-prefix-p \"image/\" (mailcap-file-name-to-mime-type file))\n \"m.image\"\n \"m.file\"))))\n\n(cl-defun ement-room-join (id-or-alias session &key then)\n \"Join room by ID-OR-ALIAS on SESSION.\nTHEN may be a function to call after joining the room (and when\n`ement-room-join-view-buffer' is non-nil, after viewing the room\nbuffer). It receives two arguments, the room and the session.\"\n (interactive (list (read-string \"Join room (ID or alias): \")\n (or ement-session\n (ement-complete-session))))\n (cl-assert id-or-alias) (cl-assert session)\n (unless (string-match-p\n ;; According to tulir in #matrix-dev:matrix.org, \": is not\n ;; allowed in the localpart, all other valid unicode is\n ;; allowed. (user ids and room ids are the same over\n ;; federation). it's mostly a lack of validation in\n ;; synapse (arbitrary unicode isn't intentionally allowed,\n ;; but it's not disallowed either)\". See\n ;; .\n (rx bos (or \"#\" \"!\") (1+ (not (any \":\")))\n \":\" (1+ (or alnum (any \"-.\"))))\n id-or-alias)\n (user-error \"Invalid room ID or alias (use, e.g. \\\"#ROOM-ALIAS:SERVER\\\")\"))\n (let ((endpoint (format \"join/%s\" (url-hexify-string id-or-alias))))\n (ement-api session endpoint :method 'post :data \"\"\n :then (lambda (data)\n ;; NOTE: This generates a symbol and sets its function value to a lambda\n ;; which removes the symbol from the hook, removing itself from the hook.\n ;; TODO: When requiring Emacs 27, use `letrec'.\n (pcase-let* (((map ('room_id room-id)) data)\n (then-fns (delq nil\n (list (when ement-room-join-view-buffer\n (lambda (room session)\n (ement-view-room room session)))\n then)))\n (then-fn-symbol (gensym (format \"ement-join-%s\" id-or-alias)))\n (then-fn (lambda (session)\n (when-let ((room (cl-loop for room in (ement-session-rooms session)\n when (equal room-id (ement-room-id room))\n return room)))\n ;; In case the join event is not in this next sync\n ;; response, make sure the room is found before removing\n ;; the function and joining the room.\n (remove-hook 'ement-sync-callback-hook then-fn-symbol)\n ;; FIXME: Probably need to unintern the symbol.\n (dolist (fn then-fns)\n (funcall fn room session))))))\n (setf (symbol-function then-fn-symbol) then-fn)\n (add-hook 'ement-sync-callback-hook then-fn-symbol)\n (message \"Joined room: %s\" room-id)))\n :else (lambda (plz-error)\n (pcase-let* (((cl-struct plz-error response) plz-error)\n ((cl-struct plz-response status body) response)\n ((map error) (json-read-from-string body)))\n (pcase status\n ((or 403 429) (error \"Unable to join room %s: %s\" id-or-alias error))\n (_ (error \"Unable to join room %s: %s %S\" id-or-alias status plz-error))))))))\n(defalias 'ement-join-room #'ement-room-join)\n\n(defun ement-room-goto-prev ()\n \"Go to the previous message in buffer.\"\n (interactive)\n (if (>= (point) (- (point-max) 2))\n ;; Point is actually on the last event, but it doesn't appear to be: move point to\n ;; the beginning of that event.\n (ewoc-goto-node ement-ewoc (ement-room--ewoc-last-matching ement-ewoc #'ement-event-p))\n ;; Go to previous event.\n (ement-room-goto-next :next-fn #'ewoc-prev)))\n\n(cl-defun ement-room-goto-next (&key (next-fn #'ewoc-next))\n \"Go to the next message in buffer.\nNEXT-FN is passed to `ement-room--ewoc-next-matching', which\nsee.\"\n (interactive)\n (if-let (node (ement-room--ewoc-next-matching ement-ewoc\n (ewoc-locate ement-ewoc) #'ement-event-p next-fn))\n (ewoc-goto-node ement-ewoc node)\n (if (= (point) (point-max))\n ;; Already at end of buffer: signal error.\n (user-error \"End of events\")\n ;; Go to end-of-buffer so new messages will auto-scroll.\n (goto-char (point-max)))))\n\n(defun ement-room-scroll-down-command ()\n \"Scroll down, and load NUMBER earlier messages when at top.\"\n (interactive)\n (condition-case _err\n (scroll-down nil)\n (beginning-of-buffer\n (call-interactively #'ement-room-retro))))\n\n(defun ement-room-mwheel-scroll (event)\n \"Scroll according to EVENT, loading earlier messages when at top.\"\n (interactive \"e\")\n (with-selected-window (posn-window (event-start event))\n (mwheel-scroll event)\n (when (= (point-min) (window-start))\n (call-interactively #'ement-room-retro))))\n\n;; TODO: Unify these retro-loading functions.\n\n(cl-defun ement-room-retro\n (room session number &key buffer\n (then (apply-partially #'ement-room-retro-callback room session)))\n ;; FIXME: Naming things is hard.\n \"Retrieve NUMBER older messages in ROOM on SESSION.\"\n (interactive (list ement-room ement-session\n (cl-typecase current-prefix-arg\n (null ement-room-retro-messages-number)\n (list (read-number \"Number of messages: \"))\n (number current-prefix-arg))\n :buffer (current-buffer)))\n (unless ement-room-retro-loading\n (pcase-let* (((cl-struct ement-room id prev-batch) room)\n (endpoint (format \"rooms/%s/messages\" (url-hexify-string id))))\n ;; We use a timeout of 30, because sometimes the server can take a while to\n ;; respond, especially if loading, e.g. hundreds or thousands of events.\n (ement-api session endpoint :timeout 30\n :params (remq nil\n (list (when prev-batch\n (list \"from\" prev-batch))\n (list \"dir\" \"b\")\n (list \"limit\" (number-to-string number))\n (list \"filter\" (json-encode ement-room-messages-filter))))\n :then then\n :else (lambda (plz-error)\n (when buffer\n (with-current-buffer buffer\n (setf ement-room-retro-loading nil)))\n (signal 'ement-api-error (list (format \"Loading %s earlier messages failed\" number)\n plz-error))))\n (message \"Loading %s earlier messages...\" number)\n (setf ement-room-retro-loading t))))\n\n(cl-defun ement-room-retro-to (room session event-id &key then (batch-size 100) (limit 1000))\n \"Retrieve messages in ROOM on SESSION back to EVENT-ID.\nWhen event is found, call function THEN. Search in batches of\nBATCH-SIZE events up to a total of LIMIT.\"\n (declare (indent defun))\n (cl-assert\n ;; Ensure the event hasn't already been retrieved.\n (not (gethash event-id (ement-session-events session))))\n (let* ((total-retrieved 0)\n ;; TODO: Use letrec someday.\n (callback-symbol (gensym \"ement-room-retro-to-callback-\"))\n (callback (lambda (data)\n (ement-room-retro-callback room session data)\n (if (gethash event-id (ement-session-events session))\n (progn\n (message \"Found event %S\" event-id)\n ;; FIXME: Probably need to unintern the symbol.\n (when then\n (funcall then)))\n ;; FIXME: What if it hits the beginning of the timeline?\n (if (>= (cl-incf total-retrieved batch-size) limit)\n (message \"%s older events retrieved without finding event %S\"\n limit event-id)\n (message \"Looking back for event %S (%s/%s events retrieved)\"\n event-id total-retrieved limit)\n (ement-room-retro room session batch-size\n :buffer (alist-get 'buffer (ement-room-local room))\n :then callback-symbol))))))\n (fset callback-symbol callback)\n (ement-room-retro room session batch-size\n :buffer (alist-get 'buffer (ement-room-local room))\n :then callback-symbol)))\n\n(cl-defun ement-room-retro-to-token (room session from to\n &key (batch-size 100) (limit 1000))\n \"Retrieve messages in ROOM on SESSION back from FROM to TO.\nRetrieve batches of BATCH-SIZE up to total LIMIT. FROM and TO\nare sync batch tokens. Used for, e.g. filling gaps in\n\\\"limited\\\" sync responses.\"\n ;; NOTE: We don't set `ement-room-retro-loading' since the room may\n ;; not have a buffer. This could theoretically allow a user to\n ;; overlap manual scrollback-induced loading of old messages with\n ;; this gap-filling loading, but that shouldn't matter, and probably\n ;; would be very rare, anyway.\n (pcase-let* (((cl-struct ement-room id) room)\n (endpoint (format \"rooms/%s/messages\" (url-hexify-string id)))\n (then\n (lambda (data)\n (ement-room-retro-callback room session data\n :set-prev-batch nil)\n (pcase-let* (((map end chunk) data))\n\t\t ;; HACK: Comparing the END and TO tokens ought to\n\t\t ;; work for determining whether we are done\n\t\t ;; filling, but it isn't (maybe the server isn't\n\t\t ;; returning the TO token as END when there are no\n\t\t ;; more events), so instead we'll check the length\n\t\t ;; of the chunk.\n (unless (< (length chunk) batch-size)\n ;; More pages remain to be loaded.\n (let ((remaining-limit (- limit batch-size)))\n (if (not (> remaining-limit 0))\n ;; FIXME: This leaves a gap if it's larger than 1,000 events.\n ;; Probably, the limit should be configurable, but it would be good\n ;; to find some way to remember the gap and fill it if the user\n ;; scrolls to it later (although that might be very awkward to do).\n (display-warning 'ement-room-retro-to-token\n (format \"Loaded events in %S (%S) without filling gap; not filling further\"\n (ement-room-display-name room)\n (or (ement-room-canonical-alias room)\n (ement-room-id room))))\n\t\t\t ;; FIXME: Remove this message after further testing.\n (message \"Ement: Continuing to fill gap in %S (%S) (remaining limit: %s)\"\n (ement-room-display-name room)\n (or (ement-room-canonical-alias room)\n (ement-room-id room))\n remaining-limit)\n (ement-room-retro-to-token\n room session end to :limit remaining-limit))))))))\n ;; FIXME: Remove this message after further testing.\n (message \"Ement: Filling gap in %S (%S)\"\n\t (ement-room-display-name room)\n (or (ement-room-canonical-alias room)\n (ement-room-id room)))\n (ement-api session endpoint :timeout 30\n :params (list (list \"from\" from)\n (list \"to\" to)\n (list \"dir\" \"b\")\n (list \"limit\" (number-to-string batch-size))\n (list \"filter\" (json-encode ement-room-messages-filter)))\n :then then\n :else (lambda (plz-error)\n (signal 'ement-api-error\n (list (format \"Filling gap in %S (%S) failed\"\n (ement-room-display-name room)\n (or (ement-room-canonical-alias room)\n (ement-room-id room)))\n plz-error))))))\n\n;; NOTE: `declare-function' doesn't recognize cl-defun forms, so this declaration doesn't work.\n(declare-function ement--sync \"ement.el\" t t)\n(defun ement-room-sync (session &optional force)\n \"Sync SESSION (interactively, current buffer's).\nIf FORCE (interactively, with prefix), cancel any outstanding\nsync requests. Also, update any room list buffers.\"\n (interactive (list ement-session current-prefix-arg))\n (ement--sync session :force force)\n (cl-loop for buffer in (buffer-list)\n when (member (buffer-local-value 'major-mode buffer)\n '(ement-room-list-mode ement-tabulated-room-list-mode))\n do (with-current-buffer buffer\n (revert-buffer))))\n\n(defun ement-room-view-event (event)\n \"Pop up buffer showing details of EVENT (interactively, the one at point).\nEVENT should be an `ement-event' or `ement-room-membership-events' struct.\"\n (interactive (list (ewoc-data (ewoc-locate ement-ewoc))))\n (require 'pp)\n (cl-labels ((event-alist (event)\n (ement-alist :id (ement-event-id event)\n :sender (ement-user-id (ement-event-sender event))\n :content (ement-event-content event)\n :origin-server-ts (ement-event-origin-server-ts event)\n :type (ement-event-type event)\n :state-key (ement-event-state-key event)\n :unsigned (ement-event-unsigned event)\n :receipts (ement-event-receipts event)\n :local (ement-event-local event))))\n (let* ((buffer-name (format \"*Ement event: %s*\"\n (cl-typecase event\n (ement-room-membership-events \"[multiple events]\")\n (ement-event (ement-event-id event)))))\n (event (cl-typecase event\n (ement-room-membership-events\n (mapcar #'event-alist (ement-room-membership-events-events event)))\n (ement-event (event-alist event))))\n (inhibit-read-only t))\n (with-current-buffer (get-buffer-create buffer-name)\n (erase-buffer)\n (pp event (current-buffer))\n (view-mode)\n (pop-to-buffer (current-buffer))))))\n\n(defun ement-room-dispatch-new-message ()\n \"Write a new message in accordance with `ement-room-compose-method'.\"\n (interactive)\n (call-interactively\n (cl-case ement-room-compose-method\n (compose-buffer 'ement-room-compose-message)\n (t 'ement-room-send-message))))\n\n(defun ement-room-dispatch-new-message-alt ()\n \"Inverse of `ement-room-dispatch-new-message'.\"\n (interactive)\n (call-interactively\n (cl-case ement-room-compose-method\n (compose-buffer 'ement-room-send-message)\n (t 'ement-room-compose-message))))\n\n(defun ement-room-dispatch-edit-message ()\n \"Edit a message in accordance with `ement-room-compose-method'.\"\n (interactive)\n (call-interactively\n (cl-case ement-room-compose-method\n (compose-buffer 'ement-room-compose-edit)\n (t 'ement-room-edit-message))))\n\n(defun ement-room-dispatch-reply-to-message ()\n \"Reply to a message in accordance with `ement-room-compose-method'.\"\n (interactive)\n (call-interactively\n (cl-case ement-room-compose-method\n (compose-buffer 'ement-room-compose-reply)\n (t 'ement-room-write-reply))))\n\n(defun ement-room-dispatch-send-message ()\n \"Send a message in accordance with `ement-room-compose-method'.\"\n (interactive)\n (call-interactively\n (cl-case ement-room-compose-method\n (compose-buffer #'ement-room-compose-send-direct)\n (t #'ement-room-compose-send))))\n\n(cl-defun ement-room-send-message (room session &key body formatted-body replying-to-event)\n \"Send message to ROOM on SESSION with BODY and FORMATTED-BODY.\nInteractively, with prefix, prompt for room and session,\notherwise use current room.\n\nREPLYING-TO-EVENT may be an event the message is in reply to; the\nmessage will reference it appropriately.\n\nIf `ement-room-send-message-filter' is non-nil, the message's\ncontent alist is passed through it before sending. This may be\nused to, e.g. process the BODY into another format and add it to\nthe content (e.g. see `ement-room-send-org-filter').\"\n (interactive\n (ement-with-room-and-session\n (let* ((prompt (format \"Send message (%s): \" (ement-room-display-name ement-room)))\n (body (ement-room-with-typing\n (ement-room-read-string prompt nil 'ement-room-message-history\n nil 'inherit-input-method))))\n (list ement-room ement-session :body body))))\n (ement-send-message room session :body body :formatted-body formatted-body\n :replying-to-event replying-to-event :filter ement-room-send-message-filter\n :then #'ement-room-send-event-callback)\n ;; NOTE: This assumes that the selected window is the buffer's window. For now\n ;; this is almost surely the case, but in the future, we might let the function\n ;; send messages to other rooms more easily, so this assumption might not hold.\n (when-let* ((buffer (alist-get 'buffer (ement-room-local room)))\n (window (get-buffer-window buffer)))\n (with-selected-window window\n (when (>= (window-point) (ewoc-location (ewoc-nth ement-ewoc -1)))\n ;; Point is on last event: advance it to eob so that when the event is received\n ;; back, the window will scroll. (This might not always be desirable, because\n ;; the user might have point on that event for a reason, but I think in most\n ;; cases, it will be what's expected and most helpful.)\n (setf (window-point) (point-max))))))\n\n(cl-defun ement-room-send-emote (room session &key body)\n \"Send emote to ROOM on SESSION with BODY.\nInteractively, with prefix, prompt for room and session,\notherwise use current room.\n\nIf `ement-room-send-message-filter' is non-nil, the message's\ncontent alist is passed through it before sending. This may be\nused to, e.g. process the BODY into another format and add it to\nthe content (e.g. see `ement-room-send-org-filter').\"\n (interactive\n (ement-with-room-and-session\n (let* ((prompt (format \"Send emote (%s): \" (ement-room-display-name ement-room)))\n (body (ement-room-with-typing\n (ement-room-read-string prompt nil 'ement-room-emote-history\n nil 'inherit-input-method))))\n (list ement-room ement-session :body body))))\n (cl-assert (not (string-empty-p body)))\n (pcase-let* (((cl-struct ement-room (id room-id) (local (map buffer))) room)\n (window (when buffer (get-buffer-window buffer)))\n (endpoint (format \"rooms/%s/send/m.room.message/%s\" (url-hexify-string room-id)\n (ement--update-transaction-id session)))\n (content (ement-aprog1\n (ement-alist \"msgtype\" \"m.emote\"\n \"body\" body))))\n (when ement-room-send-message-filter\n (setf content (funcall ement-room-send-message-filter content room)))\n (ement-api session endpoint :method 'put :data (json-encode content)\n :then (apply-partially #'ement-room-send-event-callback :room room :session session\n :content content :data)) ;; Data is added when calling back.\n ;; NOTE: This assumes that the selected window is the buffer's window. For now\n ;; this is almost surely the case, but in the future, we might let the function\n ;; send messages to other rooms more easily, so this assumption might not hold.\n (when window\n (with-selected-window window\n (when (>= (window-point) (ewoc-location (ewoc-nth ement-ewoc -1)))\n ;; Point is on last event: advance it to eob so that when the event is received\n ;; back, the window will scroll. (This might not always be desirable, because\n ;; the user might have point on that event for a reason, but I think in most\n ;; cases, it will be what's expected and most helpful.)\n (setf (window-point) (point-max)))))))\n\n(cl-defun ement-room-send-event-callback (&key data room session content)\n \"Callback for event-sending functions.\nDATA is the parsed JSON object. If DATA's event ID is already\npresent in SESSION's events table, show an appropriate warning\nmentioning the ROOM and CONTENT.\"\n (pcase-let* (((map ('event_id event-id)) data))\n (when (and ement-room-warn-for-already-seen-messages\n (gethash event-id (ement-session-events session)))\n (let ((message (format \"Event ID %S already seen in session %S. This may indicate a reused transaction ID, which could mean that the event was not sent to the room (%S). You may need to disconnect, delete the `ement-sessions-file', and connect again to start a new session. Alternatively, this can happen if the event's sent-confirmation is received after the event itself is received in the next sync response, in which case no action is needed.\"\n event-id (ement-user-id (ement-session-user session))\n (ement-room-display-name room))))\n (when content\n (setf message (concat message (format \" Event content: %S\" content))))\n (display-warning 'ement-room-send-event-callback message)))\n (when (eq 'send ement-room-mark-rooms-read)\n ;; Move read markers.\n (when-let ((buffer (alist-get 'buffer (ement-room-local room))))\n (with-current-buffer buffer\n ;; NOTE: The new event may not exist in the buffer yet, so\n ;; we just have to use the last one.\n ;; FIXME: When we add local echo, this can be fixed.\n (save-excursion\n (goto-char (ewoc-location\n (ement-room--ewoc-last-matching ement-ewoc #'ement-event-p)))\n (call-interactively #'ement-room-mark-read)))))))\n\n(defun ement-room-edit-message-prepare ()\n \"Bindings for `ement-room-edit-message' and `ement-room-compose-edit'.\"\n (cl-assert ement-ewoc) (cl-assert ement-session)\n ;; Bindings for... `event' (from ewoc).\n (pcase-let* ((event (ewoc-data (ewoc-locate ement-ewoc)))\n ;; `user' (from ement-session).\n ((cl-struct ement-session user) ement-session)\n ;; `sender', `body' (from event).\n ((cl-struct ement-event sender (content (map body))) event))\n (unless (equal (ement-user-id sender) (ement-user-id user))\n (user-error \"You may only edit your own messages\"))\n ;; Remove any leading asterisk from the plain-text body.\n (setf body (replace-regexp-in-string (rx bos \"*\" (1+ space)) \"\" body t t))\n (list event body)))\n\n(defun ement-room-edit-message (event room session body)\n \"Edit EVENT in ROOM on SESSION to have new BODY.\nThe message must be one sent by the local user. If EVENT is\nitself an edit of another event, the original event is edited.\"\n ;; See also `ement-room-compose-edit'.\n (interactive (ement-room-with-highlighted-event-at (point)\n (cl-destructuring-bind (ement-room-editing-event body)\n (ement-room-edit-message-prepare)\n (ement-room-with-typing\n (let* ((prompt (format \"Edit message (%s): \"\n (ement-room-display-name ement-room)))\n (body (ement-room-read-string prompt body 'ement-room-message-history\n nil 'inherit-input-method)))\n (when (string-empty-p body)\n (user-error \"To delete a message, use command `ement-room-delete-message'\"))\n (when (yes-or-no-p (format \"Edit message to: %S? \" body))\n (list ement-room-editing-event ement-room ement-session body)))))))\n (let* ((endpoint (format \"rooms/%s/send/%s/%s\" (url-hexify-string (ement-room-id room))\n \"m.room.message\" (ement--update-transaction-id session)))\n (new-content (ement-alist \"body\" body\n \"msgtype\" \"m.text\"))\n (_ (when ement-room-send-message-filter\n (setf new-content (funcall ement-room-send-message-filter new-content room))))\n (original-event (ement--original-event-for event session))\n (content (ement-alist \"msgtype\" \"m.text\"\n \"body\" body\n \"m.new_content\" new-content\n \"m.relates_to\" (ement-alist\n \"rel_type\" \"m.replace\"\n \"event_id\" (ement-event-id original-event)))))\n ;; Prepend the asterisk after the filter may have modified the content. Note that the\n ;; \"m.new_content\" body does not get the leading asterisk, only the \"content\" body,\n ;; which is intended as a fallback.\n (setf body (concat \"* \" body))\n (ement-api session endpoint :method 'put :data (json-encode content)\n :then (apply-partially #'ement-room-send-event-callback :room room :session session\n :content content :data))))\n\n(defun ement-room-delete-message (event room session &optional reason)\n \"Delete EVENT in ROOM on SESSION, optionally with REASON.\"\n (interactive (ement-room-with-highlighted-event-at (point)\n (if (yes-or-no-p \"Delete this event? \")\n (list (ewoc-data (ewoc-locate ement-ewoc))\n ement-room ement-session (read-string \"Reason (optional): \" nil nil nil 'inherit-input-method))\n ;; HACK: This isn't really an error, but is there a cleaner way to cancel?\n (user-error \"Message not deleted\"))))\n (ement-redact (ement--original-event-for event session) room session reason))\n\n(defun ement-room-write-reply (event)\n \"Write and send a reply to EVENT.\nInteractively, to event at point.\"\n ;; See also `ement-room-compose-reply'.\n (interactive (progn (cl-assert ement-ewoc)\n (list (ewoc-data (ewoc-locate ement-ewoc)))))\n (cl-assert ement-room) (cl-assert ement-session) (cl-assert (ement-event-p event))\n (let ((ement-room-replying-to-event event))\n (ement-room-with-highlighted-event-at (point)\n (pcase-let* ((room ement-room)\n (session ement-session)\n (prompt (format \"Send reply (%s): \" (ement-room-display-name room)))\n (ement-room-read-string-setup-hook\n (lambda ()\n (setq-local ement-room-replying-to-event event)))\n (body (ement-room-with-typing\n (ement-room-read-string prompt nil 'ement-room-message-history\n nil 'inherit-input-method))))\n ;; NOTE: `ement-room-send-message' looks up the original event, so we pass `event'\n ;; as :replying-to-event.\n (ement-room-send-message room session :body body :replying-to-event event)))))\n\n(when (assoc \"emoji\" input-method-alist)\n (defun ement-room-use-emoji-input-method ()\n \"Activate the emoji input method in the current buffer.\"\n (interactive)\n (set-input-method \"emoji\")))\n\n(defun ement-room-send-reaction (key position &optional event)\n \"Send reaction of KEY to event at POSITION.\nKEY should be a reaction string, e.g. \\\"👍\\\".\n\nInteractively, send reaction to event at point. The user option\n`ement-room-reaction-picker' controls how the reaction string\nis selected, or rather controls the initial mechanism, since the\nuser can always cancel that command with \\\\[keyboard-quit] and\nchoose a different one using the key bindings in\n`ement-room-reaction-map' (note that other than `insert-char',\nthese all require at least version 29 of Emacs):\n\n\\\\{ement-room-reaction-map}\"\n (interactive\n (let ((event (ewoc-data (ewoc-locate ement-ewoc))))\n (unless (ement-event-p event)\n (user-error \"No event at point\"))\n (list (minibuffer-with-setup-hook\n (lambda ()\n (setq-local after-change-functions\n (list (lambda (&rest _)\n (catch 'exit\n (exit-minibuffer))\n (throw 'selected (minibuffer-contents)))))\n (use-local-map\n (make-composed-keymap ement-room-reaction-map (current-local-map)))\n (let ((enable-recursive-minibuffers t))\n (call-interactively ement-room-reaction-picker)))\n (catch 'selected\n (read-string \"Reaction: \")))\n (point))))\n ;; SPEC: MSC2677 \n ;; HACK: We could simplify this by storing the key in a text property...\n (ement-room-with-highlighted-event-at position\n (pcase-let* ((event (or event\n (ewoc-data (ewoc-locate ement-ewoc position))\n (user-error \"No event at point\")))\n ;; NOTE: Sadly, `face-at-point' doesn't work here because, e.g. if\n ;; hl-line-mode is enabled, it only returns the hl-line face.\n ((cl-struct ement-event (id event-id)) event)\n ((cl-struct ement-room (id room-id)) ement-room)\n (endpoint (format \"rooms/%s/send/m.reaction/%s\" (url-hexify-string room-id)\n (ement--update-transaction-id ement-session)))\n (content (ement-alist \"m.relates_to\"\n (ement-alist \"rel_type\" \"m.annotation\"\n \"event_id\" event-id\n \"key\" key))))\n (ement-api ement-session endpoint :method 'put :data (json-encode content)\n :then (apply-partially #'ement-room-send-event-callback\n :room ement-room :session ement-session :content content\n :data)))))\n\n(defun ement-room-toggle-reaction (key event room session)\n \"Toggle reaction of KEY to EVENT in ROOM on SESSION.\"\n (interactive\n (cl-labels\n ((face-at-point-p (face)\n (let ((face-at-point (get-text-property (point) 'face)))\n (or (eq face face-at-point)\n (and (listp face-at-point)\n (member face face-at-point)))))\n (buffer-substring-while (beg pred &key (forward-fn #'forward-char))\n \"Return substring of current buffer from BEG while PRED is true.\"\n (save-excursion\n (goto-char beg)\n (cl-loop while (funcall pred)\n do (funcall forward-fn)\n finally return (buffer-substring-no-properties beg (point)))))\n (key-at (pos)\n (cond ((face-at-point-p 'ement-room-reactions-key)\n (buffer-substring-while\n pos (lambda () (face-at-point-p 'ement-room-reactions-key))))\n ((face-at-point-p 'ement-room-reactions)\n ;; Point is in a reaction button but after the key.\n (buffer-substring-while\n (button-start (button-at pos))\n (lambda () (face-at-point-p 'ement-room-reactions-key)))))))\n (list (or (key-at (point))\n (char-to-string (read-char-by-name \"Reaction (prepend \\\"*\\\" for substring search): \")))\n (ewoc-data (ewoc-locate ement-ewoc))\n ement-room ement-session)))\n (pcase-let* (((cl-struct ement-event (local (map reactions))) event)\n ((cl-struct ement-session user) session)\n ((cl-struct ement-user (id user-id)) user))\n (if-let (reaction-event (cl-find-if (lambda (event)\n (and (equal user-id (ement-user-id (ement-event-sender event)))\n (equal key (map-nested-elt (ement-event-content event) '(m.relates_to key)))))\n reactions))\n ;; Already sent this reaction: redact it.\n (ement-redact reaction-event room session)\n ;; Send reaction.\n (ement-room-send-reaction key (point)))))\n\n(defun ement-room-reaction-button-action (button)\n \"Push reaction BUTTON at point.\"\n ;; TODO: Toggle reactions off with redactions (not in spec yet, but Element does it).\n (save-excursion\n (goto-char (button-start button))\n (call-interactively #'ement-room-toggle-reaction)))\n\n(defun ement-room-toggle-space (room space session)\n ;; Naming things is hard, but this seems the best balance between concision, ambiguity,\n ;; and consistency. The docstring is always there. (Or there's the sci-fi angle:\n ;; \"spacing\" a room...)\n \"Toggle ROOM's membership in SPACE on SESSION.\"\n (interactive\n (ement-with-room-and-session\n :prompt-form (ement-complete-room :session ement-session\n :predicate (lambda (room) (not (ement--space-p room))) )\n (pcase-let* ((prompt (format \"Toggle room %S's membership in space: \"\n (ement--format-room ement-room)))\n ;; TODO: Use different face for spaces the room is already in.\n (`(,space ,_session) (ement-complete-room :session ement-session :prompt prompt :suggest nil\n :predicate #'ement--space-p)))\n (list ement-room space ement-session))))\n (pcase-let* (((cl-struct ement-room (id child-id)) room)\n (routing-server (progn\n (string-match (rx (1+ (not (any \":\"))) \":\" (group (1+ anything))) child-id)\n (match-string 1 child-id)))\n (action (if (ement--room-in-space-p room space)\n 'remove 'add))\n (data (pcase action\n ('add (ement-alist \"via\" (vector\n ;; FIXME: Finish and use the routing function.\n ;; (ement--room-routing room)\n routing-server)))\n ('remove (make-hash-table)))))\n (ement-put-state space \"m.space.child\" child-id data session\n :then (lambda (response-data)\n ;; It appears that the server doesn't send the new event in the next sync (at\n ;; least, not to the client that put the state), so we must simulate receiving it.\n (pcase-let* (((map event_id) response-data)\n ((cl-struct ement-session user) session)\n ((cl-struct ement-room (id child-id)) room)\n (fake-event (make-ement-event :id event_id :type \"m.space.child\"\n :sender user :state-key child-id\n :content (json-read-from-string (json-encode data)))))\n (push fake-event (ement-room-timeline space))\n (run-hook-with-args 'ement-event-hook fake-event space session))\n (ement-message \"Room %S %s space %S\"\n (ement--format-room room)\n (pcase action\n ('add \"added to\")\n ('remove \"removed from\"))\n (ement--format-room space))))))\n\n;;;; Functions\n\n(defun ement-room-view (room session)\n \"Switch to a buffer showing ROOM on SESSION.\nUses action `ement-view-room-display-buffer-action', which see.\"\n (interactive (ement-complete-room :session (ement-complete-session) :suggest nil\n :predicate (lambda (room)\n (not (ement--space-p room)))))\n (pcase-let* (((cl-struct ement-room (local (map buffer))) room))\n (unless (buffer-live-p buffer)\n (setf buffer (ement-room--buffer session room (ement-room--buffer-name room))\n (alist-get 'buffer (ement-room-local room)) buffer))\n ;; FIXME: This doesn't seem to work as desired, e.g. when\n ;; `ement-view-room-display-buffer-action' is set to `display-buffer-no-window'; I\n ;; guess because `pop-to-buffer' selects a window.\n (pop-to-buffer buffer ement-view-room-display-buffer-action)\n (run-hook-with-args 'ement-room-view-hook room session)))\n(defalias 'ement-view-room #'ement-room-view)\n\n(defun ement-room-view-hook-room-list-auto-update (_room session)\n \"Call `ement-room-list-auto-update' with SESSION.\nTo be used in `ement-room-view-hook', which see.\"\n ;; This function is necessary because the hook is called with the room argument, which\n ;; `ement-room-list-auto-update' doesn't need.\n (declare (function ement-room-list-auto-update \"ement-room-list\"))\n (ement-room-list-auto-update session))\n\n(defun ement-room--buffer-name (room)\n \"Return name for ROOM's buffer.\"\n (concat ement-room-buffer-name-prefix\n (or (ement-room-display-name room)\n (setf (ement-room-display-name room)\n (ement--room-display-name room)))\n ement-room-buffer-name-suffix))\n\n(defun ement-room-goto-event (event)\n \"Go to EVENT in current buffer.\"\n (if-let ((node (ement-room--ewoc-last-matching ement-ewoc\n (lambda (data)\n (and (ement-event-p data)\n (equal (ement-event-id event) (ement-event-id data)))))))\n (goto-char (ewoc-location node))\n (error \"Event not found in buffer: %S\" (ement-event-id event))))\n\n(defun ement-room--event-at (pos)\n \"Return event at POS or signal an error.\"\n ;; TODO: Use this where appropriate.\n (save-excursion\n (goto-char pos)\n (cl-assert ement-ewoc)\n (let ((data (ewoc-data (ewoc-locate ement-ewoc))))\n (cl-typecase data\n (ement-event data)\n (otherwise (user-error \"No event at point\"))))))\n\n(cl-defun ement-room-retro-callback (room session data\n &key (set-prev-batch t))\n \"Push new DATA to ROOM on SESSION and add events to room buffer.\nIf SET-PREV-BATCH is nil, don't set ROOM's prev-batch slot to the\n\\\"prev_batch\\\" token in response DATA (this should be set,\ne.g. when filling timeline gaps as opposed to retrieving messages\nbefore the earliest-seen message).\"\n (declare (function ement--make-event \"ement.el\")\n (function ement--put-event \"ement.el\"))\n (pcase-let* (((cl-struct ement-room local) room)\n\t ((map _start end chunk state) data)\n ((map buffer) local)\n (num-events (length chunk))\n ;; We do 3 things for chunk events, so we count them 3 times when\n ;; reporting progress. (We also may receive some state events for\n ;; these chunk events, but we don't bother to include them in the\n ;; count, and we don't report progress for them, because they are\n ;; likely very few compared to the number of timeline events, which is\n ;; what the user is interested in (e.g. when loading 1000 earlier\n ;; messages in #emacs:matrix.org, only 31 state events were received).\n (progress-max-value (* 3 num-events)))\n ;; NOTE: Put the newly retrieved events at the end of the slots, because they should be\n ;; older events. But reverse them first, because we're using \"dir=b\", which the\n ;; spec says causes the events to be returned in reverse-chronological order, and we\n ;; want to process them oldest-first (important because a membership event having a\n ;; user's displayname should be older than a message event sent by the user).\n ;; NOTE: The events in `chunk' and `state' are vectors, so we\n ;; convert them to a list before appending.\n (ement-debug num-events progress-max-value)\n (setf chunk (nreverse chunk)\n state (nreverse state))\n ;; FIXME: Like `ement--push-joined-room-events', this should probably run the `ement-event-hook' on the newly seen events.\n ;; Append state events.\n (cl-loop for event across-ref state\n do (setf event (ement--make-event event))\n finally do (setf (ement-room-state room)\n (append (ement-room-state room) (append state nil))))\n (ement-with-progress-reporter (:reporter (\"Ement: Processing earlier events...\" 0 progress-max-value))\n ;; Append timeline events (in the \"chunk\").\n ;; NOTE: It's regrettable that we have to turn the chunk vector into a list before\n ;; appending it to the timeline, but we have to discard events that we've already\n ;; seen.\n ;; TODO: Consider looping over the vector and pushing one-by-one instead of using\n ;; `seq-remove' and `append' (might be faster).\n (cl-loop for event across-ref chunk\n do (if (gethash (alist-get 'event_id event) (ement-session-events session))\n ;; Duplicate event: set to nil to be ignored.\n (setf event nil)\n ;; New event.\n (setf event (ement--make-event event))\n ;; HACK: Put events on events table. See FIXME above about using the event hook.\n (ement--put-event event nil session))\n (ement-progress-update)\n finally do\n (setf chunk (seq-remove #'null chunk)\n (ement-room-timeline room) (append (ement-room-timeline room) chunk)))\n (when buffer\n ;; Insert events into the room's buffer.\n (with-current-buffer buffer\n (save-window-excursion\n ;; NOTE: See note in `ement--update-room-buffers'.\n (when-let ((buffer-window (get-buffer-window buffer)))\n (select-window buffer-window))\n ;; FIXME: Use retro-loading in event handlers, or in --handle-events, anyway.\n (ement-room--process-events chunk)\n ;; Don't set the slot if the response doesn't include an \"end\" token (that\n ;; would cause subsequent retro requests to fetch events from the end of the\n ;; timeline, as if we had just joined).\n (when (and set-prev-batch end)\n ;; This feels a little hacky, but maybe not too bad.\n (setf (ement-room-prev-batch room) end))\n (setf ement-room-retro-loading nil)))))\n (message \"Ement: Loaded %s earlier events.\" num-events)))\n\n(defun ement-room--insert-events (events &optional retro)\n \"Insert EVENTS into current buffer.\nCalls `ement-room--insert-event' for each event and inserts\ntimestamp headers into appropriate places while maintaining\npoint's position. If RETRO is non-nil, assume EVENTS are earlier\nthan any existing events, and only insert timestamp headers up to\nthe previously oldest event.\"\n (let (buffer-window point-node orig-first-node point-max-p)\n (when (get-buffer-window (current-buffer))\n ;; HACK: See below.\n (setf buffer-window (get-buffer-window (current-buffer))\n point-max-p (= (point) (point-max))))\n (when (and buffer-window retro)\n (setf point-node (ewoc-locate ement-ewoc (window-start buffer-window))\n orig-first-node (ewoc-nth ement-ewoc 0)))\n (save-window-excursion\n ;; NOTE: When inserting some events, seemingly only replies, if a different buffer's\n ;; window is selected, and this buffer's window-point is at the bottom, the formatted\n ;; events may be inserted into the wrong place in the buffer, even though they are\n ;; inserted into the EWOC at the right place. We work around this by selecting the\n ;; buffer's window while inserting events, if it has one. (I don't know if this is a bug\n ;; in EWOC or in this file somewhere. But this has been particularly nasty to debug.)\n (when buffer-window\n (select-window buffer-window))\n (cl-loop for event being the elements of events\n do (ement-room--process-event event)\n do (ement-progress-update)))\n ;; Since events can be received in any order, we have to check the whole buffer\n ;; for where to insert new timestamp headers. (Avoiding that would require\n ;; getting a list of newly inserted nodes and checking each one instead of every\n ;; node in the buffer. Doing that now would probably be premature optimization,\n ;; though it will likely be necessary if users keep buffers open for busy rooms\n ;; for a long time, as the time to do this in each buffer will increase with the\n ;; number of events. At least we only do it once per batch of events.)\n (ement-room--insert-ts-headers nil (when retro orig-first-node))\n (when ement-room-sender-in-headers\n (ement-room--insert-sender-headers ement-ewoc))\n (when buffer-window\n (cond (retro (with-selected-window buffer-window\n (set-window-start buffer-window (ewoc-location point-node))\n ;; TODO: Experiment with this.\n (forward-line -1)))\n (point-max-p (set-window-point buffer-window (point-max)))))))\n\n(cl-defun ement-room--send-typing (session room &key (typing t))\n \"Send a typing notification for ROOM on SESSION.\"\n (pcase-let* (((cl-struct ement-session user) session)\n ((cl-struct ement-user (id user-id)) user)\n ((cl-struct ement-room (id room-id)) room)\n (endpoint (format \"rooms/%s/typing/%s\"\n (url-hexify-string room-id) (url-hexify-string user-id)))\n (data (ement-alist \"typing\" typing \"timeout\" 20000)))\n (ement-api session endpoint :method 'put :data (json-encode data)\n ;; We don't really care about the response, I think.\n :then #'ignore)))\n\n(defcustom ement-room-mode-hook nil\n ;; Due to Emacs bug#68600, define the mode hook separately to avoid the mode\n ;; line constructs in the `ement-room-mode' mode name being copied verbatim\n ;; into the auto-generated docstring.\n \"Hook run after entering `ement-room-mode'.\"\n :options '(visual-line-mode)\n :type 'hook\n :group 'ement-room)\n\n(define-derived-mode ement-room-mode fundamental-mode\n `(\"Ement-Room\"\n (:eval (unless (map-elt ement-syncs ement-session)\n (propertize \":Not-syncing\"\n 'face 'font-lock-warning-face\n 'help-echo \"Automatic syncing was interrupted; press \\\"g\\\" to resume\"))))\n \"Major mode for Ement room buffers.\nThis mode initializes a buffer to be used for showing events in\nan Ement room. It kills all local variables, removes overlays,\nand erases the buffer.\n\n\\\\{ement-room-mode--advertised-keymap}\"\n (use-local-map ement-room-mode-effective-keymap)\n (let ((inhibit-read-only t))\n (erase-buffer))\n (remove-overlays)\n (setf buffer-read-only t\n left-margin-width ement-room-left-margin-width\n right-margin-width ement-room-right-margin-width\n imenu-create-index-function #'ement-room--imenu-create-index-function\n ;; TODO: Use EWOC header/footer for, e.g. typing messages.\n ement-ewoc (ewoc-create #'ement-room--pp-thing))\n ;; Prevent line/wrap-prefix formatting properties being included in copied text.\n (setq-local filter-buffer-substring-function #'ement-room--buffer-substring-filter)\n ;; Set the URL handler. Note that `browse-url-handlers' was added in 28.1;\n ;; prior to that `browse-url-browser-function' served double-duty.\n ;; TODO: Remove compat code when requiring Emacs >=28.\n ;; (See also `ement-room-browse-url'.)\n (let ((handler (cons ement-room-matrix.to-url-regexp #'ement-room-browse-url)))\n (if (boundp 'browse-url-handlers)\n (setq-local browse-url-handlers (cons handler browse-url-handlers))\n (setq-local browse-url-browser-function\n (cons handler\n (if (consp browse-url-browser-function)\n browse-url-browser-function\n (and browse-url-browser-function\n (list (cons \".\" browse-url-browser-function))))))))\n (setq-local completion-at-point-functions\n '(ement-room--complete-members-at-point ement-room--complete-rooms-at-point))\n (setq-local dnd-protocol-alist (append '((\"^file:///\" . ement-room-dnd-upload-file)\n (\"^file:\" . ement-room-dnd-upload-file))\n dnd-protocol-alist)))\n\n(add-hook 'ement-room-mode-hook 'visual-line-mode)\n\n;;;###autoload\n(define-minor-mode ement-room-self-insert-mode\n \"When enabled, `self-insert-command' keys begin a new message.\n\nThe user options `ement-room-self-insert-chars' and\n`ement-room-self-insert-commands' determine the specific keys and\ncommands which will have this effect.\n\nWhen this mode is enabled, `ement-room-mode-self-insert-keymap'\ntakes precedence over `ement-room-mode-map', with the shadowed\nkey bindings in `ement-room-mode-map' becoming accessible via\n`ement-room-mode-map-prefix-key'.\n\nIf you define custom key bindings in `ement-room-mode-map', you\nshould call `ement-room-self-insert-mode' after defining those\nkeys (rather than before). Your bindings will be functional in\neither case, but they may not appear in the help for\n`ement-room-mode' if you define them afterwards.\n\nIf you bind keys in `ement-room-mode-self-insert-keymap', do so\nvia `ement-room-mode-self-insert-keymap-update-hook' (see which).\"\n :init-value nil\n :global t\n :keymap nil\n :group 'ement-room\n ;; Ensure the self-insert and advertised keymaps are up to date.\n (if ement-room-self-insert-mode\n (ement-room-mode-self-insert-keymap-update)\n (setq ement-room-mode--advertised-keymap ement-room-mode-map))\n ;; Make the local keymap used by `ement-room-mode' reflect the state\n ;; of `ement-room-self-insert-mode'.\n (ement-room-mode-effective-keymap-update))\n\n(defun ement-room-self-insert-new-message ()\n \"Compose a new message beginning with the just-typed character.\"\n (interactive)\n ;; Re-issue the event which triggered this command.\n ;; (Typically a `self-insert-command' key binding.)\n (seq-doseq (key (reverse (this-command-keys-vector)))\n (push key unread-command-events))\n (call-interactively #'ement-room-dispatch-new-message))\n\n(defun ement-room-read-string (prompt &optional initial-input history default-value inherit-input-method)\n \"Call `read-from-minibuffer', binding variables and keys for Ement.\nArguments PROMPT, INITIAL-INPUT, HISTORY, DEFAULT-VALUE, and\nINHERIT-INPUT-METHOD are as those expected by `read-string',\nwhich see. Runs hook `ement-room-read-string-setup-hook', which\nsee.\"\n (let ((room ement-room)\n (session ement-session))\n (minibuffer-with-setup-hook\n (lambda ()\n \"Bind keys and variables locally (to be called in minibuffer).\"\n (setq-local ement-room room)\n (setq-local ement-session session)\n (setq-local completion-at-point-functions\n '(ement-room--complete-members-at-point ement-room--complete-rooms-at-point))\n (visual-line-mode 1)\n (run-hooks 'ement-room-read-string-setup-hook))\n (read-from-minibuffer prompt initial-input ement-room-minibuffer-map\n nil history default-value inherit-input-method))))\n\n(defun ement-room--buffer (session room name)\n \"Return buffer named NAME showing ROOM's events on SESSION.\nIf ROOM has no buffer, one is made and stored in the room's local\ndata slot.\"\n (declare (function ement-view-space \"ement-directory\"))\n (or (map-elt (ement-room-local room) 'buffer)\n (let ((new-buffer (generate-new-buffer name)))\n (with-current-buffer new-buffer\n (ement-room-mode)\n (setf header-line-format (when ement-room-header-line-format\n 'ement-room-header-line-format)\n ement-session session\n ement-room room\n list-buffers-directory (or (ement-room-canonical-alias room)\n (ement-room-id room))\n ;; Track buffer in room's slot.\n (map-elt (ement-room-local room) 'buffer) (current-buffer))\n (add-hook 'kill-buffer-hook\n (lambda ()\n (setf (map-elt (ement-room-local room) 'buffer) nil))\n nil 'local)\n (setq-local bookmark-make-record-function #'ement-room-bookmark-make-record)\n ;; Set initial header and footer. (Do this before processing events, which\n ;; might cause the header/footer to be changed (e.g. a tombstone event).\n (let ((header (if (cl-loop for state in (list (ement-room-state ement-room)\n (ement-room-invite-state ement-room))\n thereis (cl-find \"m.room.encryption\" state\n :test #'equal :key #'ement-event-type))\n (propertize \"This appears to be an encrypted room, which is not natively supported by Ement.el. (See information about using Pantalaimon in Ement.el documentation.)\"\n 'face 'font-lock-warning-face)\n \"\"))\n (footer (pcase (ement-room-status ement-room)\n ;; Set header and footer for an invited room.\n ('invite\n (concat (propertize \"You've been invited to this room. \"\n 'face 'font-lock-warning-face)\n (propertize \"[Join this room]\"\n 'button '(t)\n 'category 'default-button\n 'mouse-face 'highlight\n 'follow-link t\n 'action (lambda (_button)\n ;; Kill the room buffer so it can be recreated after joining\n ;; (which will cleanly update the room's name, footer, etc).\n (let ((room ement-room)\n (session ement-session))\n (kill-buffer)\n (message \"Joining room... (buffer will be reopened after joining)\")\n (ement-room-join (ement-room-id room) session))))))\n (_ (if (ement--space-p room)\n (concat (propertize \"This room is a space. It is not for messaging, but only a grouping of other rooms. \"\n 'face 'font-lock-type-face)\n (propertize \"[View rooms in this space]\"\n 'button '(t)\n 'category 'default-button\n 'mouse-face 'highlight\n 'follow-link t\n 'action (lambda (_button)\n ;; Kill the room buffer so it can be recreated after joining\n ;; (which will cleanly update the room's name, footer, etc).\n (let ((room ement-room)\n (session ement-session))\n (kill-buffer)\n (message \"Viewing space...\")\n (ement-view-space room session)))))\n \"\")))))\n (ewoc-set-hf ement-ewoc header footer))\n (setf\n ;; Clear new-events, because those only matter when a buffer is already open.\n (alist-get 'new-events (ement-room-local room)) nil\n ;; Set the new buffer in the room's local alist so that it\n ;; can be used by event-inserting functions before this\n ;; function returns, e.g. `ement-room--add-member-face'.\n (alist-get 'buffer (ement-room-local room)) new-buffer)\n ;; We don't use `ement-room--insert-events' to avoid extra\n ;; calls to `ement-room--insert-ts-headers'.\n ;; NOTE: We handle the events in chronological order (i.e. the reverse of the\n ;; stored order, which is latest-first), because some logic depends on this\n ;; (e.g. processing a message-edit event before the edited event would mean the\n ;; edited event would not yet be in the buffer).\n (ement-room--process-events (reverse (ement-room-state room)))\n (ement-room--process-events (reverse (ement-room-timeline room)))\n (ement-room--insert-ts-headers)\n (when ement-room-sender-in-headers\n (ement-room--insert-sender-headers ement-ewoc))\n (ement-room-move-read-markers room\n :read-event (when-let ((event (alist-get \"m.read\" (ement-room-account-data room) nil nil #'equal)))\n (map-nested-elt event '(content event_id)))\n :fully-read-event (when-let ((event (alist-get \"m.fully_read\" (ement-room-account-data room) nil nil #'equal)))\n (map-nested-elt event '(content event_id)))))\n ;; Return the buffer!\n new-buffer)))\n\n(defun ement-room--event-data (id)\n \"Return event struct for event ID in current buffer.\"\n ;; Search from bottom, most likely to be faster.\n (cl-loop with node = (ewoc-nth ement-ewoc -1)\n while node\n for data = (ewoc-data node)\n when (and (ement-event-p data)\n (equal id (ement-event-id data)))\n return data\n do (setf node (ewoc-prev ement-ewoc node))))\n\n(defun ement-room--escape-% (string)\n \"Return STRING with \\\"%\\\" escaped.\nNeeded to display things in the header line.\"\n (replace-regexp-in-string (rx \"%\") \"%%\" string t t))\n\n(defun ement-room--buffer-substring-filter (beg end &optional delete)\n \"Value for `filter-buffer-substring-function' in Ement rooms.\n\nStrips the `line-prefix' and `wrap-prefix' text properties which\nare used when formatting certain Matrix events, but which should\nnot be copied into other buffers.\"\n (let ((string (funcall (default-value 'filter-buffer-substring-function)\n beg end delete)))\n (remove-list-of-text-properties\n 0 (length string) '(line-prefix wrap-prefix) string)\n string))\n\n;;;;; Imenu\n\n(defconst ement-room-timestamp-header-imenu-format \"%Y-%m-%d (%A) %H:%M\"\n \"Format string for timestamps in Imenu indexes.\")\n\n(defun ement-room--imenu-create-index-function ()\n \"Return Imenu index for the current buffer.\nFor use as `imenu-create-index-function'.\"\n (let ((timestamp-nodes (ement-room--ewoc-collect-nodes\n ement-ewoc (lambda (node)\n (pcase (ewoc-data node)\n (`(ts . ,_) t))))))\n (cl-loop for node in timestamp-nodes\n collect (pcase-let*\n ((`(ts ,timestamp) (ewoc-data node))\n (formatted (format-time-string ement-room-timestamp-header-imenu-format timestamp)))\n (cons formatted (ewoc-location node))))))\n\n;;;;; Occur\n\n(defvar-local ement-room-occur-pred nil\n \"Predicate used to refresh `ement-room-occur' buffers.\")\n\n(define-derived-mode ement-room-occur-mode ement-room-mode \"Ement-Room-Occur\")\n\n(progn\n (define-key ement-room-occur-mode-map [remap ement-room-send-message] #'ement-room-occur-find-event)\n (define-key ement-room-occur-mode-map (kbd \"g\") #'revert-buffer)\n (define-key ement-room-occur-mode-map (kbd \"n\") #'ement-room-occur-next)\n (define-key ement-room-occur-mode-map (kbd \"p\") #'ement-room-occur-prev))\n\n(cl-defun ement-room-occur (&key user-id regexp pred header)\n \"Show known events in current buffer matching args in a new buffer.\nIf REGEXP, show events whose sender or body content match it. Or\nif USER-ID, show events from that user. Or if PRED, show events\nmatching it. HEADER is used if given, or set according to other\narguments.\"\n (interactive (let* ((regexp (read-regexp \"Regexp (leave empty to select user instead)\"))\n (user-id (when (string-empty-p regexp)\n (ement-complete-user-id))))\n (list :regexp regexp :user-id user-id)))\n (let* ((session ement-session)\n (room ement-room)\n (occur-buffer (get-buffer-create (format \"*Ement Room Occur: %s*\" (ement-room-display-name room))))\n (pred (cond (pred)\n ((not (string-empty-p regexp))\n (lambda (data)\n (and (ement-event-p data)\n (or (string-match regexp (ement-user-id (ement-event-sender data)))\n (when-let ((room-display-name\n (gethash (ement-event-sender data) (ement-room-displaynames room))))\n (string-match regexp room-display-name))\n (when-let ((body (alist-get 'body (ement-event-content data))))\n (string-match regexp body))))))\n (user-id\n (lambda (data)\n (and (ement-event-p data)\n (equal user-id (ement-user-id (ement-event-sender data))))))))\n (header (cond (header)\n ((not (string-empty-p regexp))\n (format \"Events matching %S in %s\" regexp (ement-room-display-name room)))\n (user-id\n (format \"Events from %s in %s\" user-id (ement-room-display-name room))))))\n (with-current-buffer occur-buffer\n (let ((inhibit-read-only t))\n (erase-buffer))\n (ement-room-occur-mode)\n (setf header-line-format header\n ement-session session\n ement-room room)\n (setq-local revert-buffer-function (lambda (&rest _)\n (interactive)\n (let ((event-at-point (ewoc-data (ewoc-locate ement-ewoc))))\n (with-current-buffer (alist-get 'buffer (ement-room-local room))\n (ement-room-occur :pred pred :header header)\n (when-let ((node (ement-room--ewoc-last-matching ement-ewoc\n (lambda (data)\n (eq event-at-point data)))))\n (ewoc-goto-node ement-ewoc node))))))\n (ement-room--process-events (reverse (ement-room-state room)))\n (ement-room--process-events (reverse (ement-room-timeline room)))\n (ewoc-filter ement-ewoc pred)\n ;; TODO: Insert date header before first event.\n (ement-room--insert-ts-headers))\n (pop-to-buffer occur-buffer)))\n\n(defun ement-room-occur-find-event (event)\n \"Find EVENT in room's main buffer.\"\n (interactive (list (ewoc-data (ewoc-locate ement-ewoc))))\n (pcase-let* (((cl-struct ement-room (local (map buffer))) ement-room)\n ((cl-struct ement-event id) event))\n (display-buffer buffer)\n (with-selected-window (get-buffer-window buffer)\n (ement-room-find-event id))))\n\n(cl-defun ement-room-occur-next (&optional (n 1))\n \"Go to Nth next event.\"\n (interactive)\n (let ((command (if (> n 0)\n #'ement-room-goto-next\n #'ement-room-goto-prev)))\n (cl-loop for i below (abs n)\n do (call-interactively command))\n (ement-room-occur-find-event (ewoc-data (ewoc-locate ement-ewoc)))))\n\n(cl-defun ement-room-occur-prev (&optional (n 1))\n \"Go to Nth previous event.\"\n (interactive)\n (ement-room-occur-next (- n)))\n\n;;;;; Events\n\n;; Functions to handle types of events.\n\n;; NOTE: At the moment, this only handles \"m.typing\" ephemeral events. Message\n;; events are handled elsewhere. A better framework should be designed...\n;; TODO: Define other handlers this way.\n\n;; MAYBE: Should we intern these functions? That means every event\n;; handled has to concat and intern. Should we use lambdas in an\n;; alist or hash-table instead? For now let's use an alist.\n\n(defvar ement-users)\n\n(defvar ement-room-event-fns nil\n \"Alist mapping event types to functions which process events in room buffers.\")\n\n;; NOTE: While transitioning to the defevent-based handler system, we\n;; define both a handle-events and handle-event function that do the\n;; same thing.\n\n;; TODO: Tidy this up.\n\n;; NOTE: --handle-events and --handle-event need to be called in the room\n;; buffer's window, when it has one. This is absolutely necessary,\n;; otherwise the events may be inserted at the wrong place. (I'm not\n;; sure if this is a bug in EWOC or in my code, but doing this fixes it.)\n\n(defun ement-room--process-events (events)\n \"Process EVENTS in current buffer.\nCalls `ement-progress-update' for each event. Calls\n`ement-room--insert-ts-headers' when done. Uses handlers defined\nin `ement-room-event-fns'. The current buffer should be a room's\nbuffer.\"\n ;; FIXME: Calling `ement-room--insert-ts-headers' is convenient, but it\n ;; may also be called in functions that call this function, which may\n ;; result in it being called multiple times for a single set of events.\n (cl-loop for event being the elements of events ;; EVENTS may be a list or array.\n for handler = (alist-get (ement-event-type event) ement-room-event-fns nil nil #'equal)\n when handler\n do (funcall handler event)\n do (ement-progress-update))\n (ement-room--insert-ts-headers))\n\n(defun ement-room--process-event (event)\n \"Process EVENT in current buffer.\nUses handlers defined in `ement-room-event-fns'. The current\nbuffer should be a room's buffer.\"\n (when-let ((handler (alist-get (ement-event-type event) ement-room-event-fns nil nil #'equal)))\n ;; We demote any errors that happen while processing events, because it's possible for\n ;; events to be malformed in unexpected ways, and that could cause an error, which\n ;; would stop processing of other events and prevent further syncing. See,\n ;; e.g. .\n (with-demoted-errors \"Ement (ement-room--process-event): Error processing event: %S\"\n (funcall handler event))))\n\n;;;;;; Event handlers\n\n(defmacro ement-room-defevent (type &rest body)\n \"Define an event handling function for events of TYPE.\nAround the BODY, the variable `event' is bound to the event being\nprocessed. The function is called in the room's buffer. Adds\nfunction to `ement-room-event-fns', which see.\"\n (declare (debug (stringp def-body))\n (indent defun))\n `(setf (alist-get ,type ement-room-event-fns nil nil #'string=)\n (lambda (event)\n ,(concat \"`ement-room' handler function for \" type \" events.\")\n ,@body)))\n\n(ement-room-defevent \"m.reaction\"\n (pcase-let* (((cl-struct ement-event content) event)\n ((map ('m.relates_to relates-to)) content)\n ((map ('event_id related-id) ('rel_type rel-type) _key) relates-to))\n ;; TODO: Handle other rel_types?\n (pcase rel-type\n (\"m.annotation\"\n ;; Look for related event in timeline.\n (if-let ((related-event (cl-loop with fake-event = (make-ement-event :id related-id)\n for timeline-event in (ement-room-timeline ement-room)\n when (ement--events-equal-p fake-event timeline-event)\n return timeline-event)))\n ;; Found related event: add reaction to local slot and invalidate node.\n (progn\n ;; Every time a room buffer is made, these reaction events are processed again, so we use pushnew to\n ;; avoid duplicates. (In the future, as event-processing is refactored, this may not be necessary.)\n (cl-pushnew event (map-elt (ement-event-local related-event) 'reactions))\n (when-let ((nodes (ement-room--ewoc-last-matching ement-ewoc\n (lambda (data)\n (and (ement-event-p data)\n (equal related-id (ement-event-id data)))))))\n (ewoc-invalidate ement-ewoc nodes)))\n ;; No known related event: discard.\n ;; TODO: Is this the correct thing to do?\n (ement-debug \"No known related event for\" event))))))\n\n(ement-room-defevent \"m.room.power_levels\"\n (ement-room--insert-event event))\n\n(defun ement-room--format-power-levels-event (event room _session)\n \"Return power-levels EVENT in ROOM formatted as a string.\"\n (pcase-let (((cl-struct ement-event sender\n (content (map ('users new-users)))\n (unsigned (map ('prev_content (map ('users old-users))))))\n event))\n (when old-users\n (pcase-let* ((sender-id (ement-user-id sender))\n (sender-displayname (ement--user-displayname-in room sender))\n (`(,changed-user-id-symbol . ,new-level)\n (cl-find-if (lambda (new-user)\n (let ((old-user (cl-find (car new-user) old-users\n :key #'car)))\n (or (not old-user)\n (not (equal (cdr new-user) (cdr old-user))))))\n new-users))\n (changed-user-id (symbol-name changed-user-id-symbol))\n (changed-user (when changed-user-id-symbol\n (gethash changed-user-id ement-users)))\n (user-displayname (if changed-user\n (ement--user-displayname-in room changed-user)\n changed-user-id)))\n (ement-room-wrap-prefix\n (if (not changed-user)\n (format \"%s sent a power-level event\"\n (propertize sender-displayname\n 'help-echo sender-id))\n (format \"%s set %s's power level to %s\"\n (propertize sender-displayname\n 'help-echo sender-id)\n (propertize user-displayname 'help-echo changed-user-id)\n new-level))\n 'face 'ement-room-membership)))))\n\n(ement-room-defevent \"m.room.canonical_alias\"\n (ement-room--insert-event event))\n\n(defun ement-room--format-canonical-alias-event (event room _session)\n \"Return canonical alias EVENT in ROOM formatted as a string.\"\n (pcase-let (((cl-struct ement-event sender\n ;; TODO: Include alt_aliases, maybe.\n ;; TODO: Include old alias when it is being replaced.\n (content (map alias)))\n event))\n (ement-room-wrap-prefix\n (format \"%s set the canonical alias to <%s>\"\n (propertize (ement--user-displayname-in room sender)\n 'help-echo (ement-user-id sender))\n alias)\n 'face 'ement-room-membership)))\n\n(ement-room-defevent \"m.room.redaction\"\n ;; We handle redaction events here rather than an `ement-defevent' handler. This way we\n ;; do less work for events in rooms that the user isn't looking at, at the cost of doing\n ;; a bit more work when a room's buffer is prepared.\n (pcase-let* (((cl-struct ement-event (local (map ('redacts redacted-id)))) event)\n ((cl-struct ement-room timeline) ement-room)\n (redacted-event (cl-find redacted-id timeline\n :key #'ement-event-id :test #'equal))\n (redacted-edit-events (cl-remove-if-not (lambda (timeline-event)\n (pcase-let (((cl-struct ement-event\n (content\n (map ('m.relates_to\n (map ('event_id related-id)\n ('rel_type rel-type))))))\n timeline-event))\n (and (equal redacted-id related-id)\n (equal \"m.replace\" rel-type))))\n timeline)))\n (ement-debug event redacted-event redacted-edit-events)\n (cl-loop for edit-event in redacted-edit-events\n do (cl-pushnew event (alist-get 'redacted-by (ement-event-local edit-event))))\n (when redacted-event\n (cl-pushnew event (alist-get 'redacted-by (ement-event-local redacted-event)))\n (pcase-let* (((cl-struct ement-event (content\n (map ('m.relates_to\n (map ('event_id related-id)\n ('rel_type rel-type))))))\n redacted-event))\n (pcase rel-type\n (\"m.annotation\"\n ;; Redacted annotation/reaction. NOTE: Since we link annotations in a -room\n ;; event handler (rather than in a non-room handler), we also unlink redacted\n ;; ones here.\n (when-let (annotated-event (cl-find related-id timeline\n :key #'ement-event-id :test #'equal))\n ;; Remove it from the related event's local slot.\n (setf (map-elt (ement-event-local annotated-event) 'reactions)\n (cl-remove redacted-id (map-elt (ement-event-local annotated-event) 'reactions)\n :key #'ement-event-id :test #'equal))\n ;; Invalidate the related event's node.\n (when-let (node (ement-room--ewoc-last-matching ement-ewoc\n (lambda (data)\n (and (ement-event-p data)\n (equal related-id (ement-event-id data))))))\n (ewoc-invalidate ement-ewoc node)))))))\n ;; Invalidate the redacted event's node.\n (when-let ((node (ement-room--ewoc-last-matching ement-ewoc\n (lambda (data)\n (and (ement-event-p data)\n (pcase-let (((cl-struct ement-event id\n (content\n (map ('m.relates_to\n (map ('event_id related-id)\n ('rel_type rel-type))))))\n data))\n (or (equal redacted-id id)\n (and (equal \"m.replace\" rel-type)\n (equal redacted-id related-id)))))))))\n (ement-debug node)\n (ewoc-invalidate ement-ewoc node))))\n\n(ement-room-defevent \"m.typing\"\n (pcase-let* (((cl-struct ement-session user) ement-session)\n ((cl-struct ement-user (id local-user-id)) user)\n ((cl-struct ement-event content) event)\n ((map ('user_ids user-ids)) content)\n (usernames) (footer))\n (setf user-ids (delete local-user-id user-ids))\n (if (zerop (length user-ids))\n (setf footer \"\")\n (setf usernames (cl-loop for id across user-ids\n for user = (gethash id ement-users)\n if user\n collect (ement--user-displayname-in ement-room user)\n else collect id)\n footer (propertize (concat \"Typing: \" (string-join usernames \", \"))\n 'face 'font-lock-comment-face)))\n (with-silent-modifications\n (ewoc-set-hf ement-ewoc \"\" footer))))\n\n(ement-room-defevent \"m.room.avatar\"\n (ement-room--insert-event event))\n\n(ement-room-defevent \"org.matrix.msc3015.m.room.name.override\"\n (ignore event)\n (setf (ement-room-display-name ement-room) (ement--room-display-name ement-room))\n (rename-buffer (ement-room--buffer-name ement-room)))\n\n(ement-room-defevent \"m.room.member\"\n (with-silent-modifications\n (ement-room--insert-event event)))\n\n(ement-room-defevent \"m.room.message\"\n (pcase-let* (((cl-struct ement-event content unsigned) event)\n ((map ('m.relates_to (map ('rel_type rel-type) ('event_id replaces-event-id)))) content)\n ((map ('m.relations (map ('m.replace (map ('event_id replaced-by-id)))))) unsigned))\n (if (and ement-room-replace-edited-messages\n replaces-event-id (equal \"m.replace\" rel-type))\n ;; Event replaces existing event: find and replace it in buffer if possible, otherwise insert it.\n (or (ement-room--replace-event event)\n (progn\n (ement-debug \"Unable to replace event ID: inserting instead.\" replaces-event-id)\n (ement-room--insert-event event)))\n ;; New event.\n (if replaced-by-id\n (ement-debug \"Event replaced: not inserting.\" replaced-by-id)\n ;; Not replaced: insert it.\n (ement-room--insert-event event)))))\n\n(ement-room-defevent \"m.room.tombstone\"\n (pcase-let* (((cl-struct ement-event content) event)\n ((map body ('replacement_room new-room-id)) content)\n (session ement-session)\n (button (ement--button-buttonize\n (propertize new-room-id 'help-echo \"Join replacement room\")\n (lambda (_)\n (ement-room-join new-room-id session))))\n (banner (format \"This room has been replaced. Explanation:%S Replacement room: <%s>\" body button)))\n (add-face-text-property 0 (length banner) 'font-lock-warning-face t banner)\n ;; NOTE: We assume that no more typing events will be received,\n ;; which would replace the footer.\n (ement-room--insert-event event)\n (ewoc-set-hf ement-ewoc banner banner)))\n\n;;;;; Read markers\n\n;; Marking rooms as read and showing lines where marks are.\n\n(ement-room-defevent \"m.read\"\n (ement-room-move-read-markers ement-room\n :read-event (ement-event-id event)))\n\n(ement-room-defevent \"m.fully_read\"\n (ement-room-move-read-markers ement-room\n :fully-read-event (ement-event-id event)))\n\n(defvar-local ement-room-read-receipt-marker nil\n \"EWOC node for the room's read-receipt marker.\")\n\n(defvar-local ement-room-fully-read-marker nil\n \"EWOC node for the room's fully-read marker.\")\n\n(defface ement-room-read-receipt-marker\n '((t (:inherit show-paren-match)))\n \"Read marker line in rooms.\"\n :group 'ement-room-faces)\n\n(defface ement-room-fully-read-marker\n '((t (:inherit isearch)))\n \"Fully read marker line in rooms.\"\n :group 'ement-room-faces)\n\n(defcustom ement-room-send-read-receipts t\n \"Whether to send read receipts.\nAlso controls whether the read-receipt marker in a room is moved\nautomatically.\"\n :type 'boolean\n :group 'ement-room)\n\n(defun ement-room-read-receipt-idle-timer ()\n \"Update read receipts in visible Ement room buffers.\nTo be called from timer stored in\n`ement-read-receipt-idle-timer'.\"\n (when ement-room-send-read-receipts\n (dolist (window (window-list))\n (when (and (eq 'ement-room-mode (buffer-local-value 'major-mode (window-buffer window)))\n (buffer-local-value 'ement-room (window-buffer window)))\n (ement-room-update-read-receipt window)))))\n\n(defun ement-room-update-read-receipt (window)\n \"Update read receipt for room displayed in WINDOW.\nAlso, mark room's buffer as unmodified.\"\n (with-selected-window window\n (let ((read-receipt-node (ement-room--ewoc-last-matching ement-ewoc\n (lambda (node-data)\n (eq 'ement-room-read-receipt-marker node-data))))\n (window-end-node (or (ewoc-locate ement-ewoc (window-end nil t))\n (ewoc-nth ement-ewoc -1))))\n (when (or\n ;; The window's end has been scrolled to or past the position of the\n ;; receipt marker.\n (and read-receipt-node\n (>= (window-end nil t) (ewoc-location read-receipt-node)))\n ;; The read receipt is outside of retrieved events.\n (not read-receipt-node))\n (let* ((event-node (when window-end-node\n ;; It seems like `window-end-node' shouldn't ever be nil,\n ;; but just in case...\n (cl-typecase (ewoc-data window-end-node)\n (ement-event window-end-node)\n (t (ement-room--ewoc-next-matching ement-ewoc window-end-node\n #'ement-event-p #'ewoc-prev)))))\n (node-after-event (ewoc-next ement-ewoc event-node))\n (event))\n (when event-node\n (unless (or (when node-after-event\n (<= (ewoc-location node-after-event) (window-end nil t)))\n (>= (window-end) (point-max)))\n ;; The entire event is not visible: use the previous event. (NOTE: This\n ;; isn't quite perfect, because apparently `window-end' considers a position\n ;; visible if even one pixel of its line is visible. This will have to be\n ;; good enough for now.)\n ;; FIXME: Workaround that an entire line's height need not be displayed for it to be considered so.\n (setf event-node (ement-room--ewoc-next-matching ement-ewoc event-node\n #'ement-event-p #'ewoc-prev)))\n (setf event (ewoc-data event-node))\n ;; Mark the buffer as not modified so that will not contribute to its being\n ;; considered unread. NOTE: This will mean that any room buffer displayed in\n ;; a window will have its buffer marked unmodified when this function is\n ;; called. This is probably for the best.\n (set-buffer-modified-p nil)\n (unless (alist-get event ement-room-read-receipt-request)\n ;; No existing request for this event: cancel any outstanding request and\n ;; send a new one.\n (when-let ((request-process (car (map-values ement-room-read-receipt-request))))\n (when (process-live-p request-process)\n (interrupt-process request-process)))\n (setf ement-room-read-receipt-request nil)\n (setf (alist-get event ement-room-read-receipt-request)\n (ement-room-mark-read ement-room ement-session\n :read-event event)))))))))\n\n(defun ement-room-goto-fully-read-marker ()\n \"Move to the fully-read marker in the current room.\"\n (interactive)\n (if-let ((fully-read-pos (when ement-room-fully-read-marker\n (ewoc-location ement-room-fully-read-marker))))\n (with-suppressed-warnings ((obsolete point))\n ;; I like using `point' as a GV, and I object to its being obsoleted (and said so\n ;; on emacs-devel).\n (setf (point) fully-read-pos (window-start) fully-read-pos))\n ;; Unlike the fully-read marker, there doesn't seem to be a\n ;; simple way to get the user's read-receipt marker. So if\n ;; we haven't seen either marker in the retrieved events, we\n ;; go back to the fully-read marker.\n (if-let* ((fully-read-event (alist-get \"m.fully_read\" (ement-room-account-data ement-room) nil nil #'equal))\n (fully-read-event-id (map-nested-elt fully-read-event '(content event_id))))\n ;; Fully-read account-data event is known.\n (if (gethash fully-read-event-id (ement-session-events ement-session))\n ;; The fully-read event (i.e. the message event that was read, not the\n ;; account-data event) is already retrieved, but the marker is not present in\n ;; the buffer (this shouldn't happen, but somehow, it can): Reset the marker,\n ;; which should work around the problem.\n (ement-room-mark-read ement-room ement-session\n :fully-read-event (gethash fully-read-event-id (ement-session-events ement-session)))\n ;; Fully-read event not retrieved: search for it in room history.\n (let ((buffer (current-buffer)))\n (message \"Searching for first unread event...\")\n (ement-room-retro-to ement-room ement-session fully-read-event-id\n :then (lambda ()\n (with-current-buffer buffer\n ;; HACK: Should probably call this function elsewhere, in a hook or something.\n (ement-room-move-read-markers ement-room)\n (ement-room-goto-fully-read-marker))))))\n (error \"Room has no fully-read event\"))))\n\n(cl-defun ement-room-mark-read (room session &key read-event fully-read-event)\n \"Mark ROOM on SESSION as read on the server.\nSet \\\"m.read\\\" to READ-EVENT and \\\"m.fully_read\\\" to\nFULLY-READ-EVENT. Return the API request.\n\nInteractively, mark both types as read up to event at point.\"\n (declare (indent defun))\n (interactive\n (progn\n (cl-assert (equal 'ement-room-mode major-mode) nil\n \"This command is to be used in `ement-room-mode' buffers\")\n (let* ((node (ewoc-locate ement-ewoc))\n (event-at-point (cl-typecase (ewoc-data node)\n (ement-event (ewoc-data node))\n (t (when-let ((prev-event-node (ement-room--ewoc-next-matching ement-ewoc node\n #'ement-event-p #'ewoc-prev)))\n (ewoc-data prev-event-node)))))\n (last-event (ewoc-data (ement-room--ewoc-last-matching ement-ewoc #'ement-event-p)))\n (event-to-mark-read (if (eq event-at-point last-event)\n ;; The node is at the end of the buffer: use the last event in the timeline\n ;; instead of the last node in the EWOC, because the last event in the timeline\n ;; might not be the last event in the EWOC (e.g. a reaction to an earlier event).\n (car (ement-room-timeline ement-room))\n event-at-point)))\n (list ement-room ement-session\n :read-event event-to-mark-read\n :fully-read-event event-to-mark-read))))\n (cl-assert room) (cl-assert session) (cl-assert (or read-event fully-read-event))\n (if (not fully-read-event)\n ;; Sending only a read receipt, which uses a different endpoint\n ;; than when setting the fully-read marker or both.\n (ement-room-send-receipt room session read-event)\n ;; Setting the fully-read marker, and maybe the \"m.read\" one too.\n (pcase-let* (((cl-struct ement-room (id room-id)) room)\n (endpoint (format \"rooms/%s/read_markers\" (url-hexify-string room-id)))\n (data (ement-alist \"m.fully_read\" (ement-event-id fully-read-event))))\n (when read-event\n (push (cons \"m.read\" (ement-event-id read-event)) data))\n ;; NOTE: See similar code in `ement-room-update-read-receipt'.\n (let ((request-process (ement-api session endpoint :method 'post :data (json-encode data)\n :then (lambda (_data)\n (ement-room-move-read-markers room\n :read-event read-event :fully-read-event fully-read-event))\n :else (lambda (plz-error)\n (pcase (plz-error-message plz-error)\n (\"curl process interrupted\"\n ;; Ignore this, because it happens when we\n ;; update a read marker before the previous\n ;; update request is completed.\n nil)\n (_ (signal 'ement-api-error\n (list (format \"Ement: (ement-room-mark-read) Unexpected API error: %s\"\n plz-error)\n plz-error))))))))\n (when-let ((room-buffer (alist-get 'buffer (ement-room-local room))))\n ;; NOTE: Ideally we would do this before sending the new request, but to make\n ;; the code much simpler, we do it afterward.\n (with-current-buffer room-buffer\n (when-let ((request-process (car (map-values ement-room-read-receipt-request))))\n (when (process-live-p request-process)\n (interrupt-process request-process)))\n (setf ement-room-read-receipt-request nil\n (alist-get read-event ement-room-read-receipt-request) request-process)))))))\n\n(cl-defun ement-room-send-receipt (room session event &key (type \"m.read\"))\n \"Send receipt of TYPE for EVENT to ROOM on SESSION.\"\n (pcase-let* (((cl-struct ement-room (id room-id)) room)\n ((cl-struct ement-event (id event-id)) event)\n (endpoint (format \"rooms/%s/receipt/%s/%s\"\n (url-hexify-string room-id) type\n (url-hexify-string event-id))))\n (ement-api session endpoint :method 'post :data \"{}\"\n :then (pcase type\n (\"m.read\" (lambda (_data)\n (ement-room-move-read-markers room\n :read-event event)))\n ;; No other type is yet specified.\n (_ #'ignore)))))\n\n(cl-defun ement-room-move-read-markers\n (room &key\n (read-event (when-let ((event (alist-get \"m.read\" (ement-room-account-data room) nil nil #'equal)))\n (map-nested-elt event '(content event_id))))\n (fully-read-event (when-let ((event (alist-get \"m.fully_read\" (ement-room-account-data room) nil nil #'equal)))\n (map-nested-elt event '(content event_id)))))\n \"Move read markers in ROOM to READ-EVENT and FULLY-READ-EVENT.\nEach event may be an `ement-event' struct or an event ID. This\nupdates the markers in ROOM's buffer, not on the server; see\n`ement-room-mark-read' for that.\"\n (declare (indent defun))\n (cl-labels ((update-marker (symbol to-event)\n (let* ((old-node (symbol-value symbol))\n (new-event-id (cl-etypecase to-event\n (ement-event (ement-event-id to-event))\n (string to-event)))\n ;; FIXME: Some events, like reactions, are not inserted into the\n ;; EWOC directly, and if a read marker refers to such an event, the\n ;; place for the read marker will not be found.\n (event-node (ement-room--ewoc-last-matching ement-ewoc\n (lambda (data)\n (and (ement-event-p data)\n (equal (ement-event-id data) new-event-id)))))\n (inhibit-read-only t))\n (with-silent-modifications\n (when old-node\n (ewoc-delete ement-ewoc old-node))\n (set symbol (when event-node\n ;; If the event hasn't been inserted into the buffer yet,\n ;; this might be nil. That shouldn't happen, but...\n (ewoc-enter-after ement-ewoc event-node symbol)))))))\n (when-let ((buffer (alist-get 'buffer (ement-room-local room))))\n ;; MAYBE: Error if no buffer? Or does it matter?\n (with-current-buffer buffer\n (when read-event\n (update-marker 'ement-room-read-receipt-marker read-event))\n (when fully-read-event\n (update-marker 'ement-room-fully-read-marker fully-read-event))))\n ;; NOTE: Return nil so that, in the event this function is called manually with `eval-expression',\n ;; it does not cause an error due to the return value being an EWOC node, which is a structure too\n ;; big and/or circular to print. (This was one of those bugs that only happens WHEN debugging.)\n nil))\n\n(defun ement-room-scroll-up-mark-read ()\n \"Scroll buffer contents up, move fully read marker, and bury when at end.\nMoves fully read marker to the top of the window (when the\nmarker's position is within the range of received events). At\nend-of-buffer, moves fully read marker to after the last event,\nburies the buffer and shows the next unread room, if any.\"\n (declare (function ement-tabulated-room-list-next-unread \"ement-tabulated-room-list\")\n (function ement-room-list-next-unread \"ement-room-list\"))\n (interactive)\n (if (= (window-point) (point-max))\n (progn\n ;; At the bottom of the buffer: mark read and show next unread room.\n (when ement-room-mark-rooms-read\n (ement-room-mark-read ement-room ement-session\n :read-event (ewoc-data (ement-room--ewoc-last-matching ement-ewoc\n (lambda (data) (ement-event-p data))))\n :fully-read-event (ewoc-data (ement-room--ewoc-last-matching ement-ewoc\n (lambda (data) (ement-event-p data))))))\n (set-buffer-modified-p nil)\n (if-let ((rooms-window (cl-find-if (lambda (window)\n (member (buffer-name (window-buffer window))\n '(\"*Ement Taxy*\" \"*Ement Rooms*\")))\n (window-list))))\n ;; Rooms buffer already displayed: select its window and move to next unread room.\n (progn\n (select-window rooms-window)\n (funcall (pcase-exhaustive major-mode\n ('ement-tabulated-room-list-mode #'ement-tabulated-room-list-next-unread)\n ('ement-room-list-mode #'ement-room-list-next-unread))))\n ;; Rooms buffer not displayed: bury this room buffer, which should usually\n ;; result in another room buffer or the rooms list buffer being displayed.\n (bury-buffer))\n (when (member major-mode '(ement-tabulated-room-list-mode ement-room-list-mode))\n ;; Back in the room-list buffer: revert it.\n (revert-buffer)))\n ;; Not at the bottom of the buffer: scroll.\n (condition-case _err\n (scroll-up-command)\n (end-of-buffer (set-window-point nil (point-max))))\n (when-let* ((node (ewoc-locate ement-ewoc (window-start)))\n (event-node (ement-room--ewoc-next-matching ement-ewoc node\n #'ement-event-p #'ewoc-prev))\n (fully-read-pos (and ement-room-fully-read-marker\n (ewoc-location ement-room-fully-read-marker)))\n ((< fully-read-pos (ewoc-location event-node))))\n ;; Move fully-read marker to top of window.\n (ement-room-mark-read ement-room ement-session :fully-read-event (ewoc-data event-node)))))\n\n;;;;; EWOC\n\n(cl-defun ement-room--ewoc-next-matching (ewoc node pred &optional (move-fn #'ewoc-next))\n \"Return the next node in EWOC after NODE that PRED is true of.\nPRED is called with node's data. Moves to next node by MOVE-FN.\"\n (declare (indent defun))\n (cl-loop do (setf node (funcall move-fn ewoc node))\n until (or (null node)\n (funcall pred (ewoc-data node)))\n finally return node))\n\n(defun ement-room--ewoc-last-matching (ewoc predicate)\n \"Return the last node in EWOC matching PREDICATE.\nPREDICATE is called with node's data. Searches backward from\nlast node.\"\n (declare (indent defun))\n ;; Intended to be like `ewoc-collect', but returning as soon as a match is found.\n (cl-loop with node = (ewoc-nth ewoc -1)\n while node\n when (funcall predicate (ewoc-data node))\n return node\n do (setf node (ewoc-prev ewoc node))))\n\n(defun ement-room--ewoc-collect-nodes (ewoc predicate)\n \"Collect all nodes in EWOC matching PREDICATE.\nPREDICATE is called with the full node.\"\n ;; Intended to be like `ewoc-collect', but working with the full node instead of just the node's data.\n (cl-loop with node = (ewoc-nth ewoc 0)\n do (setf node (ewoc-next ewoc node))\n while node\n when (funcall predicate node)\n collect node))\n\n(defun ement-room--insert-ts-headers (&optional start-node end-node)\n \"Insert timestamp headers into current buffer's `ement-ewoc'.\nInserts headers between START-NODE and END-NODE, which default to\nthe first and last nodes in the buffer, respectively.\"\n (let* ((type-predicate (lambda (node-data)\n (and (ement-event-p node-data)\n (not (equal \"m.room.member\" (ement-event-type node-data))))))\n (ewoc ement-ewoc)\n (end-node (or end-node\n (ewoc-nth ewoc -1)))\n (end-pos (if end-node\n (ewoc-location end-node)\n ;; HACK: Trying to work around a bug in case the\n ;; room doesn't seem to have any events yet.\n (point-max)))\n (node-b (or start-node (ewoc-nth ewoc 0)))\n node-a)\n ;; On the first loop iteration, node-a is set to the first matching\n ;; node after node-b; then it's set to the first node after node-a.\n (while (and (setf node-a (ement-room--ewoc-next-matching ewoc (or node-a node-b) type-predicate)\n node-b (when node-a\n (ement-room--ewoc-next-matching ewoc node-a type-predicate)))\n (not (or (> (ewoc-location node-a) end-pos)\n (when node-b\n (> (ewoc-location node-b) end-pos)))))\n (cl-labels ((format-event (event)\n (format \"TS:%S (%s) Sender:%s Message:%S\"\n (/ (ement-event-origin-server-ts (ewoc-data event)) 1000)\n (format-time-string \"%Y-%m-%d %H:%M:%S\"\n (/ (ement-event-origin-server-ts (ewoc-data event)) 1000))\n (ement-user-id (ement-event-sender (ewoc-data event)))\n (when (alist-get 'body (ement-event-content (ewoc-data event)))\n (substring-no-properties\n (truncate-string-to-width (alist-get 'body (ement-event-content (ewoc-data event))) 20))))))\n (ement-debug \"Comparing event timestamps:\"\n (list 'A (format-event node-a))\n (list 'B (format-event node-b))))\n ;; NOTE: Matrix timestamps are in milliseconds.\n (let* ((a-ts (/ (ement-event-origin-server-ts (ewoc-data node-a)) 1000))\n (b-ts (/ (ement-event-origin-server-ts (ewoc-data node-b)) 1000))\n (diff-seconds (- b-ts a-ts))\n (ement-room-timestamp-header-format ement-room-timestamp-header-format))\n (when (and (>= diff-seconds ement-room-timestamp-header-delta)\n (not (when-let ((node-after-a (ewoc-next ewoc node-a)))\n (pcase (ewoc-data node-after-a)\n (`(ts . ,_) t)\n ((or 'ement-room-read-receipt-marker 'ement-room-fully-read-marker) t)))))\n (unless (equal (time-to-days a-ts) (time-to-days b-ts))\n ;; Different date: bind format to print date.\n (let ((ement-room-timestamp-header-format ement-room-timestamp-header-with-date-format))\n ;; Insert the date-only header.\n (setf node-a (ewoc-enter-after ewoc node-a (list 'ts b-ts)))))\n (with-silent-modifications\n ;; Avoid marking a buffer as modified just because we inserted a ts\n ;; header (this function may be called after other events which shouldn't\n ;; cause it to be marked modified, like moving the read markers).\n (ewoc-enter-after ewoc node-a (list 'ts b-ts))))))))\n\n(cl-defun ement-room--insert-sender-headers\n (ewoc &optional (start-node (ewoc-nth ewoc 0)) (end-node (ewoc-nth ewoc -1)))\n ;; TODO: Use this in appropriate places.\n \"Insert sender headers into EWOC.\nInserts headers between START-NODE and END-NODE, which default to\nthe first and last nodes in the buffer, respectively.\"\n (cl-labels ((message-event-p (data)\n (and (ement-event-p data)\n (equal \"m.room.message\" (ement-event-type data)))))\n (when (and start-node (not (message-event-p (ewoc-data start-node))))\n ;; Start node not a message event: forward to next message event (and if none are\n ;; found, there's nothing to do).\n (setf start-node (ement-room--ewoc-next-matching ewoc start-node #'message-event-p)))\n (when end-node\n ;; Set end node to first message event after it. (This simplifies the loop by\n ;; continuing until finding `end-node' or the last node, and ensures we fix headers\n ;; after any inserted messages.)\n (setf end-node (ement-room--ewoc-next-matching ewoc end-node #'message-event-p)))\n (let ((event-node start-node) prev-node)\n (while (and event-node (not (eq event-node end-node)))\n (setf prev-node\n ;; Find previous message or user header.\n (ement-room--ewoc-next-matching ewoc event-node\n (lambda (data)\n (or (ement-user-p data) (message-event-p data)))\n #'ewoc-prev))\n (let ((sender (ement-event-sender (ewoc-data event-node))))\n (cond ((not prev-node)\n ;; No previous message/sender: insert sender.\n (ewoc-enter-before ewoc event-node sender))\n ((ement-user-p (ewoc-data prev-node))\n ;; Previous node is a sender.\n (unless (equal sender (ewoc-data prev-node))\n ;; Previous node is the wrong sender: fix it.\n (ewoc-set-data prev-node sender)))\n ((and (message-event-p (ewoc-data prev-node))\n (not (equal sender (ement-event-sender (ewoc-data prev-node)))))\n ;; Previous node is a message from a different sender: insert header.\n (ewoc-enter-before ewoc event-node sender))))\n (setf event-node (ement-room--ewoc-next-matching ewoc event-node #'message-event-p))))))\n\n(defun ement-room--coalesce-nodes (a b ewoc)\n \"Try to coalesce events in nodes A and B in EWOC.\nReturn absorbing node if coalesced.\"\n ;; NOTE: This does not coalesce two `ement-room-membership-events' nodes; it only\n ;; coalesces an individual membership event into another one or into an\n ;; `ement-room-membership-events' node.\n ;; TODO: Allow two `ement-room-membership-events' nodes to be coalesced.\n (cl-labels ((coalescable-p (node)\n (or (and (ement-event-p (ewoc-data node))\n (member (ement-event-type (ewoc-data node)) '(\"m.room.member\")))\n (ement-room-membership-events-p (ewoc-data node)))))\n (when (and (coalescable-p a) (coalescable-p b))\n (let* ((absorbing-node (if (or (ement-room-membership-events-p (ewoc-data a))\n (not (ement-room-membership-events-p (ewoc-data b))))\n a b))\n (absorbed-node (if (eq absorbing-node a) b a)))\n (when (cl-etypecase (ewoc-data absorbing-node)\n (ement-room-membership-events\n (pcase-exhaustive ement-room-coalesce-events\n ((pred integerp)\n (< (length (ement-room-membership-events-events (ewoc-data absorbing-node)))\n ement-room-coalesce-events))\n (`t t)))\n (ement-event\n (setf (ewoc-data absorbing-node)\n (ement-room-membership-events--update\n (make-ement-room-membership-events\n :events (list (ewoc-data absorbing-node)))))))\n (push (ewoc-data absorbed-node)\n (ement-room-membership-events-events (ewoc-data absorbing-node)))\n (ement-room-membership-events--update (ewoc-data absorbing-node))\n (ewoc-delete ewoc absorbed-node)\n (ewoc-invalidate ewoc absorbing-node)\n absorbing-node)))))\n\n(defun ement-room--insert-event (event)\n \"Insert EVENT into current buffer.\"\n (cl-labels ((format-event (event)\n (format \"TS:%S (%s) Sender:%s Message:%S\"\n (/ (ement-event-origin-server-ts event) 1000)\n (format-time-string \"%Y-%m-%d %H:%M:%S\"\n (/ (ement-event-origin-server-ts event) 1000))\n (ement-user-id (ement-event-sender event))\n (when (alist-get 'body (ement-event-content event))\n (substring-no-properties\n (truncate-string-to-width (alist-get 'body (ement-event-content event)) 20)))))\n (find-node-if (ewoc pred &key (move #'ewoc-prev) (start (ewoc-nth ewoc -1)))\n \"Return node in EWOC whose data matches PRED.\nSearch starts from node START and moves by NEXT.\"\n (cl-loop for node = start then (funcall move ewoc node)\n while node\n when (funcall pred (ewoc-data node))\n return node))\n (timestamped-node-p (data)\n (pcase data\n ((pred ement-event-p) t)\n ((pred ement-room-membership-events-p) t)\n (`(ts . ,_) t)))\n (read-marker-p\n (data) (member data '(ement-room-fully-read-marker\n ement-room-read-receipt-marker)))\n (node-ts (data)\n (pcase data\n ((pred ement-event-p) (ement-event-origin-server-ts data))\n ((pred ement-room-membership-events-p)\n ;; Not sure whether to use earliest or latest ts; let's try this for now.\n (ement-room-membership-events-earliest-ts data))\n (`(ts ,ts)\n ;; Matrix server timestamps are in ms, so we must convert back.\n (* 1000 ts))))\n (node< (a b)\n \"Return non-nil if event A's timestamp is before B's.\"\n (< (node-ts a) (node-ts b))))\n (ement-debug \"INSERTING NEW EVENT: \" (format-event event))\n (let* ((ewoc ement-ewoc)\n (event-node-before (ement-room--ewoc-node-before ewoc event #'node< :pred #'timestamped-node-p))\n new-node)\n ;; HACK: Insert after any read markers.\n (cl-loop for node-after-node-before = (ewoc-next ewoc event-node-before)\n while node-after-node-before\n while (read-marker-p (ewoc-data node-after-node-before))\n do (setf event-node-before node-after-node-before))\n (setf new-node (if (not event-node-before)\n (progn\n (ement-debug \"No event before it: add first.\")\n (if-let ((first-node (ewoc-nth ewoc 0)))\n (progn\n (ement-debug \"EWOC not empty.\")\n (if (and (ement-user-p (ewoc-data first-node))\n (equal (ement-event-sender event)\n (ewoc-data first-node)))\n (progn\n (ement-debug \"First node is header for this sender: insert after it, instead.\")\n (setf event-node-before first-node)\n (ewoc-enter-after ewoc first-node event))\n (ement-debug \"First node is not header for this sender: insert first.\")\n (ewoc-enter-first ewoc event)))\n (ement-debug \"EWOC empty: add first.\")\n (ewoc-enter-first ewoc event)))\n (ement-debug \"Found event before new event: insert after it.\")\n (when-let ((next-node (ewoc-next ewoc event-node-before)))\n (when (and (ement-user-p (ewoc-data next-node))\n (equal (ement-event-sender event)\n (ewoc-data next-node)))\n (ement-debug \"Next node is header for this sender: insert after it, instead.\")\n (setf event-node-before next-node)))\n (ement-debug \"Inserting after event\"\n ;; NOTE: `format-event' is only for debugging, and it\n ;; doesn't handle user headers, so commenting it out or now.\n ;; (format-event (ewoc-data event-node-before))\n\n ;; NOTE: And it's *Very Bad* to pass the raw node data\n ;; to `ement-debug', because it makes event insertion\n ;; *Very Slow*. So we just comment that out for now.\n ;; (ewoc-data event-node-before)\n )\n (ewoc-enter-after ewoc event-node-before event)))\n (when ement-room-coalesce-events\n ;; Try to coalesce events.\n ;; TODO: Move this to a separate function and call it from where this function is called.\n (setf new-node (or (when event-node-before\n (ement-room--coalesce-nodes event-node-before new-node ewoc))\n (when (ewoc-next ewoc new-node)\n (ement-room--coalesce-nodes new-node (ewoc-next ewoc new-node) ewoc))\n new-node)))\n (when ement-room-sender-in-headers\n (ement-room--insert-sender-headers ewoc new-node new-node))\n ;; Return new node.\n new-node)))\n\n(defun ement-room--replace-event (new-event)\n \"Replace appropriate event with NEW-EVENT in current buffer.\nIf replaced event is not found, return nil, otherwise non-nil.\"\n (let* ((ewoc ement-ewoc)\n (old-event-node (ement-room--ewoc-last-matching ewoc\n (lambda (data)\n (cl-typecase data\n (ement-event (ement--events-equal-p data new-event)))))))\n (when old-event-node\n ;; TODO: Record old events in new event's local data, and make it accessible when inspecting the new event.\n (let ((node-before (ewoc-prev ewoc old-event-node))\n (inhibit-read-only t))\n (ewoc-delete ewoc old-event-node)\n (if node-before\n (ewoc-enter-after ewoc node-before new-event)\n (ewoc-enter-first ewoc new-event))))))\n\n(cl-defun ement-room--ewoc-node-before (ewoc data <-fn\n &key (from 'last) (pred #'identity))\n \"Return node in EWOC that matches PRED and belongs before DATA by <-FN.\nSearch from FROM (either `first' or `last').\"\n (cl-assert (member from '(first last)))\n (if (null (ewoc-nth ewoc 0))\n (ement-debug \"EWOC is empty: returning nil.\")\n (ement-debug \"EWOC has data: add at appropriate place.\")\n (cl-labels ((next-matching (ewoc node next-fn pred)\n (cl-loop do (setf node (funcall next-fn ewoc node))\n until (or (null node)\n (funcall pred (ewoc-data node)))\n finally return node)))\n (let* ((next-fn (pcase from ('first #'ewoc-next) ('last #'ewoc-prev)))\n (start-node (ewoc-nth ewoc (pcase from ('first 0) ('last -1)))))\n (unless (funcall pred (ewoc-data start-node))\n (setf start-node (next-matching ewoc start-node next-fn pred)))\n (if (funcall <-fn (ewoc-data start-node) data)\n (progn\n (ement-debug \"New data goes before start node.\")\n start-node)\n (ement-debug \"New data goes after start node: find node before new data.\")\n (let ((compare-node start-node))\n (cl-loop while (setf compare-node (next-matching ewoc compare-node next-fn pred))\n until (funcall <-fn (ewoc-data compare-node) data)\n finally return (if compare-node\n (progn\n (ement-debug \"Found place: enter there.\")\n compare-node)\n (ement-debug \"Reached end of collection: insert there.\")\n (pcase from\n ('first (ewoc-nth ewoc -1))\n ('last nil))))))))))\n\n;;;;; Formatting\n\n(defun ement-room--pp-thing (thing)\n \"Pretty-print THING.\nTo be used as the pretty-printer for `ewoc-create'. THING may be\nan `ement-event' or `ement-user' struct, or a list like `(ts\nTIMESTAMP)', where TIMESTAMP is a Unix timestamp number of\nseconds.\"\n ;; TODO: Use handlers to insert so e.g. membership events can be inserted silently.\n\n ;; TODO: Use `cl-defmethod' and define methods for each of these THING types. (I've\n ;; benchmarked thoroughly and found no difference in performance between using\n ;; `cl-defmethod' and using a `defun' with `pcase', so as long as the `cl-defmethod'\n ;; specializer is sufficient, I see no reason not to use it.)\n (pcase-exhaustive thing\n ((pred ement-event-p)\n (insert \"\" (ement-room--format-event thing ement-room ement-session)))\n ((pred ement-user-p)\n (insert (propertize (ement--format-user thing)\n 'display ement-room-username-display-property)))\n (`(ts ,(and (pred numberp) ts)) ;; Insert a date header.\n (let* ((string (format-time-string ement-room-timestamp-header-format ts))\n (width (string-width string))\n (maybe-newline (if (equal ement-room-timestamp-header-format ement-room-timestamp-header-with-date-format)\n ;; HACK: Rather than using another variable, compare the format strings to\n ;; determine whether the date is changing: if so, add a newline before the header.\n (progn\n (cl-incf width 3)\n \"\\n\")\n \"\"))\n (alignment-space (pcase ement-room-timestamp-header-align\n ('right (propertize \" \"\n 'display `(space :align-to (- text ,(1+ width)))))\n ('center (propertize \" \"\n 'display `(space :align-to (- center ,(/ (1+ width) 2)))))\n (_ \" \"))))\n (insert maybe-newline\n alignment-space\n (propertize string\n 'face 'ement-room-timestamp-header))))\n ((or 'ement-room-read-receipt-marker 'ement-room-fully-read-marker)\n (insert (propertize \" \"\n 'display '(space :width text :height (1))\n 'face thing)))\n ((pred ement-room-membership-events-p)\n (let ((formatted-events (ement-room--format-membership-events thing ement-room)))\n (add-face-text-property 0 (length formatted-events)\n 'ement-room-membership 'append formatted-events)\n (insert (ement-room-wrap-prefix formatted-events))))))\n\n;; (defun ement-room--format-event (event)\n;; \"Format `ement-event' EVENT.\"\n;; (pcase-let* (((cl-struct ement-event sender type content origin-server-ts) event)\n;; ((map body format ('formatted_body formatted-body)) content)\n;; (ts (/ origin-server-ts 1000)) ; Matrix timestamps are in milliseconds.\n;; (body (if (not formatted-body)\n;; body\n;; (pcase format\n;; (\"org.matrix.custom.html\"\n;; (ement-room--render-html formatted-body))\n;; (_ (format \"[unknown formatted-body format: %s] %s\" format body)))))\n;; (timestamp (propertize\n;; \" \" 'display `((margin left-margin)\n;; ,(propertize (format-time-string ement-room-timestamp-format ts)\n;; 'face 'ement-room-timestamp))))\n;; (body-face (pcase type\n;; (\"m.room.member\" 'ement-room-membership)\n;; (_ (if (equal (ement-user-id sender)\n;; (ement-user-id (ement-session-user ement-session)))\n;; 'ement-room-self-message 'default))))\n;; (string (pcase type\n;; (\"m.room.message\" body)\n;; (\"m.room.member\" \"\")\n;; (_ (format \"[unknown event-type: %s] %s\" type body)))))\n;; (add-face-text-property 0 (length body) body-face 'append body)\n;; (prog1 (concat timestamp string)\n;; ;; Hacky or elegant? We return the string, but for certain event\n;; ;; types, we also insert a widget (this function is called by\n;; ;; EWOC with point at the insertion position). Seems to work...\n;; (pcase type\n;; (\"m.room.member\"\n;; (widget-create 'ement-room-membership\n;; :button-face 'ement-room-membership\n;; :value (list (alist-get 'membership content))))))))\n\n(defun ement-room--format-event (event room session)\n \"Return EVENT in ROOM on SESSION formatted.\nFormats according to `ement-room-message-format-spec', which see.\"\n (concat (pcase (ement-event-type event)\n ;; TODO: Define these with a macro, like the defevent and format-spec ones.\n (\"m.room.message\" (ement-room--format-message event room session))\n (\"m.room.member\"\n (widget-create 'ement-room-membership\n :button-face 'ement-room-membership\n :value event)\n \"\")\n (\"m.reaction\"\n ;; Handled by defevent-based handler.\n \"\")\n (\"m.room.avatar\"\n (ement-room-wrap-prefix\n (format \"%s changed the room's avatar.\"\n (propertize (ement--user-displayname-in room (ement-event-sender event))\n 'help-echo (ement-user-id (ement-event-sender event))))\n 'face 'ement-room-membership))\n (\"m.room.power_levels\"\n (ement-room--format-power-levels-event event room session))\n (\"m.room.canonical_alias\"\n (ement-room--format-canonical-alias-event event room session))\n (_ (ement-room-wrap-prefix\n (format \"[sender:%s type:%s]\"\n (ement-user-id (ement-event-sender event))\n (ement-event-type event))\n 'help-echo (format \"%S\" (ement-event-content event)))))\n (propertize \" \"\n 'display ement-room-event-separator-display-property)))\n\n(defun ement-room--format-reactions (event room)\n \"Return formatted reactions to EVENT in ROOM.\"\n ;; TODO: Like other events, pop to a buffer showing the raw reaction events when a key is pressed.\n (cl-labels\n ((format-reaction (ks)\n (pcase-let* ((`(,key . ,senders) ks)\n (key (propertize key 'face 'ement-room-reactions-key))\n (count (propertize (format \" (%s)\"\n (if (length> senders ement-room-reaction-names-limit)\n (length senders)\n (senders-names senders room)))\n 'face 'ement-room-reactions))\n (string\n (propertize (concat key count)\n 'button '(t)\n 'category 'default-button\n 'action #'ement-room-reaction-button-action\n 'follow-link t\n 'help-echo (lambda (_window buffer _pos)\n ;; NOTE: If the reaction key string is a Unicode character composed\n ;; with, e.g. \"VARIATION SELECTOR-16\", `string-to-char' ignores the\n ;; composed modifier/variation-selector and just returns the first\n ;; character of the string. This should be fine, since it's just\n ;; for the tooltip.\n (concat\n (get-char-code-property (string-to-char key) 'name) \": \"\n (senders-names senders (buffer-local-value 'ement-room buffer))))))\n (local-user-p (cl-member (ement-user-id (ement-session-user ement-session)) senders\n :key #'ement-user-id :test #'equal)))\n (when local-user-p\n (add-face-text-property 0 (length string) '(:box (:style pressed-button) :inverse-video t)\n nil string))\n (ement--remove-face-property string 'button)\n string))\n (senders-names (senders room)\n (cl-loop for sender in senders\n collect (ement--user-displayname-in room sender)\n into names\n finally return (string-join names \", \"))))\n (if-let ((reactions (map-elt (ement-event-local event) 'reactions)))\n (cl-loop with keys-senders\n for reaction in reactions\n for key = (map-nested-elt (ement-event-content reaction) '(m.relates_to key))\n for sender = (ement-event-sender reaction)\n do (push sender (alist-get key keys-senders nil nil #'string=))\n finally do (setf keys-senders (cl-sort keys-senders #'> :key (lambda (pair) (length (cdr pair)))))\n finally return (concat \"\\n \" (mapconcat #'format-reaction keys-senders \" \")))\n \"\")))\n\n(cl-defun ement-room--format-message (event room session &optional (format ement-room-message-format-spec))\n \"Return EVENT in ROOM on SESSION formatted according to FORMAT.\nFormat defaults to `ement-room-message-format-spec', which see.\"\n ;; Bind this locally so formatters can modify it for this call.\n (let ((ement-room--format-message-margin-p)\n (left-margin-width ement-room-left-margin-width)\n (right-margin-width ement-room-right-margin-width))\n ;; Copied from `format-spec'.\n (with-current-buffer\n (or (get-buffer \" *ement-room--format-message*\")\n ;; TODO: Kill this buffer when disconnecting from all sessions.\n (with-current-buffer (get-buffer-create \" *ement-room--format-message*\")\n (setq buffer-undo-list t)\n (current-buffer)))\n (erase-buffer)\n ;; Pretend this is a room buffer.\n (setf ement-session session\n ement-room room)\n ;; HACK: Setting these buffer-locally in a temp buffer is ugly.\n (setq-local ement-room-left-margin-width left-margin-width)\n (setq-local ement-room-right-margin-width right-margin-width)\n (insert format)\n (goto-char (point-min))\n (while (search-forward \"%\" nil t)\n (cond\n ((eq (char-after) ?%)\n ;; Quoted percent sign.\n (delete-char 1))\n ((looking-at \"\\\\([-0-9.]*\\\\)\\\\([a-zA-Z]\\\\)\")\n ;; Valid format spec.\n (let* ((num (match-string 1))\n (spec (string-to-char (match-string 2)))\n (_\n ;; We delete the specifier now, because the formatter may change the\n ;; match data, and we already have what we need.\n (delete-region (1- (match-beginning 0)) (match-end 0)))\n (formatter (or (alist-get spec ement-room-event-formatters)\n (error \"Invalid format character: `%%%c'\" spec)))\n (val (or (funcall formatter event room session)\n (let ((print-level 1))\n (propertize (format \"[Event has no value for spec \\\"?%s\\\"]\" (char-to-string spec))\n 'face 'font-lock-comment-face\n 'help-echo (format \"%S\" event)))))\n ;; Pad result to desired length.\n (text (format (concat \"%\" num \"s\") val)))\n (insert text)))\n (t\n ;; Signal an error on bogus format strings.\n (error \"ement-room--format-message: Invalid format string: %S\" format))))\n ;; Propertize margin text.\n (when ement-room--format-message-wrap-prefix\n (when-let ((wrap-prefix-end (next-single-property-change (point-min) 'wrap-prefix-end)))\n (goto-char wrap-prefix-end)\n (delete-char 1)\n (let* ((prefix-width (string-width (buffer-substring-no-properties\n (line-beginning-position) (point))))\n (prefix (propertize \" \" 'display `((space :width ,prefix-width)))))\n ;; We apply the prefix to the entire event as `wrap-prefix', and to just the\n ;; body as `line-prefix'.\n (put-text-property (point-min) (point-max) 'wrap-prefix prefix)\n (put-text-property (point) (point-max) 'line-prefix prefix))))\n (when ement-room--format-message-margin-p\n (when-let ((left-margin-end (next-single-property-change (point-min) 'left-margin-end)))\n (goto-char left-margin-end)\n (delete-char 1)\n (let ((left-margin-text-width (string-width (buffer-substring-no-properties (point-min) (point)))))\n ;; It would be preferable to not have to allocate a string to\n ;; calculate the display width, but I don't know of another way.\n (put-text-property (point-min) (point)\n 'display `((margin left-margin)\n ,(buffer-substring (point-min) (point))))\n (save-excursion\n (goto-char (point-min))\n ;; Insert a string with a display specification that causes it to be displayed in the\n ;; left margin as a space that displays with the width of the difference between the\n ;; left margin's width and the display width of the text in the left margin (whew).\n ;; This is complicated, but it seems to work (minus a possible Emacs/Gtk bug that\n ;; sometimes causes the space to have a little \"junk\" displayed in it at times, but\n ;; that's not our fault). (And this is another example of how well-documented Emacs\n ;; is: this was only possible by carefully reading the Elisp manual.)\n (insert (propertize \" \" 'display `((margin left-margin)\n (space :width (- left-margin ,left-margin-text-width))))))))\n (when-let ((right-margin-start (next-single-property-change (point-min) 'right-margin-start)))\n (goto-char right-margin-start)\n (delete-char 1)\n (let ((string (buffer-substring (point) (point-max))))\n ;; Relocate its text to the beginning so it won't be\n ;; displayed at the last line of wrapped messages.\n (delete-region (point) (point-max))\n (goto-char (point-min))\n (insert-and-inherit\n (propertize \" \"\n 'display `((margin right-margin) ,string))))))\n (buffer-string))))\n\n(cl-defun ement-room--format-message-body (event session &key (formatted-p t))\n \"Return formatted body of \\\"m.room.message\\\" EVENT on SESSION.\nIf FORMATTED-P, return the formatted body content, when available.\"\n (pcase-let* (((cl-struct ement-event content\n (unsigned (map ('redacted_by unsigned-redacted-by)))\n (local (map ('redacted-by local-redacted-by))))\n event)\n ((map ('body main-body) msgtype ('format content-format) ('formatted_body formatted-body)\n ('m.relates_to (map ('rel_type rel-type)))\n ('m.new_content (map ('body new-body) ('formatted_body new-formatted-body)\n ('format new-content-format))))\n content)\n (body (or new-body main-body))\n (formatted-body (or new-formatted-body formatted-body))\n (body (if (or (not formatted-p) (not formatted-body))\n ;; Copy the string so as not to add face properties to the one in the struct.\n (copy-sequence body)\n (pcase (or new-content-format content-format)\n (\"org.matrix.custom.html\"\n (save-match-data\n (ement-room--render-html formatted-body)))\n (_ (format \"[unknown body format: %s] %s\"\n (or new-content-format content-format) body)))))\n (appendix (pcase msgtype\n ;; TODO: Face for m.notices.\n ((or \"m.text\" \"m.emote\" \"m.notice\") nil)\n (\"m.image\" (ement-room--format-m.image event session))\n (\"m.file\" (ement-room--format-m.file event))\n (\"m.video\" (ement-room--format-m.video event))\n (\"m.audio\" (ement-room--format-m.audio event))\n (_ (if (or local-redacted-by unsigned-redacted-by)\n nil\n (format \"[unsupported msgtype: %s]\" msgtype ))))))\n (when body\n ;; HACK: Once I got an error when body was nil, so let's avoid that.\n (setf body (ement-room--linkify-urls body)))\n ;; HACK: Ensure body isn't nil (e.g. redacted messages can have empty bodies).\n (unless body\n (setf body (copy-sequence\n ;; Yes, copying this string is necessary here too, otherwise a single\n ;; string will be used across every call to this function, whose face\n ;; properties will be added to every time in other functions, which will\n ;; make a very big mess of face properties if a room's buffer is opened\n ;; and closed a few times.\n (if (or local-redacted-by unsigned-redacted-by)\n \"[redacted]\"\n \"[message has no body content]\"))))\n (when appendix\n (setf body (concat body \" \" appendix)))\n (when (equal \"m.replace\" rel-type)\n ;; Message is an edit.\n (setf body (concat body \" \" (propertize \"[edited]\" 'face 'font-lock-comment-face))))\n (when (and (or local-redacted-by unsigned-redacted-by)\n ement-room-hide-redacted-message-content)\n ;; Message is redacted and hiding is enabled: override the body to hide the content.\n ;; (This is a bit of a hack, since we've already prepared the body at this point,\n ;; but retrofitting this into the existing logic is more than I want to do right\n ;; now. There are probably 3 or 4 different ways and places we could handle\n ;; redaction of content, and this seems like the simplest.)\n (setf body \"[redacted]\"))\n body))\n\n(defun ement-room--render-html (string)\n \"Return rendered version of HTML STRING.\nHTML is rendered to Emacs text using `shr-insert-document'.\"\n (with-current-buffer\n (or (get-buffer \" *ement-room--render-html*\")\n ;; TODO: Kill this buffer when disconnecting from all sessions.\n (with-current-buffer (get-buffer-create \" *ement-room--render-html*\")\n (setq buffer-undo-list t)\n (current-buffer)))\n (erase-buffer)\n (insert string)\n (save-excursion\n ;; NOTE: We workaround `shr`'s not indenting the blockquote properly (it\n ;; doesn't seem to compensate for the margin). I don't know exactly how\n ;; `shr-tag-blockquote' and `shr-mark-fill' and `shr-fill-line' and\n ;; `shr-indentation' work together, but through trial-and-error, this\n ;; seems to work. It even seems to work properly when a window is\n ;; resized (i.e. the wrapping is adjusted automatically by redisplay\n ;; rather than requiring the message to be re-rendered to HTML).\n (let ((shr-use-fonts ement-room-use-variable-pitch)\n (old-fn (symbol-function 'shr-tag-blockquote))) ;; Bind to a var to avoid unknown-function linting errors.\n (cl-letf (((symbol-function 'shr-fill-line) #'ignore)\n ((symbol-function 'shr-tag-blockquote)\n (lambda (dom)\n (let ((beg (point-marker)))\n (funcall old-fn dom)\n (add-text-properties beg (point-max)\n '( wrap-prefix \" \"\n line-prefix \" \"))\n ;; NOTE: We use our own gv, `ement-text-property'; very convenient.\n (add-face-text-property beg (point-max) 'ement-room-quote 'append)))))\n (shr-insert-document\n (libxml-parse-html-region (point-min) (point-max))))))\n (string-trim (buffer-substring (point) (point-max)))))\n\n(cl-defun ement-room--event-mentions-user-p (event user &optional (room ement-room))\n \"Return non-nil if EVENT in ROOM mentions USER.\"\n (pcase-let* (((cl-struct ement-event content) event)\n ((map body formatted_body) content)\n (body (or formatted_body body)))\n ;; FIXME: `ement--user-displayname-in' may not be returning the right result for the\n ;; local user, so test the displayname slot too. (But even that may be nil sometimes?\n ;; Something needs to be fixed...)\n ;; HACK: So we use the username slot, which was created just for this, for now.\n (when body\n (cl-macrolet ((matches-body-p\n (form) `(when-let ((string ,form))\n (string-match-p (regexp-quote string) body))))\n (or (matches-body-p (ement-user-username user))\n (matches-body-p (ement--user-displayname-in room user))\n (matches-body-p (ement-user-id user)))))))\n\n(defun ement-room--linkify-urls (string)\n \"Return STRING with URLs in it made clickable.\"\n ;; Is there an existing Emacs function to do this? I couldn't find one.\n ;; Yes, maybe: `goto-address-mode'. TODO: Try goto-address-mode.\n (with-temp-buffer\n (insert string)\n (goto-char (point-min))\n (cl-loop while (re-search-forward (rx bow \"http\" (optional \"s\") \"://\" (1+ (not space)))\n nil 'noerror)\n do (make-text-button (match-beginning 0) (match-end 0)\n 'mouse-face 'highlight\n 'face 'link\n 'help-echo (match-string 0)\n 'action #'browse-url-at-mouse\n 'follow-link t))\n (buffer-string)))\n\n;; NOTE: This function is not useful when displaynames are shown in the margin, because\n;; margins are not mouse-interactive in Emacs, therefore the help-echo function is called\n;; with the string and the position in the string, which leaves the buffer position\n;; unknown. So we have to set the help-echo to a string rather than a function. But the\n;; function may be useful in the future, so leaving it commented for now.\n\n;; (defun ement-room--user-help-echo (window _object pos)\n;; \"Return user ID string for POS in WINDOW.\n;; For use as a `help-echo' function on `ement-user' headings.\"\n;; (let ((data (with-selected-window window\n;; (ewoc-data (ewoc-locate ement-ewoc pos)))))\n;; (cl-typecase data\n;; (ement-event (ement-user-id (ement-event-sender data)))\n;; (ement-user (ement-user-id data)))))\n\n(defun ement-room--user-color (user)\n \"Return a color in which to display USER's messages.\"\n (cl-labels ((relative-luminance (rgb)\n ;; Copy of `modus-themes-wcag-formula', an elegant\n ;; implementation by Protesilaos Stavrou. Also see\n ;; and\n ;; .\n (cl-loop for k in '(0.2126 0.7152 0.0722)\n for x in rgb\n sum (* k (if (<= x 0.03928)\n (/ x 12.92)\n (expt (/ (+ x 0.055) 1.055) 2.4)))))\n (contrast-ratio (a b)\n ;; Copy of `modus-themes-contrast'; see above.\n (let ((ct (/ (+ (relative-luminance a) 0.05)\n (+ (relative-luminance b) 0.05))))\n (max ct (/ ct))))\n (increase-contrast (color against target toward)\n (let ((gradient (cdr (color-gradient color toward 20)))\n new-color)\n (cl-loop do (setf new-color (pop gradient))\n while new-color\n until (>= (contrast-ratio new-color against) target)\n ;; Avoid infinite loop in case of weirdness\n ;; by returning color as a fallback.\n finally return (or new-color color)))))\n (let* ((id (ement-user-id user))\n (id-hash (float (+ (abs (sxhash id)) ement-room-prism-color-adjustment)))\n ;; TODO: Wrap-around the value to get the color I want.\n (ratio (/ id-hash (float most-positive-fixnum)))\n (color-num (round (* (* 255 255 255) ratio)))\n (color-rgb (list (/ (float (logand color-num 255)) 255)\n (/ (float (ash (logand color-num 65280) -8)) 255)\n (/ (float (ash (logand color-num 16711680) -16)) 255)))\n (background-rgb (color-name-to-rgb (face-background 'default))))\n (when (< (contrast-ratio color-rgb background-rgb) ement-room-prism-minimum-contrast)\n (setf color-rgb (increase-contrast color-rgb background-rgb ement-room-prism-minimum-contrast\n (color-name-to-rgb (face-foreground 'default)))))\n (apply #'color-rgb-to-hex (append color-rgb (list 2))))))\n\n;;;;; Compose buffer\n\n;; Compose messages in a separate buffer, like `org-edit-special'.\n\n(defvar-local ement-room-compose-buffer nil\n \"Non-nil in buffers that are composing a message to a room.\")\n\n(cl-defun ement-room-compose-message (room session &key body)\n \"Compose a message to ROOM on SESSION.\nInteractively, with prefix, prompt for room and session,\notherwise use current room. With BODY, use it as the initial\nmessage contents.\"\n (interactive\n (ement-with-room-and-session\n (list ement-room ement-session)))\n (let* ((compose-buffer (generate-new-buffer (format \"*Ement compose: %s*\" (ement--room-display-name ement-room))))\n (send-message-filter ement-room-send-message-filter))\n (ement-room-compose-highlight compose-buffer)\n (with-current-buffer compose-buffer\n (ement-room-init-compose-buffer room session)\n (setf ement-room-send-message-filter send-message-filter)\n ;; TODO: Make mode configurable.\n (when body\n (insert body))\n\n ;; FIXME: Inexplicably, this doesn't do anything, so we comment it out for now.\n ;; (add-function :override (local 'org-mode)\n ;; ;; HACK: Since `org-mode' kills buffer-local variables we need, we add\n ;; ;; buffer-local advice to prevent that from happening in case a user enables it.\n ;; (lambda (&rest _ignore)\n ;; (message \"Use `ement-room-compose-org' to activate Org in this buffer\")))\n\n ;; NOTE: Surprisingly, we don't run this hook in `ement-room-init-compose-buffer',\n ;; because if a function in that hook calls the init function (like\n ;; `ement-room-compose-org' does), it makes `run-hooks' recursive. As long as this\n ;; is the only function that makes the compose buffer, and as long as none of the\n ;; hooks do anything that activating `org-mode' nullifies, this should be okay...\n (run-hooks 'ement-room-compose-hook))\n ;; Display the compose buffer. This might obscure the room buffer's window\n ;; point, so minimise the amount of scrolling which occurs to restore that\n ;; to a visible position.\n (pop-to-buffer compose-buffer ement-room-compose-buffer-display-action)\n (unless ement-room-compose-buffer-window-auto-height\n (let ((scroll-conservatively 101))\n (redisplay)))))\n\n(defun ement-room-compose-edit (event room session body)\n \"Edit EVENT in ROOM on SESSION to have new BODY, using a compose buffer.\nThe message must be one sent by the local user.\"\n ;; See also `ement-room-edit-message'.\n (interactive (cl-destructuring-bind (event body)\n (ement-room-edit-message-prepare)\n (list event ement-room ement-session body)))\n (cl-assert (ement-event-p event)) (cl-assert room) (cl-assert session)\n (let ((ement-room-editing-event event))\n (ement-room-with-highlighted-event-at (point)\n (ement-room-compose-message room session :body body))))\n\n(defun ement-room-compose-reply (event)\n \"Write and send a reply to EVENT, using a compose buffer.\nInteractively, to event at point.\"\n ;; See also `ement-room-write-reply'.\n (interactive (progn (cl-assert ement-ewoc)\n (list (ewoc-data (ewoc-locate ement-ewoc)))))\n (cl-assert ement-room) (cl-assert ement-session) (cl-assert (ement-event-p event))\n (let ((ement-room-replying-to-event event))\n (ement-room-with-highlighted-event-at (point)\n (ement-room-compose-message ement-room ement-session))))\n\n(defun ement-room-compose-from-minibuffer ()\n \"Edit the current message in a compose buffer.\nTo be called from a minibuffer opened from\n`ement-room-read-string'.\"\n (interactive)\n (cl-assert (minibufferp)) (cl-assert ement-room) (cl-assert ement-session)\n ;; TODO: When requiring Emacs 27, use `letrec'.\n ;; HACK: I can't seem to find a better way to do this, to exit the minibuffer without exiting this command too.\n (let* ((body (minibuffer-contents))\n (compose-fn-symbol (gensym (format \"ement-compose-%s\" (or (ement-room-canonical-alias ement-room)\n (ement-room-id ement-room)))))\n (input-method current-input-method) ; Capture this value from the minibuffer.\n (send-message-filter ement-room-send-message-filter)\n (replying-to-event ement-room-replying-to-event)\n (editing-event ement-room-editing-event)\n (compose-fn (lambda ()\n ;; HACK: Since exiting the minibuffer restores the previous window configuration,\n ;; we have to do some magic to get the new compose buffer to appear.\n ;; TODO: Use letrec with Emacs 27.\n (remove-hook 'minibuffer-exit-hook compose-fn-symbol)\n ;; FIXME: Probably need to unintern the symbol.\n (ement-room-compose-message ement-room ement-session :body body)\n\t\t ;; FIXME: This doesn't propagate the send-message-filter to the minibuffer.\n (setf ement-room-send-message-filter send-message-filter)\n (setq-local ement-room-replying-to-event replying-to-event\n ement-room-editing-event editing-event)\n (cond (replying-to-event\n (setq-local header-line-format\n (concat header-line-format\n (format \" (Replying to message from %s)\"\n (ement--user-displayname-in\n ement-room (ement-event-sender replying-to-event))))))\n (editing-event\n (setq-local header-line-format (concat header-line-format \" (Editing message)\"))))\n (let* ((compose-buffer (current-buffer))\n (show-buffer-fn-symbol (gensym \"ement-show-compose-buffer\"))\n (show-buffer-fn (lambda ()\n (remove-hook 'window-configuration-change-hook show-buffer-fn-symbol)\n ;; FIXME: Probably need to unintern the symbol.\n (pop-to-buffer compose-buffer ement-room-compose-buffer-display-action)\n (set-input-method input-method))))\n (fset show-buffer-fn-symbol show-buffer-fn)\n (add-hook 'window-configuration-change-hook show-buffer-fn-symbol)))))\n (fset compose-fn-symbol compose-fn)\n (add-hook 'minibuffer-exit-hook compose-fn-symbol)\n ;; Deactivate minibuffer's input method, otherwise subsequent\n ;; minibuffers will have it, too.\n (deactivate-input-method)\n (abort-recursive-edit)))\n\n(defun ement-room-compose-buffer-string-trimmed ()\n \"Like `buffer-string' trimmed with `string-trim'.\"\n (buffer-substring-no-properties (progn (goto-char (point-min))\n (skip-chars-forward \" \\t\\r\\n\")\n (point))\n (progn (goto-char (point-max))\n (skip-chars-backward \" \\t\\r\\n\")\n (point))))\n\n(defun ement-room-compose-send-prepare ()\n \"Bindings for `ement-room-compose-send' and `ement-room-compose-send-direct'.\"\n (cl-assert ement-room-compose-buffer)\n (cl-assert ement-room) (cl-assert ement-session)\n ;; Capture the necessary values from the compose buffer before killing it and\n ;; switching back to the room buffer. Return the values as a list.\n (let ((body (ement-room-compose-buffer-string-trimmed))\n (input-method current-input-method)\n (send-message-filter ement-room-send-message-filter)\n (replying-to-event ement-room-replying-to-event)\n (editing-event ement-room-editing-event)\n (room ement-room)\n (session ement-session))\n (ement-room-compose-buffer-quit-restore-window)\n (ement-view-room room session)\n (add-to-history 'ement-room-message-history body)\n (list body input-method send-message-filter replying-to-event editing-event room session)))\n\n(defun ement-room-compose-send ()\n \"Prompt to send the current compose buffer's contents.\nTo be called from an `ement-room-compose' buffer.\nSee also `ement-room-compose-send-direct'.\"\n (interactive)\n (cl-destructuring-bind (body input-method send-message-filter\n replying-to-event editing-event room session)\n (ement-room-compose-send-prepare)\n (let* ((prompt (format \"Send message (%s): \" (ement-room-display-name room)))\n (current-input-method input-method) ; Bind around read-string call.\n (ement-room-send-message-filter send-message-filter)\n (body (if (or editing-event replying-to-event)\n (let ((pos (ewoc-location (ement-room--ewoc-last-matching ement-ewoc\n (lambda (data)\n (eq data (or editing-event\n replying-to-event)))))))\n (ement-room-with-highlighted-event-at pos\n (ement-room-read-string prompt body 'ement-room-message-history\n nil 'inherit-input-method)))\n (ement-room-read-string prompt body 'ement-room-message-history\n nil 'inherit-input-method))))\n (if editing-event\n (ement-room-edit-message (ement--original-event-for editing-event session)\n room session body)\n (ement-room-send-message room session\n :body body\n :replying-to-event (and replying-to-event\n (ement--original-event-for\n replying-to-event session)))))))\n\n(defun ement-room-compose-send-direct ()\n \"Directly send the current compose buffer's contents.\nTo be called from an `ement-room-compose' buffer.\nSee also `ement-room-compose-send'.\"\n (interactive)\n (cl-destructuring-bind (body _input-method send-message-filter\n replying-to-event editing-event room session)\n (ement-room-compose-send-prepare)\n (let ((ement-room-send-message-filter send-message-filter))\n (if editing-event\n (ement-room-edit-message (ement--original-event-for editing-event session)\n room session body)\n (ement-room-send-message room session\n :body body\n :replying-to-event (and replying-to-event\n (ement--original-event-for\n replying-to-event session)))))))\n\n(defun ement-room-compose-abort (&optional no-history)\n \"Kill the compose buffer and window.\nWith prefix arg NO-HISTORY, do not add to `ement-room-message-history'.\"\n (interactive \"P\")\n (let ((body (ement-room-compose-buffer-string-trimmed))\n (room ement-room))\n (unless no-history\n (add-to-history 'ement-room-message-history body))\n (ement-room-compose-buffer-quit-restore-window)\n ;; Make sure we end up with the associated room buffer selected.\n (when-let ((win (catch 'room-win\n (walk-windows\n (lambda (win)\n (with-selected-window win\n (and (derived-mode-p 'ement-room-mode)\n (bound-and-true-p ement-room)\n (eq ement-room room)\n (throw 'room-win win))))))))\n (select-window win))))\n\n(defun ement-room-compose-abort-no-history ()\n \"Kill the compose buffer and window without adding to the history.\"\n (interactive)\n (ement-room-compose-abort t))\n\n(defun ement-room-init-compose-buffer (room session)\n \"Set up the current buffer as a compose buffer.\nSets ROOM and SESSION buffer-locally, binds `save-buffer' in\na copy of the local keymap, and sets `header-line-format'.\"\n ;; Using a macro for this seems awkward but necessary.\n (setq-local ement-room room)\n (setq-local ement-session session)\n (setq-local ement-room-replying-to-event ement-room-replying-to-event)\n (setq-local ement-room-editing-event ement-room-editing-event)\n (setf ement-room-compose-buffer t)\n (setq-local completion-at-point-functions\n (append '(ement-room--complete-members-at-point ement-room--complete-rooms-at-point)\n completion-at-point-functions))\n (setq-local dabbrev-select-buffers-function #'ement-compose-dabbrev-select-buffers\n dabbrev-friend-buffer-function #'ement-room-mode-p)\n (setq-local yank-excluded-properties\n (append '(line-prefix wrap-prefix)\n (default-value 'yank-excluded-properties)))\n (add-hook 'isearch-mode-hook 'ement-room-compose-history-isearch-setup nil t)\n ;; FIXME: Compose with local map?\n (use-local-map (if (current-local-map)\n (copy-keymap (current-local-map))\n (make-sparse-keymap)))\n ;; When `ement-room-self-insert-mode' is enabled, deleting the final character of the\n ;; message aborts and kills the compose buffer.\n (local-set-key [remap delete-backward-char]\n `(menu-item \"\" ement-room-compose-abort-no-history\n :filter ,(lambda (cmd)\n (and ement-room-self-insert-mode\n (<= (buffer-size) 1)\n (save-restriction (widen) (eobp))\n cmd))))\n (local-set-key [remap save-buffer] #'ement-room-dispatch-send-message)\n (local-set-key (kbd \"C-c C-k\") #'ement-room-compose-abort)\n (local-set-key (kbd \"M-p\") #'ement-room-compose-history-prev-message)\n (local-set-key (kbd \"M-n\") #'ement-room-compose-history-next-message)\n (local-set-key (kbd \"M-r\") #'ement-room-compose-history-isearch-backward)\n (local-set-key (kbd \"C-M-r\") #'ement-room-compose-history-isearch-backward-regexp)\n (setq header-line-format\n (concat (substitute-command-keys\n (format \" Press \\\\[save-buffer] to send message to room (%s), or \\\\[ement-room-compose-abort] to cancel.\"\n (ement-room-display-name room)))\n (cond (ement-room-replying-to-event\n (format \" (Replying to message from %s)\"\n (ement--user-displayname-in\n ement-room (ement-event-sender\n ement-room-replying-to-event))))\n (ement-room-editing-event\n \" (Editing message)\"))))\n ;; Adjust the window height automatically.\n (when ement-room-compose-buffer-window-auto-height\n (add-hook 'post-command-hook\n #'ement-room-compose-buffer-window-auto-height nil :local)\n ;; Our `window-min-height' comprises header & mode line + body lines.\n (setq-local window-min-height\n (+ 2 (if ement-room-compose-buffer-window-auto-height-min\n (max 1 ement-room-compose-buffer-window-auto-height-min)\n 1)))\n (when ement-room-compose-buffer-window-auto-height-fixed\n (setq-local window-size-fixed\n ement-room-compose-buffer-window-auto-height-fixed))\n ;; The following helps when `window--sanitize-window-sizes' adjusts all\n ;; windows in a frame (e.g. when splitting windows), as otherwise any\n ;; existing compose buffer windows are liable to be resized line-wise,\n ;; resulting in excess padding being introduced.\n (when ement-room-compose-buffer-window-auto-height-pixelwise\n (setq-local window-resize-pixelwise t)))\n ;; Other compose buffer window behaviours.\n (add-hook 'window-state-change-functions\n #'ement-room-compose-buffer-window-state-change-handler nil :local)\n (add-hook 'window-buffer-change-functions\n #'ement-room-compose-buffer-window-buffer-change-handler nil :local))\n\n(defun ement-room-compose-buffer-window-auto-height ()\n \"Ensure that the compose buffer displays the whole message.\n\nCalled via `post-command-hook' if option\n`ement-room-compose-buffer-window-auto-height' is non-nil.\"\n ;; We use `post-command-hook' (rather than, say, `after-change-functions'),\n ;; because the required window height might change for reasons other than text\n ;; editing (e.g. changes to the window's width or the font size).\n ;;\n ;; Note that changes to the default face size (e.g. via `text-scale-adjust')\n ;; affect `default-line-height', invalidating the cache even when the text\n ;; itself didn't change.\n ;;\n ;; The following may also clear the cache in order to force a recalculation:\n ;; - `ement-room-compose-buffer-window-state-change-handler'\n ;; - `ement-room-compose-buffer-window-buffer-change-handler'\n ;;\n ;; Global mutex `ement-room-compose-buffer-window-auto-height-resizing-p'\n ;; ensures that we cannot run recursively. We also resize only the selected\n ;; window, even if there are compose buffers displayed in other windows which\n ;; might also be affected. This conservative approach can prevent desirable\n ;; resizing in some cases, but restricting our behaviour this way keeps things\n ;; simple so that we needn't consider potential issues such as endless cycles\n ;; of conflicting resizes.\n ;;\n ;; Perfection would in any case be non-trivial -- consider two compose windows\n ;; side-by-side in a horizontal split, each showing a different compose buffer\n ;; with a different desired height. We cannot have the \"correct\" size for\n ;; both simultaneously. The best thing to do would be to maintain the tallest\n ;; height amongst all conflicting windows at all times -- but that is, again,\n ;; considerably more complex.\n ;;\n ;; Most of the time the window arrangements are expected to be very simple and\n ;; so a more comprehensive solution, while possible, is not worth the added\n ;; complexity -- our relatively simplistic approach is good enough for the\n ;; vast majority of situations.\n\n ;; Skip resizing if we are being called recursively...\n (unless (or (bound-and-true-p ement-room-compose-buffer-window-auto-height-resizing-p)\n ;; ...or there are no other windows to resize...\n (window-full-height-p)\n ;; ...or we have just switched to this buffer from another buffer\n ;; (we may be cycling window buffers, and about to switch again).\n (and (window-old-buffer)\n (not (eq (window-old-buffer) (current-buffer)))))\n ;; Manipulate the window body height.\n (let* ((pixelwise (and ement-room-compose-buffer-window-auto-height-pixelwise\n (display-graphic-p)))\n (lineheight (and pixelwise (default-line-height)))\n (buflines (max 1 (count-screen-lines nil nil t)))\n (cache (if pixelwise\n (* buflines lineheight)\n buflines))\n (wcache (window-parameter\n nil 'ement-room-compose-buffer-window-auto-height-cache)))\n ;; Do nothing if the desired height has not changed.\n (unless (and wcache (eql cache wcache))\n ;; Otherwise resize the window...\n (set-window-parameter\n nil 'ement-room-compose-buffer-window-auto-height-cache cache)\n (let* ((ement-room-compose-buffer-window-auto-height-resizing-p t)\n (minheight (if ement-room-compose-buffer-window-auto-height-min\n (max 1 ement-room-compose-buffer-window-auto-height-min)\n 1))\n (maxheight ement-room-compose-buffer-window-auto-height-max)\n (maxlines (or (and maxheight (min buflines maxheight))\n buflines))\n (reqlines (max maxlines minheight)))\n (if pixelwise\n ;; In GUI frames we should do this in pixels, as the line-based\n ;; `window-resize' DELTA is based on the default frame character\n ;; height, rather than the buffer's `default-line-height', which\n ;; doesn't take face remapping (e.g. `text-scale-adjust') into\n ;; account and would therefore enlarge the window by the wrong\n ;; value. Pixel-based resizing also lets us eliminate vertical\n ;; padding resulting from the body lines being a different height\n ;; to the mode- and/or header-line height (which can easily happen\n ;; in GUI frames and is distractingly obvious in a small window\n ;; which is supposed to fit its content).\n (let* ((window-resize-pixelwise t)\n (pixheight (* lineheight reqlines))\n (pixels (- pixheight (window-body-height nil t))))\n (when-let ((pixels (window-resizable nil pixels nil t t)))\n (window-resize nil pixels nil t t)))\n ;; In terminal frames we deal in lines rather than pixels.\n (let ((delta (- reqlines (window-body-height))))\n (when-let ((delta (window-resizable nil delta nil t)))\n (window-resize nil delta nil t))))\n ;; Ask Emacs to \"preserve\" the new height. So long as the window\n ;; maintains this height and is displaying this specific buffer, Emacs\n ;; will avoid unnecessary height changes from side-effects of commands\n ;; such as `balance-windows'. Explicit height changes are allowed.\n ;; We must update this parameter every time we change the height so\n ;; that the \"preserved\" height value is always correct.\n (window-preserve-size nil nil t)\n ;; In most cases we can fit the whole buffer in the resized window.\n (set-window-start nil (point-min) :noforce)\n ;; The resizing might have obscured the room buffer's window point, so\n ;; minimise the amount of scrolling which occurs to restore that to a\n ;; visible position.\n (let ((scroll-conservatively 101))\n (redisplay)))))))\n\n(defun ement-room-compose-buffer-window-state-change-handler (win)\n \"Called via buffer-local `window-state-change-functions' in compose buffers.\n\nCalled for any window WIN showing a compose buffer if that window\nhas been added or assigned another buffer, changed size, or been\nselected or deselected.\n\nThis prevents a compose buffer window being stuck at the wrong\nheight (until the number of lines changes again) if something\nother than the auto-height feature resizes the window. We simply\nflush the auto-height cache, thus ensuring the required height is\nrecalculated on the next cycle).\n\nSee also `ement-room-compose-buffer-window-buffer-change-handler'.\"\n ;; Ignore the window state changes triggered by our auto-height resizing.\n ;;\n ;; Also do nothing if the state change is for the selected window, as\n ;; the buffer-local `post-command-hook' is already dealing with that\n ;; case. We only care about window state changes which are triggered\n ;; from elsewhere. This means we skip the case whereby the selected\n ;; window has just switched to the compose buffer, and so we use\n ;; `window-buffer-change-functions' as well to capture that case.\n ;; (See `ement-room-compose-buffer-window-buffer-change-handler'.)\n (when ement-room-compose-buffer-window-auto-height\n (unless (or (bound-and-true-p ement-room-compose-buffer-window-auto-height-resizing-p)\n (eq win (selected-window)))\n ;; Clear the auto-height cache for this window.\n (set-window-parameter\n win 'ement-room-compose-buffer-window-auto-height-cache nil))))\n\n(defun ement-room-compose-buffer-window-buffer-change-handler (win)\n \"Called via buffer-local `window-buffer-change-functions' in compose buffers.\n\nCalled for any window WIN showing a compose buffer if that window\nhas just been created or assigned that buffer.\n\nFlush the auto-height cache for any window which switches to\ndisplaying a compose buffer, to ensure the required height is\nrecalculated on the next cycle.\n\nAlso detect whether a composer buffer's window was created for\nthat purpose, as this information affects the behaviour of\n`ement-room-compose-buffer-quit-restore-window'.\n\nSee also `ement-room-compose-buffer-window-state-change-handler'.\"\n (with-selected-window win\n (when ement-room-compose-buffer-window-auto-height\n ;; Clear the auto-height cache for this window.\n (set-window-parameter\n win 'ement-room-compose-buffer-window-auto-height-cache nil))\n ;; Establish whether we've processed this window before, and whether it was\n ;; created to display a compose buffer. We set a window property the first\n ;; time that we see the window, so if it's set at all, we've seen it before.\n (unless (assq 'ement-room-compose-buffer-window-created-p (window-parameters win))\n ;; If the window has never shown any other buffer, then it was created\n ;; specifically to display a compose buffer.\n (let ((created-for-compose-p (set-window-parameter\n win 'ement-room-compose-buffer-window-created-p\n (not (window-prev-buffers win)))))\n ;; Process `ement-room-compose-buffer-window-dedicated' when the compose\n ;; buffer is first displayed in this window, to decide whether the\n ;; window should be dedicated to the buffer.\n (when (cl-case ement-room-compose-buffer-window-dedicated\n (created created-for-compose-p)\n (auto-height ement-room-compose-buffer-window-auto-height)\n (delete nil)\n (t ement-room-compose-buffer-window-dedicated))\n (set-window-dedicated-p win t))))))\n\n(defun ement-room-compose-buffer-quit-restore-window ()\n \"Kill the current compose buffer and deal appropriately with its window.\n\nThe default `ement-room-compose-buffer-window-dedicated' value\nensures that the window is dedicated and therefore that it will\nbe deleted.\n\nA non-dedicated window which has displayed another buffer at any\npoint will not be deleted.\"\n ;; N.b. This function exists primarily for documentation purposes,\n ;; to clarify the side-effect of using a dedicated window.\n (when (eq ement-room-compose-buffer-window-dedicated 'delete)\n ;; `quit-restore-window' always deletes a dedicated window.\n (set-window-dedicated-p nil t))\n (quit-restore-window nil 'kill))\n\n(declare-function dabbrev--select-buffers \"dabbrev\")\n\n(defun ement-compose-dabbrev-select-buffers ()\n \"Used as `dabbrev-select-buffers-function' in compose buffers.\"\n (let ((buflist (dabbrev--select-buffers))\n (roombuf (map-elt (ement-room-local ement-room) 'buffer)))\n (if (and roombuf (buffer-live-p roombuf))\n (cons roombuf (delq roombuf buflist))\n buflist)))\n\n(defun ement-room-mode-p (buffer)\n \"Non-nil if BUFFER has `ement-room-mode' as its major mode.\nUsed with `dabbrev-friend-buffer-function'.\"\n (with-current-buffer buffer\n (derived-mode-p 'ement-room-mode)))\n\n;;; Message history for compose buffers. Isearch code is derived from comint.el.\n\n(defvar-local ement-room--compose-message-history-index -1)\n(defvar-local ement-room--compose-message-history-initial \"\")\n(defvar-local ement-room--compose-history-isearch nil)\n\n(defun ement-room-compose-message-history-insert (hist-pos &optional with-message)\n \"Insert text of the absolute history position HIST-POS.\"\n ;; Store the not-from-history buffer message.\n (when (< ement-room--compose-message-history-index 0)\n (setq ement-room--compose-message-history-initial\n (ement-room-compose-buffer-string-trimmed)))\n ;; Update the index.\n (setq ement-room--compose-message-history-index (or hist-pos -1))\n (when (and with-message hist-pos (>= hist-pos 0))\n (let ((message-log-max nil))\n (message \"History item %d\" hist-pos)))\n ;; Update the buffer.\n (erase-buffer)\n (insert (if (< ement-room--compose-message-history-index 0)\n ement-room--compose-message-history-initial\n (or (nth ement-room--compose-message-history-index\n ement-room-message-history)\n (format \"[invalid ement message history element %d]\"\n ement-room--compose-message-history-index)))))\n\n(defun ement-room-compose-history-prev-message (arg)\n \"Cycle backward through message history, after saving current message.\nWith a numeric prefix ARG, go back ARG messages.\"\n (interactive \"*p\")\n (let ((len (length ement-room-message-history)))\n ;; Valid index values: -1 <= idx < len.\n (cond ((<= len 0)\n (user-error \"Empty message history\"))\n ((eql arg 0)) ;; No-op.\n ((and (> arg 0) (>= ement-room--compose-message-history-index (1- len)))\n (user-error \"Beginning of history; no preceding item\"))\n ((and (< arg 0) (< ement-room--compose-message-history-index 0))\n (user-error \"End of history; no next item\"))\n (t\n ;; It's still possible to move in the specified direction.\n (ement-room-compose-message-history-insert\n (let ((hist-pos (+ arg ement-room--compose-message-history-index)))\n (cond ((>= hist-pos len) (1- len))\n ((< hist-pos -1) -1)\n (t hist-pos)))\n :with-message)))))\n\n(defun ement-room-compose-history-next-message (arg)\n \"Cycle forward through message history, after saving current message.\nWith a numeric prefix ARG, go forward ARG messages.\"\n (interactive \"*p\")\n (ement-room-compose-history-prev-message (- arg)))\n\n(defun ement-room-compose-history-isearch-backward ()\n \"Search for a string in the message history using Isearch.\nUse \\\\[isearch-backward] and \\\\[isearch-forward] to continue searching.\"\n (interactive)\n (setq ement-room--compose-history-isearch t)\n (isearch-backward nil t))\n\n(defun ement-room-compose-history-isearch-backward-regexp ()\n \"Search for a regular expression in the message history using Isearch.\nUse \\\\[isearch-backward] and \\\\[isearch-forward] to continue searching.\"\n (interactive)\n (setq ement-room--compose-history-isearch t)\n (isearch-backward-regexp nil t))\n\n(defun ement-room-compose-history-isearch-setup ()\n \"Set up Isearch to search `ement-room-message-history'.\nIntended to be added to `isearch-mode-hook' in an ement compose buffer.\"\n (when (eq ement-room--compose-history-isearch t)\n (setq isearch-message-prefix-add \"history \")\n (setq-local isearch-search-fun-function\n #'ement-room-compose-history-isearch-search)\n (setq-local isearch-message-function\n #'ement-room-compose-history-isearch-message)\n (setq-local isearch-wrap-function\n #'ement-room-compose-history-isearch-wrap)\n (setq-local isearch-push-state-function\n #'ement-room-compose-history-isearch-push-state)\n (setq-local isearch-lazy-count nil)\n (add-hook 'isearch-mode-end-hook 'ement-room-compose-history-isearch-end nil t)))\n\n(defun ement-room-compose-history-isearch-end ()\n \"Clean up the buffer after terminating Isearch.\nCalled via `isearch-mode-end-hook'.\"\n (setq isearch-message-prefix-add nil)\n (setq isearch-search-fun-function 'isearch-search-fun-default)\n (setq isearch-wrap-function nil)\n (setq isearch-push-state-function nil)\n ;; Force isearch to not change mark.\n (setq isearch-opoint (point))\n (kill-local-variable 'isearch-lazy-count)\n (remove-hook 'isearch-mode-end-hook 'ement-room-compose-history-isearch-end t)\n (unless isearch-suspended\n (setq ement-room--compose-history-isearch nil)))\n\n(defun ement-room-compose-history-isearch-search ()\n \"Return the search function for Isearch in message history.\nThis function is used as the value of `isearch-search-fun-function'.\"\n #'ement-room-compose-history-isearch-function)\n\n(defun ement-room-compose-history-isearch-function (string bound noerror)\n \"Isearch in message history.\"\n (let ((search-fun\n\t ;; Use standard functions to search within message text\n\t (isearch-search-fun-default))\n\tfound)\n (or\n ;; 1. First try searching in the initial message\n (funcall search-fun string nil noerror)\n ;; 2. If the above search fails, start putting next/prev history elements in the\n ;; buffer successively, and search the string in them. Do this only when bound is\n ;; nil (i.e. not while lazy-highlighting search strings in the current message).\n (unless bound\n (condition-case nil\n\t (progn\n\t (while (not found)\n\t (if isearch-forward\n\t\t (ement-room-compose-history-next-message 1)\n\t\t (ement-room-compose-history-prev-message 1))\n (goto-char (if isearch-forward (point-min) (point-max)))\n\t (setq isearch-barrier (point)\n isearch-opoint (point))\n\t ;; After putting the next/prev history element, search the string in\n ;; them again, until `ement-room-compose-history-next-message' or\n\t ;; `ement-room-compose-history-prev-message' raises an error at the\n\t ;; beginning/end of history.\n\t (setq found (funcall search-fun string nil noerror)))\n\t ;; Return point of the new search result.\n\t (point))\n\t ;; Return nil on any isearch errors, including the \"no next/preceding item\"\n ;; user-errors signalled from `ement-room-compose-history-prev-message'.\n (error nil))))))\n\n(defun ement-room-compose-history-isearch-message (&optional c-q-hack ellipsis)\n \"Display the isearch message.\nThis function is used as the value of `isearch-message-function'.\"\n (setq isearch-message-prefix-add\n (if (and isearch-success\n (not isearch-error)\n (>= ement-room--compose-message-history-index 0))\n (format \"history item %d: \"\n ement-room--compose-message-history-index)\n \"history \"))\n (isearch-message c-q-hack ellipsis))\n\n(defun ement-room-compose-history-isearch-wrap ()\n \"Wrap the history search when search fails.\nMove point to the first history element for a forward search,\nor to the last history element for a backward search.\nThis function is used as the value of `isearch-wrap-function'.\"\n ;; When `ement-room-compose-history-isearch-search' fails on reaching the\n ;; beginning/end of the history, wrap the search to the first/last\n ;; input history element.\n (ement-room-compose-message-history-insert\n (if isearch-forward\n (1- (length ement-room-message-history))\n -1))\n (goto-char (if isearch-forward (point-min) (point-max))))\n\n(defun ement-room-compose-history-isearch-push-state ()\n \"Save a function restoring the state of input history search.\nSave `ement-room--compose-message-history-index' to the additional state parameter\nin the search status stack.\nThis function is used as the value of `isearch-push-state-function'.\"\n (let ((index ement-room--compose-message-history-index))\n (lambda (cmd)\n (ement-room-compose-history-isearch-pop-state cmd index))))\n\n(defun ement-room-compose-history-isearch-pop-state (_cmd hist-pos)\n \"Restore the input history search state.\nGo to the history element by the absolute history position HIST-POS.\nSee `ement-room-compose-history-isearch-push-state'.\"\n (ement-room-compose-message-history-insert hist-pos))\n\n;;;;; Widgets\n\n(require 'widget)\n\n(define-widget 'ement-room-membership 'item\n \"Widget for membership events.\"\n ;; FIXME: This makes it hard to add a timestamp according to the buffer's message format spec.\n ;; NOTE: The widget needs something before and after \"%v\" to correctly apply the\n ;; `ement-room-membership' face. We could use a zero-width space, but that won't work on\n ;; a TTY. So we use a regular space but replace it with nothing with a display spec.\n :format (let ((zws (propertize \" \" 'display \"\")))\n (concat \"%{\" zws \"%v\" zws \"%}\"))\n :sample-face 'ement-room-membership\n :value-create (lambda (widget)\n (pcase-let* ((event (widget-value widget)))\n (insert (ement-room-wrap-prefix\n (ement-room--format-member-event event ement-room))))))\n\n(defun ement-room--format-member-event (event room)\n \"Return formatted string for \\\"m.room.member\\\" EVENT in ROOM.\"\n ;; SPEC: Section 9.3.4: \"m.room.member\".\n (pcase-let* (((cl-struct ement-event sender state-key\n (content (map reason ('avatar_url new-avatar-url)\n ('membership new-membership) ('displayname new-displayname)))\n (unsigned (map ('prev_content (map ('avatar_url old-avatar-url)\n ('membership prev-membership)\n ('displayname prev-displayname))))))\n event)\n (sender-name (ement--user-displayname-in ement-room sender)))\n (cl-macrolet ((nes (var)\n ;; For \"non-empty-string\". Needed because the displayname can be\n ;; an empty string, but apparently is never null. (Note that the\n ;; argument should be a variable, never any other form, to avoid\n ;; multiple evaluation.)\n `(when (and ,var (not (string-empty-p ,var)))\n ,var))\n (sender-name-id-string ()\n `(propertize sender-name\n 'help-echo (ement-user-id sender)))\n (new-displayname-sender-name-state-key-string ()\n `(propertize (or (nes new-displayname) (nes sender-name) (nes state-key))\n 'help-echo state-key))\n (sender-name-state-key-string ()\n `(propertize sender-name\n 'help-echo state-key))\n (prev-displayname-id-string ()\n `(propertize (or prev-displayname sender-name)\n 'help-echo (ement-user-id sender))))\n (pcase-exhaustive new-membership\n (\"invite\"\n (pcase prev-membership\n ((or \"leave\" '())\n (format \"%s invited %s\"\n (sender-name-id-string)\n (new-displayname-sender-name-state-key-string)))\n (_ (format \"%s sent unrecognized invite event for %s\"\n (sender-name-id-string)\n (new-displayname-sender-name-state-key-string)))))\n (\"join\"\n (pcase prev-membership\n (\"invite\"\n (format \"%s accepted invitation to join\"\n (sender-name-state-key-string)))\n (\"join\"\n (cond ((not (equal new-displayname prev-displayname))\n (propertize (format \"%s changed name to %s\"\n prev-displayname (or new-displayname (ement--user-displayname-in room sender)))\n 'help-echo state-key))\n ((not (equal new-avatar-url old-avatar-url))\n (format \"%s changed avatar\"\n (new-displayname-sender-name-state-key-string)))\n (t (format \"Unrecognized membership event for %s\"\n (sender-name-state-key-string)))))\n (\"leave\"\n (format \"%s rejoined\"\n (sender-name-state-key-string)))\n (`nil\n (format \"%s joined\"\n (new-displayname-sender-name-state-key-string)))\n (_ (format \"%s sent unrecognized join event for %s\"\n (sender-name-id-string)\n (new-displayname-sender-name-state-key-string)))))\n (\"leave\"\n (pcase prev-membership\n (\"invite\"\n (pcase state-key\n ((pred (equal (ement-user-id sender)))\n (format \"%s rejected invitation\"\n (sender-name-id-string)))\n (_ (format \"%s revoked %s's invitation\"\n (sender-name-id-string)\n (new-displayname-sender-name-state-key-string)))))\n (\"join\"\n (pcase state-key\n ((pred (equal (ement-user-id sender)))\n (format \"%s left%s\"\n (prev-displayname-id-string)\n (if reason\n (format \" (%S)\" reason)\n \"\")))\n (_ (format \"%s kicked %s%s\"\n (sender-name-id-string)\n (propertize (or prev-displayname state-key)\n 'help-echo state-key)\n (if reason\n (format \" (%S)\" reason)\n \"\")))))\n (\"ban\"\n (format \"%s unbanned %s\"\n (sender-name-id-string)\n state-key))\n (_ (format \"%s left%s\"\n (prev-displayname-id-string)\n (if reason\n (format \" (%S)\" reason)\n \"\")))))\n (\"ban\"\n (pcase prev-membership\n ((or \"invite\" \"leave\")\n (format \"%s banned %s%s\"\n (sender-name-id-string)\n (propertize (or prev-displayname state-key)\n 'help-echo state-key)\n (if reason\n (format \" (%S)\" reason)\n \"\")))\n (\"join\"\n (format \"%s kicked and banned %s%s\"\n (sender-name-id-string)\n (propertize (or prev-displayname state-key)\n 'help-echo state-key)\n (if reason\n (format \" (%S)\" reason)\n \"\")))\n (_ (format \"%s sent unrecognized ban event for %s\"\n (sender-name-id-string)\n (propertize (or prev-displayname state-key)\n 'help-echo state-key)))))))))\n\n;; NOTE: Widgets are only currently used for single membership events, not grouped ones.\n\n(defun ement-room--format-membership-events (struct room)\n \"Return string for STRUCT in ROOM.\nSTRUCT should be an `ement-room-membership-events' struct.\"\n (cl-labels ((event-user (event)\n (propertize (if-let (user (gethash (ement-event-state-key event) ement-users))\n (ement--user-displayname-in room user)\n (ement-event-state-key event))\n 'help-echo (concat (ement-room--format-member-event event room)\n \" <\" (ement-event-state-key event) \">\")))\n (old-membership (event)\n (map-nested-elt (ement-event-unsigned event) '(prev_content membership)))\n (new-membership (event)\n (alist-get 'membership (ement-event-content event))))\n (pcase-let* (((cl-struct ement-room-membership-events events) struct))\n (pcase (length events)\n (0 (warn \"No events in `ement-room-membership-events' struct\"))\n (1 (ement-room--format-member-event (car events) room))\n (_ (let* ((left-events (cl-remove-if-not (lambda (event)\n (and (equal \"leave\" (new-membership event))\n (not (member (old-membership event) '(\"ban\" \"invite\")))))\n events))\n (join-events (cl-remove-if-not (lambda (event)\n (and (equal \"join\" (new-membership event))\n (not (equal \"join\" (old-membership event)))))\n events))\n (rejoin-events (cl-remove-if-not (lambda (event)\n (and (equal \"join\" (new-membership event))\n (equal \"leave\" (old-membership event))))\n events))\n (invite-events (cl-remove-if-not (lambda (event)\n (equal \"invite\" (new-membership event)))\n events))\n (reject-events (cl-remove-if-not (lambda (event)\n (and (equal \"invite\" (old-membership event))\n (equal \"leave\" (new-membership event))))\n events))\n (ban-events (cl-remove-if-not (lambda (event)\n (and (member (old-membership event) '(\"invite\" \"leave\"))\n (equal \"ban\" (new-membership event))))\n events))\n (unban-events (cl-remove-if-not (lambda (event)\n (and (equal \"ban\" (old-membership event))\n (equal \"leave\" (new-membership event))))\n events))\n (kicked-events (cl-remove-if-not (lambda (event)\n (and (equal \"join\" (old-membership event))\n (equal \"leave\" (new-membership event))\n (not (equal (ement-user-id (ement-event-sender event))\n (ement-event-state-key event)))))\n events))\n (kick-and-ban-events (cl-remove-if-not (lambda (event)\n (and (equal \"join\" (old-membership event))\n (equal \"ban\" (new-membership event))))\n events))\n (rename-events (cl-remove-if-not (lambda (event)\n (and (equal \"join\" (old-membership event))\n (equal \"join\" (new-membership event))\n (equal (alist-get 'avatar_url (ement-event-content event))\n (map-nested-elt (ement-event-unsigned event)\n '(prev_content avatar_url)))))\n events))\n (avatar-events (cl-remove-if-not (lambda (event)\n (and (equal \"join\" (old-membership event))\n (equal \"join\" (new-membership event))\n (not (equal (alist-get 'avatar_url (ement-event-content event))\n (map-nested-elt (ement-event-unsigned event)\n '(prev_content avatar_url))))))\n events))\n join-and-leave-events rejoin-and-leave-events kicked-and-rejoined-events)\n ;; Remove apparent duplicates between join/rejoin events.\n (setf join-events (cl-delete-if (lambda (event)\n (cl-find (ement-event-state-key event) rejoin-events\n :test #'equal :key #'ement-event-state-key))\n join-events)\n rejoin-events (cl-delete-if (lambda (event)\n (cl-find (ement-event-state-key event) join-events\n :test #'equal :key #'ement-event-state-key))\n rejoin-events)\n join-and-leave-events (cl-loop for join-event in join-events\n for left-event = (cl-find (ement-event-state-key join-event) left-events\n :test #'equal :key #'ement-event-state-key)\n when left-event\n collect left-event\n and do (setf join-events (cl-delete (ement-event-state-key join-event) join-events\n :test #'equal :key #'ement-event-state-key)\n left-events (cl-delete (ement-event-state-key left-event) left-events\n :test #'equal :key #'ement-event-state-key)))\n kicked-and-rejoined-events (cl-loop for rejoin-event in rejoin-events\n for kicked-event = (cl-find (ement-event-state-key rejoin-event) kicked-events\n :test #'equal :key #'ement-event-state-key)\n when kicked-event collect kicked-event\n and do (setf rejoin-events (cl-delete (ement-event-state-key kicked-event) rejoin-events\n :test #'equal :key #'ement-event-state-key)\n left-events (cl-delete (ement-event-state-key kicked-event) left-events\n :test #'equal :key #'ement-event-state-key)))\n rejoin-and-leave-events (cl-loop for rejoin-event in rejoin-events\n for left-event = (cl-find (ement-event-state-key rejoin-event) left-events\n :test #'equal :key #'ement-event-state-key)\n when left-event\n collect left-event\n and do (setf rejoin-events (cl-delete\n (ement-event-state-key rejoin-event) rejoin-events\n :test #'equal :key #'ement-event-state-key)\n left-events (cl-delete (ement-event-state-key left-event) left-events\n :test #'equal :key #'ement-event-state-key))))\n (format \"Membership: %s.\"\n (string-join (cl-loop for (type . events)\n in (ement-alist \"rejoined\" rejoin-events\n \"joined\" join-events\n \"left\" left-events\n \"joined and left\" join-and-leave-events\n \"was kicked and rejoined\" kicked-and-rejoined-events\n \"rejoined and left\" rejoin-and-leave-events\n \"invited\" invite-events\n \"rejected invitation\" reject-events\n \"banned\" ban-events\n \"unbanned\" unban-events\n \"kicked and banned\" kick-and-ban-events\n \"changed name\" rename-events\n \"changed avatar\" avatar-events)\n for users = (mapcar #'event-user\n (cl-delete-duplicates\n events :key #'ement-event-state-key))\n for number = (length users)\n when events\n collect (format \"%s %s (%s)\" number\n (propertize type 'face 'bold)\n (string-join users \", \")))\n \"; \"))))))))\n\n;;;;; Images\n\n;; Downloading and displaying images in messages, room/user avatars, etc.\n\n(require 'image)\n\n(defvar ement-room-image-keymap\n (let ((map (make-sparse-keymap)))\n (set-keymap-parent map image-map)\n (define-key map (kbd \"M-RET\") #'ement-room-image-scale)\n (define-key map (kbd \"RET\") #'ement-room-image-show)\n (define-key map [mouse-1] #'ement-room-image-scale-mouse)\n (define-key map [double-mouse-1] #'ement-room-image-show-mouse)\n map)\n \"Keymap for images in room buffers.\")\n\n(defgroup ement-room-images nil\n \"Showing images in rooms.\"\n :group 'ement-room)\n\n(defcustom ement-room-images t\n \"Download and show images in messages, avatars, etc.\"\n :type 'boolean\n :set (lambda (option value)\n (if (or (fboundp 'imagemagick-types)\n (when (fboundp 'image-transforms-p)\n (image-transforms-p)))\n (set-default option value)\n (set-default option nil)\n (when (and value (display-images-p))\n (display-warning 'ement \"This Emacs was not built with ImageMagick support, nor does it support Cairo/XRender scaling, so images can't be displayed in Ement\")))))\n\n(defcustom ement-room-image-thumbnail-height 0.2\n \"Scale thumbnail images to this multiple of the window body height.\nShould be a number between 0 and 1.\nSee also `ement-room-image-thumbnail-height-min'.\"\n :type '(number :tag \"Multiple of the window body height\"))\n\n(defcustom ement-room-image-thumbnail-height-min 30\n \"Minimum height in pixels when scaling thumbnail images.\nSee also `ement-room-image-thumbnail-height'.\"\n :type 'natnum)\n\n(defcustom ement-room-image-initial-height ement-room-image-thumbnail-height\n \"Limit images' initial display height.\nIf a number, it should be no larger than 1 (because Emacs can't\ndisplay images larger than the window body height).\"\n :type '(choice (const :tag \"Use full window height (or width)\" nil)\n (number :tag \"Multiple of the window body height\")))\n\n(defcustom ement-room-image-margin 5\n \"How many pixels to add as an extra margin around the image.\"\n :type 'natnum)\n\n(defcustom ement-room-image-relief 2\n \"Width in pixels of shadow rectangle around the image.\nIf negative, shadows are drawn so that the image appears as a\npressed button; otherwise, it appears as an unpressed button.\"\n :type 'integer)\n\n(defun ement-room-image-scale-mouse (event)\n \"Toggle scale of image at mouse EVENT.\nScale image to fit within the window's body. If image is already\nfit to the window, reduce its max-height to 10% of the window's\nheight.\"\n (interactive \"e\")\n (let* ((pos (event-start event))\n (window (posn-window pos)))\n (with-selected-window window\n (ement-room-image-scale (posn-point pos)))))\n\n(defun ement-room-image-scale (pos)\n \"Toggle scale of image at POS.\nScale image to fit the window body. If the image already fits\nthe window body, reduce its max-height in accordance with user\noptions `ement-room-image-thumbnail-height' and\n`ement-room-image-thumbnail-height-min'.\"\n (interactive \"d\")\n (pcase-let* ((image (get-text-property pos 'display))\n (max-height (image-property image :max-height))\n (xy (posn-x-y (posn-at-point pos)))\n (window-width (window-body-width nil t))\n (max-width (- window-width (car xy)))\n (window-height (window-body-height nil t))\n (use-window-body-size (not (and (numberp max-height)\n (= window-height max-height))))\n ;; Image scaling commands set :max-height and friends to nil.\n ;; See .\n (new-height (if use-window-body-size\n window-height\n (max ement-room-image-thumbnail-height-min\n ;; Emacs doesn't like floats as the max-height.\n (truncate (* window-height\n ement-room-image-thumbnail-height))))))\n (when (fboundp 'imagemagick-types)\n ;; Only do this when ImageMagick is supported.\n ;; FIXME: When requiring Emacs 27+, remove this (I guess?).\n (setf (image-property image :type) 'imagemagick))\n ;; Set :scale to nil since image scaling commands might have changed it.\n (setf (image-property image :scale) nil\n (image-property image :max-width) max-width\n (image-property image :max-height) new-height)\n ;; When maximising, eliminate all padding around the image, so that the line\n ;; height will not exceed the window height. This prevents window scrolling\n ;; issues. Set the window start to ensure the image is displayed in full.\n (if use-window-body-size\n (setf (image-property image :relief) nil\n (image-property image :margin) nil\n (window-start) pos)\n (setf (image-property image :relief) ement-room-image-relief\n (image-property image :margin) ement-room-image-margin))))\n\n(defun ement-room-image-show-mouse (event)\n \"Show image at mouse EVENT in a new buffer.\"\n (interactive \"e\")\n (let* ((pos (event-start event))\n (window (posn-window pos)))\n (with-selected-window window\n (ement-room-image-show (posn-point pos)))))\n\n(defun ement-room-image-show (pos)\n \"Show image at POS in a new buffer.\"\n (interactive \"d\")\n (pcase-let* ((image (copy-sequence (get-text-property pos 'display)))\n (ement-event (ewoc-data (ewoc-locate ement-ewoc pos)))\n ((cl-struct ement-event id) ement-event)\n (buffer-name (format \"*Ement image: %s*\" id)))\n (when (fboundp 'imagemagick-types)\n ;; Only do this when ImageMagick is supported.\n ;; FIXME: When requiring Emacs 27+, remove this (I guess?).\n (setf (image-property image :type) 'imagemagick))\n (setf (image-property image :scale) 1.0\n (image-property image :max-width) nil\n (image-property image :max-height) nil)\n (unless (get-buffer buffer-name)\n (with-current-buffer (get-buffer-create buffer-name)\n (erase-buffer)\n (insert-image image)\n (image-mode)))\n (pop-to-buffer buffer-name\n '((display-buffer-pop-up-frame\n (pop-up-frame-parameters . ((fullscreen . t) (maximized . t))))))))\n\n(cl-defun ement-room--image-download (event session &key then else (authenticatedp t))\n \"Download image EVENT on SESSION and call THEN, else ELSE.\nIf AUTHENTICATEDP, send authenticated request to new\nendpoint (Matrix 1.11, MSC3911); otherwise send old-style,\nunauthenticated request to old endpoint.\"\n (declare (indent defun))\n (pcase-let* (((cl-struct ement-event content) event)\n ((map ('url mxc)) content))\n (ement--media-request mxc session :then then :else else\n :queue ement-images-queue :authenticatedp authenticatedp)))\n\n(defun ement-room--format-m.image (event session)\n \"Return \\\"m.image\\\" EVENT on SESSION formatted as a string.\nWhen `ement-room-images' is non-nil, also download it and then\nshow it in the buffer.\"\n (pcase-let* (((cl-struct ement-event (local event-local)) event)\n ;; HACK: Get the room's buffer from the variable (the current buffer\n ;; will be a temp formatting buffer when this is called, but it still\n ;; inherits the `ement-room' variable from the room buffer, thankfully).\n ((cl-struct ement-room local) ement-room)\n ((map buffer) local)\n ;; TODO: Thumbnail support.\n ((map image) event-local)\n (then (apply-partially #'ement-room--m.image-callback event ement-room))\n (else (lambda (plz-error)\n \"Handle PLZ-ERROR for a failed request to download an image.\"\n (pcase-let* (((cl-struct plz-error response\n (message plz-message)\n (curl-error `(,curl-exit-code . ,curl-message)))\n plz-error)\n (status (when (plz-response-p response)\n (plz-response-status response)))\n (body (when (plz-response-p response)\n (plz-response-body response)))\n (json-object (when body\n (ignore-errors\n (json-read-from-string body))))\n (errcode (alist-get 'errcode json-object))\n (error-message (format \"%S: %s\"\n (or curl-exit-code status)\n (or (when json-object\n (alist-get 'error json-object))\n curl-message\n plz-message))))\n (pcase errcode\n (\"M_UNRECOGNIZED\"\n ;; Resend unauthenticated media request for older servers.\n ;; FIXME: Test the \"/versions\" endpoint to see what's supported. See\n ;; .\n (ement-room--image-download event session :authenticatedp nil\n :then then))\n (_ (signal 'ement-api-error (list error-message))))))))\n (if (and ement-room-images image)\n ;; Images enabled and image downloaded: create image and\n ;; return it in a string.\n (condition-case err\n (let ((image (create-image image nil 'data-p :ascent 'center))\n (buffer-window (when buffer\n (get-buffer-window buffer)))\n max-height max-width)\n ;; Calculate max image display size.\n (cond (ement-room-image-initial-height\n ;; Use configured value.\n (setf max-height (max ement-room-image-thumbnail-height-min\n ;; Emacs doesn't like floats as the max-height.\n (truncate\n (* (window-body-height buffer-window t)\n ement-room-image-initial-height)))\n max-width (window-body-width buffer-window t)))\n (buffer-window\n ;; Buffer displayed: use window size.\n (setf max-height (window-body-height buffer-window t)\n max-width (window-body-width buffer-window t)))\n (t\n ;; Buffer not displayed: use frame size.\n (setf max-height (frame-pixel-height)\n max-width (frame-pixel-width))))\n (when (fboundp 'imagemagick-types)\n ;; Only do this when ImageMagick is supported.\n ;; FIXME: When requiring Emacs 27+, remove this (I guess?).\n (setf (image-property image :type) 'imagemagick))\n (setf (image-property image :max-width) max-width\n (image-property image :max-height) max-height\n (image-property image :relief) ement-room-image-relief\n (image-property image :margin) ement-room-image-margin\n (image-property image :pointer) 'hand)\n (concat \"\\n\"\n (ement-room-wrap-prefix \" \"\n 'display image\n 'keymap ement-room-image-keymap)))\n (error (format \"\\n [error inserting image: %s]\" (error-message-string err))))\n ;; Image not downloaded: insert URL as button, and download if enabled.\n (prog1\n (ement-room-wrap-prefix \"[image]\"\n 'action (apply-partially #'apply #'ement-room--image-download)\n 'button t\n 'button-data (list event session\n :then (lambda (&rest args)\n ;; Bind non-nil to force the image to be displayed.\n (let ((ement-room-images t))\n (apply then args)))\n :else else)\n 'category t\n 'face 'button\n 'follow-link t\n 'help-echo \"Show image\"\n 'keymap button-map\n 'mouse-face 'highlight)\n (when ement-room-images\n ;; Images enabled: download it.\n (ement-room--image-download event session\n :then then :else else))))))\n\n(defun ement-room--m.image-callback (event room data)\n \"Add downloaded image from DATA to EVENT in ROOM.\nThen invalidate EVENT's node to show the image.\"\n (pcase-let* (((cl-struct ement-room (local (map buffer))) room))\n (setf (map-elt (ement-event-local event) 'image) data)\n (when (buffer-live-p buffer)\n (with-current-buffer buffer\n (if-let (node (ement-room--ewoc-last-matching ement-ewoc\n (lambda (node-data)\n (eq node-data event))))\n (ewoc-invalidate ement-ewoc node)\n ;; This shouldn't happen, but very rarely, it can. I haven't figured out why\n ;; yet, so checking whether a node is found rather than blindly calling\n ;; `ewoc-invalidate' prevents an error from aborting event processing.\n (display-warning 'ement-room--m.image-callback\n (format \"Event %S not found in room %S (a very rare, as-yet unexplained bug, which can be safely ignored; you may disconnect and reconnect if you wish, but it isn't strictly necessary)\"\n (ement-event-id event)\n (ement-room-display-name room))))))))\n\n(defun ement-room--format-m.file (event)\n \"Return \\\"m.file\\\" EVENT formatted as a string.\"\n ;; TODO: Insert thumbnail images when enabled.\n (pcase-let* (((cl-struct ement-event\n (content (map filename\n ('info (map mimetype size))\n ('url mxc-url))))\n event)\n (human-size (when size\n (file-size-human-readable size)))\n (string (format \"[file: %s (%s) (%s)]\" filename mimetype human-size)))\n (concat (propertize string\n 'action #'call-interactively\n 'button t\n 'button-data #'ement-room-download-file\n 'category t\n 'face 'button\n 'follow-link t\n 'help-echo mxc-url\n 'keymap button-map\n 'mouse-face 'highlight)\n (propertize \" \"\n 'display '(space :relative-height 1.5)))))\n\n(defun ement-room--format-m.video (event)\n \"Return \\\"m.video\\\" EVENT formatted as a string.\"\n ;; TODO: Insert thumbnail images when enabled.\n (pcase-let* (((cl-struct ement-event\n (content (map body\n ('info (map mimetype size w h))\n ('url mxc-url))))\n event)\n (human-size (file-size-human-readable size))\n (string (format \"[video: %s (%s) (%sx%s) (%s)]\" body mimetype w h human-size)))\n (concat (propertize string\n 'action #'call-interactively\n 'button t\n 'button-data #'ement-room-download-file\n 'category t\n 'face 'button\n 'follow-link t\n 'help-echo mxc-url\n 'keymap button-map\n 'mouse-face 'highlight)\n (propertize \" \"\n 'display '(space :relative-height 1.5)))))\n\n(defun ement-room--format-m.audio (event)\n \"Return \\\"m.audio\\\" EVENT formatted as a string.\"\n (pcase-let* (((cl-struct ement-event\n (content (map body\n ('info (map mimetype duration size))\n ('url mxc-url))))\n event)\n (human-size (file-size-human-readable size))\n (human-duration (format-seconds \"%m:%s\" (/ duration 1000)))\n (string (format \"[audio: %s (%s) (%s) (%s)]\" body mimetype human-duration human-size)))\n (concat (propertize string\n 'action #'ement-room-download-file\n 'button t\n 'button-data event\n 'category t\n 'face 'button\n 'follow-link t\n 'help-echo mxc-url\n 'keymap button-map\n 'mouse-face 'highlight)\n (propertize \" \"\n 'display '(space :relative-height 1.5)))))\n\n;;;;; Org format sending\n\n;; Some of these declarations may need updating as Org changes.\n\n(defvar org-export-with-toc)\n(defvar org-export-with-broken-links)\n(defvar org-export-with-section-numbers)\n(defvar org-export-with-sub-superscripts)\n(defvar org-html-inline-images)\n\n(declare-function org-element-property \"org-element\")\n(declare-function org-export-data \"ox\")\n(declare-function org-export-get-caption \"ox\")\n(declare-function org-export-get-ordinal \"ox\")\n(declare-function org-export-get-reference \"ox\")\n(declare-function org-export-read-attribute \"ox\")\n(declare-function org-html--has-caption-p \"ox-html\")\n(declare-function org-html--textarea-block \"ox-html\")\n(declare-function org-html--translate \"ox-html\")\n(declare-function org-html-export-as-html \"ox-html\")\n(declare-function org-html-format-code \"ox-html\")\n\n(defun ement-room-compose-org ()\n \"Activate `org-mode' in current compose buffer.\nConfigures the buffer appropriately so that saving it will export\nthe Org buffer's contents.\"\n (interactive)\n (unless ement-room-compose-buffer\n (user-error \"This command should be run in a compose buffer. Use `ement-room-compose-message' first\"))\n ;; Calling `org-mode' seems to wipe out local variables.\n (let ((room ement-room)\n (session ement-session))\n (org-mode)\n (ement-room-init-compose-buffer room session))\n (setq-local ement-room-send-message-filter #'ement-room-send-org-filter))\n\n(defun ement-room-send-org-filter (content room)\n \"Return event CONTENT for ROOM having processed its Org content.\nThe CONTENT's body is exported with\n`org-html-export-as-html' (with some adjustments for\ncompatibility), and the result is added to the CONTENT as\n\\\"formatted_body\\\".\"\n (require 'ox-html)\n ;; The CONTENT alist has string keys before being sent.\n (pcase-let* ((body (alist-get \"body\" content nil nil #'equal))\n (formatted-body\n (save-window-excursion\n (with-temp-buffer\n (insert (ement--format-body-mentions body room\n :template \"[[https://matrix.to/#/%s][%s]]\"))\n (cl-letf (((symbol-function 'org-html-src-block)\n (symbol-function 'ement-room--org-html-src-block)))\n (let ((org-export-with-toc nil)\n (org-export-with-broken-links t)\n (org-export-with-section-numbers nil)\n (org-export-with-sub-superscripts nil)\n (org-html-inline-images nil)\n (display-buffer-alist (cons '(\"^\\\\*Org HTML Export\\\\*$\"\n . (display-buffer-no-window nil))\n display-buffer-alist)))\n (org-html-export-as-html nil nil nil 'body-only)))\n (with-current-buffer \"*Org HTML Export*\"\n (prog1 (string-trim (buffer-string))\n (kill-buffer)))))))\n (setf (alist-get \"formatted_body\" content nil nil #'equal) formatted-body\n (alist-get \"format\" content nil nil #'equal) \"org.matrix.custom.html\")\n content))\n\n(defun ement-room--org-html-src-block (src-block _contents info)\n \"Transcode a SRC-BLOCK element from Org to HTML.\nCONTENTS holds the contents of the item. INFO is a plist holding\ncontextual information.\n\nThis is a copy of `org-html-src-block' that uses Riot\nWeb-compatible HTML output, using HTML like:\n\n
...\"\n  (if (org-export-read-attribute :attr_html src-block :textarea)\n      (org-html--textarea-block src-block)\n    (let ((lang (pcase (org-element-property :language src-block)\n                  ;; Riot's syntax coloring doesn't support \"elisp\", but \"lisp\" works.\n                  (\"elisp\" \"lisp\")\n                  (else else)))\n\t  (code (org-html-format-code src-block info))\n\t  (label (let ((lbl (and (org-element-property :name src-block)\n\t\t\t\t (org-export-get-reference src-block info))))\n\t\t   (if lbl (format \" id=\\\"%s\\\"\" lbl) \"\"))))\n      (if (not lang) (format \"
\\n%s
\" label code)\n\t(format \"
\\n%s%s\\n
\"\n\t\t;; Build caption.\n\t\t(let ((caption (org-export-get-caption src-block)))\n\t\t  (if (not caption) \"\"\n\t\t    (let ((listing-number\n\t\t\t   (format\n\t\t\t    \"%s \"\n\t\t\t    (format\n\t\t\t     (org-html--translate \"Listing %d:\" info)\n\t\t\t     (org-export-get-ordinal\n\t\t\t      src-block info nil #'org-html--has-caption-p)))))\n\t\t      (format \"\"\n\t\t\t      listing-number\n\t\t\t      (string-trim (org-export-data caption info))))))\n\t\t;; Contents.\n\t\t(format \"
%s
\"\n\t\t\tlang label code))))))\n\n;;;;; Completion\n\n;; Completing member and room names.\n\n(defun ement-room--complete-members-at-point ()\n  \"Complete member names and IDs at point.\nUses members in the current buffer's room.  For use in\n`completion-at-point-functions'.\"\n  (let ((beg (save-excursion\n               (when (re-search-backward (rx (or bol bos blank)) nil t)\n                 (skip-syntax-forward \"-\")\n                 (point))))\n        (end (point))\n        (collection-fn (completion-table-dynamic\n                        ;; The manual seems to show the FUN ignoring any\n                        ;; arguments, but the `completion-table-dynamic' docstring\n                        ;; seems to say that it should use the argument.\n                        (lambda (_ignore)\n                          (ement-room--member-names-and-ids)))))\n    (when beg\n      (list beg end collection-fn :exclusive 'no))))\n\n(defun ement-room--complete-rooms-at-point ()\n  \"Complete room aliases and IDs at point.\nFor use in `completion-at-point-functions'.\"\n  (let ((beg (save-excursion\n               (when (re-search-backward (rx (or bol bos blank) (or \"!\" \"#\")) nil t)\n                 (skip-syntax-forward \"-\")\n                 (point))))\n        (end (point))\n        (collection-fn (completion-table-dynamic\n                        ;; The manual seems to show the FUN ignoring any\n                        ;; arguments, but the `completion-table-dynamic' docstring\n                        ;; seems to say that it should use the argument.\n                        (lambda (_ignore)\n                          (ement-room--room-aliases-and-ids)))))\n    (when beg\n      (list beg end collection-fn :exclusive 'no))))\n\n;; TODO: Use `cl-pushnew' in these two functions instead of `delete-dups'.\n\n(defun ement-room--member-names-and-ids ()\n  \"Return a list of member names and IDs seen in current room.\nIf room's `members' table is filled, use it; otherwise, fetch\nmembers list and return already-seen members instead.  For use in\n`completion-at-point-functions'.\"\n  ;; For now, we just collect a list of members from events we've seen.\n  ;; TODO: In the future, we may maintain a per-room table of members, which\n  ;; would be more suitable for completing names according to the spec.\n  (pcase-let* ((room (if (minibufferp)\n                         (buffer-local-value\n                          'ement-room (window-buffer (minibuffer-selected-window)))\n                       ement-room))\n               (session (if (minibufferp)\n                            (buffer-local-value\n                             'ement-session (window-buffer (minibuffer-selected-window)))\n                          ement-session))\n               ((cl-struct ement-room members) room)\n               (members (if (alist-get 'fetched-members-p (ement-room-local room))\n                            (hash-table-values members)\n                          ;; HACK: Members table empty: update list and use known events\n                          ;; for now.\n                          (ement-singly (alist-get 'getting-members-p (ement-room-local room))\n                            (ement--get-joined-members room session\n                              :then (lambda (_) (setf (alist-get 'getting-members-p (ement-room-local room)) nil))\n                              :else (lambda (_) (setf (alist-get 'getting-members-p (ement-room-local room)) nil))))\n                          (mapcar #'ement-event-sender\n                                  (ement-room-timeline ement-room)))))\n    (delete-dups\n     (cl-loop for member in members\n              collect (ement-user-id member)\n              collect (ement--user-displayname-in room member)))))\n\n(defun ement-room--room-aliases-and-ids ()\n  \"Return a list of room names and aliases seen in current session.\nFor use in `completion-at-point-functions'.\"\n  (let* ((session (if (minibufferp)\n                      (buffer-local-value\n                       'ement-session (window-buffer (minibuffer-selected-window)))\n                    ement-session)))\n    (delete-dups\n     (delq nil (cl-loop for room in (ement-session-rooms session)\n                        collect (ement-room-id room)\n                        collect (ement-room-canonical-alias room))))))\n\n;;;;; Transient\n\n(require 'transient)\n\n(transient-define-prefix ement-room-transient ()\n  \"Transient for Ement Room buffers.\"\n  [:pad-keys t\n             [\"Movement\"\n              (\"TAB\" \"Next event\" ement-room-goto-next)\n              (\"\" \"Previous event\" ement-room-goto-prev)\n              (\"SPC\" \"Scroll up and mark read\" ement-room-scroll-up-mark-read)\n              (\"S-SPC\" \"Scroll down\" ement-room-scroll-down-command)\n              (\"M-SPC\" \"Jump to fully-read marker\" ement-room-goto-fully-read-marker)\n              (\"m\" \"Move read markers to point\" ement-room-mark-read)]\n             [\"Switching\"\n              (\"M-g M-l\" \"List rooms\" ement-room-list)\n              (\"M-g M-r\" \"Switch to other room\" ement-view-room)\n              (\"M-g M-m\" \"Switch to mentions buffer\" ement-notify-switch-to-mentions-buffer)\n              (\"M-g M-n\" \"Switch to notifications buffer\" ement-notify-switch-to-notifications-buffer)\n              (\"q\" \"Quit window\" quit-window)]]\n  [:pad-keys t\n             [\"Messages\"\n              (\"c\" \"Composition format\" ement-room-set-composition-format\n               :description (lambda ()\n                              (concat \"Composition format: \"\n                                      (propertize (car (cl-rassoc ement-room-send-message-filter\n                                                                  (list (cons \"Plain-text\" nil)\n                                                                        (cons \"Org-mode\" 'ement-room-send-org-filter))\n                                                                  :test #'equal))\n                                                  'face 'transient-value))))\n              (\"RET\" \"Write message\" ement-room-dispatch-new-message)\n              (\"M-RET\" \"Write message (alternative)\" ement-room-dispatch-new-message-alt)\n              (\"S-\" \"Write reply\" ement-room-dispatch-reply-to-message)\n              (\"\" \"Edit message\" ement-room-dispatch-edit-message)\n              (\"C-k\" \"Delete message\" ement-room-delete-message)\n              (\"s r\" \"Send reaction\" ement-room-send-reaction)\n              (\"s e\" \"Send emote\" ement-room-send-emote)\n              (\"s f\" \"Send file\" ement-room-send-file)\n              (\"s i\" \"Send image\" ement-room-send-image)\n              (\"D\" \"Download event media\" ement-room-download-file)]\n             [\"Users\"\n              (\"u RET\" \"Send direct message\" ement-send-direct-message)\n              (\"u i\" \"Invite user\" ement-invite-user)\n              (\"u I\" \"Ignore user\" ement-ignore-user)]]\n  [:pad-keys t\n             [\"Room\"\n              (\"M-s o\" \"Occur search in room\" ement-room-occur)\n              (\"r d\" \"Describe room\" ement-describe-room)\n              (\"r m\" \"List members\" ement-list-members)\n              (\"r t\" \"Set topic\" ement-room-set-topic)\n              (\"r f\" \"Set message format\" ement-room-set-message-format)\n              (\"r N\" \"Override name\" ement-room-override-name\n               :description (lambda ()\n                              (format \"Name override: %s\"\n                                      (if-let* ((event (alist-get \"org.matrix.msc3015.m.room.name.override\"\n                                                                  (ement-room-account-data ement-room) nil nil #'equal))\n                                                (name (map-nested-elt event '(content name))))\n                                          (propertize name 'face 'transient-value)\n                                        (propertize \"none\" 'face 'transient-inactive-value)))))\n              (\"r n\" \"Set notification state\" ement-room-set-notification-state\n               :description (lambda ()\n                              (let ((state (ement-room-notification-state ement-room ement-session)))\n                                (format \"Notifications (%s|%s|%s|%s|%s)\"\n                                        (propertize \"default\"\n                                                    'face (pcase state\n                                                            (`nil 'transient-value)\n                                                            (_ 'transient-inactive-value)))\n                                        (propertize \"all-loud\"\n                                                    'face (pcase state\n                                                            ('all-loud 'transient-value)\n                                                            (_ 'transient-inactive-value)))\n                                        (propertize \"all\"\n                                                    'face (pcase state\n                                                            ('all 'transient-value)\n                                                            (_ 'transient-inactive-value)))\n                                        (propertize \"mentions\"\n                                                    'face (pcase state\n                                                            ('mentions-and-keywords 'transient-value)\n                                                            (_ 'transient-inactive-value)))\n                                        (propertize \"none\"\n                                                    'face (pcase state\n                                                            ('none 'transient-value)\n                                                            (_ 'transient-inactive-value)))))))\n              (\"r T\" \"Tag/untag room\" ement-tag-room\n               :description (lambda ()\n                              (format \"Tag/untag room (%s|%s)\"\n                                      (propertize \"Fav\"\n                                                  'face (if (ement--room-tagged-p \"m.favourite\" ement-room)\n                                                            'transient-value 'transient-inactive-value))\n                                      (propertize \"Low-prio\"\n                                                  'face (if (ement--room-tagged-p \"m.lowpriority\" ement-room)\n                                                            'transient-value 'transient-inactive-value)))))]\n             [\"Room membership\"\n              (\"R c\" \"Create room\" ement-create-room)\n              (\"R j\" \"Join room\" ement-join-room)\n              (\"R l\" \"Leave room\" ement-leave-room)\n              (\"R F\" \"Forget room\" ement-forget-room)\n              (\"R n\" \"Set nick\" ement-room-set-display-name\n               :description (lambda ()\n                              (format \"Set nick (%s)\"\n                                      (propertize (ement--user-displayname-in\n                                                   ement-room (gethash (ement-user-id (ement-session-user ement-session))\n                                                                       ement-users))\n                                                  'face 'transient-value))))\n              (\"R s\" \"Toggle spaces\" ement-room-toggle-space\n               :description (lambda ()\n                              (format \"Toggle spaces (%s)\"\n                                      (if-let ((spaces (ement--room-spaces ement-room ement-session)))\n                                          (string-join\n                                           (mapcar (lambda (space)\n                                                     (propertize (ement-room-display-name space)\n                                                                 'face 'transient-value))\n                                                   spaces)\n                                           \", \")\n                                        (propertize \"none\" 'face 'transient-inactive-value)))))]]\n  [\"Other\"\n   (\"v\" \"View event\" ement-room-view-event)\n   (\"g\" \"Sync new messages\" ement-room-sync\n    :if (lambda ()\n          (interactive)\n          (or (not ement-auto-sync)\n              (not (map-elt ement-syncs ement-session)))))])\n\n;;;; Browsing URLs, EWW\n\n(defun ement-room-browse-mxc (mxc)\n  ;; TODO: If prefix arg, prompt for destination and download to file.\n  \"Browse MXC URL on current `ement-session'.\"\n  ;; For authenticated media, we have to provide our own version of `eww-retrieve'.\n  (let ((session ement-session))\n    (cl-letf (((symbol-function 'eww-retrieve)\n               (lambda (mxc callback cbargs)\n                 (ement--media-request mxc session\n                   :as (lambda ()\n                         ;; EWW wants to parse the headers itself, so widen and decode them.\n                         (widen)\n                         (decode-coding-region (point-min) (point) 'utf-8)\n                         ;; HACK: This STATUS argument to `eww-render' is bogus.\n                         (apply callback 'status cbargs))))))\n      (eww-browse-url mxc))))\n\n;;;; Downloading media/files\n\n;; We load `eww' to define this variable on-demand.\n(defvar eww-download-directory)\n\n(defun ement-room-download-file (event destination)\n  \"Download EVENT's file to DESTINATION.\nIf DESTINATION is a directory, use the file's default name;\notherwise, download to the filename.  Interactively, download to\n`eww-download-directory'; with prefix, prompt for destination.\"\n  (interactive (progn\n                 (require 'eww)\n                 (list (ement-room--event-at (point))\n                       (if current-prefix-arg\n                           (expand-file-name\n                            (read-file-name\n                             \"Download to: \"\n                             (cl-typecase eww-download-directory\n                               (string eww-download-directory)\n                               (function (funcall eww-download-directory)))))\n                         (expand-file-name\n                          (cl-typecase eww-download-directory\n                            (string eww-download-directory)\n                            (function (funcall eww-download-directory))))))))\n  (pcase-let* (((cl-struct ement-event\n                           (content (map ('filename event-filename) ('url mxc-url)\n                                         body)))\n                event)\n               (started-at (current-time))\n               (filename (if (not event-filename)\n                             body\n                           (if (equal body event-filename)\n                               body\n                             event-filename))))\n    (when (file-directory-p destination)\n      (unless (file-exists-p destination)\n        (make-directory destination 'parents))\n      (setf destination (file-name-concat destination filename)))\n    (unless (file-writable-p destination)\n      ;; FIXME: Pressing \"C-u\" before clicking a download link doesn't work.\n      (user-error \"Destination path not writable: %S (Call with prefix to prompt for filename)\"\n                  destination))\n    (when (file-exists-p destination)\n      (user-error \"File already exists: %S (Call with prefix to prompt for filename)\" destination))\n    ;; TODO: For bonus points, provide a way to cancel a download (otherwise the user\n    ;; would have to use `list-processes' and find the right one to delete), and to see\n    ;; progress (perhaps borrowing some of the relevant code in hyperdrive.el).\n    (ement--media-request mxc-url ement-session :authenticatedp t\n      :as `(file ,destination)\n      :then (lambda (&rest _)\n              (let* ((file-size (file-attribute-size\n                                 (file-attributes destination)))\n                     (duration (float-time (time-subtract (current-time) started-at)))\n                     (speed (file-size-human-readable (/ file-size duration))))\n                (message \"File downloaded: %S (%s in %s at %s/sec) \"\n                         destination (file-size-human-readable file-size)\n                         (format-seconds \"%h:%m:%s%z seconds\" duration)\n                         speed))))\n    (message \"Downloading to %S...\" destination)))\n\n;;;; Footer\n\n(provide 'ement-room)\n\n;;; ement-room.el ends here\n"
  },
  {
    "path": "ement-structs.el",
    "content": ";;; ement-structs.el --- Ement structs               -*- lexical-binding: t; -*-\n\n;; Copyright (C) 2022-2023  Free Software Foundation, Inc.\n\n;; Author: Adam Porter \n;; Maintainer: Adam Porter \n\n;; This program is free software; you can redistribute it and/or modify\n;; it under the terms of the GNU General Public License as published by\n;; the Free Software Foundation, either version 3 of the License, or\n;; (at your option) any later version.\n\n;; This program is distributed in the hope that it will be useful,\n;; but WITHOUT ANY WARRANTY; without even the implied warranty of\n;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n;; GNU General Public License for more details.\n\n;; You should have received a copy of the GNU General Public License\n;; along with this program.  If not, see .\n\n;;; Commentary:\n\n;;\n\n;;; Code:\n\n;;;; Debugging\n\n;; NOTE: Uncomment this form and `emacs-lisp-byte-compile-and-load' the file to enable\n;; `ement-debug' messages.  This is commented out by default because, even though the\n;; messages are only displayed when `warning-minimum-log-level' is `:debug' at runtime, if\n;; that is so at expansion time, the expanded macro calls format the message and check the\n;; log level at runtime, which is not zero-cost.\n\n;; (eval-and-compile\n;;   (setq-local warning-minimum-log-level nil)\n;;   (setq-local warning-minimum-log-level :debug))\n\n;;;; Requirements\n\n(require 'cl-lib)\n\n;;;; Structs\n\n(cl-defstruct ement-user\n  id displayname account-data\n  (color nil :documentation \"Color in which to display user's name.\")\n  (message-color nil :documentation \"Color in which to display user's messages.\")\n  (username nil\n            ;; NOTE: Not exactly according to spec, I guess, but useful for now.\n            :documentation \"Username part of user's Matrix ID.\")\n  (avatar-url nil :documentation \"MXC URL to user's avatar.\")\n  (avatar nil :documentation \"One-space string with avatar image in display property.\"))\n\n(cl-defstruct ement-event\n  id sender content origin-server-ts type unsigned state-key\n  receipts\n  ;; The local slot is an alist used by the local client only.\n  local)\n\n(cl-defstruct ement-server\n  name uri-prefix)\n\n(cl-defstruct ement-session\n  user server token transaction-id rooms next-batch\n  device-id initial-device-display-name has-synced-p\n  account-data\n  ;; Hash table of all seen events, keyed on event ID.\n  events)\n\n(cl-defstruct ement-room\n  id display-name prev-batch\n  summary state timeline ephemeral account-data unread-notifications\n  latest-ts topic canonical-alias avatar status type invite-state\n  (members (make-hash-table :test #'equal) :documentation \"Hash table mapping joined user IDs to user structs.\")\n  ;; The local slot is an alist used by the local client only.\n  local\n  (receipts (make-hash-table :test #'equal))\n  (displaynames (make-hash-table) :documentation \"Hash table mapping users to their displayname in this room.\"))\n\n;;;; Variables\n\n\n;;;; Customization\n\n\n;;;; Commands\n\n\n;;;; Functions\n\n\n;;;; Footer\n\n(provide 'ement-structs)\n\n;;; ement-structs.el ends here\n"
  },
  {
    "path": "ement-tabulated-room-list.el",
    "content": ";;; ement-tabulated-room-list.el --- Ement tabulated room list buffer    -*- lexical-binding: t; -*-\n\n;; Copyright (C) 2022-2023  Free Software Foundation, Inc.\n\n;; Author: Adam Porter \n;; Maintainer: Adam Porter \n\n;; This program is free software; you can redistribute it and/or modify\n;; it under the terms of the GNU General Public License as published by\n;; the Free Software Foundation, either version 3 of the License, or\n;; (at your option) any later version.\n\n;; This program is distributed in the hope that it will be useful,\n;; but WITHOUT ANY WARRANTY; without even the implied warranty of\n;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n;; GNU General Public License for more details.\n\n;; You should have received a copy of the GNU General Public License\n;; along with this program.  If not, see .\n\n;;; Commentary:\n\n;; This library implements a room list buffer with `tabulated-list-mode'.\n\n;; NOTE: It doesn't appear that there is a way to get the number of\n;; members in a room other than by retrieving the list of members and\n;; counting them.  For a large room (e.g. the Spacemacs Gitter room or\n;; #debian:matrix.org), that means thousands of users, none of the\n;; details of which we care about.  So it seems impractical to know\n;; the number of members when using lazy-loading.  So I guess we just\n;; won't show the number of members.\n\n;; TODO: (Or maybe there is, see m.joined_member_count).\n\n;; NOTE: The tabulated-list API is awkward here.  When the\n;; `tabulated-list-format' is changed, we have to make the change in 4\n;; or 5 other places, and if one forgets to, bugs with non-obvious\n;; causes happen.  I think library using EIEIO or structs would be\n;; very helpful.\n\n;;; Code:\n\n;;;; Requirements\n\n(require 'cl-lib)\n(require 'tabulated-list)\n\n(require 'ement)\n\n;;;; Variables\n\n(declare-function ement-notify-switch-to-mentions-buffer \"ement-notify\")\n(declare-function ement-notify-switch-to-notifications-buffer \"ement-notify\")\n(defvar ement-tabulated-room-list-mode-map\n  (let ((map (make-sparse-keymap)))\n    ;; (define-key map (kbd \"g\") #'tabulated-list-revert)\n    ;; (define-key map (kbd \"q\") #'bury-buffer)\n    (define-key map (kbd \"SPC\") #'ement-tabulated-room-list-next-unread)\n    (define-key map (kbd \"M-g M-m\") #'ement-notify-switch-to-mentions-buffer)\n    (define-key map (kbd \"M-g M-n\") #'ement-notify-switch-to-notifications-buffer)\n    ;; (define-key map (kbd \"S\") #'tabulated-list-sort)\n    map))\n\n(defvar ement-tabulated-room-list-timestamp-colors nil\n  \"List of colors used for timestamps.\nSet automatically when `ement-tabulated-room-list-mode' is activated.\")\n\n(defvar ement-sessions)\n\n;;;; Customization\n\n(defgroup ement-tabulated-room-list-faces nil\n  \"Faces for tabulated room list buffers.\"\n  :group 'ement-tabulated-room-list\n  :group 'ement-faces)\n\n(defgroup ement-tabulated-room-list nil\n  \"Options for tabulated room list buffers.\"\n  :group 'ement)\n\n(defcustom ement-tabulated-room-list-auto-update t\n  \"Automatically update the room list buffer.\"\n  :type 'boolean)\n\n(defcustom ement-tabulated-room-list-avatars (display-images-p)\n  \"Show room avatars in the room list.\"\n  :type 'boolean)\n\n(defcustom ement-tabulated-room-list-simplify-timestamps t\n  \"Only show the largest unit of time in a timestamp.\nFor example, \\\"1h54m3s\\\" becomes \\\"1h\\\".\"\n  :type 'boolean)\n\n;;;;; Faces\n\n(defface ement-tabulated-room-list-name\n  '((t (:inherit (font-lock-function-name-face button))))\n  \"Non-direct rooms.\"\n  :group 'ement-tabulated-room-list-faces)\n\n(defface ement-tabulated-room-list-direct\n  ;; In case `font-lock-constant-face' is bold, we set the weight to normal, so it can be\n  ;; made bold for unread rooms only.\n  '((t (:weight normal :inherit (font-lock-constant-face ement-tabulated-room-list-name))))\n  \"Direct rooms.\"\n  :group 'ement-tabulated-room-list-faces)\n\n(defface ement-tabulated-room-list-invited\n  '((t (:inherit (italic ement-tabulated-room-list-name))))\n  \"Invited rooms.\"\n  :group 'ement-tabulated-room-list-faces)\n\n(defface ement-tabulated-room-list-left\n  '((t (:strike-through t :inherit ement-tabulated-room-list-name)))\n  \"Left rooms.\"\n  :group 'ement-tabulated-room-list-faces)\n\n(defface ement-tabulated-room-list-unread\n  '((t (:inherit (bold ement-tabulated-room-list-name))))\n  \"Unread rooms.\"\n  :group 'ement-tabulated-room-list-faces)\n\n(defface ement-tabulated-room-list-favourite '((t (:inherit (font-lock-doc-face ement-tabulated-room-list-name))))\n  \"Favourite rooms.\"\n  :group 'ement-tabulated-room-list-faces)\n\n(defface ement-tabulated-room-list-low-priority '((t (:inherit (font-lock-comment-face ement-tabulated-room-list-name))))\n  \"Low-priority rooms.\"\n  :group 'ement-tabulated-room-list-faces)\n\n(defface ement-tabulated-room-list-recent\n  '((t (:inherit font-lock-warning-face)))\n  \"Latest timestamp of recently updated rooms.\nThe foreground color is used to generate a gradient of colors\nfrom recent to non-recent for rooms updated in the past 24\nhours but at least one hour ago.\"\n  :group 'ement-tabulated-room-list-faces)\n\n(defface ement-tabulated-room-list-very-recent\n  '((t (:inherit error)))\n  \"Latest timestamp of very recently updated rooms.\nThe foreground color is used to generate a gradient of colors\nfrom recent to non-recent for rooms updated in the past hour.\"\n  :group 'ement-tabulated-room-list-faces)\n\n;;;; Bookmark support\n\n;; Especially useful with Burly: \n\n(require 'bookmark)\n\n(defun ement-tabulated-room-list-bookmark-make-record ()\n  \"Return a bookmark record for the `ement-tabulated-room-list' buffer.\"\n  (pcase-let* (((cl-struct ement-session user) ement-session)\n               ((cl-struct ement-user (id session-id)) user))\n    ;; MAYBE: Support bookmarking specific events in a room.\n    (list (concat \"Ement room list (\" session-id \")\")\n          (cons 'session-id session-id)\n          (cons 'handler #'ement-tabulated-room-list-bookmark-handler))))\n\n(defun ement-tabulated-room-list-bookmark-handler (bookmark)\n  \"Show Ement room list buffer for BOOKMARK.\"\n  (pcase-let* (((map session-id) bookmark))\n    (unless (alist-get session-id ement-sessions nil nil #'equal)\n      ;; MAYBE: Automatically connect.\n      (user-error \"Session %s not connected: call `ement-connect' first\" session-id))\n    (ement-tabulated-room-list)))\n\n;;;; Commands\n\n(defun ement-tabulated-room-list-next-unread ()\n  \"Show next unread room.\"\n  (interactive)\n  (unless (button-at (point))\n    (call-interactively #'forward-button))\n  (unless (cl-loop with starting-line = (line-number-at-pos)\n                   if (equal \"U\" (elt (tabulated-list-get-entry) 0))\n                   do (progn\n                        (goto-char (button-end (button-at (point))))\n                        (push-button (1- (point)))\n                        (cl-return t))\n                   else do (call-interactively #'forward-button)\n                   while (> (line-number-at-pos) starting-line))\n    ;; No more unread rooms.\n    (message \"No more unread rooms\")))\n\n;;;###autoload\n(defun ement-tabulated-room-list (&rest _ignore)\n  \"Show buffer listing joined rooms.\nCalls `pop-to-buffer-same-window'.  Interactively, with prefix,\ncall `pop-to-buffer'.\"\n  (interactive)\n  (with-current-buffer (get-buffer-create \"*Ement Rooms*\")\n    (ement-tabulated-room-list-mode)\n    (setq-local bookmark-make-record-function #'ement-tabulated-room-list-bookmark-make-record)\n    ;; FIXME: There must be a better way to handle this.\n    (funcall (if current-prefix-arg\n                 #'pop-to-buffer #'pop-to-buffer-same-window)\n             (current-buffer))))\n\n(defun ement-tabulated-room-list--timestamp-colors ()\n  \"Return a vector of generated latest-timestamp colors for rooms.\nUsed in `ement-tabulated-room-list' and `ement-room-list'.\"\n  (if (or (equal \"unspecified-fg\" (face-foreground 'default nil 'default))\n          (equal \"unspecified-bg\" (face-background 'default nil 'default)))\n      ;; NOTE: On a TTY, the default face's foreground and background colors may be the\n      ;; special values \"unspecified-fg\"/\"unspecified-bg\", in which case we can't generate\n      ;; gradients, so we just return a vector of \"unspecified-fg\".  See\n      ;; .\n      (make-vector 134 \"unspecified-fg\")\n    (cl-coerce\n     (append (mapcar\n              ;; One face per 10-minute period, from \"recent\" to 1-hour.\n              (lambda (rgb)\n                (pcase-let ((`(,r ,g ,b) rgb))\n                  (color-rgb-to-hex r g b 2)))\n              (color-gradient (color-name-to-rgb (face-foreground 'ement-tabulated-room-list-very-recent\n                                                                  nil 'default))\n                              (color-name-to-rgb (face-foreground 'ement-tabulated-room-list-recent\n                                                                  nil 'default))\n                              6))\n             (mapcar\n              ;; One face per hour, from \"recent\" to default.\n              (lambda (rgb)\n                (pcase-let ((`(,r ,g ,b) rgb))\n                  (color-rgb-to-hex r g b 2)))\n              (color-gradient (color-name-to-rgb (face-foreground 'ement-tabulated-room-list-recent\n                                                                  nil 'default))\n                              (color-name-to-rgb (face-foreground 'default nil 'default))\n                              24))\n             (mapcar\n              ;; One face per week for the last year (actually we\n              ;; generate colors for the past two years' worth so\n              ;; that the face for one-year-ago is halfway to\n              ;; invisible, and we don't use colors past that point).\n              (lambda (rgb)\n                (pcase-let ((`(,r ,g ,b) rgb))\n                  (color-rgb-to-hex r g b 2)))\n              (color-gradient (color-name-to-rgb (face-foreground 'default nil 'default))\n                              (color-name-to-rgb (face-background 'default nil 'default))\n                              104)))\n     'vector)))\n\n(define-derived-mode ement-tabulated-room-list-mode tabulated-list-mode\n  \"Ement-Tabulated-Room-List\"\n  :group 'ement\n  (setf tabulated-list-format (vector\n                               '(\"U\" 1 t)\n                               '(#(\"P\" 0 1 (help-echo \"Priority (favorite/low)\")) 1 t)\n                               '(\"B\" 1 t)\n                               ;; '(\"U\" 1 t)\n                               '(\"d\" 1 t) ; Direct\n                               (list (propertize \"🐱\"\n                                                 'help-echo \"Avatar\")\n                                     4 t) ; Avatar\n                               '(\"Name\" 25 t) '(\"Topic\" 35 t)\n                               (list \"Latest\"\n                                     (if ement-tabulated-room-list-simplify-timestamps\n                                         6 20)\n                                     #'ement-tabulated-room-list-latest<\n\t\t\t\t     :right-align t)\n                               '(\"Members\" 7 ement-tabulated-room-list-members<)\n                               ;; '(\"P\" 1 t) '(\"Tags\" 15 t)\n                               '(\"Session\" 15 t))\n        tabulated-list-sort-key '(\"Latest\" . t)\n        ement-tabulated-room-list-timestamp-colors (ement-tabulated-room-list--timestamp-colors))\n  (add-hook 'tabulated-list-revert-hook #'ement-tabulated-room-list--set-entries nil 'local)\n  (tabulated-list-init-header)\n  (ement-tabulated-room-list--set-entries)\n  (tabulated-list-revert))\n\n(defun ement-tabulated-room-list-action (event)\n  \"Show buffer for room at EVENT or point.\"\n  (interactive \"e\")\n  (mouse-set-point event)\n  (pcase-let* ((room (tabulated-list-get-id))\n               (`[,_unread ,_priority ,_buffer ,_direct ,_avatar ,_name ,_topic ,_latest ,_members ,user-id]\n                (tabulated-list-get-entry))\n               (session (alist-get user-id ement-sessions nil nil #'equal)))\n    (ement-view-room room session)))\n\n;;;; Functions\n\n;;;###autoload\n(defun ement-tabulated-room-list-auto-update (_session)\n  \"Automatically update the room list buffer.\nDoes so when variable `ement-tabulated-room-list-auto-update' is non-nil.\nTo be called in `ement-sync-callback-hook'.\"\n  (when (and ement-tabulated-room-list-auto-update\n             (buffer-live-p (get-buffer \"*Ement Rooms*\")))\n    (with-current-buffer (get-buffer \"*Ement Rooms*\")\n      (revert-buffer))))\n\n(defun ement-tabulated-room-list--set-entries ()\n  \"Set `tabulated-list-entries'.\"\n  ;; Reset avatar size in case default font size has changed.\n  ;; TODO: After implementing avatars.\n  ;; (customize-set-variable 'ement-room-avatar-in-buffer-name-size ement-room-avatar-in-buffer-name-size)\n\n  ;; NOTE: From Emacs docs:\n\n  ;; This buffer-local variable specifies the entries displayed in the\n  ;; Tabulated List buffer.  Its value should be either a list, or a\n  ;; function.\n  ;;\n  ;; If the value is a list, each list element corresponds to one entry,\n  ;; and should have the form ‘(ID CONTENTS)’, where\n  ;;\n  ;; • ID is either ‘nil’, or a Lisp object that identifies the\n  ;; entry.  If the latter, the cursor stays on the same entry when\n  ;; re-sorting entries.  Comparison is done with ‘equal’.\n  ;;\n  ;; • CONTENTS is a vector with the same number of elements as\n  ;; ‘tabulated-list-format’.  Each vector element is either a\n  ;;  string, which is inserted into the buffer as-is, or a list\n  ;;  ‘(LABEL . PROPERTIES)’, which means to insert a text button by\n  ;;   calling ‘insert-text-button’ with LABEL and PROPERTIES as\n  ;;   arguments (*note Making Buttons::).\n  ;;\n  ;;   There should be no newlines in any of these strings.\n  (let ((entries (cl-loop for (_id . session) in ement-sessions\n                          append (mapcar (lambda (room)\n                                           (ement-tabulated-room-list--entry session room))\n                                         (ement-session-rooms session)))))\n    (setf tabulated-list-entries\n          ;; Pre-sort by latest event so that, when the list is sorted by other columns,\n          ;; the rooms will be secondarily sorted by latest event.\n          (cl-sort entries #'> :key (lambda (entry)\n                                      ;; In case a room has no latest event (not sure if\n                                      ;; this may obscure a bug, but this has happened, so\n                                      ;; we need to handle it), we fall back to 0.\n                                      (or (ement-room-latest-ts (car entry)) 0))))))\n\n(defun ement-tabulated-room-list--entry (session room)\n  \"Return entry for ROOM in SESSION for `tabulated-list-entries'.\"\n  (pcase-let* (((cl-struct ement-room id canonical-alias display-name avatar topic latest-ts summary\n                           (local (map buffer room-list-avatar)))\n                room)\n               ((map ('m.joined_member_count member-count)) summary)\n               (e-alias (or canonical-alias\n                            (setf (ement-room-canonical-alias room)\n                                  (ement--room-alias room))\n                            id))\n               ;; FIXME: Figure out how to track unread status cleanly.\n               (e-unread (if (and buffer (buffer-modified-p buffer))\n                             (propertize \"U\" 'help-echo \"Unread\") \"\"))\n               (e-buffer (if buffer (propertize \"B\" 'help-echo \"Room has buffer\") \"\"))\n               (e-avatar (if (and ement-tabulated-room-list-avatars avatar)\n                             (or room-list-avatar\n                                 (if-let* ((avatar-image (get-text-property 0 'display avatar))\n                                           (new-avatar-string (propertize \" \" 'display\n                                                                          (ement--resize-image avatar-image\n                                                                                               nil (frame-char-height)))))\n                                     (progn\n                                       ;; alist-get doesn't seem to return the new value when used with setf?\n                                       (setf (alist-get 'room-list-avatar (ement-room-local room))\n                                             new-avatar-string)\n                                       new-avatar-string)\n                                   ;; If a room avatar image fails to download or decode\n                                   ;; and ends up nil, we return the empty string.\n                                   (ement-debug \"nil avatar for room: \" (ement-room-display-name room) (ement-room-canonical-alias room))\n                                   \"\"))\n                           ;; Room avatars disabled.\n                           \"\"))\n               ;; We have to copy the list, otherwise using `setf' on it\n               ;; later causes its value to be mutated for every entry.\n               (name-face (cl-copy-list '(:inherit (ement-tabulated-room-list-name))))\n               (e-name (list (propertize (or display-name\n                                             (ement--room-display-name room))\n                                         ;; HACK: Apply face here, otherwise tabulated-list overrides it.\n                                         'face name-face\n                                         'help-echo e-alias)\n                             'action #'ement-tabulated-room-list-action))\n               (e-topic (if topic\n                            ;; Remove newlines from topic.  Yes, this can happen.\n                            (replace-regexp-in-string \"\\n\" \"\" topic t t)\n                          \"\"))\n               (formatted-timestamp (if latest-ts\n                                        (ement--human-format-duration (- (time-convert nil 'integer) (/ latest-ts 1000))\n                                                                      t)\n                                      \"\"))\n               (latest-face (when latest-ts\n                              (let* ((difference-seconds (- (float-time) (/ latest-ts 1000))  )\n                                     (n (cl-typecase difference-seconds\n                                          ((number 0 3599) ;; 1 hour to 1 day: 24 1-hour periods.\n                                           (truncate (/ difference-seconds 600)))\n                                          ((number 3600 86400) ;; 1 day\n                                           (+ 6 (truncate (/ difference-seconds 3600))))\n                                          (otherwise ;; Difference in weeks.\n                                           (min (/ (length ement-tabulated-room-list-timestamp-colors) 2)\n                                                (+ 24 (truncate (/ difference-seconds 86400 7))))))))\n                                (list :foreground (elt ement-tabulated-room-list-timestamp-colors n)))))\n               (e-latest (or (when formatted-timestamp\n                               (propertize formatted-timestamp\n                                           'value latest-ts\n                                           'face latest-face))\n                             ;; Invited rooms don't have a latest-ts.\n                             \"\"))\n               (e-session (propertize (ement-user-id (ement-session-user session))\n                                      'value session))\n               ;;  ((e-tags favorite-p low-priority-p) (ement-tabulated-room-list--tags room))\n               (e-direct-p (if (ement--room-direct-p room session)\n                               (propertize \"d\" 'help-echo \"Direct room\")\n                             \"\"))\n               (e-priority (cond ((ement--room-favourite-p room) \"F\")\n                                 ((ement--room-low-priority-p room) \"l\")\n                                 (\" \")))\n               (e-members (if member-count (number-to-string member-count) \"\")))\n    (when ement-tabulated-room-list-simplify-timestamps\n      (setf e-latest (replace-regexp-in-string\n                      (rx bos (1+ digit) (1+ alpha) (group (1+ (1+ digit) (1+ alpha))))\n                      \"\" e-latest t t 1)))\n    ;; Add face modifiers.\n    (when (and buffer (buffer-modified-p buffer))\n      ;; For some reason, `push' doesn't work with `map-elt'.\n      (setf (map-elt name-face :inherit)\n            (cons 'ement-tabulated-room-list-unread (map-elt name-face :inherit))))\n    (when (ement--room-direct-p room session)\n      (setf (map-elt name-face :inherit)\n            (cons 'ement-tabulated-room-list-direct (map-elt name-face :inherit))))\n    (when (ement--room-favourite-p room)\n      (push 'ement-tabulated-room-list-favourite (map-elt name-face :inherit)))\n    (when (ement--room-low-priority-p room)\n      (push 'ement-tabulated-room-list-low-priority (map-elt name-face :inherit)))\n    (pcase (ement-room-type room)\n      ('invite\n       (setf e-topic (concat (propertize \"[invited]\"\n                                         'face 'ement-tabulated-room-list-invited)\n                             \" \" e-topic)\n             (map-elt name-face :inherit) (cons 'ement-tabulated-room-list-invited\n                                                (map-elt name-face :inherit))))\n      ('leave\n       (setf e-topic (concat (propertize \"[left]\"\n                                         'face 'ement-tabulated-room-list-left)\n                             \" \" e-topic)\n             (map-elt name-face :inherit) (cons (map-elt name-face :inherit)\n                                                'ement-tabulated-room-list-left))))\n    (list room (vector e-unread e-priority e-buffer e-direct-p\n                       e-avatar e-name e-topic e-latest e-members\n                       ;; e-tags\n                       e-session\n                       ;; e-avatar\n                       ))))\n\n;; TODO: Define sorters with a macro?  This gets repetitive and hard to update.\n\n(defun ement-tabulated-room-list-members< (a b)\n  \"Return non-nil if entry A has fewer members than room B.\nA and B should be entries from `tabulated-list-mode'.\"\n  (pcase-let* ((`(,_room [,_unread ,_priority ,_buffer ,_direct ,_avatar ,_name-for-list ,_topic ,_latest ,a-members ,_session]) a)\n               (`(,_room [,_unread ,_priority ,_buffer ,_direct ,_avatar ,_name-for-list ,_topic ,_latest ,b-members ,_session]) b))\n    (when (and a-members b-members)\n      ;; Invited rooms may have no member count (I think).\n      (< (string-to-number a-members) (string-to-number b-members)))))\n\n(defun ement-tabulated-room-list-latest< (a b)\n  \"Return non-nil if entry A has fewer members than room B.\nA and B should be entries from `tabulated-list-mode'.\"\n  (pcase-let* ((`(,_room-a [,_unread ,_priority ,_buffer ,_direct ,_avatar ,_name-for-list ,_topic ,a-latest ,_a-members ,_session]) a)\n               (`(,_room-b [,_unread ,_priority ,_buffer ,_direct ,_avatar ,_name-for-list ,_topic ,b-latest ,_b-members ,_session]) b)\n               (a-latest (get-text-property 0 'value a-latest))\n               (b-latest (get-text-property 0 'value b-latest)))\n    (cond ((and a-latest b-latest)\n           (< a-latest b-latest))\n          (b-latest\n           ;; Invited rooms have no latest timestamp, and we want to sort them first.\n           nil)\n          (t t))))\n\n;;;; Footer\n\n(provide 'ement-tabulated-room-list)\n\n;;; ement-tabulated-room-list.el ends here\n"
  },
  {
    "path": "ement.el",
    "content": ";;; ement.el --- Matrix client                       -*- lexical-binding: t; -*-\n\n;; Copyright (C) 2022-2023  Free Software Foundation, Inc.\n\n;; Author: Adam Porter \n;; Maintainer: Adam Porter \n;; URL: https://github.com/alphapapa/ement.el\n;; Version: 0.18-pre\n;; Package-Requires: ((emacs \"27.1\") (map \"2.1\") (persist \"0.5\") (plz \"0.6\") (taxy \"0.10\") (taxy-magit-section \"0.13\") (svg-lib \"0.2.5\") (transient \"0.3.7\"))\n;; Keywords: comm\n\n;; This program is free software; you can redistribute it and/or modify\n;; it under the terms of the GNU General Public License as published by\n;; the Free Software Foundation, either version 3 of the License, or\n;; (at your option) any later version.\n\n;; This program is distributed in the hope that it will be useful,\n;; but WITHOUT ANY WARRANTY; without even the implied warranty of\n;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n;; GNU General Public License for more details.\n\n;; You should have received a copy of the GNU General Public License\n;; along with this program.  If not, see .\n\n;;; Commentary:\n\n;; Another Matrix client!  This one is written from scratch and is\n;; intended to be more \"Emacsy,\" more suitable for MELPA, etc.  Also\n;; it has a shorter, perhaps catchier name, that is a mildly clever\n;; play on the name of the official Matrix client and the Emacs Lisp\n;; filename extension (oops, I explained the joke), which makes for\n;; much shorter symbol names.\n\n;; This file implements the core client library.  Functions that may be called in multiple\n;; files belong in `ement-lib'.\n\n;;; Code:\n\n;;;; Debugging\n\n;; NOTE: Uncomment this form and `emacs-lisp-byte-compile-and-load' the file to enable\n;; `ement-debug' messages.  This is commented out by default because, even though the\n;; messages are only displayed when `warning-minimum-log-level' is `:debug' at runtime, if\n;; that is so at expansion time, the expanded macro calls format the message and check the\n;; log level at runtime, which is not zero-cost.\n\n;; (eval-and-compile\n;;   (require 'warnings)\n;;   (setq-local warning-minimum-log-level nil)\n;;   (setq-local warning-minimum-log-level :debug))\n\n;;;; Requirements\n\n;; Built in.\n(require 'cl-lib)\n(require 'dns)\n(require 'files)\n(require 'map)\n\n;; This package.\n(require 'ement-lib)\n(require 'ement-room)\n(require 'ement-notifications)\n(require 'ement-notify)\n\n;;;; Variables\n\n(defvar ement-sessions nil\n  \"Alist of active `ement-session' sessions, keyed by MXID.\")\n\n(defvar ement-syncs nil\n  \"Alist of outstanding sync processes for each session.\")\n\n(defvar ement-users (make-hash-table :test #'equal)\n  ;; NOTE: When changing the ement-user struct, it's necessary to\n  ;; reset this table to clear old-type structs.\n  \"Hash table storing user structs keyed on user ID.\")\n\n(defvar ement-progress-reporter nil\n  \"Used to report progress while processing sync events.\")\n\n(defvar ement-progress-value nil\n  \"Used to report progress while processing sync events.\")\n\n(defvar ement-sync-callback-hook\n  '(ement--update-room-buffers ement--auto-sync ement-tabulated-room-list-auto-update\n                               ement-room-list-auto-update)\n  \"Hook run after `ement--sync-callback'.\nHooks are called with one argument, the session that was\nsynced.\")\n\n(defvar ement-event-hook\n  '(ement-notify ement--process-event ement--put-event)\n  \"Hook called for events.\nEach function is called with three arguments: the event, the\nroom, and the session.  This hook isn't intended to be modified\nby users; ones who do so should know what they're doing.\")\n\n(defvar ement-default-sync-filter\n  '((room (state (lazy_load_members . t))\n          (timeline (lazy_load_members . t))))\n  \"Default filter for sync requests.\")\n\n(defvar ement-images-queue (make-plz-queue :limit 5)\n  \"`plz' HTTP request queue for image requests.\")\n\n(defvar ement-read-receipt-idle-timer nil\n  \"Idle timer used to update read receipts.\")\n\n(defvar ement-connect-user-id-history nil\n  \"History list of user IDs entered into `ement-connect'.\")\n\n;; From other files.\n(defvar ement-room-avatar-max-width)\n(defvar ement-room-avatar-max-height)\n\n;;;; Customization\n\n(defgroup ement-faces nil\n  \"Faces for Ement.\"\n  :group 'ement)\n\n(defgroup ement nil\n  \"Options for Ement, the Matrix client.\"\n  :group 'comm)\n\n(defcustom ement-save-sessions nil\n  \"Save session to disk.\nWrites the session file when Emacs is killed.\"\n  :type 'boolean\n  :set (lambda (option value)\n         (set-default option value)\n         (if value\n             (add-hook 'kill-emacs-hook #'ement--kill-emacs-hook)\n           (remove-hook 'kill-emacs-hook #'ement--kill-emacs-hook))))\n\n(defcustom ement-sessions-file \"~/.cache/ement.el\"\n  ;; FIXME: Expand correct XDG cache directory (new in Emacs 27).\n  \"Save username and access token to this file.\"\n  :type 'file)\n\n(defcustom ement-auto-sync t\n  \"Automatically sync again after syncing.\"\n  :type 'boolean)\n\n(defcustom ement-after-initial-sync-hook\n  '(ement-room-list--after-initial-sync ement-view-initial-rooms ement--link-children ement--run-idle-timer)\n  \"Hook run after initial sync.\nRun with one argument, the session synced.\"\n  :type 'hook)\n\n(defcustom ement-initial-sync-timeout 40\n  \"Timeout in seconds for initial sync requests.\nFor accounts in many rooms, the Matrix server may take some time\nto prepare the initial sync response, and increasing this timeout\nmight be necessary.\"\n  :type 'integer)\n\n(defcustom ement-auto-view-rooms nil\n  \"Rooms to view after initial sync.\nAlist mapping user IDs to a list of room aliases/IDs to open buffers for.\"\n  :type '(alist :key-type (string :tag \"Local user ID\")\n                :value-type (repeat (string :tag \"Room alias/ID\"))))\n\n(defcustom ement-disconnect-hook '(ement-kill-buffers ement--stop-idle-timer)\n  ;; FIXME: Put private functions in a private hook.\n  \"Functions called when disconnecting.\nThat is, when calling command `ement-disconnect'.  Functions are\ncalled with no arguments.\"\n  :type 'hook)\n\n(defcustom ement-view-room-display-buffer-action '(display-buffer-same-window)\n  \"Display buffer action to use when opening room buffers.\nSee function `display-buffer' and info node `(elisp) Buffer\nDisplay Action Functions'.\"\n  :type 'function)\n\n(defcustom ement-auto-view-room-display-buffer-action '(display-buffer-no-window)\n  \"Display buffer action to use when automatically opening room buffers.\nThat is, rooms listed in `ement-auto-view-rooms', which see.  See\nfunction `display-buffer' and info node `(elisp) Buffer Display\nAction Functions'.\"\n  :type 'function)\n\n(defcustom ement-interrupted-sync-hook '(ement-interrupted-sync-warning)\n  \"Functions to call when syncing of a session is interrupted.\nOnly called when `ement-auto-sync' is non-nil.  Functions are\ncalled with one argument, the session whose sync was interrupted.\n\nThis hook allows the user to customize how sync interruptions are\nhandled (e.g. how to be notified).\"\n  :type 'hook\n  :options '(ement-interrupted-sync-message ement-interrupted-sync-warning))\n\n(defcustom ement-sso-server-port 4567\n  \"TCP port used for local HTTP server for SSO logins.\nIt shouldn't usually be necessary to change this.\"\n  :type 'integer)\n\n;;;; Commands\n\n;;;###autoload\n(cl-defun ement-connect (&key user-id password uri-prefix session)\n  \"Connect to Matrix with USER-ID and PASSWORD, or using SESSION.\nInteractively, with prefix, ignore a saved session and log in\nagain; otherwise, use a saved session if `ement-save-sessions' is\nenabled and a saved session is available, or prompt to log in if\nnot enabled or available.\n\nIf USER-ID or PASSWORD are not specified, the user will be\nprompted for them.\n\nIf URI-PREFIX is specified, it should be the prefix of the\nserver's API URI, including protocol, hostname, and optionally\nthe port, e.g.\n\n  \\\"https://matrix-client.matrix.org\\\"\n  \\\"http://localhost:8080\\\"\"\n  (interactive (if current-prefix-arg\n                   ;; Force new session.\n                   (list :user-id (read-string \"User ID: \" nil 'ement-connect-user-id-history))\n                 ;; Use known session.\n                 (unless ement-sessions\n                   ;; Read sessions from disk.\n                   (condition-case err\n                       (setf ement-sessions (ement--read-sessions))\n                     (error (display-warning 'ement (format \"Unable to read session data from disk (%s).  Prompting to log in again.\"\n                                                            (error-message-string err))))))\n                 (cl-case (length ement-sessions)\n                   (0 (list :user-id (read-string \"User ID: \" nil 'ement-connect-user-id-history)))\n                   (1 (list :session (cdar ement-sessions)))\n                   (otherwise (list :session (ement-complete-session))))))\n  (let (sso-server-process)\n    (cl-labels ((new-session ()\n                  (unless (string-match (rx bos \"@\" (group (1+ (not (any \":\")))) ; Username\n                                            \":\" (group (optional (1+ (not (any blank)))))) ; Server name\n                                        user-id)\n                    (user-error \"Invalid user ID format: use @USERNAME:SERVER\"))\n                  (let* ((username (match-string 1 user-id))\n                         (server-name (match-string 2 user-id))\n                         (uri-prefix (or uri-prefix (ement--hostname-uri server-name)))\n                         (user (make-ement-user :id user-id :username username))\n                         (server (make-ement-server :name server-name :uri-prefix uri-prefix))\n                         (transaction-id (ement--initial-transaction-id))\n                         (initial-device-display-name (format \"Ement.el: %s@%s\"\n                                                              ;; Just to be extra careful:\n                                                              (or user-login-name \"[unknown user-login-name]\")\n                                                              (or (system-name) \"[unknown system-name]\")))\n                         (device-id (secure-hash 'sha256 initial-device-display-name)))\n                    (make-ement-session :user user :server server :transaction-id transaction-id\n                                        :device-id device-id :initial-device-display-name initial-device-display-name\n                                        :events (make-hash-table :test #'equal))))\n                (password-login ()\n                  (pcase-let* (((cl-struct ement-session user device-id initial-device-display-name) session)\n                               ((cl-struct ement-user id) user)\n                               (data (ement-alist \"type\" \"m.login.password\"\n                                                  \"identifier\"\n                                                  (ement-alist \"type\" \"m.id.user\"\n                                                               \"user\" id)\n                                                  \"password\" (or password\n                                                                 (read-passwd (format \"Password for %s: \" id)))\n                                                  \"device_id\" device-id\n                                                  \"initial_device_display_name\" initial-device-display-name)))\n                    ;; TODO: Clear password in callback (if we decide to hold on to it for retrying login timeouts).\n                    (ement-api session \"login\" :method 'post :data (json-encode data)\n                      :then (apply-partially #'ement--login-callback session))\n                    (ement-message \"Logging in with password...\")))\n                (sso-filter (process string)\n                  ;; NOTE: This is technically wrong, because it's not guaranteed that the\n                  ;; string will be a complete request--it could just be a chunk.  But in\n                  ;; practice, if this works, it's much simpler than setting up process log\n                  ;; functions and per-client buffers for this throwaway, pretend HTTP server.\n                  (when (string-match (rx \"GET /?loginToken=\" (group (0+ nonl)) \" \" (0+ nonl)) string)\n                    (unwind-protect\n                        (pcase-let* ((token (match-string 1 string))\n                                     ((cl-struct ement-session user device-id initial-device-display-name)\n                                      session)\n                                     ((cl-struct ement-user id) user)\n                                     (data (ement-alist\n                                            \"type\" \"m.login.token\"\n                                            \"identifier\" (ement-alist \"type\" \"m.id.user\"\n                                                                      \"user\" id)\n                                            \"token\" token\n                                            \"device_id\" device-id\n                                            \"initial_device_display_name\" initial-device-display-name)))\n                          (ement-api session \"login\" :method 'post\n                            :data (json-encode data)\n                            :then (apply-partially #'ement--login-callback session))\n                          (process-send-string process \"HTTP/1.0 202 Accepted\nContent-Type: text/plain; charset=utf-8\n\nEment: SSO login accepted; session token received.  Connecting to Matrix server.  (You may close this page.)\")\n                          (process-send-eof process))\n                      (delete-process sso-server-process)\n                      (delete-process process))))\n                (sso-login ()\n                  (setf sso-server-process\n                        (make-network-process\n                         :name \"ement-sso\" :family 'ipv4 :host 'local :service ement-sso-server-port\n                         :filter #'sso-filter :server t :noquery t))\n                  ;; Kill server after 2 minutes in case of problems.\n                  (run-at-time 120 nil (lambda ()\n                                         (when (process-live-p sso-server-process)\n                                           (delete-process sso-server-process))))\n                  (let ((url (concat (ement-server-uri-prefix (ement-session-server session))\n                                     \"/_matrix/client/r0/login/sso/redirect?redirectUrl=http://localhost:\"\n                                     (number-to-string ement-sso-server-port))))\n                    (funcall browse-url-secondary-browser-function url)\n                    (message \"Browsing to single sign-on page <%s>...\" url)))\n                (flows-callback (data)\n                  (let ((flows (cl-loop for flow across (map-elt data 'flows)\n                                        for type = (map-elt flow 'type)\n                                        when (member type '(\"m.login.password\" \"m.login.sso\"))\n                                        collect type)))\n                    (pcase (length flows)\n                      (0 (error \"Ement: No supported login flows:  Server:%S  Supported flows:%S\"\n                                (ement-server-uri-prefix (ement-session-server session))\n                                (map-elt data 'flows)))\n                      (1 (pcase (car flows)\n                           (\"m.login.password\" (password-login))\n                           (\"m.login.sso\" (sso-login))\n                           (_ (error \"Ement: Unsupported login flow: %s  Server:%S  Supported flows:%S\"\n                                     (car flows) (ement-server-uri-prefix (ement-session-server session))\n                                     (map-elt data 'flows)))))\n                      (_ (pcase (completing-read \"Select authentication method: \"\n                                                 (cl-loop for flow in flows\n                                                          collect (string-trim-left flow (rx \"m.login.\"))))\n                           (\"password\" (password-login))\n                           (\"sso\" (sso-login))\n                           (else (error \"Ement: Unsupported login flow:%S  Server:%S  Supported flows:%S\"\n                                        else (ement-server-uri-prefix (ement-session-server session))\n                                        (map-elt data 'flows)))))))))\n      (if session\n          ;; Start syncing given session.\n          (let ((user-id (ement-user-id (ement-session-user session))))\n            ;; HACK: If session is already in ement-sessions, this replaces it.  I think that's okay...\n            (setf (alist-get user-id ement-sessions nil nil #'equal) session)\n            (ement--sync session :timeout ement-initial-sync-timeout))\n        ;; Start password login flow.  Prompt for user ID and password\n        ;; if not given (i.e. if not called interactively.)\n        (unless user-id\n          (setf user-id (read-string \"User ID: \" nil 'ement-connect-user-id-history)))\n        (setf session (new-session))\n        (when (ement-api session \"login\" :then #'flows-callback)\n          (message \"Ement: Checking server's login flows...\"))))))\n\n(defun ement-disconnect (sessions)\n  \"Disconnect from SESSIONS.\nInteractively, with prefix, disconnect from all sessions.  If\n`ement-auto-sync' is enabled, stop syncing, and clear the session\ndata.  When enabled, write the session to disk.  Any existing\nroom buffers are left alive and can be read, but other commands\nin them won't work.\"\n  (interactive (list (if current-prefix-arg\n                         (mapcar #'cdr ement-sessions)\n                       (list (ement-complete-session)))))\n  (when ement-save-sessions\n    ;; Write sessions before we remove them from the variable.\n    (ement--write-sessions ement-sessions))\n  (dolist (session sessions)\n    (let ((user-id (ement-user-id (ement-session-user session))))\n      (when-let ((process (map-elt ement-syncs session)))\n        ;; Disable the sync process's ELSE handler, preventing error messages, but still\n        ;; allowing `plz--respond' to clean up the buffer, etc.\n        (setf (process-get process :plz-else) #'ignore)\n        (delete-process process))\n      ;; NOTE: I'd like to use `map-elt' here, but not until\n      ;;  is fixed, I guess.\n      (setf (alist-get session ement-syncs nil nil #'equal) nil\n            (alist-get user-id ement-sessions nil 'remove #'equal) nil)))\n  (unless ement-sessions\n    ;; HACK: If no sessions remain, clear the users table.  It might be best\n    ;; to store a per-session users table, but this is probably good enough.\n    (clrhash ement-users))\n  (run-hooks 'ement-disconnect-hook)\n  (message \"Ement: Disconnected <%s>.\"\n           (string-join (cl-loop for session in sessions\n                                 collect (ement-user-id (ement-session-user session)))\n                        \", \")))\n\n(defun ement-kill-buffers ()\n  \"Kill all Ement buffers.\nUseful in, e.g. `ement-disconnect-hook', which see.\"\n  (interactive)\n  (dolist (buffer (buffer-list))\n    (when (string-prefix-p \"ement-\" (symbol-name (buffer-local-value 'major-mode buffer)))\n      (kill-buffer buffer))))\n\n(defun ement--login-callback (session data)\n  \"Record DATA from logging in to SESSION and do initial sync.\"\n  (pcase-let* (((cl-struct ement-session (user (cl-struct ement-user (id user-id)))) session)\n               ((map ('access_token token) ('device_id device-id)) data))\n    (setf (ement-session-token session) token\n          (ement-session-device-id session) device-id\n          (alist-get user-id ement-sessions nil nil #'equal) session)\n    (ement--sync session :timeout ement-initial-sync-timeout)))\n\n;;;; Functions\n\n(defun ement-interrupted-sync-warning (session)\n  \"Display a warning that syncing of SESSION was interrupted.\"\n  (display-warning\n   'ement\n   (format\n    (substitute-command-keys\n     \"\\\\Syncing of session <%s> was interrupted.  Use command `ement-room-sync' in a room buffer to retry.\")\n    (ement-user-id (ement-session-user session)))\n   :error))\n\n(defun ement-interrupted-sync-message (session)\n  \"Display a message that syncing of SESSION was interrupted.\"\n  (message\n   (substitute-command-keys\n    \"\\\\Syncing of session <%s> was interrupted.  Use command `ement-room-sync' in a room buffer to retry.\")\n   (ement-user-id (ement-session-user session))))\n\n(defun ement--run-idle-timer (&rest _ignore)\n  \"Run idle timer that updates read receipts.\nTo be called from `ement-after-initial-sync-hook'.  Timer is\nstored in `ement-read-receipt-idle-timer'.\"\n  (unless (timerp ement-read-receipt-idle-timer)\n    (setf ement-read-receipt-idle-timer (run-with-idle-timer 3 t #'ement-room-read-receipt-idle-timer))))\n\n(defun ement--stop-idle-timer (&rest _ignore)\n  \"Stop idle timer stored in `ement-read-receipt-idle-timer'.\nTo be called from `ement-disconnect-hook'.\"\n  (unless ement-sessions\n    (when (timerp ement-read-receipt-idle-timer)\n      (cancel-timer ement-read-receipt-idle-timer)\n      (setf ement-read-receipt-idle-timer nil))))\n\n(defun ement-view-initial-rooms (session)\n  \"View rooms for SESSION configured in `ement-auto-view-rooms'.\"\n  (when-let (rooms (alist-get (ement-user-id (ement-session-user session))\n\t\t\t      ement-auto-view-rooms nil nil #'equal))\n    (dolist (alias/id rooms)\n      (when-let (room (cl-find-if (lambda (room)\n\t\t\t\t    (or (equal alias/id (ement-room-canonical-alias room))\n\t\t\t\t\t(equal alias/id (ement-room-id room))))\n\t\t\t\t  (ement-session-rooms session)))\n        (let ((ement-view-room-display-buffer-action ement-auto-view-room-display-buffer-action))\n          (ement-view-room room session))))))\n\n(defun ement--initial-transaction-id ()\n  \"Return an initial transaction ID for a new session.\"\n  ;; We generate a somewhat-random initial transaction ID to avoid potential conflicts in\n  ;; case, e.g. using Pantalaimon causes a transaction ID conflict.  See\n  ;; .\n  (cl-parse-integer\n   (secure-hash 'sha256 (prin1-to-string (list (current-time) (system-name))))\n   :end 8 :radix 16))\n\n(defsubst ement--sync-messages-p (session)\n  \"Return non-nil if sync-related messages should be shown for SESSION.\"\n  ;; For now, this seems like the best way.\n  (or (not (ement-session-has-synced-p session))\n      (not ement-auto-sync)))\n\n(defun ement--hostname-uri (hostname)\n  \"Return the \\\".well-known\\\" URI for server HOSTNAME.\nIf no URI is found, prompt the user for the hostname.\"\n  ;; FIXME: When fail-prompting, a URI should be returned, not just a hostname.\n  ;; SPEC:  (\"4.1   Well-known URI\")\n  (cl-labels ((fail-prompt ()\n                (let ((input (read-string \"Auto-discovery of server's well-known URI failed.  Input server hostname, or leave blank to use server name: \")))\n                  (pcase input\n                    (\"\" hostname)\n                    (_ input))))\n              (parse (string)\n                (if-let* ((object (ignore-errors (json-read-from-string string)))\n                          (url (map-nested-elt object '(m.homeserver base_url)))\n                          ((string-match-p\n                            (rx bos \"http\" (optional \"s\") \"://\" (1+ nonl))\n                            url)))\n                    url\n                  ;; Parsing error: FAIL_PROMPT.\n                  (fail-prompt))))\n    (condition-case err\n        (let ((response (plz 'get (concat \"https://\" hostname \"/.well-known/matrix/client\")\n                          :as 'response :then 'sync)))\n          (if (plz-response-p response)\n              (pcase (plz-response-status response)\n                (200 (parse (plz-response-body response)))\n                (404 (fail-prompt))\n                (_ (warn \"Ement: `plz' request for .well-known URI returned unexpected code: %s\"\n                         (plz-response-status response))\n                   (fail-prompt)))\n            (warn \"Ement: `plz' request for .well-known URI did not return a `plz' response\")\n            (fail-prompt)))\n      (error (warn \"Ement: `plz' request for .well-known URI signaled an error: %S\" err)\n             (fail-prompt)))))\n\n(cl-defun ement--sync (session &key force quiet\n                               (timeout 40) ;; Give the server an extra 10 seconds.\n                               (filter ement-default-sync-filter))\n  \"Send sync request for SESSION.\nIf SESSION has a `next-batch' token, it's used.  If FORCE, first\ndelete any outstanding sync processes.  If QUIET, don't show a\nmessage about syncing this time.  Cancel request after TIMEOUT\nseconds.\n\nFILTER may be an alist representing a raw event filter (i.e. not\na filter ID).  When unspecified, the value of\n`ement-default-sync-filter' is used.  The filter is encoded with\n`json-encode'.  To use no filter, specify FILTER as nil.\"\n  ;; SPEC: .\n  ;; TODO: Filtering: .\n  ;; TODO: Use a filter ID for default filter.\n  ;; TODO: Optionally, automatically sync again when HTTP request fails.\n  ;; TODO: Ensure that the process in (map-elt ement-syncs session) is live.\n  (when (map-elt ement-syncs session)\n    (if force\n        (condition-case err\n            (delete-process (map-elt ement-syncs session))\n          ;; Ensure the only error is the expected one from deleting the process.\n          (ement-api-error (cl-assert (equal \"curl process killed\" (plz-error-message (cl-third err))))\n                           (message \"Ement: Forcing new sync\")))\n      (user-error \"Ement: Already syncing this session\")))\n  (pcase-let* (((cl-struct ement-session next-batch) session)\n               (params (remove\n                        nil (list (list \"full_state\" (if next-batch \"false\" \"true\"))\n                                  (when filter\n                                    ;; TODO: Document filter arg.\n                                    (list \"filter\" (json-encode filter)))\n                                  (when next-batch\n                                    (list \"since\" next-batch))\n                                  (when next-batch\n                                    (list \"timeout\" \"30000\")))))\n               (sync-start-time (time-to-seconds))\n               ;; FIXME: Auto-sync again in error handler.\n               (process (ement-api session \"sync\" :params params\n                          :timeout timeout\n                          :then (apply-partially #'ement--sync-callback session)\n                          :else (lambda (plz-error)\n                                  (setf (map-elt ement-syncs session) nil)\n                                  ;; TODO: plz probably needs nicer error handling.\n                                  ;; Ideally we would use `condition-case', but since the\n                                  ;; error is signaled in `plz--sentinel'...\n                                  (pcase-let (((cl-struct plz-error curl-error response) plz-error)\n                                              (reason))\n                                    (cond ((when response\n                                             (pcase (plz-response-status response)\n                                               ((or 429 502) (setf reason \"failed\")))))\n                                          ((pcase curl-error\n                                             (`(28 . ,_) (setf reason \"timed out\")))))\n                                    (if reason\n                                        (if (not ement-auto-sync)\n                                            (run-hook-with-args 'ement-interrupted-sync-hook session)\n                                          (message \"Ement: Sync %s (%s).  Syncing again...\"\n                                                   reason (ement-user-id (ement-session-user session)))\n                                          ;; Set QUIET to allow the just-printed message to remain visible.\n                                          (ement--sync session :timeout timeout :quiet t))\n                                      ;; Unrecognized errors:\n                                      (pcase curl-error\n                                        (`(,code . ,message)\n                                         (signal 'ement-api-error (list (format \"Ement: Network error: %s: %s\" code message)\n                                                                        plz-error)))\n                                        (_ (signal 'ement-api-error (list \"Ement: Unrecognized network error\" plz-error)))))))\n                          :json-read-fn (lambda ()\n                                          \"Print a message, then call `ement--json-parse-buffer'.\"\n                                          (when (ement--sync-messages-p session)\n                                            (message \"Ement: Response arrived after %.2f seconds.  Reading %s JSON response...\"\n                                                     (- (time-to-seconds) sync-start-time)\n                                                     (file-size-human-readable (buffer-size))))\n                                          (let ((start-time (time-to-seconds)))\n                                            (prog1 (ement--json-parse-buffer)\n                                              (when (ement--sync-messages-p session)\n                                                (message \"Ement: Reading JSON took %.2f seconds\"\n                                                         (- (time-to-seconds) start-time)))))))))\n    (when process\n      (setf (map-elt ement-syncs session) process)\n      (when (and (not quiet) (ement--sync-messages-p session))\n        (ement-message \"Sync request sent.  Waiting for response...\")))))\n\n(defun ement--sync-callback (session data)\n  \"Process sync DATA for SESSION.\nRuns `ement-sync-callback-hook' with SESSION.\"\n  (ement-debug (ement-user-id (ement-session-user session)))\n  ;; Remove the sync first.  We already have the data from it, and the\n  ;; process has exited, so it's safe to run another one.\n  (setf (map-elt ement-syncs session) nil)\n  (pcase-let* (((map rooms ('next_batch next-batch) ('account_data (map ('events account-data-events))))\n                data)\n               ((map ('join joined-rooms) ('invite invited-rooms) ('leave left-rooms)) rooms)\n               (num-events (+\n                            ;; HACK: In `ement--push-joined-room-events', we do something\n                            ;; with each event 3 times, so we multiply this by 3.\n                            ;; FIXME: That calculation doesn't seem to be quite right, because\n                            ;; the progress reporter never seems to hit 100% before it's done.\n                            (* 3 (cl-loop for (_id . room) in joined-rooms\n                                          sum (length (map-nested-elt room '(state events)))\n                                          sum (length (map-nested-elt room '(timeline events)))))\n                            (cl-loop for (_id . room) in invited-rooms\n                                     sum (length (map-nested-elt room '(invite_state events)))))))\n    ;; Append account data events.\n    ;; TODO: Since only one event of each type is allowed in account data (the spec\n    ;; doesn't seem to make this clear, but see\n    ;; ),\n    ;; we should store account-data events in a hash table or alist rather than just a\n    ;; list of events.\n    (cl-callf2 append (cl-coerce account-data-events 'list) (ement-session-account-data session))\n    ;; Process invited and joined rooms.\n    (ement-with-progress-reporter (:when (ement--sync-messages-p session)\n                                         :reporter (\"Ement: Reading events...\" 0 num-events))\n      ;; Left rooms.\n      (mapc (apply-partially #'ement--push-left-room-events session) left-rooms)\n      ;; Invited rooms.\n      (mapc (apply-partially #'ement--push-invite-room-events session) invited-rooms)\n      ;; Joined rooms.\n      (mapc (apply-partially #'ement--push-joined-room-events session) joined-rooms))\n    ;; TODO: Process \"left\" rooms (remove room structs, etc).\n    ;; NOTE: We update the next-batch token before updating any room buffers.  This means\n    ;; that any errors in updating room buffers (like for unexpected event formats that\n    ;; expose a bug) could cause events to not appear in the buffer, but the user could\n    ;; still dismiss the error and start syncing again, and the client could remain\n    ;; usable.  Updating the token after doing everything would be preferable in some\n    ;; ways, but it would mean that an event that exposes a bug would be processed again\n    ;; on every sync, causing the same error each time.  It would seem preferable to\n    ;; maintain at least some usability rather than to keep repeating a broken behavior.\n    (setf (ement-session-next-batch session) next-batch)\n    ;; Run hooks which update buffers, etc.\n    (run-hook-with-args 'ement-sync-callback-hook session)\n    ;; Show sync message if appropriate, and run after-initial-sync-hook.\n    (when (ement--sync-messages-p session)\n      (message (concat \"Ement: Sync done.\"\n                       (unless (ement-session-has-synced-p session)\n                         (run-hook-with-args 'ement-after-initial-sync-hook session)\n                         ;; Show tip after initial sync.\n                         (setf (ement-session-has-synced-p session) t)\n                         \"  Use commands `ement-list-rooms' or `ement-view-room' to view a room.\"))))))\n\n(defun ement--push-invite-room-events (session invited-room)\n  \"Push events for INVITED-ROOM into that room in SESSION.\"\n  ;; TODO: Make ement-session-rooms a hash-table.\n  (ement--push-joined-room-events session invited-room 'invite))\n\n(defun ement--auto-sync (session)\n  \"If `ement-auto-sync' is non-nil, sync SESSION again.\"\n  (when ement-auto-sync\n    (ement--sync session)))\n\n(defun ement--update-room-buffers (session)\n  \"Insert new events into SESSION's rooms which have buffers.\nTo be called in `ement-sync-callback-hook'.\"\n  ;; TODO: Move this to ement-room.el, probably.\n  ;; For now, we primitively iterate over the buffer list to find ones\n  ;; whose mode is `ement-room-mode'.\n  (let* ((buffers (cl-loop for room in (ement-session-rooms session)\n                           for buffer = (map-elt (ement-room-local room) 'buffer)\n                           when (buffer-live-p buffer)\n                           collect buffer)))\n    (dolist (buffer buffers)\n      (with-current-buffer buffer\n        (save-window-excursion\n          ;; NOTE: When the buffer has a window, it must be the selected one\n          ;; while calling event-insertion functions.  I don't know if this is\n          ;; due to a bug in EWOC or if I just misunderstand something, but\n          ;; without doing this, events may be inserted at the wrong place.\n          (when-let ((buffer-window (get-buffer-window buffer)))\n            (select-window buffer-window))\n          (cl-assert ement-room)\n          (when (ement-room-ephemeral ement-room)\n            ;; Ephemeral events.\n            (ement-room--process-events (ement-room-ephemeral ement-room))\n            (setf (ement-room-ephemeral ement-room) nil))\n          (when-let ((new-events (alist-get 'new-events (ement-room-local ement-room))))\n            ;; HACK: Process these events in reverse order, so that later events (like reactions)\n            ;; which refer to earlier events can find them.  (Not sure if still necessary.)\n            (ement-room--process-events (reverse new-events))\n            (setf (alist-get 'new-events (ement-room-local ement-room)) nil))\n          (when-let ((new-events (alist-get 'new-account-data-events (ement-room-local ement-room))))\n            ;; Account data events.  Do this last so, e.g. read markers can refer to message events we've seen.\n            (ement-room--process-events new-events)\n            (setf (alist-get 'new-account-data-events (ement-room-local ement-room)) nil)))))))\n\n(cl-defun ement--push-joined-room-events (session joined-room &optional (status 'join))\n  \"Push events for JOINED-ROOM into that room in SESSION.\nAlso used for left rooms, in which case STATUS should be set to\n`leave'.\"\n  (pcase-let* ((`(,id . ,event-types) joined-room)\n               (id (symbol-name id)) ; Really important that the ID is a STRING!\n               ;; TODO: Make ement-session-rooms a hash-table.\n               (room (or (cl-find-if (lambda (room)\n                                       (equal id (ement-room-id room)))\n                                     (ement-session-rooms session))\n                         (car (push (make-ement-room :id id) (ement-session-rooms session)))))\n               ((map summary state ephemeral timeline\n                     ('invite_state (map ('events invite-state-events)))\n                     ('account_data (map ('events account-data-events)))\n                     ('unread_notifications unread-notifications))\n                event-types)\n               (latest-timestamp))\n    (setf (ement-room-status room) status\n          (ement-room-unread-notifications room) unread-notifications)\n    ;; NOTE: The idea is that, assuming that events in the sync response are in\n    ;; chronological order, we push them to the lists in the room slots in that order,\n    ;; leaving the head of each list as the most recent event of that type.  That means\n    ;; that, e.g. the room state events may be searched in order to find, e.g. the most\n    ;; recent room name event.  However, chronological order is not guaranteed, e.g. after\n    ;; loading older messages (the \"retro\" function; this behavior is in development).\n\n    ;; MAYBE: Use queue.el to store the events in a DLL, so they could\n    ;; be accessed from either end.  Could be useful.\n\n    ;; Push the StrippedState events to the room's invite-state.  (These events have no\n    ;; timestamp data.)  We also run the event hook, because for invited rooms, the\n    ;; invite-state events include room name, topic, etc.\n    (cl-loop for event across-ref invite-state-events do\n             (setf event (ement--make-event event))\n             (push event (ement-room-invite-state room))\n             (run-hook-with-args 'ement-event-hook event room session))\n\n    ;; Save room summary.\n    (dolist (parameter '(m.heroes m.joined_member_count m.invited_member_count))\n      (when (alist-get parameter summary)\n        ;; These fields are only included when they change.\n        (setf (alist-get parameter (ement-room-summary room)) (alist-get parameter summary))))\n\n    ;; Update account data.  According to the spec, only one of each event type is\n    ;; supposed to be present in a room's account data, so we store them as an alist keyed\n    ;; on their type.  (NOTE: We don't currently make them into event structs, but maybe\n    ;; we should in the future.)\n    (cl-loop for event across account-data-events\n             for type = (alist-get 'type event)\n             do (setf (alist-get type (ement-room-account-data room) nil nil #'equal) event))\n    ;; But we also need to track just the new events so we can process those in a room\n    ;; buffer (and for some reason, we do make them into structs here, but I don't\n    ;; remember why).  FIXME: Unify this.\n    (cl-callf2 append (mapcar #'ement--make-event account-data-events)\n               (alist-get 'new-account-data-events (ement-room-local room)))\n\n    ;; Save state and timeline events.\n    (cl-macrolet ((push-events (type accessor)\n                    ;; Push new events of TYPE to room's slot of ACCESSOR, and return the latest timestamp pushed.\n                    `(let ((ts 0))\n                       ;; NOTE: We replace each event in the vector with the\n                       ;; struct, which is used when calling hooks later.\n                       (cl-loop for event across-ref (alist-get 'events ,type)\n                                do (setf event (ement--make-event event))\n                                do (push event (,accessor room))\n                                (when (ement--sync-messages-p session)\n                                  (ement-progress-update))\n                                (when (> (ement-event-origin-server-ts event) ts)\n                                  (setf ts (ement-event-origin-server-ts event))))\n                       ;; One would think that one should use `maximizing' here, but, completely\n                       ;; inexplicably, it sometimes returns nil, even when every single value it's comparing\n                       ;; is a number.  It's absolutely bizarre, but I have to do the equivalent manually.\n                       ts)))\n      ;; FIXME: This is a bit convoluted and hacky now.  Refactor it.\n      (setf latest-timestamp\n            (max (push-events state ement-room-state)\n                 (push-events timeline ement-room-timeline)))\n      ;; NOTE: We also append the new events to the new-events list in the room's local\n      ;; slot, which is used by `ement--update-room-buffers' to insert only new events.\n      ;; FIXME: Does this also need to be done for invite-state events?\n      (cl-callf2 append (cl-coerce (alist-get 'events timeline) 'list)\n                 (alist-get 'new-events (ement-room-local room)))\n      ;; Update room's latest-timestamp slot.\n      (when (> latest-timestamp (or (ement-room-latest-ts room) 0))\n        (setf (ement-room-latest-ts room) latest-timestamp))\n      (unless (ement-session-has-synced-p session)\n        ;; Only set this token on initial sync, otherwise it would\n        ;; overwrite earlier tokens from loading earlier messages.\n        (setf (ement-room-prev-batch room) (alist-get 'prev_batch timeline))))\n    ;; Run event hook for state and timeline events.\n    (cl-loop for event across (alist-get 'events state)\n             do (run-hook-with-args 'ement-event-hook event room session)\n             (when (ement--sync-messages-p session)\n               (ement-progress-update)))\n    (cl-loop for event across (alist-get 'events timeline)\n             do (run-hook-with-args 'ement-event-hook event room session)\n             (when (ement--sync-messages-p session)\n               (ement-progress-update)))\n    ;; Ephemeral events (do this after state and timeline hooks, so those events will be\n    ;; in the hash tables).\n    (cl-loop for event across (alist-get 'events ephemeral)\n             for event-struct = (ement--make-event event)\n             do (push event-struct (ement-room-ephemeral room))\n             (ement--process-event event-struct room session))\n    (when (ement-session-has-synced-p session)\n      ;; NOTE: We don't fill gaps in \"limited\" requests on initial\n      ;; sync, only in subsequent syncs, e.g. after the system has\n      ;; slept and awakened.\n      ;; NOTE: When not limited, the read value is `:json-false', so\n      ;; we must explicitly compare to t.\n      (when (eq t (alist-get 'limited timeline))\n\t;; Timeline was limited: start filling gap.  We start the\n\t;; gap-filling, retrieving up to the session's current\n\t;; next-batch token (this function is not called when retrieving\n\t;; older messages, so the session's next-batch token is only\n\t;; evaluated once, when this chain begins, and then that token\n\t;; is passed to repeated calls to `ement-room-retro-to-token'\n\t;; until the gap is filled).\n\t(ement-room-retro-to-token room session (alist-get 'prev_batch timeline)\n\t\t\t\t   (ement-session-next-batch session))))))\n\n(defun ement--push-left-room-events (session left-room)\n  \"Push events for LEFT-ROOM into that room in SESSION.\"\n  (ement--push-joined-room-events session left-room 'leave))\n\n(defun ement--make-event (event)\n  \"Return `ement-event' struct for raw EVENT list.\nAdds sender to `ement-users' when necessary.\"\n  (pcase-let* (((map content type unsigned redacts\n                     ('event_id id) ('origin_server_ts ts)\n                     ('sender sender-id) ('state_key state-key))\n                event)\n               (sender (or (gethash sender-id ement-users)\n                           (puthash sender-id (make-ement-user :id sender-id)\n                                    ement-users))))\n    ;; MAYBE: Handle other keys in the event, such as \"room_id\" in \"invite\" events.\n    (make-ement-event :id id :sender sender :type type :content content :state-key state-key\n                      :origin-server-ts ts :unsigned unsigned\n                      ;; Since very few events will be redactions and have this key, we\n                      ;; record it in the local slot alist rather than as another slot on\n                      ;; the struct.\n                      :local (when redacts\n                               (ement-alist 'redacts redacts)))))\n\n(defun ement--put-event (event _room session)\n  \"Put EVENT on SESSION's events table.\"\n  (puthash (ement-event-id event) event (ement-session-events session)))\n\n;; FIXME: These functions probably need to compare timestamps to\n;; ensure that older events that are inserted at the head of the\n;; events lists aren't used instead of newer ones.\n\n;; TODO: These two functions should be folded into event handlers.\n\n;;;;; Reading/writing sessions\n\n;; TODO: Use `persist' and/or `multisession'.\n\n(defun ement--read-sessions ()\n  \"Return saved sessions alist read from disk.\nReturns nil if unable to read `ement-sessions-file'.\"\n  (cl-labels ((plist-to-session (plist)\n                (pcase-let* (((map (:user user-data) (:server server-data)\n                                   (:token token) (:transaction-id transaction-id))\n                              plist)\n                             (user (apply #'make-ement-user user-data))\n                             (server (apply #'make-ement-server server-data))\n                             (session (make-ement-session :user user :server server\n                                                          :token token :transaction-id transaction-id)))\n                  (setf (ement-session-events session) (make-hash-table :test #'equal))\n                  session)))\n    (when (file-exists-p ement-sessions-file)\n      (pcase-let* ((read-circle t)\n                   (sessions (with-temp-buffer\n                               (insert-file-contents ement-sessions-file)\n                               (read (current-buffer)))))\n        (prog1\n            (cl-loop for (id . plist) in sessions\n                     collect (cons id (plist-to-session plist)))\n          (message \"Ement: Read sessions.\"))))))\n\n(defun ement--write-sessions (sessions-alist)\n  \"Write SESSIONS-ALIST to disk.\"\n  ;; We only record the slots we need.  We record them as a plist\n  ;; so that changes to the struct definition don't matter.\n  ;; NOTE: If we ever persist more session data (like room data, so we\n  ;; could avoid doing an initial sync next time), we should limit the\n  ;; amount of session data saved (e.g. room history could grow\n  ;; forever on-disk, which probably isn't what we want).\n\n  ;; NOTE: This writes all current sessions, even if there are multiple active ones and only one\n  ;; is being disconnected.  That's probably okay, but it might be something to keep in mind.\n  (cl-labels ((session-plist (session)\n                (pcase-let* (((cl-struct ement-session user server token transaction-id) session)\n                             ((cl-struct ement-user (id user-id) username) user)\n                             ((cl-struct ement-server (name server-name) uri-prefix) server))\n                  (list :user (list :id user-id\n                                    :username username)\n                        :server (list :name server-name\n                                      :uri-prefix uri-prefix)\n                        :token token\n                        :transaction-id transaction-id))))\n    (message \"Ement: Writing sessions...\")\n    (with-temp-file ement-sessions-file\n      (pcase-let* ((print-level nil)\n                   (print-length nil)\n                   ;; Very important to use `print-circle', although it doesn't\n                   ;; solve everything.  Writing/reading Lisp data can be tricky...\n                   (print-circle t)\n                   (sessions-alist-plist (cl-loop for (id . session) in sessions-alist\n                                                  collect (cons id (session-plist session)))))\n        (prin1 sessions-alist-plist (current-buffer))))\n    ;; Ensure permissions are safe.\n    (chmod ement-sessions-file #o600)))\n\n(defun ement--kill-emacs-hook ()\n  \"Function to be added to `kill-emacs-hook'.\nWrites Ement session to disk when enabled.\"\n  (ignore-errors\n    ;; To avoid interfering with Emacs' exit, We must be careful that\n    ;; this function handles errors, so just ignore any.\n    (when (and ement-save-sessions\n               ement-sessions)\n      (ement--write-sessions ement-sessions))))\n\n;;;;; Event handlers\n\n(defvar ement-event-handlers nil\n  \"Alist mapping event types to functions which process an event of each type.\nEach function is called with three arguments: the event, the\nroom, and the session.  These handlers are run regardless of\nwhether a room has a live buffer.\")\n\n(defun ement--process-event (event room session)\n  \"Process EVENT for ROOM in SESSION.\nUses handlers defined in `ement-event-handlers'.  If no handler\nis defined for EVENT's type, does nothing and returns nil.  Any\nerrors signaled during processing are demoted in order to prevent\nunexpected errors from arresting event processing and syncing.\"\n  (when-let ((handler (alist-get (ement-event-type event) ement-event-handlers nil nil #'equal)))\n    ;; We demote any errors that happen while processing events, because it's possible for\n    ;; events to be malformed in unexpected ways, and that could cause an error, which\n    ;; would stop processing of other events and prevent further syncing.  See,\n    ;; e.g. .\n    (with-demoted-errors \"Ement (ement--process-event): Error processing event: %S\"\n      (funcall handler event room session))))\n\n(defmacro ement-defevent (type &rest body)\n  \"Define an event handling function for events of TYPE, a string.\nAround the BODY, the variable `event' is bound to the event being\nprocessed, `room' to the room struct in which the event occurred,\nand `session' to the session.  Adds function to\n`ement-event-handlers', which see.\"\n  (declare (indent defun))\n  `(setf (alist-get ,type ement-event-handlers nil nil #'string=)\n         (lambda (event room session)\n           ,(concat \"`ement-' handler function for \" type \" events.\")\n           ,@body)))\n\n;; I love how Lisp macros make it so easy and concise to define these\n;; event handlers!\n\n(ement-defevent \"m.room.avatar\"\n  (when ement-room-avatars\n    ;; If room avatars are disabled, we don't download avatars at all.  This\n    ;; means that, if a user has them disabled and then reenables them, they will\n    ;; likely need to reconnect to cause them to be displayed in most rooms.\n    (if-let ((url (alist-get 'url (ement-event-content event))))\n        (plz-run\n         (plz-queue ement-images-queue\n           'get (ement--mxc-to-url url session) :as 'binary :noquery t\n           :then (lambda (data)\n                   (when ement-room-avatars\n                     ;; MAYBE: Store the raw image data instead of using create-image here.\n                     (let ((image (create-image data nil 'data-p\n                                                :ascent 'center\n                                                :max-width ement-room-avatar-max-width\n                                                :max-height ement-room-avatar-max-height)))\n                       (if (not image)\n                           (progn\n                             (display-warning 'ement (format \"Room avatar seems unreadable:  ROOM-ID:%S  AVATAR-URL:%S\"\n                                                             (ement-room-id room) (ement--mxc-to-url url session)))\n                             (setf (ement-room-avatar room) nil\n                                   (alist-get 'room-list-avatar (ement-room-local room)) nil))\n                         (when (fboundp 'imagemagick-types)\n                           ;; Only do this when ImageMagick is supported.\n                           ;; FIXME: When requiring Emacs 27+, remove this (I guess?).\n                           (setf (image-property image :type) 'imagemagick))\n                         ;; We set the room-avatar slot to a propertized string that\n                         ;; displays as the image.  This seems the most convenient thing to\n                         ;; do.  We also unset the cached room-list-avatar so it can be\n                         ;; remade.\n                         (setf (ement-room-avatar room) (propertize \" \" 'display image)\n                               (alist-get 'room-list-avatar (ement-room-local room)) nil)))))))\n      ;; Unset avatar.\n      (setf (ement-room-avatar room) nil\n            (alist-get 'room-list-avatar (ement-room-local room)) nil))))\n\n(ement-defevent \"m.room.create\"\n  (ignore session)\n  (pcase-let* (((cl-struct ement-event (content (map type))) event))\n    (when type\n      (setf (ement-room-type room) type))))\n\n(ement-defevent \"m.room.member\"\n  \"Put/update member on `ement-users' and room's members table.\"\n  (ignore session)\n  (pcase-let* (((cl-struct ement-room members) room)\n               ((cl-struct ement-event state-key\n                           (content (map displayname membership\n                                         ('avatar_url avatar-url))))\n                event)\n               (user (or (gethash state-key ement-users)\n                         (puthash state-key\n                                  (make-ement-user\n                                   :id state-key :avatar-url avatar-url\n                                   ;; NOTE: The spec doesn't seem to say whether the\n                                   ;; displayname in the member event applies only to\n                                   ;; the room or is for the user generally, so we'll\n                                   ;; save it in the struct anyway.\n                                   ;; FIXME: This is probably wrong: it probably means\n                                   ;; overwriting the global displayname with any\n                                   ;; room-specific one that was most recently processed.\n                                   :displayname displayname)\n                                  ement-users))))\n    (pcase membership\n      (\"join\"\n       (puthash state-key user members)\n       (if displayname\n           ;; NOTE: This handler is only called for new events, not when retrieving old events.\n           ;; Therefore it's safe to update the cached displayname from such an event.\n           (puthash user displayname (ement-room-displaynames room))\n         ;; No displayname set for this room: recalculate.\n         (ement--user-displayname-in room user 'recalculate)))\n      (_ (remhash state-key members)\n         (remhash user (ement-room-displaynames room))))))\n\n(ement-defevent \"m.room.name\"\n  (ignore session)\n  (pcase-let* (((cl-struct ement-event (content (map name))) event))\n    (when name\n      ;; Recalculate room name and cache in slot.\n      (setf (ement-room-display-name room) (ement--room-display-name room)))))\n\n(ement-defevent \"m.room.topic\"\n  (ignore session)\n  (pcase-let* (((cl-struct ement-event (content (map topic))) event))\n    (when topic\n      (setf (ement-room-topic room) topic))))\n\n(ement-defevent \"m.receipt\"\n  (ignore session)\n  (pcase-let (((cl-struct ement-event content) event)\n              ((cl-struct ement-room (receipts room-receipts)) room))\n    (cl-loop for (event-id . receipts) in content\n             do (cl-loop for (user-id . receipt) in (alist-get 'm.read receipts)\n                         ;; Users may not have been \"seen\" yet, so although we'd\n                         ;; prefer to key on the user struct, we key on the user ID.\n                         ;; Same for events, unfortunately.\n                         ;; NOTE: The JSON map keys are converted to symbols by `json-read'.\n                         ;; MAYBE: (Should we keep them that way?  It would use less memory, I guess.)\n                         do (puthash (symbol-name user-id)\n                                     (cons (symbol-name event-id) (alist-get 'ts receipt))\n                                     room-receipts)))))\n\n(ement-defevent \"m.space.child\"\n  ;; SPEC: v1.2/11.35.\n  (pcase-let* ((space-room room)\n               ((cl-struct ement-session rooms) session)\n               ((cl-struct ement-room (id parent-room-id)) space-room)\n               ((cl-struct ement-event (state-key child-room-id) (content (map via))) event)\n               (child-room (cl-find child-room-id rooms :key #'ement-room-id :test #'equal)))\n    (if via\n        ;; Child being declared: add it.\n        (progn\n          (cl-pushnew child-room-id (alist-get 'children (ement-room-local space-room)) :test #'equal)\n          (when child-room\n            ;; The user is also in the child room: link the parent space-room in it.\n            ;; FIXME: On initial sync, if the child room hasn't been processed yet, this will fail.\n            (cl-pushnew parent-room-id (alist-get 'parents (ement-room-local child-room)) :test #'equal)))\n      ;; Child being disowned: remove it.\n      (setf (alist-get 'children (ement-room-local space-room))\n            (delete child-room-id (alist-get 'children (ement-room-local space-room))))\n      (when child-room\n        ;; The user is also in the child room: unlink the parent space-room in it.\n        (setf (alist-get 'parents (ement-room-local child-room))\n              (delete parent-room-id (alist-get 'parents (ement-room-local child-room))))))))\n\n(ement-defevent \"m.room.canonical_alias\"\n  (ignore session)\n  (pcase-let (((cl-struct ement-event (content (map alias))) event))\n    (setf (ement-room-canonical-alias room) alias)))\n\n(defun ement--link-children (session)\n  \"Link child rooms in SESSION.\nTo be called after initial sync.\"\n  ;; On initial sync, when processing m.space.child events, the child rooms may not have\n  ;; been processed yet, so we link them again here.\n  (pcase-let (((cl-struct ement-session rooms) session))\n    (dolist (room rooms)\n      (pcase-let (((cl-struct ement-room (id parent-id) (local (map children))) room))\n        (when children\n          (dolist (child-id children)\n            (when-let ((child-room (cl-find child-id rooms :key #'ement-room-id :test #'equal)))\n              (cl-pushnew parent-id (alist-get 'parents (ement-room-local child-room)) :test #'equal))))))))\n\n;;;;; Savehist compatibility\n\n;; See .\n\n(defvar savehist-save-hook)\n\n(with-eval-after-load 'savehist\n  ;; TODO: Consider using a symbol property on our commands and checking that rather than\n  ;; symbol names; would avoid consing.\n  (defun ement--savehist-save-hook ()\n    \"Remove all `ement-' commands from `command-history'.\nBecause when `savehist' saves `command-history', it includes the\ninteractive arguments passed to the command, which in our case\nincludes large data structures that should never be persisted!\"\n    (setf command-history\n          (cl-remove-if (pcase-lambda (`(,command . ,_))\n                          (cl-typecase command\n                            (symbol (string-match-p (rx bos \"ement-\") (symbol-name command)))))\n                        command-history)))\n  (cl-pushnew 'ement--savehist-save-hook savehist-save-hook))\n\n;;;; Footer\n\n(provide 'ement)\n\n;;; ement.el ends here\n"
  },
  {
    "path": "makem.sh",
    "content": "#!/usr/bin/env bash\n\n# * makem.sh --- Script to aid building and testing Emacs Lisp packages\n\n# URL: https://github.com/alphapapa/makem.sh\n# Version: 0.7.1\n\n# * Commentary:\n\n# makem.sh is a script that helps to build, lint, and test Emacs Lisp\n# packages.  It aims to make linting and testing as simple as possible\n# without requiring per-package configuration.\n\n# It works similarly to a Makefile in that \"rules\" are called to\n# perform actions such as byte-compiling, linting, testing, etc.\n\n# Source and test files are discovered automatically from the\n# project's Git repo, and package dependencies within them are parsed\n# automatically.\n\n# Output is simple: by default, there is no output unless errors\n# occur.  With increasing verbosity levels, more detail gives positive\n# feedback.  Output is colored by default to make reading easy.\n\n# The script can run Emacs with the developer's local Emacs\n# configuration, or with a clean, \"sandbox\" configuration that can be\n# optionally removed afterward.  This is especially helpful when\n# upstream dependencies may have released new versions that differ\n# from those installed in the developer's personal configuration.\n\n# * License:\n\n# This program is free software; you can redistribute it and/or modify\n# it under the terms of the GNU General Public License as published by\n# the Free Software Foundation, either version 3 of the License, or\n# (at your option) any later version.\n\n# This program is distributed in the hope that it will be useful,\n# but WITHOUT ANY WARRANTY; without even the implied warranty of\n# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n# GNU General Public License for more details.\n\n# You should have received a copy of the GNU General Public License\n# along with this program.  If not, see .\n\n# * Functions\n\nfunction usage {\n    cat <$file <$file <$file <\"$file\" <$file <\"$file\" <$file <&1)\n\n    # Set output file.\n    output_file=$(mktemp) || die \"Unable to make output file.\"\n    paths_temp+=(\"$output_file\")\n\n    # Run Emacs.\n    debug \"run_emacs: ${emacs_command[@]} $@ &>\\\"$output_file\\\"\"\n    \"${emacs_command[@]}\" \"$@\" &>\"$output_file\"\n\n    # Check exit code and output.\n    exit=$?\n    [[ $exit != 0 ]] \\\n        && debug \"Emacs exited non-zero: $exit\"\n\n    [[ $verbose -gt 1 || $exit != 0 ]] \\\n        && cat $output_file\n\n    return $exit\n}\n\n# ** Compilation\n\nfunction batch-byte-compile {\n    debug \"batch-byte-compile: ERROR-ON-WARN:$compile_error_on_warn\"\n\n    [[ $compile_error_on_warn ]] && local error_on_warn=(--eval \"(setq byte-compile-error-on-warn t)\")\n\n    run_emacs \\\n        --load \"$(elisp-byte-compile-file)\" \\\n        \"${error_on_warn[@]}\" \\\n        --eval \"(unless (makem-batch-byte-compile) (kill-emacs 1))\" \\\n        \"$@\"\n}\n\nfunction byte-compile-file {\n    debug \"byte-compile: ERROR-ON-WARN:$compile_error_on_warn\"\n    local file=\"$1\"\n\n    [[ $compile_error_on_warn ]] && local error_on_warn=(--eval \"(setq byte-compile-error-on-warn t)\")\n\n    # FIXME: Why is the line starting with \"&& verbose 3\" not indented properly?  Emacs insists on indenting it back a level.\n    run_emacs \\\n        --load \"$(elisp-byte-compile-file)\" \\\n        \"${error_on_warn[@]}\" \\\n        --eval \"(pcase-let ((\\`(,num-errors ,num-warnings) (makem-byte-compile-file \\\"$file\\\"))) (when (or (and byte-compile-error-on-warn (not (zerop num-warnings))) (not (zerop num-errors))) (kill-emacs 1)))\" \\\n        && verbose 3 \"Compiling $file finished without errors.\" \\\n            || { verbose 3 \"Compiling file failed: $file\"; return 1; }\n}\n\n# ** Files\n\nfunction submodules {\n    # Echo a list of submodules's paths relative to the repo root.\n    # TODO: Parse with bash regexp instead of cut.\n    git submodule status | awk '{print $2}'\n}\n\nfunction project-root {\n    # Echo the root of the project (or superproject, if running from\n    # within a submodule).\n    root_dir=$(git rev-parse --show-superproject-working-tree)\n    [[ $root_dir ]] || root_dir=$(git rev-parse --show-toplevel)\n    [[ $root_dir ]] || error \"Can't find repo root.\"\n\n    echo \"$root_dir\"\n}\n\nfunction files-project {\n    # Echo a list of files in project; or with $1, files in it\n    # matching that pattern with \"git ls-files\".  Excludes submodules.\n    [[ $1 ]] && pattern=\"/$1\" || pattern=\".\"\n\n    local excludes\n    for submodule in $(submodules)\n    do\n        excludes+=(\":!:$submodule\")\n    done\n\n    git ls-files -- \"$pattern\" \"${excludes[@]}\"\n}\n\nfunction dirs-project {\n    # Echo list of directories to be used in load path.\n    files-project-feature | dirnames\n    files-project-test | dirnames\n}\n\nfunction files-project-elisp {\n    # Echo list of Elisp files in project.\n    files-project 2>/dev/null \\\n        | egrep \"\\.el$\" \\\n        | filter-files-exclude-default \\\n        | filter-files-exclude-args\n}\n\nfunction files-project-feature {\n    # Echo list of Elisp files that are not tests and provide a feature.\n    files-project-elisp \\\n        | grep -E -v \"$test_files_regexp\" \\\n        | filter-files-feature\n}\n\nfunction files-project-test {\n    # Echo list of Elisp test files.\n    files-project-elisp | grep -E \"$test_files_regexp\"\n}\n\nfunction dirnames {\n    # Echo directory names for files on STDIN.\n    while read file\n    do\n        dirname \"$file\"\n    done\n}\n\nfunction filter-files-exclude-default {\n    # Filter out paths (STDIN) which should be excluded by default.\n    grep -E -v \"(/\\.cask/|-autoloads\\.el|\\.dir-locals)\"\n}\n\nfunction filter-files-exclude-args {\n    # Filter out paths (STDIN) which are excluded with --exclude.\n    if [[ ${files_exclude[@]} ]]\n    then\n        (\n            # We use a subshell to set IFS temporarily so we can send\n            # the list of files to grep -F.  This is ugly but more\n            # correct than replacing spaces with line breaks.  Note\n            # that, for some reason, using IFS=\"\\n\" or IFS='\\n' doesn't\n            # work, and a literal line break seems to be required.\n            IFS=\"\n\"\n            grep -Fv \"${files_exclude[*]}\"\n        )\n    else\n        cat\n    fi\n}\n\nfunction filter-files-feature {\n    # Read paths on STDIN and echo ones that (provide 'a-feature).\n    while read path\n    do\n        grep -E \"^\\\\(provide '\" \"$path\" &>/dev/null \\\n            && echo \"$path\"\n    done\n}\n\nfunction args-load-files {\n    # For file in $@, echo \"--load $file\".\n    for file in \"$@\"\n    do\n        sans_extension=${file%%.el}\n        printf -- '--load %q ' \"$sans_extension\"\n    done\n}\n\nfunction args-load-path {\n    # Echo load-path arguments.\n    for path in $(dirs-project | sort -u)\n    do\n        printf -- '-L %q ' \"$path\"\n    done\n}\n\nfunction test-files-p {\n    # Return 0 if $files_project_test is non-empty.\n    [[ \"${files_project_test[@]}\" ]]\n}\n\nfunction buttercup-tests-p {\n    # Return 0 if Buttercup tests are found.\n    test-files-p || die \"No tests found.\"\n    debug \"Checking for Buttercup tests...\"\n\n    grep \"(require 'buttercup)\" \"${files_project_test[@]}\" &>/dev/null\n}\n\nfunction ert-tests-p {\n    # Return 0 if ERT tests are found.\n    test-files-p || die \"No tests found.\"\n    debug \"Checking for ERT tests...\"\n\n    # We check for this rather than \"(require 'ert)\", because ERT may\n    # already be loaded in Emacs and might not be loaded with\n    # \"require\" in a test file.\n    grep \"(ert-deftest\" \"${files_project_test[@]}\" &>/dev/null\n}\n\nfunction package-main-file {\n    # Echo the package's main file.\n    file_pkg=$(files-project \"*-pkg.el\" 2>/dev/null)\n\n    if [[ $file_pkg ]]\n    then\n        # Use *-pkg.el file if it exists.\n        echo \"$file_pkg\"\n    else\n        # Use shortest filename (a sloppy heuristic that will do for now).\n        for file in \"${files_project_feature[@]}\"\n        do\n            echo ${#file} \"$file\"\n        done \\\n            | sort -h \\\n            | head -n1 \\\n            | sed -r 's/^[[:digit:]]+ //'\n    fi\n}\n\nfunction dependencies {\n    # Echo list of package dependencies.\n\n    # Search package headers.  Use -a so grep won't think that an Elisp file containing\n    # control characters (rare, but sometimes necessary) is binary and refuse to search it.\n    grep -E -a -i '^;; Package-Requires: ' $(files-project-feature) $(files-project-test) \\\n        | grep -E -o '\\([^([:space:]][^)]*\\)' \\\n        | grep -E -o '^[^[:space:])]+' \\\n        | sed -r 's/\\(//g' \\\n        | grep -E -v '^emacs$'  # Ignore Emacs version requirement.\n\n    # Search Cask file.\n    if [[ -r Cask ]]\n    then\n        grep -E '\\(depends-on \"[^\"]+\"' Cask \\\n            | sed -r -e 's/\\(depends-on \"([^\"]+)\".*/\\1/g'\n    fi\n\n    # Search -pkg.el file.\n    if [[ $(files-project \"*-pkg.el\" 2>/dev/null) ]]\n    then\n        sed -nr 's/.*\\(([-[:alnum:]]+)[[:blank:]]+\"[.[:digit:]]+\"\\).*/\\1/p' $(files-project- -- -pkg.el 2>/dev/null)\n    fi\n}\n\n# ** Sandbox\n\nfunction sandbox {\n    verbose 2 \"Initializing sandbox...\"\n\n    # *** Sandbox arguments\n\n    # MAYBE: Optionally use branch-specific sandbox?\n\n    # Check or make user-emacs-directory.\n    if [[ $sandbox_dir ]]\n    then\n        # Directory given as argument: ensure it exists.\n        if ! [[ -d $sandbox_dir ]]\n        then\n            debug \"Making sandbox directory: $sandbox_dir\"\n            mkdir -p \"$sandbox_dir\" || die \"Unable to make sandbox dir.\"\n        fi\n\n        # Add Emacs version-specific subdirectory, creating if necessary.\n        sandbox_dir=\"$sandbox_dir/$(emacs-version)\"\n        if ! [[ -d $sandbox_dir ]]\n        then\n            mkdir \"$sandbox_dir\" || die \"Unable to make sandbox subdir: $sandbox_dir\"\n        fi\n    else\n        # Not given: make temp directory, and delete it on exit.\n        local sandbox_dir=$(mktemp -d) || die \"Unable to make sandbox dir.\"\n        paths_temp+=(\"$sandbox_dir\")\n    fi\n\n    # Make argument to load init file if it exists.\n    init_file=\"$sandbox_dir/init.el\"\n\n    # Set sandbox args.  This is a global variable used by the run_emacs function.\n    args_sandbox=(\n        --title \"makem.sh: $(basename $(pwd)) (sandbox: $sandbox_dir)\"\n        --eval \"(setq user-emacs-directory (file-truename \\\"$sandbox_dir\\\"))\"\n        --load package\n        --eval \"(setq package-user-dir (expand-file-name \\\"elpa\\\" user-emacs-directory))\"\n        --eval \"(setq user-init-file (file-truename \\\"$init_file\\\"))\"\n    )\n\n    # Add package-install arguments for dependencies.\n    if [[ $install_deps ]]\n    then\n        local deps=($(dependencies))\n        debug \"Installing dependencies: ${deps[@]}\"\n\n        # Ensure built-in packages get upgraded to newer versions from ELPA.\n        args_sandbox_package_install+=(--eval \"(setq package-install-upgrade-built-in t)\")\n\n        for package in \"${deps[@]}\"\n        do\n            args_sandbox_package_install+=(--eval \"(package-install '$package)\")\n        done\n    fi\n\n    # Add package-install arguments for linters.\n    if [[ $install_linters ]]\n    then\n        debug \"Installing linters: package-lint relint\"\n\n        args_sandbox_package_install+=(\n            --eval \"(package-install 'elsa)\"\n            --eval \"(package-install 'package-lint)\"\n            --eval \"(package-install 'relint)\")\n    fi\n\n    # *** Install packages into sandbox\n\n    if [[ ${args_sandbox_package_install[@]} ]]\n    then\n        # Initialize the sandbox (installs packages once rather than for every rule).\n        verbose 1 \"Installing packages into sandbox...\"\n\n        run_emacs \\\n            --eval \"(package-refresh-contents)\" \\\n            \"${args_sandbox_package_install[@]}\" \\\n            && success \"Packages installed.\" \\\n                || die \"Unable to initialize sandbox.\"\n    fi\n\n    verbose 2 \"Sandbox initialized.\"\n}\n\n# ** Utility\n\nfunction cleanup {\n    # Remove temporary paths (${paths_temp[@]}).\n\n    for path in \"${paths_temp[@]}\"\n    do\n        if [[ $debug ]]\n        then\n            debug \"Debugging enabled: not deleting temporary path: $path\"\n        elif [[ -r $path ]]\n        then\n            rm -rf \"$path\"\n        else\n            debug \"Temporary path doesn't exist, not deleting: $path\"\n        fi\n    done\n}\n\nfunction echo-unset-p {\n    # Echo 0 if $1 is set, otherwise 1.  IOW, this returns the exit\n    # code of [[ $1 ]] as STDOUT.\n    [[ $1 ]]\n    echo $?\n}\n\nfunction ensure-package-available {\n    # If package $1 is available, return 0.  Otherwise, return 1, and\n    # if $2 is set, give error otherwise verbose.  Outputting messages\n    # here avoids repetition in callers.\n    local package=$1\n    local direct_p=$2\n\n    if ! run_emacs --load $package &>/dev/null\n    then\n        if [[ $direct_p ]]\n        then\n            error \"$package not available.\"\n        else\n            verbose 2 \"$package not available.\"\n        fi\n        return 1\n    fi\n}\n\nfunction ensure-tests-available {\n    # If tests of type $1 (like \"ERT\") are available, return 0.  Otherwise, if\n    # $2 is set, give an error and return 1; otherwise give verbose message.  $1\n    # should have a corresponding predicate command, like ert-tests-p for ERT.\n    local test_name=$1\n    local test_command=\"${test_name,,}-tests-p\"  # Converts name to lowercase.\n    local direct_p=$2\n\n    if ! $test_command\n    then\n        if [[ $direct_p ]]\n        then\n            error \"$test_name tests not found.\"\n        else\n            verbose 2 \"$test_name tests not found.\"\n        fi\n        return 1\n    fi\n}\n\nfunction echo_color {\n    # This allows bold, italic, etc. without needing a function for\n    # each variation.\n    local color_code=\"COLOR_$1\"\n    shift\n\n    if [[ $color ]]\n    then\n        echo -e \"${!color_code}${@}${COLOR_off}\"\n    else\n        echo \"$@\"\n    fi\n}\nfunction debug {\n    if [[ $debug ]]\n    then\n        function debug {\n            echo_color yellow \"DEBUG ($(ts)): $@\" >&2\n        }\n        debug \"$@\"\n    else\n        function debug {\n            true\n        }\n    fi\n}\nfunction error {\n    echo_color red \"ERROR ($(ts)): $@\" >&2\n    ((errors++))\n    return 1\n}\nfunction die {\n    [[ $@ ]] && error \"$@\"\n    exit $errors\n}\nfunction log {\n    echo \"LOG ($(ts)): $@\" >&2\n}\nfunction log_color {\n    local color_name=$1\n    shift\n    echo_color $color_name \"LOG ($(ts)): $@\" >&2\n}\nfunction success {\n    if [[ $verbose -ge 2 ]]\n    then\n        log_color green \"$@\" >&2\n    fi\n}\nfunction verbose {\n    # $1 is the verbosity level, rest are echoed when appropriate.\n    if [[ $verbose -ge $1 ]]\n    then\n        [[ $1 -eq 1 ]] && local color_name=blue\n        [[ $1 -eq 2 ]] && local color_name=cyan\n        [[ $1 -ge 3 ]] && local color_name=white\n\n        shift\n        log_color $color_name \"$@\" >&2\n    fi\n}\n\nfunction ts {\n    date \"+%Y-%m-%d %H:%M:%S\"\n}\n\nfunction emacs-version {\n    # Echo Emacs version number.\n\n    # Don't use run_emacs function, which does more than we need.\n    \"${emacs_command[@]}\" -Q --batch --eval \"(princ emacs-version)\" \\\n        || die \"Unable to get Emacs version.\"\n}\n\nfunction rule-p {\n    # Return 0 if $1 is a rule.\n    [[ $1 =~ ^(lint-?|tests?)$ ]] \\\n        || [[ $1 =~ ^(batch|interactive)$ ]] \\\n        || [[ $(type -t \"$2\" 2>/dev/null) =~ function ]]\n}\n\n# * Rules\n\n# These functions are intended to be called as rules, like a Makefile.\n# Some rules test $1 to determine whether the rule is being called\n# directly or from a meta-rule; if directly, an error is given if the\n# rule can't be run, otherwise it's skipped.\n\nfunction all {\n    verbose 1 \"Running all rules...\"\n\n    lint\n    tests\n}\n\nfunction compile-batch {\n    [[ $compile ]] || return 0\n    unset compile  # Only compile once.\n\n    verbose 1 \"Compiling...\"\n    verbose 2 \"Batch-compiling files...\"\n    debug \"Byte-compile files: ${files_project_byte_compile[@]}\"\n\n    batch-byte-compile \"${files_project_byte_compile[@]}\"\n}\n\nfunction compile-each {\n    [[ $compile ]] || return 0\n    unset compile  # Only compile once.\n\n    verbose 1 \"Compiling...\"\n    debug \"Byte-compile files: ${files_project_byte_compile[@]}\"\n\n    local compile_errors\n    for file in \"${files_project_byte_compile[@]}\"\n    do\n        verbose 2 \"Compiling file: $file...\"\n        byte-compile-file \"$file\" \\\n            || compile_errors=t\n    done\n\n    [[ ! $compile_errors ]]\n}\n\nfunction compile {\n    if [[ $compile = batch ]]\n    then\n        compile-batch \"$@\"\n    else\n        compile-each \"$@\"\n    fi\n    local status=$?\n\n    if [[ $compile_error_on_warn ]]\n    then\n        # Linting: just return status code, because lint rule will print messages.\n        [[ $status = 0 ]]\n    else\n        # Not linting: print messages here.\n        [[ $status = 0 ]] \\\n            && success \"Compiling finished without errors.\" \\\n                || error \"Compiling failed.\"\n    fi\n}\n\nfunction batch {\n    # Run Emacs in batch mode with ${args_batch_interactive[@]} and\n    # with project source and test files loaded.\n    verbose 1 \"Executing Emacs with arguments: ${args_batch_interactive[@]}\"\n\n    run_emacs \\\n        $(args-load-files \"${files_project_feature[@]}\" \"${files_project_test[@]}\") \\\n        \"${args_batch_interactive[@]}\"\n}\n\nfunction interactive {\n    # Run Emacs interactively.  Most useful with --sandbox and --install-deps.\n    local load_file_args=$(args-load-files \"${files_project_feature[@]}\" \"${files_project_test[@]}\")\n    verbose 1 \"Running Emacs interactively...\"\n    verbose 2 \"Loading files: ${load_file_args//--load /}\"\n\n    [[ $compile ]] && compile\n\n    unset arg_batch\n    run_emacs \\\n        $load_file_args \\\n        --eval \"(load user-init-file)\" \\\n        \"${args_batch_interactive[@]}\"\n    arg_batch=\"--batch\"\n}\n\nfunction lint {\n    verbose 1 \"Linting...\"\n\n    lint-checkdoc\n    lint-compile\n    lint-declare\n    # NOTE: Elint doesn't seem very useful at the moment.  See comment\n    # in lint-elint function.\n    # lint-elint\n    lint-indent\n    lint-package\n    lint-regexps\n}\n\nfunction lint-checkdoc {\n    verbose 1 \"Linting checkdoc...\"\n\n    local checkdoc_file=\"$(elisp-checkdoc-file)\"\n    paths_temp+=(\"$checkdoc_file\")\n\n    run_emacs \\\n        --load=\"$checkdoc_file\" \\\n        \"${files_project_feature[@]}\" \\\n        && success \"Linting checkdoc finished without errors.\" \\\n            || error \"Linting checkdoc failed.\"\n}\n\nfunction lint-compile {\n    verbose 1 \"Linting compilation...\"\n\n    compile_error_on_warn=true\n    compile \"${files_project_byte_compile[@]}\" \\\n        && success \"Linting compilation finished without errors.\" \\\n            || error \"Linting compilation failed.\"\n    unset compile_error_on_warn\n}\n\nfunction lint-declare {\n    verbose 1 \"Linting declarations...\"\n\n    local check_declare_file=\"$(elisp-check-declare-file)\"\n    paths_temp+=(\"$check_declare_file\")\n\n    run_emacs \\\n        --load \"$check_declare_file\" \\\n        -f makem-check-declare-files-and-exit \\\n        \"${files_project_feature[@]}\" \\\n        && success \"Linting declarations finished without errors.\" \\\n            || error \"Linting declarations failed.\"\n}\n\nfunction lint-elsa {\n    verbose 1 \"Linting with Elsa...\"\n\n    # MAYBE: Install Elsa here rather than in sandbox init, to avoid installing\n    # it when not needed.  However, we should be careful to be clear about when\n    # packages are installed, because installing them does execute code.\n    run_emacs \\\n        --load elsa \\\n        -f elsa-run-files-and-exit \\\n        \"${files_project_feature[@]}\" \\\n        && success \"Linting with Elsa finished without errors.\" \\\n            || error \"Linting with Elsa failed.\"\n}\n\nfunction lint-elint {\n    # NOTE: Elint gives a lot of spurious warnings, apparently because it doesn't load files\n    # that are `require'd, so its output isn't very useful.  But in case it's improved in\n    # the future, and since this wrapper code already works, we might as well leave it in.\n    verbose 1 \"Linting with Elint...\"\n\n    local errors=0\n    for file in \"${files_project_feature[@]}\"\n    do\n        verbose 2 \"Linting with Elint: $file...\"\n        run_emacs \\\n            --load \"$(elisp-elint-file)\" \\\n            --eval \"(makem-elint-file \\\"$file\\\")\" \\\n            && verbose 3 \"Linting with Elint found no errors.\" \\\n                || { error \"Linting with Elint failed: $file\"; ((errors++)) ; }\n    done\n\n    [[ $errors = 0 ]] \\\n        && success \"Linting with Elint finished without errors.\" \\\n            || error \"Linting with Elint failed.\"\n}\n\nfunction lint-indent {\n    verbose 1 \"Linting indentation...\"\n\n    # We load project source files as well, because they may contain\n    # macros with (declare (indent)) rules which must be loaded to set\n    # indentation.\n\n    run_emacs \\\n        --load \"$(elisp-lint-indent-file)\" \\\n        $(args-load-files \"${files_project_feature[@]}\" \"${files_project_test[@]}\") \\\n        --funcall makem-lint-indent-batch-and-exit \\\n        \"${files_project_feature[@]}\" \"${files_project_test[@]}\" \\\n        && success \"Linting indentation finished without errors.\" \\\n            || error \"Linting indentation failed.\"\n}\n\nfunction lint-package {\n    ensure-package-available package-lint $1 || return $(echo-unset-p $1)\n\n    verbose 1 \"Linting package...\"\n\n    run_emacs \\\n        --load package-lint \\\n        --eval \"(setq package-lint-main-file \\\"$(package-main-file)\\\")\" \\\n        --funcall package-lint-batch-and-exit \\\n        \"${files_project_feature[@]}\" \\\n        && success \"Linting package finished without errors.\" \\\n            || error \"Linting package failed.\"\n}\n\nfunction lint-regexps {\n    ensure-package-available relint $1 || return $(echo-unset-p $1)\n\n    verbose 1 \"Linting regexps...\"\n\n    run_emacs \\\n        --load relint \\\n        --funcall relint-batch \\\n        \"${files_project_source[@]}\" \\\n        && success \"Linting regexps finished without errors.\" \\\n            || error \"Linting regexps failed.\"\n}\n\nfunction tests {\n    verbose 1 \"Running all tests...\"\n\n    test-ert\n    test-buttercup\n}\n\nfunction test-ert-interactive {\n    verbose 1 \"Running ERT tests interactively...\"\n\n    unset arg_batch\n    run_emacs \\\n        $(args-load-files \"${files_project_test[@]}\") \\\n        --eval \"(ert-run-tests-interactively t)\"\n    arg_batch=\"--batch\"\n}\n\nfunction test-buttercup {\n    ensure-tests-available Buttercup $1 || return $(echo-unset-p $1)\n    compile || die\n\n    verbose 1 \"Running Buttercup tests...\"\n\n    local buttercup_file=\"$(elisp-buttercup-file)\"\n    paths_temp+=(\"$buttercup_file\")\n\n    run_emacs \\\n        $(args-load-files \"${files_project_test[@]}\") \\\n        --load \"$buttercup_file\" \\\n        --eval \"(progn (setq backtrace-on-error-noninteractive nil) (buttercup-run))\" \\\n        && success \"Buttercup tests finished without errors.\" \\\n            || error \"Buttercup tests failed.\"\n}\n\nfunction test-ert {\n    ensure-tests-available ERT $1 || return $(echo-unset-p $1)\n    compile || die\n\n    verbose 1 \"Running ERT tests...\"\n    debug \"Test files: ${files_project_test[@]}\"\n\n    run_emacs \\\n        $(args-load-files \"${files_project_test[@]}\") \\\n        -f ert-run-tests-batch-and-exit \\\n        && success \"ERT tests finished without errors.\" \\\n            || error \"ERT tests failed.\"\n}\n\n# * Defaults\n\ntest_files_regexp='^((tests?|t)/)|-tests?.el$|^test-'\n\nemacs_command=(\"emacs\")\nerrors=0\nverbose=0\ncompile=true\narg_batch=\"--batch\"\ncompile=each\n\n# MAYBE: Disable color if not outputting to a terminal.  (OTOH, the\n# colorized output is helpful in CI logs, and I don't know if,\n# e.g. GitHub Actions logging pretends to be a terminal.)\ncolor=true\n\n# TODO: Using the current directory (i.e. a package's repo root directory) in\n# load-path can cause weird errors in case of--you guessed it--stale .ELC files,\n# the zombie problem that just won't die.  It's incredible how many different ways\n# this problem presents itself.  In this latest example, an old .ELC file, for a\n# .EL file that had since been renamed, was present on my local system, which meant\n# that an example .EL file that hadn't been updated was able to \"require\" that .ELC\n# file's feature without error.  But on another system (in this case, trying to\n# setup CI using GitHub Actions), the old .ELC was not present, so the example .EL\n# file was not able to load the feature, which caused a byte-compilation error.\n\n# In this case, I will prevent such example files from being compiled.  But in\n# general, this can cause weird problems that are tedious to debug.  I guess\n# the best way to fix it would be to actually install the repo's code as a\n# package into the sandbox, but doing that would require additional tooling,\n# pulling in something like Quelpa or package-build--and if the default recipe\n# weren't being used, the actual recipe would have to be fetched off MELPA or\n# something, which seems like getting too smart for our own good.\n\n# TODO: Emit a warning if .ELC files that don't match any .EL files are detected.\n\n# ** Colors\n\nCOLOR_off='\\e[0m'\nCOLOR_black='\\e[0;30m'\nCOLOR_red='\\e[0;31m'\nCOLOR_green='\\e[0;32m'\nCOLOR_yellow='\\e[0;33m'\nCOLOR_blue='\\e[0;34m'\nCOLOR_purple='\\e[0;35m'\nCOLOR_cyan='\\e[0;36m'\nCOLOR_white='\\e[0;37m'\n\n# ** Package system args\n\nargs_package_archives=(\n    --eval \"(add-to-list 'package-archives '(\\\"gnu\\\" . \\\"https://elpa.gnu.org/packages/\\\") t)\"\n    --eval \"(add-to-list 'package-archives '(\\\"melpa\\\" . \\\"https://melpa.org/packages/\\\") t)\"\n)\n\nargs_package_init=(\n    --eval \"(package-initialize)\"\n)\n\n# * Args\n\nargs=$(getopt -n \"$0\" \\\n              -o dhce:E:i:s::vf:C \\\n              -l compile-batch,exclude:,emacs:,install-deps,install-linters,debug,debug-load-path,help,install:,verbose,file:,no-color,no-compile,sandbox:: \\\n              -- \"$@\") \\\n    || { usage; exit 1; }\neval set -- \"$args\"\n\nwhile true\ndo\n    case \"$1\" in\n        --install-deps)\n            install_deps=true\n            ;;\n        --install-linters)\n            install_linters=true\n            ;;\n        -d|--debug)\n            debug=true\n            verbose=2\n            args_debug=(--eval \"(setq init-file-debug t)\"\n                        --eval \"(setq debug-on-error t)\")\n            ;;\n        --debug-load-path)\n            debug_load_path=true\n            ;;\n        -h|--help)\n            usage\n            exit\n            ;;\n        -c|--compile-batch)\n            debug \"Compiling files in batch mode\"\n            compile=batch\n            ;;\n        -E|--emacs)\n            shift\n            emacs_command=($1)\n            ;;\n        -i|--install)\n            shift\n            args_sandbox_package_install+=(--eval \"(package-install '$1)\")\n            ;;\n        -s|--sandbox)\n            sandbox=true\n            shift\n            sandbox_dir=\"$1\"\n\n            if ! [[ $sandbox_dir ]]\n            then\n                debug \"No sandbox dir: installing dependencies.\"\n                install_deps=true\n            else\n                debug \"Sandbox dir: $1\"\n            fi\n            ;;\n        -v|--verbose)\n            ((verbose++))\n            ;;\n        -e|--exclude)\n            shift\n            debug \"Excluding file: $1\"\n            files_exclude+=(\"$1\")\n            ;;\n        -f|--file)\n            shift\n            args_files+=(\"$1\")\n            ;;\n        --no-color)\n            unset color\n            ;;\n        -C|--no-compile)\n            unset compile\n            ;;\n        --)\n            # Remaining args (required; do not remove)\n            shift\n            rest=(\"$@\")\n            break\n            ;;\n    esac\n\n    shift\ndone\n\ndebug \"ARGS: $args\"\ndebug \"Remaining args: ${rest[@]}\"\n\n# Set package elisp (which depends on --no-org-repo arg).\npackage_initialize_file=\"$(elisp-package-initialize-file)\"\npaths_temp+=(\"$package_initialize_file\")\n\n# * Main\n\ntrap cleanup EXIT INT TERM\n\n# Change to project root directory first.\ncd \"$(project-root)\"\n\n# Discover project files.\nfiles_project_feature=($(files-project-feature))\nfiles_project_test=($(files-project-test))\nfiles_project_byte_compile=(\"${files_project_feature[@]}\" \"${files_project_test[@]}\")\n\nif [[ ${args_files[@]} ]]\nthen\n    # Add specified files.\n    files_project_feature+=(\"${args_files[@]}\")\n    files_project_byte_compile+=(\"${args_files[@]}\")\nfi\n\ndebug \"EXCLUDING FILES: ${files_exclude[@]}\"\ndebug \"FEATURE FILES: ${files_project_feature[@]}\"\ndebug \"TEST FILES: ${files_project_test[@]}\"\ndebug \"BYTE-COMPILE FILES: ${files_project_byte_compile[@]}\"\ndebug \"PACKAGE-MAIN-FILE: $(package-main-file)\"\n\nif ! [[ ${files_project_feature[@]} ]]\nthen\n    error \"No files specified and not in a git repo.\"\n    exit 1\nfi\n\n# Set load path.\nargs_load_paths=($(args-load-path))\ndebug \"LOAD PATH ARGS: ${args_load_paths[@]}\"\n\n# If rules include linters and sandbox-dir is unspecified, install\n# linters automatically.\nif [[ $sandbox && ! $sandbox_dir ]] && [[ \"${rest[@]}\" =~ lint ]]\nthen\n    debug \"Installing linters automatically.\"\n    install_linters=true\nfi\n\n# Initialize sandbox.\n[[ $sandbox ]] && sandbox\n\n# Run rules.\nfor rule in \"${rest[@]}\"\ndo\n    if [[ $batch || $interactive ]]\n    then\n        debug \"Adding batch/interactive argument: $rule\"\n        args_batch_interactive+=(\"$rule\")\n\n    elif [[ $rule = batch ]]\n    then\n        # Remaining arguments are passed to Emacs.\n        batch=true\n    elif [[ $rule = interactive ]]\n    then\n        # Remaining arguments are passed to Emacs.\n        interactive=true\n\n    elif type -t \"$rule\" 2>/dev/null | grep function &>/dev/null\n    then\n        # Pass called-directly as $1 to indicate that the rule is\n        # being called directly rather than from a meta-rule.\n        $rule called-directly\n    elif [[ $rule = test ]]\n    then\n        # Allow the \"tests\" rule to be called as \"test\".  Since \"test\"\n        # is a shell builtin, this workaround is required.\n        tests\n    else\n        error \"Invalid rule: $rule\"\n    fi\ndone\n\n# Batch/interactive rules.\n[[ $batch ]] && batch\n[[ $interactive ]] && interactive\n\nif [[ $errors -gt 0 ]]\nthen\n    log_color red \"Finished with $errors errors.\"\nelse\n    success \"Finished without errors.\"\nfi\n\nexit $errors\n"
  },
  {
    "path": "tests/ement-tests.el",
    "content": ";;; ement-tests.el --- Tests for Ement.el                  -*- lexical-binding: t; -*-\n\n;; Copyright (C) 2023  Free Software Foundation, Inc.\n\n;; Author: Adam Porter \n\n;; This program is free software; you can redistribute it and/or modify\n;; it under the terms of the GNU General Public License as published by\n;; the Free Software Foundation, either version 3 of the License, or\n;; (at your option) any later version.\n\n;; This program is distributed in the hope that it will be useful,\n;; but WITHOUT ANY WARRANTY; without even the implied warranty of\n;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n;; GNU General Public License for more details.\n\n;; You should have received a copy of the GNU General Public License\n;; along with this program.  If not, see .\n\n;;; Commentary:\n\n;; \n\n;;; Code:\n\n(require 'ert)\n(require 'map)\n\n(require 'ement-lib)\n\n;;;; Tests\n\n(ert-deftest ement--format-body-mentions ()\n  (let ((room (make-ement-room\n               :members (map-into\n                         `((\"@foo:matrix.org\" . ,(make-ement-user :id \"@foo:matrix.org\"\n                                                                  :displayname \"foo\"))\n                           (\"@bar:matrix.org\" . ,(make-ement-user :id \"@bar:matrix.org\"\n                                                                  :displayname \"bar\")))\n                         '(hash-table :test equal)))))\n    (should (equal (ement--format-body-mentions \"@foo: hi\" room)\n                   \"foo: hi\"))\n    (should (equal (ement--format-body-mentions \"@foo:matrix.org: hi\" room)\n                   \"foo: hi\"))\n    (should (equal (ement--format-body-mentions \"foo: hi\" room)\n                   \"foo: hi\"))\n    (should (equal (ement--format-body-mentions \"@foo and @bar:matrix.org: hi\" room)\n                   \"foo and bar: hi\"))\n    (should (equal (ement--format-body-mentions \"foo: how about you and @bar ...\" room)\n                   \"foo: how about you and bar ...\"))\n    (should (equal (ement--format-body-mentions \"Hello, @foo:matrix.org.\" room)\n                   \"Hello, foo.\"))\n    (should (equal (ement--format-body-mentions \"Hello, @foo:matrix.org, how are you?\" room)\n                   \"Hello, foo, how are you?\"))))\n\n(provide 'ement-tests)\n\n;;; ement-tests.el ends here\n"
  }
]