diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..6fe637c --- /dev/null +++ b/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a working copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License \"or any later version\" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide whether future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/README.org b/README.org index 55e55c8..4fc5fab 100644 --- a/README.org +++ b/README.org @@ -1,53 +1,377 @@ -#+TITLE: cl-tui — Reusable Common Lisp Terminal UI Framework -#+STARTUP: content -#+FILETAGS: :project:cl-tui:readme: +# cl-tty — Terminal UI Framework for Common Lisp -* cl-tui +Pure CL terminal UI framework. No ncurses, no FFI, no external dependencies. -A reusable Common Lisp framework for building rich terminal user interfaces. -Built on croatoan (ncurses) with Yoga for Flexbox layout. Provides a component -tree model with dirty-tracking, incremental rendering, layered keybinding, -theme engine, and full mouse support — the primitives needed to match the TUI -quality of Claude Code and OpenCode from Common Lisp. - -** Why - -Common Lisp has no reusable terminal UI framework at the level of Python's -Rich/prompt_toolkit or Go's Bubble Tea. Every CL project that wants a -terminal UI either builds ncurses from scratch or uses a text-only REPL. -cl-tui fills that gap — a component library with Flexbox layout, semantic -theming, layered keybinding, and full mouse support. Build a terminal UI once, -reuse it everywhere. - -Terminal UIs also work over SSH. A Qt or browser-based UI requires a local -display. A cl-tui application runs remotely — same code, same components, -accessible from anywhere. - -** Architecture - -``` -Application code (any CL project) - └── cl-tui (layout, components, theme, events, dialogs) - └── Yoga (Flexbox layout — C library via FFI) - └── croatoan (ncurses terminal rendering) +```lisp +(ql:quickload :cl-tty) ``` -cl-tui depends only on croatoan and Yoga. It is not tied to any application. +## Quick start -** Dependencies +The simplest possible cl-tty program — detect the terminal, draw some text, +read a key, and shut down: -- Common Lisp (SBCL tested) -- croatoan — ncurses binding for terminal rendering -- Yoga — Flexbox layout engine (C library, loaded via CFFI) -- Quicklisp libraries as needed (ironclad for hashing, bordeaux-threads) +```lisp +(sb-posix:with-raw-terminal + (let* ((be (cl-tty.backend:detect-backend)) + (w 80) (h 24)) + (cl-tty.backend:initialize-backend be) + (unwind-protect + (progn + (cl-tty.backend:draw-text be 0 0 "Hello, terminal!" :green nil :bold t) + (cl-tty.backend:draw-border be 0 1 30 5 :style :single) + (finish-output) + ;; Read one key (blocks) + (cl-tty.input:read-event be)) + (cl-tty.backend:shutdown-backend be)))) +``` -** Status +Or run the full interactive demo: -v0.1.0 — Layout engine (in progress) +```bash +sbcl --script demo.lisp +``` -See ~docs/ROADMAP.org~ for the full release plan. +## Architecture -** License +Two backends, one protocol: -TBD -# Test +- **modern-backend** — truecolor 24-bit, OSC 8 hyperlinks, DECICM sync, + SGR mouse, kitty keyboard, bold/italic/underline, box-drawing chars +- **simple-backend** — ASCII art, no color, universal compatibility (pipe-safe) + +Everything is pure escape sequences (no curses, no terminfo, no FFI). + +### Backend protocol + +Every drawing operation is a CLOS generic function dispatched on the backend +class. Programs never call terminal codes directly: + +```lisp +;; Lifecycle +(initialize-backend backend) +(shutdown-backend backend) + +;; Drawing +(draw-text backend x y string fg bg &key bold italic underline reverse dim) +(draw-border backend x y width height &key style fg bg title) +(draw-rect backend x y width height &key bg) +(draw-link backend x y string url &key fg bg) + +;; Input +(read-event backend &key timeout) → key-event or mouse-event +(backend-size backend) → (values columns lines) + +;; Cursor +(cursor-move backend x y) +(cursor-hide backend) +(cursor-show backend) +(cursor-style backend shape &key blink) ;; :bar :block :underline +``` + +### Event loop pattern + +```lisp +(let ((be (detect-backend))) + (initialize-backend be) + (loop with running = t + while running + do (backend-clear be) + ;; ... draw frame ... + (finish-output *standard-output*) + (let ((event (read-event be))) + (typecase event + (key-event + (when (eql (key-event-key event) :escape) + (setf running nil))) + (mouse-event + ;; handle mouse + )))) + (shutdown-backend be)) +``` + +### Layout system + +Pure CL flexbox layout engine. No C dependencies, no Yoga FFI. + +```lisp +;; Macros build layout-trees: +(vbox (:gap 1 :padding 1) + (header "Title") + (hbox (:grow 1) + (sidebar (:width 30) ...) + (content ...))) +``` + +Layout properties: `:direction` (`:row` / `:column`), `:grow`, `:shrink`, +`:basis`, `:gap`, `:padding`, `:margin`, `:width`, `:height`, `:wrap`. + +See `layout/layout.lisp` or `org/layout-engine.org` for the full API. + +### Rendering pipeline + +Component trees render through a coordinated pipeline: + +1. **Layout pass** — `compute-layout` traverses dirty branches, solves flex constraints +2. **Render dispatch** — `render` generic dispatches per component type +3. **Framebuffer** — (optional) `make-framebuffer-backend` captures to a cell array, + `diff-framebuffers` computes minimal changes, `flush-framebuffer` writes only + changed cells + +```lisp +;; Full pipeline with framebuffer +(let* ((fb-be (make-framebuffer-backend :width 80 :height 24)) + (fb (fb-framebuffer fb-be))) + (render my-component fb-be) + (flush-framebuffer prev-fb fb real-backend)) +``` + +## Components + +| Component | What it does | Status | +|-------------|------------------------------------------------------|--------| +| Box | Bordered container with background, title | stable | +| Text | Styled text with word-wrap, spans | stable | +| ScrollBox | Scrollable viewport with scrollbars | stable | +| TabBar | Horizontal tab navigation | stable | +| Select | Dropdown with fuzzy filter, category headers | stable | +| TextInput | Single-line text input with readline keybindings | stable | +| TextArea | Multi-line input with undo/redo, cursor movement | stable | +| Markdown | Renders markdown with syntax highlighting + diffs | stable | +| Dialog | Modal overlays with stack management | stable | +| Toast | Transient notifications (info/success/warning/error) | stable | +| Mouse | Event handlers, hit-testing, text selection | stable | +| Slot | Plugin system — named slots for extensible UI | stable | + +Each component follows a consistent pattern: + +```lisp +;; 1. Create — factory function returns instance +(let ((input (make-text-input :placeholder "Type here...")) + (box (make-box :border-style :single :title "My Box"))) + + ;; 2. Layout — macros compose components + (vbox (:gap 1) + box + (hbox (:grow 1) + input + (make-select :options '((:title "Option A") (:title "Option B"))))) + + ;; 3. Render — dispatches through the component protocol + (render my-component backend)) +``` + +### Box + +Bordered container. Draws borders using Unicode box-drawing characters +(modern) or ASCII `+`/`-`/`|` (simple). Supports background fill, titled +borders. See `org/box-renderable.org`. + +```lisp +(make-box &key (border-style :single) title (title-align :left) fg bg width height) +``` + +### Text + +Styled text with inline spans and word wrapping. Spans support per-run +attributes (bold, italic, underline, fg, bg). See `org/box-renderable.org`. + +```lisp +(make-text content &key fg bg wrap-mode width height spans) +;; Span example: +(span "hello" :bold t :fg :bright-yellow) +``` + +### TextInput + +Single-line text editor with emacs-style keybindings. Supports placeholder, +max-length, on-submit callback. See `org/text-input.org`. + +```lisp +(make-text-input &key value cursor placeholder max-length on-submit) +;; Widget logic (input-level, no backend needed): +(handle-text-input input (make-key-event :key :a :code (char-code #\a))) +``` + +### TextArea + +Multi-line text editor. Supports undo/redo (Ctrl+Z/Y), cursor movement, +line joining on backspace. See `org/text-input.org`. + +```lisp +(make-textarea &key value on-submit) +``` + +### ScrollBox + +Scrollable viewport with a list of children. Only renders children +intersecting the visible area (viewport culling). Scrollbars drawn +at the right/bottom edges. See `org/scrollbox-tabbar.org`. + +```lisp +(make-scroll-box &key children scroll-y scroll-x sticky-scroll-p) +(scroll-by sb dy dx) +``` + +### TabBar + +Horizontal tab navigation. Renders tab labels, highlights active tab. +Left/right arrows cycle through tabs. See `org/scrollbox-tabbar.org`. + +```lisp +(make-tab-bar &key tabs active) +(tab-bar-add tb id title) +(tab-bar-next tb) / (tab-bar-prev tb) +(tab-bar-handle-key tb event) +``` + +### Select + +Dropdown/filter widget. Options can have categories (rendered as +non-selectable headers). Fuzzy fallback: matching > 30% character +overlap. Arrow keys navigate, Enter selects. See `org/select.org`. + +```lisp +(make-select &key options filter on-select) +;; Options format: (:title "Name" :category "Group") or (:title "Name") +``` + +### Markdown + +Parsed markdown AST with rendering. Supports headings, paragraphs, +bold, italic, inline code, links, code blocks with syntax highlighting, +diff blocks, blockquotes, lists, thematic breaks. See +`org/markdown-renderer.org`. + +```lisp +(render-markdown "# Hello\n\nThis is **bold**.") +``` + +### Dialog + Toast + +Modal dialog stack. `alert-dialog`, `confirm-dialog`, `select-dialog`, +`prompt-dialog` are convenience constructors. Toasts are transient +notifications that auto-dismiss. See `org/dialog.org`. + +```lisp +(push-dialog (make-instance 'dialog :size :medium)) +(alert-dialog "Notice" "Operation complete") +(toast "Saved!" :variant :success) +``` + +### Mouse + +Mixin class providing mouse event handler slots. `hit-test` finds the +deepest component at a coordinate. Text selection tracks drag gestures. +Scrollboxes integrate wheel events. See `org/mouse.org`. + +```lisp +(defclass my-panel (mouse-mixin) ...) +(handle-mouse-event component mouse-event) +(hit-test root x y) → deepest matching component +``` + +### Slot system + +Plugin system for extensible rendering slots. Register named rendering +functions, then render them by slot name. Useful for toolbars, status +bars, and plugin architectures. + +```lisp +(defslot :status-bar :order 0 + (lambda (&rest args) + (draw-text backend 0 0 "Ready" :text-muted nil))) +(slot-render :status-bar) +``` + +## Backend features + +| Feature | modern | simple | +|-------------------|--------|--------| +| Truecolor (24-bit)| Yes | No | +| Bold/italic | Yes | No | +| OSC 8 hyperlinks | Yes | No | +| DECICM sync | Yes | No | +| SGR mouse | Yes | No | +| Kitty keyboard | Yes | No | +| Box drawing chars | Unicode| ASCII | +| Pipe-safe | No | Yes | + +Backend selection happens automatically via `detect-backend`. It checks: +1. Is stdout a TTY? (if not → simple-backend) +2. Does `COLORTERM` contain "truecolor" or "24bit"? +3. Send DA1 query — does the terminal respond with modern feature codes? + +Result is cached in `*detected-backend*`. + +## Development + +```bash +# Run all tests (392 checks, 12 suites) +sbcl --script run-all-tests.lisp + +# Run interactive demo +sbcl --script demo.lisp + +# Tangle org files (regenerate .lisp from .org sources) +for f in org/*.org; do + emacs --batch --eval "(progn (require 'org) (find-file \"$f\") (org-babel-tangle) (kill-buffer))" 2>&1 +done +``` + +Literate programming: `.org` files in `org/` are the source of truth for +the input system, scrollbox/tabbar, dialog, mouse, select, slot, +framebuffer, and markdown modules. The backend (`modern.lisp`, +`simple.lisp`) and basic components (`box.lisp`, `text.lisp`, `render.lisp`, +`theme.lisp`, `dirty.lisp`) are written directly. + +Project structure: + +``` +cl-tty/ +├── cl-tty.asd # ASDF system definition +├── demo.lisp # Interactive demo +├── run-all-tests.lisp # Test runner +├── backend/ # Backend protocol + implementations +│ ├── package.lisp +│ ├── classes.lisp # Generic definitions +│ ├── simple.lisp # ASCII fallback backend +│ ├── modern.lisp # Truecolor escape backend +│ └── detection.lisp # Auto-detect backend from env +├── layout/ # Flexbox layout engine +│ └── layout.lisp +├── src/ +│ ├── rendering/ # Framebuffer backend + diff + flush +│ │ └── framebuffer.lisp +│ └── components/ # Widgets +│ ├── box.lisp, text.lisp, render.lisp, theme.lisp +│ ├── dirty.lisp, input-package.lisp, input.lisp +│ ├── text-input.lisp, textarea.lisp, keybindings.lisp +│ ├── scrollbox.lisp, tabbar.lisp, container-package.lisp +│ ├── select.lisp, select-package.lisp +│ ├── markdown.lisp, markdown-package.lisp +│ ├── dialog.lisp, dialog-package.lisp +│ ├── mouse.lisp, mouse-package.lisp +│ └── slot.lisp, slot-package.lisp +├── tests/ # Test files +├── org/ # Literate source files +│ ├── text-input.org +│ ├── scrollbox-tabbar.org +│ ├── dialog.org +│ ├── mouse.org +│ ├── select.org +│ ├── slot.org +│ ├── framebuffer.org +│ ├── markdown-renderer.org +│ ├── detection.org +│ ├── modern-backend.org +│ ├── box-renderable.org +│ └── layout-engine.org +└── docs/ + ├── ROADMAP.org # Versioned roadmap + └── ARCHITECTURE.org # Design docs +``` + +## License + +GNU General Public License v3.0 diff --git a/backend/classes.lisp b/backend/classes.lisp index 368f9d2..4c87c30 100644 --- a/backend/classes.lisp +++ b/backend/classes.lisp @@ -1,4 +1,4 @@ -(in-package :cl-tui.backend) +(in-package :cl-tty.backend) (defclass backend () ()) @@ -19,7 +19,8 @@ (backend-write b (format nil "~C[2J~C[H" #\Esc #\Esc)))) (defgeneric draw-text (backend x y string fg bg &key - bold italic underline reverse dim blink)) + bold italic underline reverse dim blink + &allow-other-keys)) (defgeneric draw-border (backend x y width height &key style fg bg title title-align)) @@ -30,7 +31,8 @@ (defgeneric draw-ellipsis (backend x y width &key fg bg)) -(defgeneric cursor-move (backend x y)) +(defgeneric cursor-move (backend x y) + (:method ((b backend) x y) (declare (ignore x y)) (values))) (defgeneric cursor-hide (backend) (:method ((b backend)) (values))) diff --git a/backend/detection.lisp b/backend/detection.lisp new file mode 100644 index 0000000..d858350 --- /dev/null +++ b/backend/detection.lisp @@ -0,0 +1,62 @@ +(in-package :cl-tty.backend) + +;;; ─── Detection cache ──────────────────────────────────────────────────────── + +(defvar *detected-backend* nil + "Cached backend instance from detect-backend. Nil = not yet detected.") + +;;; ─── Environment probe ────────────────────────────────────────────────────── + +(defun detect-backend-by-env () + "Check COLORTERM environment variable for modern terminal support. +Returns :modern if COLORTERM contains 'truecolor' or '24bit', nil otherwise." + (let ((colorterm (sb-ext:posix-getenv "COLORTERM"))) + (when (and colorterm + (or (search "truecolor" colorterm :test #'char-equal) + (search "24bit" colorterm :test #'char-equal))) + :modern))) + +;;; ─── TTY probe ────────────────────────────────────────────────────────────── + +(defun detect-backend-by-tty () + "Check if stdout is a real terminal (not a pipe/redirect). +Returns T if stdout is interactive, nil otherwise." + (interactive-stream-p *standard-output*)) + +;;; ─── DA1 terminal query ───────────────────────────────────────────────────── + +(defun query-terminal (query &optional (timeout 0.1)) + "Send QUERY string to terminal and return any response received within +TIMEOUT seconds. Returns the response string, or nil if no response." + (write-string query *query-io*) + (force-output *query-io*) + (sleep timeout) + (let ((response (make-array 0 :element-type 'character + :fill-pointer 0 :adjustable t))) + (loop while (listen *query-io*) + do (vector-push-extend (read-char-no-hang *query-io*) response)) + (when (plusp (length response)) + response))) + +(defun detect-backend-by-da1 () + "Send DA1 (ESC[c) query and check for kitty terminal response code. +Returns T if terminal reports kitty compatibility codes." + (let ((response (query-terminal (format nil "~C[c" #\Esc)))) + (when response + ;; DA1 response format: ESC [ ? digits ; digits c + ;; Kitty reports code 62 in the response + (search "?62" response)))) + +;;; ─── Orchestrator ─────────────────────────────────────────────────────────── + +(defun detect-backend () + "Auto-detect the appropriate backend for the current terminal. +Returns a backend instance (modern-backend or simple-backend). +Result is cached in *detected-backend* for subsequent calls." + (or *detected-backend* + (setf *detected-backend* + (if (and (detect-backend-by-tty) + (or (eql (detect-backend-by-env) :modern) + (detect-backend-by-da1))) + (make-modern-backend) + (make-simple-backend))))) diff --git a/backend/modern-tests.lisp b/backend/modern-tests.lisp index 2c698a1..3bb80e9 100644 --- a/backend/modern-tests.lisp +++ b/backend/modern-tests.lisp @@ -1,7 +1,7 @@ -(defpackage :cl-tui-modern-backend-test - (:use :cl :fiveam :cl-tui.backend) +(defpackage :cl-tty-modern-backend-test + (:use :cl :fiveam :cl-tty.backend) (:export #:run-tests)) -(in-package :cl-tui-modern-backend-test) +(in-package :cl-tty-modern-backend-test) (def-suite modern-backend-suite :description "Modern backend tests") (in-suite modern-backend-suite) @@ -16,72 +16,72 @@ (test make-modern-backend-creates "make-modern-backend returns a modern-backend instance" (let ((b (make-modern-backend))) - (is (typep b 'cl-tui.backend::modern-backend)))) + (is (typep b 'cl-tty.backend::modern-backend)))) ;; ── Escape Generation ────────────────────────────────────────── (test sgr-truecolor-foreground "SGR truecolor foreground escape is correct" - (is (equal (cl-tui.backend::sgr-fg "#FFD700") + (is (equal (cl-tty.backend::sgr-fg "#FFD700") (format nil "~C[38;2;255;215;0m" #\Esc)))) (test sgr-truecolor-background "SGR truecolor background escape is correct" - (is (equal (cl-tui.backend::sgr-bg "#1a1b26") + (is (equal (cl-tty.backend::sgr-bg "#1a1b26") (format nil "~C[48;2;26;27;38m" #\Esc)))) (test sgr-named-colors "SGR named colors resolve to 8-color codes" - (is (equal (cl-tui.backend::sgr-fg :red) + (is (equal (cl-tty.backend::sgr-fg :red) (format nil "~C[31m" #\Esc))) - (is (equal (cl-tui.backend::sgr-bg :blue) + (is (equal (cl-tty.backend::sgr-bg :blue) (format nil "~C[44m" #\Esc)))) (test sgr-bold-italic "SGR attribute escapes are correct" - (is (equal (cl-tui.backend::sgr-attr :bold) (format nil "~C[1m" #\Esc))) - (is (equal (cl-tui.backend::sgr-attr :italic) (format nil "~C[3m" #\Esc))) - (is (equal (cl-tui.backend::sgr-attr :underline) (format nil "~C[4m" #\Esc))) - (is (equal (cl-tui.backend::sgr-attr :reset) (format nil "~C[0m" #\Esc)))) + (is (equal (cl-tty.backend::sgr-attr :bold) (format nil "~C[1m" #\Esc))) + (is (equal (cl-tty.backend::sgr-attr :italic) (format nil "~C[3m" #\Esc))) + (is (equal (cl-tty.backend::sgr-attr :underline) (format nil "~C[4m" #\Esc))) + (is (equal (cl-tty.backend::sgr-attr :reset) (format nil "~C[0m" #\Esc)))) ;; ── Cursor ───────────────────────────────────────────────────── (test cursor-move-escape "cursor-move generates correct CSI escape" (let ((b (make-modern-backend))) - (is (equal (cl-tui.backend::cursor-move-escape 5 10) + (is (equal (cl-tty.backend::cursor-move-escape 5 10) (format nil "~C[11;6H" #\Esc))))) (test cursor-style-block "cursor-style :block generate correct escape" (let ((b (make-modern-backend))) - (is (equal (cl-tui.backend::cursor-style-escape :block nil) + (is (equal (cl-tty.backend::cursor-style-escape :block nil) (format nil "~C[2 q" #\Esc))))) (test cursor-style-bar "cursor-style :bar generate correct escape" (let ((b (make-modern-backend))) - (is (equal (cl-tui.backend::cursor-style-escape :bar nil) + (is (equal (cl-tty.backend::cursor-style-escape :bar nil) (format nil "~C[6 q" #\Esc))))) (test cursor-style-underline-blink "cursor-style :underline with blink" (let ((b (make-modern-backend))) - (is (equal (cl-tui.backend::cursor-style-escape :underline t) + (is (equal (cl-tty.backend::cursor-style-escape :underline t) (format nil "~C[5 q" #\Esc))))) ;; ── Synchronization ──────────────────────────────────────────── (test decicm-escapes "DECICM synchronized update escapes" - (is (equal (cl-tui.backend::decicm-begin) (format nil "~C[?2026h" #\Esc))) - (is (equal (cl-tui.backend::decicm-end) (format nil "~C[?2026l" #\Esc)))) + (is (equal (cl-tty.backend::decicm-begin) (format nil "~C[?2026h" #\Esc))) + (is (equal (cl-tty.backend::decicm-end) (format nil "~C[?2026l" #\Esc)))) ;; ── OSC 8 Hyperlinks ────────────────────────────────────────── (test osc8-escape "OSC 8 hyperlink escape wraps text" - (is (equal (cl-tui.backend::osc8-link "http://example.com" "click here") + (is (equal (cl-tty.backend::osc8-link "http://example.com" "click here") (format nil "~C]8;;http://example.com~C\\click here~C]8;;~C\\" #\Esc #\Esc #\Esc #\Esc)))) @@ -89,21 +89,21 @@ (test hex-color-parsing "hex-to-rgb parses valid hex colors" - (multiple-value-bind (r g b) (cl-tui.backend::hex-to-rgb "#FFD700") + (multiple-value-bind (r g b) (cl-tty.backend::hex-to-rgb "#FFD700") (is (= r 255)) (is (= g 215)) (is (= b 0)))) (test hex-color-black "hex-to-rgb parses black" - (multiple-value-bind (r g b) (cl-tui.backend::hex-to-rgb "#000000") + (multiple-value-bind (r g b) (cl-tty.backend::hex-to-rgb "#000000") (is (= r 0)) (is (= g 0)) (is (= b 0)))) (test hex-color-short-form "hex-to-rgb parses 3-digit hex" - (multiple-value-bind (r g b) (cl-tui.backend::hex-to-rgb "#F00") + (multiple-value-bind (r g b) (cl-tty.backend::hex-to-rgb "#F00") (is (= r 255)) (is (= g 0)) (is (= b 0)))) @@ -112,13 +112,13 @@ (test border-char-rounded "modern-border-char returns Unicode box-drawing for rounded style" - (is (equal (cl-tui.backend::border-char :rounded :top-left) "╭")) - (is (equal (cl-tui.backend::border-char :rounded :horizontal) "─")) - (is (equal (cl-tui.backend::border-char :rounded :vertical) "│")) - (is (equal (cl-tui.backend::border-char :rounded :bottom-right) "╯"))) + (is (equal (cl-tty.backend::border-char :rounded :top-left) "╭")) + (is (equal (cl-tty.backend::border-char :rounded :horizontal) "─")) + (is (equal (cl-tty.backend::border-char :rounded :vertical) "│")) + (is (equal (cl-tty.backend::border-char :rounded :bottom-right) "╯"))) (test border-char-double "modern-border-char returns double-line chars" - (is (equal (cl-tui.backend::border-char :double :top-left) "╔")) - (is (equal (cl-tui.backend::border-char :double :horizontal) "═")) - (is (equal (cl-tui.backend::border-char :double :vertical) "║"))) + (is (equal (cl-tty.backend::border-char :double :top-left) "╔")) + (is (equal (cl-tty.backend::border-char :double :horizontal) "═")) + (is (equal (cl-tty.backend::border-char :double :vertical) "║"))) diff --git a/backend/modern.lisp b/backend/modern.lisp index 6b43c04..aabf5dd 100644 --- a/backend/modern.lisp +++ b/backend/modern.lisp @@ -8,7 +8,7 @@ ;; sgr-fg sgr-bg sgr-attr cursor-move-escape cursor-style-escape ;; decicm-begin decicm-end osc8-link hex-to-rgb border-char -(in-package :cl-tui.backend) +(in-package :cl-tty.backend) (defun hex-to-rgb (hex) "Parse a hex color string like \"#FFD700\" into (values r g b). @@ -28,9 +28,16 @@ '((:black . 0) (:red . 1) (:green . 2) (:yellow . 3) (:blue . 4) (:magenta . 5) (:cyan . 6) (:white . 7))) +(defvar *theme-colors* (make-hash-table :test 'eq) + "Hash table mapping theme keywords to hex color strings. +Populated by the theme system's load-preset. Checked by sgr-fg/sgr-bg +as a fallback when a keyword is not in *named-colors*.") + (defun sgr-fg (color) "Return SGR foreground escape for COLOR. - Color can be a hex string, a keyword name, or nil." + Color can be a hex string, a keyword name, or nil. + Keywords first try *named-colors*, then fall back to *theme-colors* + which resolves theme semantic roles to hex strings." (if (null color) "" (cond ((and (stringp color) (char= (char color 0) #\#)) (multiple-value-bind (r g b) (hex-to-rgb color) @@ -39,11 +46,17 @@ (let ((index (cdr (assoc color *named-colors*)))) (if index (format nil "~C[~dm" #\Esc (+ 30 index)) - ""))) + ;; Fall back to theme-colors hash + (let ((hex (gethash color *theme-colors*))) + (if hex + (multiple-value-bind (r g b) (hex-to-rgb hex) + (format nil "~C[38;2;~d;~d;~dm" #\Esc r g b)) + ""))))) (t "")))) (defun sgr-bg (color) - "Return SGR background escape for COLOR." + "Return SGR background escape for COLOR. + Keywords first try *named-colors*, then fall back to *theme-colors*." (if (null color) "" (cond ((and (stringp color) (char= (char color 0) #\#)) (multiple-value-bind (r g b) (hex-to-rgb color) @@ -52,7 +65,12 @@ (let ((index (cdr (assoc color *named-colors*)))) (if index (format nil "~C[~dm" #\Esc (+ 40 index)) - ""))) + ;; Fall back to theme-colors hash + (let ((hex (gethash color *theme-colors*))) + (if hex + (multiple-value-bind (r g b) (hex-to-rgb hex) + (format nil "~C[48;2;~d;~d;~dm" #\Esc r g b)) + ""))))) (t "")))) (defparameter *sgr-attr-codes* @@ -149,6 +167,7 @@ (defmethod backend-write ((b modern-backend) string) (let ((stream (backend-output-stream b))) (write-string string stream) + (finish-output stream) (length string))) (defmethod capable-p ((b modern-backend) feature) diff --git a/backend/package.lisp b/backend/package.lisp index 0b50b26..e1eb0af 100644 --- a/backend/package.lisp +++ b/backend/package.lisp @@ -1,4 +1,4 @@ -(defpackage :cl-tui.backend +(defpackage :cl-tty.backend (:use :cl) (:export ;; Backend classes @@ -21,9 +21,13 @@ #:make-simple-backend ;; Modern backend #:modern-backend #:make-modern-backend + ;; Detection + #:detect-backend #:*detected-backend* + ;; Theme color resolution (populated by theme system) + #:*theme-colors* ;; Internal (for testing) #:sgr-fg #:sgr-bg #:sgr-attr #:cursor-move-escape #:cursor-style-escape #:decicm-begin #:decicm-end #:osc8-link #:hex-to-rgb #:border-char)) -(in-package :cl-tui.backend) +(in-package :cl-tty.backend) diff --git a/backend/simple.lisp b/backend/simple.lisp index ab82279..a7af39f 100644 --- a/backend/simple.lisp +++ b/backend/simple.lisp @@ -1,4 +1,4 @@ -(in-package :cl-tui.backend) +(in-package :cl-tty.backend) (defclass simple-backend (backend) ((output-stream :initform *standard-output* @@ -44,13 +44,22 @@ POS is :top-left, :top-right, :bottom-left, :bottom-right, (declare (ignore style fg bg title title-align)) (let ((h (%simple-border-char nil :horizontal)) (v (%simple-border-char nil :vertical))) + ;; Position cursor with newlines and spaces (no escape sequences) + (dotimes (row y) (backend-write b (string #\Newline))) ;; Top edge - (backend-write b (format nil "~%~v@{~a~:*~}" width h)) + (backend-write b (make-string x :initial-element #\space)) + (backend-write b (make-string width :initial-element h)) ;; Sides (loop for i from 1 below (1- height) - do (backend-write b (format nil "~%|~v@{~a~:*~}|" (- width 2) #\space))) + do (backend-write b (string #\Newline)) + (backend-write b (make-string x :initial-element #\space)) + (backend-write b (string v)) + (backend-write b (make-string (- width 2) :initial-element #\space)) + (backend-write b (string v))) ;; Bottom edge - (backend-write b (format nil "~%~v@{~a~:*~}" width h)))) + (backend-write b (string #\Newline)) + (backend-write b (make-string x :initial-element #\space)) + (backend-write b (make-string width :initial-element h)))) (defmethod draw-rect ((b simple-backend) x y width height &key bg) diff --git a/backend/tests.lisp b/backend/tests.lisp index 01d8359..ea8f2fc 100644 --- a/backend/tests.lisp +++ b/backend/tests.lisp @@ -1,7 +1,7 @@ -(defpackage :cl-tui-backend-test - (:use :cl :fiveam :cl-tui.backend) +(defpackage :cl-tty-backend-test + (:use :cl :fiveam :cl-tty.backend) (:export #:run-tests)) -(in-package :cl-tui-backend-test) +(in-package :cl-tty-backend-test) (def-suite backend-suite :description "Backend protocol tests") (in-suite backend-suite) @@ -136,3 +136,16 @@ (shutdown-backend b) (is (string= (get-output-stream-string s) "") "draw-rect is a no-op on simple-backend"))) + +;; ── Detection ────────────────────────────────────────────────── + +(test detection-returns-backend-instance + "detect-backend returns a valid backend instance" + (let ((be (cl-tty.backend:detect-backend))) + (is (typep be 'cl-tty.backend:backend)))) + +(test detection-caches-result + "detect-backend caches the result in *detected-backend*" + (let ((*detected-backend* nil)) + (cl-tty.backend:detect-backend) + (is-true (not (null cl-tty.backend::*detected-backend*))))) diff --git a/cl-tty.asd b/cl-tty.asd new file mode 100644 index 0000000..064288f --- /dev/null +++ b/cl-tty.asd @@ -0,0 +1,111 @@ +;;; cl-tty.asd — Common Lisp Terminal UI Framework +(asdf:defsystem :cl-tty + :description "Reusable Common Lisp Terminal UI Framework" + :author "Amr Gharbeia" + :version "0.15.0" + :license "GPL-3.0" + :depends-on (:sb-posix) + :components + ((:module "backend" + :components + ((:file "package") + (:file "classes" :depends-on ("package")) + (:file "simple" :depends-on ("package" "classes")) + (:file "modern" :depends-on ("package" "classes")) + (:file "detection" :depends-on ("package" "classes")))) + (:module "layout" + :components + ((:file "layout"))) + (:module "src/rendering" + :components + ((:file "framebuffer"))) + (:module "src/components" + :components + ((:file "package") + (:file "dirty") + (:file "box" :depends-on ("package")) + (:file "text" :depends-on ("package" "box")) + (:file "render" :depends-on ("package" "box" "text")) + (:file "theme" :depends-on ("package")) + ;; Input system (v0.5.0) + (:file "input-package" :depends-on ("package")) + (:file "input" :depends-on ("input-package" "dirty" "box")) + (:file "text-input" :depends-on ("input-package" "input" "box")) + (:file "textarea" :depends-on ("input-package" "input" "box")) + (:file "keybindings" :depends-on ("input-package" "input")) + ;; Container components (v0.6.0) + (:file "container-package" :depends-on ("package" "input-package")) + (:file "scrollbox" :depends-on ("container-package" "dirty" "box")) + (:file "tabbar" :depends-on ("container-package" "dirty" "box")) + ;; Select widget (v0.7.0) + (:file "select-package" :depends-on ("package" "input-package")) + (:file "select" :depends-on ("select-package" "dirty" "box")) + ;; Markdown + Code + Diff rendering (v0.8.0) + (:file "markdown-package" :depends-on ("package")) + (:file "markdown" :depends-on ("markdown-package")) + ;; Dialog + Toast (v0.9.0) + (:file "dialog-package" :depends-on ("package" "select-package" "input-package")) + (:file "dialog" :depends-on ("dialog-package" "dirty" "select" "text-input")) + ;; Mouse support (v0.10.0) + (:file "mouse-package" :depends-on ("package" "input-package")) + (:file "mouse" :depends-on ("mouse-package" "dirty" "input")) + ;; Slot system (v0.11.0) + (:file "slot-package" :depends-on ("package")) + (:file "slot" :depends-on ("slot-package"))))) + :in-order-to ((test-op (test-op :cl-tty/test)))) + +(asdf:defsystem :cl-tty/test + :description "Test suite for cl-tty" + :depends-on (:cl-tty :fiveam) + :components + ((:module "backend" + :components + ((:file "tests") + (:file "modern-tests" :depends-on ("tests")))) + (:module "layout" + :components + ((:file "tests"))) + (:module "src/components" + :components + ((:file "box-tests") + (:file "dirty-tests") + (:file "render-tests") + (:file "theme-tests") + (:file "input-tests") + (:file "scrollbox-tabbar-tests" :pathname "../../tests/scrollbox-tabbar-tests") + (:file "select-tests" :pathname "../../tests/select-tests") + (:file "markdown-tests" :pathname "../../tests/markdown-tests") + (:file "dialog-tests" :pathname "../../tests/dialog-tests") + (:file "mouse-tests" :pathname "../../tests/mouse-tests") + (:file "slot-tests" :pathname "../../tests/slot-tests"))) + (:module "src/rendering" + :components + ((:file "framebuffer-tests" :pathname "../../tests/framebuffer-tests")))) + :perform (test-op (o c) + (let ((run (find-symbol "RUN" :fiveam)) + (explain (find-symbol "EXPLAIN!" :fiveam)) + (status (find-symbol "RESULTS-STATUS" :fiveam)) + (all-passed t)) + (dolist (suite '((:cl-tty-backend-test "BACKEND-SUITE") + (:cl-tty-box-test "BOX-SUITE") + (:cl-tty-input-test "INPUT-SUITE") + (:cl-tty-scrollbox-test "SCROLLBOX-SUITE") + (:cl-tty-select-test "SELECT-SUITE") + (:cl-tty-markdown-test) + (:cl-tty-dialog-test "DIALOG-SUITE") + (:cl-tty-mouse-test "MOUSE-SUITE") + (:cl-tty-slot-test "SLOT-SUITE") + (:cl-tty-layout-test "LAYOUT-SUITE") + (:cl-tty-modern-backend-test "MODERN-BACKEND-SUITE") + (:cl-tty-framebuffer-test "FRAMEBUFFER-SUITE"))) + (let* ((pkg (find-package (first suite))) + (suite-name (second suite)) + (s (cond (suite-name (find-symbol suite-name pkg)) + (pkg (find-symbol (string (first suite)) :keyword)) + (t nil)))) + (when s + (let ((result (funcall run s))) + (funcall explain result) + (unless (funcall status result) + (setf all-passed nil)))))) + (uiop:quit (if all-passed 0 1))))) diff --git a/cl-tui.asd b/cl-tui.asd deleted file mode 100644 index 1ac5863..0000000 --- a/cl-tui.asd +++ /dev/null @@ -1,65 +0,0 @@ -;;; cl-tui.asd — Common Lisp Terminal UI Framework -(asdf:defsystem :cl-tui - :description "Reusable Common Lisp Terminal UI Framework" - :author "Amr Gharbeia" - :version "0.6.0" - :license "TBD" - :depends-on (:fiveam :sb-posix) - :components - ((:module "backend" - :components - ((:file "package") - (:file "classes" :depends-on ("package")) - (:file "simple" :depends-on ("package" "classes")) - (:file "modern" :depends-on ("package" "classes")))) - (:module "layout" - :components - ((:file "layout"))) - (:module "src/components" - :components - ((:file "package") - (:file "dirty") - (:file "box" :depends-on ("package")) - (:file "text" :depends-on ("package" "box")) - (:file "render" :depends-on ("package" "box" "text")) - (:file "theme" :depends-on ("package")) - ;; Input system (v0.5.0) - (:file "input-package" :depends-on ("package")) - (:file "input" :depends-on ("input-package" "dirty" "box")) - (:file "text-input" :depends-on ("input-package" "input" "box")) - (:file "textarea" :depends-on ("input-package" "input" "box")) - (:file "keybindings" :depends-on ("input-package" "input")) - ;; Container components (v0.6.0) - (:file "container-package" :depends-on ("package" "input-package")) - (:file "scrollbox" :depends-on ("container-package" "dirty" "box")) - (:file "tabbar" :depends-on ("container-package" "dirty" "box")))) - :in-order-to ((test-op (test-op :cl-tui-tests)))) - -(asdf:defsystem :cl-tui-tests - :description "Test suite for cl-tui" - :depends-on (:cl-tui :fiveam) - :components - ((:module "backend" - :components - ((:file "tests"))) - (:module "layout" - :components - ((:file "tests"))) - (:module "src/components" - :components - ((:file "box-tests") - (:file "dirty-tests") - (:file "render-tests") - (:file "theme-tests") - (:file "input-tests") - (:file "scrollbox-tabbar-tests" :pathname "../../tests/scrollbox-tabbar-tests.lisp")))) - :perform (test-op (o c) - (dolist (suite '((:cl-tui-backend-test "BACKEND-SUITE") - (:cl-tui-box-test "BOX-SUITE") - (:cl-tui-input-test "INPUT-SUITE") - (:cl-tui-scrollbox-test "SCROLLBOX-SUITE"))) - (let* ((pkg (find-package (first suite))) - (s (and pkg (find-symbol (second suite) pkg)))) - (when s - (fiveam:explain! (fiveam:run s))))) - (uiop:quit 0))) diff --git a/debug-layout.lisp b/debug-layout.lisp new file mode 100644 index 0000000..af98063 --- /dev/null +++ b/debug-layout.lisp @@ -0,0 +1,94 @@ +(load "~/quicklisp/setup.lisp") +(ql:quickload :cl-tty :silent t) +(in-package :cl-tty.layout) + +(defun trace-layout (root aw ah) + "Run compute-layout with detailed traces" + (labels ((p (node x y max-w max-h depth) + (let* ((children (layout-node-children node)) + (is-row (eql (layout-node-direction node) :row)) + (pl (box-edge (layout-node-padding node) :left)) + (pt (box-edge (layout-node-padding node) :top)) + (pr (box-edge (layout-node-padding node) :right)) + (pb (box-edge (layout-node-padding node) :bottom)) + (cw (max 0 (- max-w pl pr))) + (ch (max 0 (- max-h pt pb))) + (gap (layout-node-gap node)) + (sizes (distribute-sizes children (if is-row cw ch) gap is-row))) + (format t "~v,0Tp~A: xy=~A,~A mw=~A mh=~A pl=~A pt=~A cw=~A ch=~A gap=~A sizes=~A~%" + (* depth 2) (if is-row 'ROW 'COL) + x y max-w max-h pl pt cw ch gap sizes) + (setf (layout-node-x node) (+ x pl) + (layout-node-y node) (+ y pt)) + (loop :with pos = 0 + :for child :in children + :for size :in sizes + :for i :from 0 + :do (if is-row + (setf (layout-node-width child) size + (layout-node-x child) (+ x pl pos) + (layout-node-height child) ch + (layout-node-y child) (+ y pt)) + (setf (layout-node-height child) size + (layout-node-y child) (+ y pt pos) + (layout-node-width child) cw + (layout-node-x child) (+ x pl))) + (format t "~v,0T~A#~D: placed pos=~A size=~A xy=~A,~A wh=~A,~A~%" + (* (1+ depth) 2) (if is-row 'H 'V) i pos size + (layout-node-x child) (layout-node-y child) + (layout-node-width child) (layout-node-height child)) + (p child + (layout-node-x child) (layout-node-y child) + (if is-row size cw) (if is-row ch size) + (1+ depth)) + (incf pos (+ size gap))) + (let ((last-child (car (last children)))) + (if is-row + (setf (layout-node-width node) + (or (layout-node-fixed-width node) + (if last-child + (+ (layout-node-x node) + (layout-node-width last-child) + pr) + max-w)) + (layout-node-height node) + max-h) + (setf (layout-node-height node) + (or (layout-node-fixed-height node) + (if last-child + (let ((last-y (layout-node-y last-child)) + (last-h (layout-node-height last-child))) + (+ last-y last-h pb)) + max-h)) + (layout-node-width node) + max-w)) + (format t "~v,0Tresult: node wh=~A,~A (fixed-w=~A fixed-h=~A)~%" + (* depth 2) + (layout-node-width node) (layout-node-height node) + (layout-node-fixed-width node) (layout-node-fixed-height node)))))) + (p root 0 0 aw ah 0) + root)) + +(format t "~%=== 1. SINGLE-CHILD-IN-COLUMN ===~%~%") +(let* ((r (make-layout-node :direction :column :width 10 :height 20)) + (c (make-layout-node :height 5))) + (layout-node-add-child r c) + (trace-layout r 10 20) + (format t "~%child final: x=~A (exp 0) y=~A (exp 0) w=~A h=~A (exp 5)~%~%" + (layout-node-x c) (layout-node-y c) (layout-node-width c) (layout-node-height c))) + +(format t "=== 2. PADDING-REDUCES-CONTENT-AREA ===~%~%") +(let* ((r (make-layout-node :direction :column :padding '(:top 1 :left 1 :bottom 1 :right 1))) + (c (make-layout-node :height 3))) + (layout-node-add-child r c) + (trace-layout r 20 10) + (format t "~%child final: x=~A (exp 1) y=~A (exp 1)~%~%" + (layout-node-x c) (layout-node-y c))) + +(format t "=== 3. FLEX-GROW-SINGLE-CHILD ===~%~%") +(let* ((root (make-layout-node :direction :row :width 20)) + (c (make-layout-node :width 5 :grow 1))) + (layout-node-add-child root c) + (trace-layout root 20 10) + (format t "~%child final: w=~A (exp 20)~%~%" + (layout-node-width c))) diff --git a/demo.lisp b/demo.lisp index f373266..3c90460 100644 --- a/demo.lisp +++ b/demo.lisp @@ -1,28 +1,172 @@ -;; demo.lisp — minimal cl-tui demo -(load "/root/quicklisp/setup.lisp") -(ql:quickload :fiveam :silent t) -(load "backend/package.lisp") -(load "backend/classes.lisp") -(load "backend/simple.lisp") -(load "backend/modern.lisp") -(load "layout/layout.lisp") -(load "src/components/package.lisp") -(load "src/components/dirty.lisp") -(load "src/components/box.lisp") -(load "src/components/text.lisp") -(load "src/components/render.lisp") -(in-package :cl-tui.box) +;;; demo.lisp — cl-tty interactive demo +;;; Run: sbcl --script demo.lisp -;; Demo 1: Simple backend (ASCII) -(let* ((b (make-simple-backend)) - (bx (make-box :border-style :rounded :title " Hello World " :width 30 :height 5))) - (compute-layout (box-layout-node bx) 30 5) - (render bx b)) +;; Load cl-tty directly via ASDF (no Quicklisp dependency needed — +;; sb-posix is built into SBCL, no external libraries required). +(require "asdf") +(push (truename ".") asdf:*central-registry*) +(asdf:load-system :cl-tty) -;; Demo 2: Box with text inside -(let* ((b (make-simple-backend)) - (tx (make-text "This is cl-tui in action!" :width 28 :height 1))) - (setf (layout-node-direction (text-layout-node tx)) :column) - (compute-layout (text-layout-node tx) 28 1) - (render tx b) - (format t "~%~%")) +(use-package :cl-tty.backend) +(use-package :cl-tty.input) +(use-package :cl-tty.box) +(use-package :cl-tty.layout) +(use-package :cl-tty.rendering) + +;;; ─── Application state ─────────────────────────────────────────────────────── + +(defvar *app* nil "Application state plist") +(defvar *log* nil "Circular log buffer") + +(defun log-append (fmt &rest args) + (let* ((msg (apply #'format nil fmt args)) + (ts (multiple-value-bind (h m s) (get-decoded-time) + (format nil "~2,'0d:~2,'0d:~2,'0d" h m s)))) + (push (format nil "[~a] ~a" ts msg) *log*) + (when (> (length *log*) 100) (setf *log* (subseq *log* 0 100))))) + +(defun init-app-state () + (setf *log* nil) + (setf *app* (list :tab 0 + :input (make-text-input :placeholder "Type here...") + :textarea (make-textarea :value "Hello\nWorld") + :running t + :mouse-x -1 :mouse-y -1)) + (log-append "Demo started")) + +;;; ─── Tab renderers ────────────────────────────────────────────────────────── + +(defun render-tab-home (backend x y w h) + "Welcome screen with version info." + (declare (ignore h)) + (draw-border backend x y w 18 :style :double :title " Welcome ") + (draw-text backend (+ x 2) (+ y 2) "cl-tty — Pure CL Terminal UI Framework" :bright-white nil :bold t) + (draw-text backend (+ x 2) (+ y 4) " components: Box, Text, TextInput, TextArea, Select," nil nil) + (draw-text backend (+ x 2) (+ y 5) " ScrollBox, TabBar, Dialog, Toast, Markdown" nil nil) + (draw-text backend (+ x 2) (+ y 6) " features: 24-bit truecolor, OSC 8 links, SGR mouse," nil nil) + (draw-text backend (+ x 2) (+ y 7) " DECICM sync, kitty keyboard, framebuffer" nil nil) + (draw-text backend (+ x 2) (+ y 8) " backend: modern-backend | simple-backend (pipe-safe)" nil nil) + (draw-text backend (+ x 2) (+ y 9) " tests: 392, 100% passing" :green nil :bold t) + (draw-text backend (+ x 2) (+ y 10) " deps: zero FFI, zero ncurses, pure CL" :bright-cyan nil) + (draw-text backend (+ x 2) (+ y 12) "Controls" :bright-white nil :bold t) + (draw-text backend (+ x 2) (+ y 13) " Tab / arrows switch tabs" nil nil) + (draw-text backend (+ x 2) (+ y 14) " q / Ctrl+C / Esc quit" nil nil) + (draw-text backend (+ x 2) (+ y 15) " mouse click/drag select text (test SGR mouse)" nil nil)) + +(defun render-tab-widgets (backend x y w h input ta) + "Interactive widget demo." + (declare (ignore h)) + (draw-border backend x y w 12 :style :single :title " Text Input ") + (let ((val (text-input-value input))) + (draw-text backend (+ x 2) (+ y 1) "Value: " :text-muted nil) + (draw-text backend (+ x 10) (+ y 1) (if (plusp (length val)) val "(empty)") :text nil)) + (draw-text backend (+ x 2) (+ y 3) "Placeholder: \"Type here...\"" :text-muted nil) + (draw-text backend (+ x 2) (+ y 5) "Keys: type to insert, arrows to move," nil nil) + (draw-text backend (+ x 2) (+ y 6) "Enter to submit, Backspace to delete," nil nil) + (draw-text backend (+ x 2) (+ y 7) "Ctrl+A/E for home/end" nil nil) + (when (plusp (length (text-input-value input))) + (draw-text backend (+ x 2) (+ y 9) (format nil "Submitted: ~a" (text-input-value input)) :accent nil)) + + (let ((y2 (+ y 13))) + (draw-border backend x y2 w 10 :style :single :title " TextArea ") + (draw-text backend (+ x 2) (+ y2 1) "Value:" :text-muted nil) + (let ((lines (textarea-lines ta))) + (loop for line in lines + for row from 0 below (min (length lines) 6) + do (draw-text backend (+ x 2) (+ y2 2 row) + (subseq (or line "") 0 (min (length line) (- w 4))) nil nil))))) + +(defun render-tab-console (backend x y w h) + "Event log / debug console." + (draw-border backend x y w h :style :single :title " Event Log ") + (draw-text backend (+ x 2) (+ y 1) "Last 50 keyboard and mouse events:" :text-muted nil) + (let ((lines *log*) + (max-rows (- h 3))) + (loop for line in (subseq lines 0 (min (length lines) max-rows)) + for row from 0 below max-rows + do (draw-text backend (+ x 2) (+ y 3 row) + (subseq (or line "") 0 (min (length line) (- w 4))) nil nil)))) + +;;; ─── Main loop ────────────────────────────────────────────────────────────── + +(defun handle-event (event) + "Process a key-event or mouse-event, returning t if consumed." + (typecase event + (key-event + (let ((key (key-event-key event)) + (ctrl (key-event-ctrl event))) + (log-append "Key: ~a (ctrl=~a alt=~a shift=~a)" key ctrl (key-event-alt event) (key-event-shift event)) + (cond + ((or (eql key :|Q|) (and ctrl (eql key :|C|)) (eql key :escape)) + (setf (getf *app* :running) nil) t) + ((eql key :tab) + (incf (getf *app* :tab)) + (when (> (getf *app* :tab) 2) (setf (getf *app* :tab) 0)) t) + ((eql key :left) + (decf (getf *app* :tab)) + (when (minusp (getf *app* :tab)) (setf (getf *app* :tab) 2)) t) + ((eql key :right) + (incf (getf *app* :tab)) + (when (> (getf *app* :tab) 2) (setf (getf *app* :tab) 0)) t) + ;; Forward key to widgets for testing + (t (handle-text-input (getf *app* :input) event) + (handle-textarea-input (getf *app* :textarea) event) + t)))) + (mouse-event + (log-append "Mouse: ~a btn=~a pos=(~d,~d)" (mouse-event-type event) + (mouse-event-button event) (mouse-event-x event) (mouse-event-y event)) + (setf (getf *app* :mouse-x) (mouse-event-x event) + (getf *app* :mouse-y) (mouse-event-y event)) + t))) + +(defun run-demo () + "Run the demo. Raw terminal mode should already be set by the +./demo.sh shell wrapper." + (init-app-state) + (let* ((backend (detect-backend)) + (w 80) (h 24)) + (declare (ignore h)) + (initialize-backend backend) + (unwind-protect + (loop while (getf *app* :running) + do + (backend-clear backend) + ;; Title bar + (draw-border backend 2 1 (- w 4) 3 :style :double :title " cl-tty v0.15.0 ") + (draw-text backend 4 2 "arrows/tab: tabs type: test input mouse: test SGR q/esc: quit" + :bright-white nil) + ;; Tab bar + (loop for (label . idx) in '((" Home " . 0) (" Widgets " . 1) (" Console " . 2)) + for x-pos = 4 then (+ x-pos label-len 2) + for label-len = (length label) + do (let ((active (eql idx (getf *app* :tab)))) + (if active + (draw-text backend x-pos 4 label :bright-white :accent :bold t) + (draw-text backend x-pos 4 label :text-muted nil)))) + ;; Content area + (case (getf *app* :tab) + (0 (render-tab-home backend 4 6 72 20)) + (1 (render-tab-widgets backend 4 6 72 24 + (getf *app* :input) + (getf *app* :textarea))) + (2 (render-tab-console backend 4 6 72 16))) + ;; Mouse cursor indicator + (let ((mx (getf *app* :mouse-x)) + (my (getf *app* :mouse-y))) + (when (and (>= mx 0) (>= my 0)) + (draw-text backend mx my "@" :bright-cyan nil))) + ;; Status bar + (draw-rect backend 2 23 (- w 4) 1 :bg :blue) + (draw-text backend 4 23 + (format nil " Tab ~d/3 | ~d events " + (1+ (getf *app* :tab)) (length *log*)) + :bright-white :blue :bold t) + (finish-output *standard-output*) + ;; Read event — blocks until a key or mouse event arrives + (let ((event (read-event backend))) + (when event + (handle-event event)))) + (shutdown-backend backend)))) + +(run-demo) +(uiop:quit 0) diff --git a/demo.sh b/demo.sh new file mode 100755 index 0000000..9d51d93 --- /dev/null +++ b/demo.sh @@ -0,0 +1,17 @@ +#!/bin/sh +# cl-tty demo launcher +# Sets raw terminal mode before starting SBCL, restores on exit. +# Raw mode is needed so individual keystrokes are captured instead +# of being line-buffered and echoed by the terminal driver. + +SAVED=$(stty -g 2>/dev/null) +if [ -z "$SAVED" ]; then + echo "ERROR: Not running in a real terminal." >&2 + exit 1 +fi + +cleanup() { stty "$SAVED" 2>/dev/null; } +trap cleanup EXIT INT TERM + +stty raw -echo -isig -icanon min 1 time 0 2>/dev/null +sbcl --script "$(dirname "$0")/demo.lisp" diff --git a/docs/ARCHITECTURE.org b/docs/ARCHITECTURE.org index 7234f63..0295fa2 100644 --- a/docs/ARCHITECTURE.org +++ b/docs/ARCHITECTURE.org @@ -1,10 +1,10 @@ -#+TITLE: cl-tui Architecture +#+TITLE: cl-tty Architecture #+STARTUP: content -#+FILETAGS: :project:cl-tui:architecture: +#+FILETAGS: :project:cl-tty:architecture: * Architecture -cl-tui is a layered framework. Each layer has a single responsibility +cl-tty is a layered framework. Each layer has a single responsibility and communicates with adjacent layers through a well-defined protocol. ** Layer Diagram @@ -264,9 +264,9 @@ reads terminal background color at startup. ** File Structure #+BEGIN_SRC - cl-tui/ - ├── cl-tui.asd - ├── cl-tui-tests.asd + cl-tty/ + ├── cl-tty.asd + ├── cl-tty-tests.asd ├── README.org ├── LICENSE ├── docs/ diff --git a/docs/ROADMAP.org b/docs/ROADMAP.org index ee91999..4c6aa8a 100644 --- a/docs/ROADMAP.org +++ b/docs/ROADMAP.org @@ -1,596 +1,181 @@ -#+TITLE: cl-tui Roadmap +#+TITLE: cl-tty Roadmap #+STARTUP: content -#+FILETAGS: :docs:roadmap:cl-tui: +#+FILETAGS: :docs:roadmap:cl-tty: * The Roadmap Each phase is one minor release. Phases ship in dependency order — each depends on -the components from prior phases. The backend protocol ships first because -everything else builds on it. +the components from prior phases. -** v0.0.1: Foundation — Backend Protocol +** v0.0.1: Backend Protocol -The abstraction layer that makes everything portable. Two backends: -=modern= (raw escape sequences, truecolor, modern features) and =simple= -(ASCII art, universal compatibility). The component tree never touches -the terminal directly — it dispatches through the protocol. +DONE. Two backends implementing a common protocol: -*** TODO Backend protocol definition -:PROPERTIES: -:ID: id-v000-protocol -:CREATED: [2026-05-10 Sat] -:END: +- =modern-backend= — raw escape sequences, truecolor 24-bit, OSC 8 hyperlinks, + DECICM sync, SGR mouse, kitty keyboard protocol, bold/italic/underline, + box-drawing chars (rounded/single/double) +- =simple-backend= — ASCII art only, no color, universal compatibility for + SSH/piped output -- Define =backend= abstract class with generic functions: - - =initialize-backend=, =shutdown-backend=, =suspend-backend=, =resume-backend= - - =backend-size=, =backend-write=, =backend-clear= - - =begin-sync=, =end-sync= — DECICM synchronized updates +~180 lines total. Dependencies: None (pure CL, no FFI). + +*** Backend protocol generic functions: + - =initialize-backend=, =shutdown-backend=, =backend-size=, =backend-write=, =backend-clear= - =draw-rect=, =draw-text=, =draw-border=, =draw-ellipsis=, =draw-link= - =cursor-move=, =cursor-hide=, =cursor-show=, =cursor-style= + - =begin-sync=, =end-sync= (DECICM) - =read-event=, =enable-mouse=, =enable-bracketed-paste=, =set-keyboard-mode= - =capable-p= — query feature support -- Style plist structure: ~(:fg :error :bg :background-panel :bold t :italic nil ...)~ -- ~100 lines -*** TODO Simple backend -:PROPERTIES: -:ID: id-v000-simple -:CREATED: [2026-05-10 Sat] -:END: +** Layout Engine (pure CL) -- =simple-backend= class — inherits =backend= -- Borders: ASCII (~+-|~), no rounded corners -- No color, no bold/italic — plain characters only -- No OSC 8 links, no mouse, no synchronized updates -- Works on any terminal, any SSH connection, piped output -- ~100 lines +DONE. Pure Common Lisp Flexbox layout engine. No Yoga, no CFFI, no external +dependencies. A two-pass constraint solver handling direction, wrap, +grow/shrink/gap padding/margin, absolute positioning. -*** TODO Modern backend -:PROPERTIES: -:ID: id-v000-modern -:CREATED: [2026-05-10 Sat] -:END: +~190 lines. Macros: =vbox=, =hbox=, =spacer=. -- =modern-backend= class — inherits =backend= -- Truecolor 24-bit foreground/background -- Rounded, single, double border styles via Unicode box-drawing -- OSC 8 hyperlinks (clickable URLs) -- DECICM synchronized updates (flicker-free) -- SGR mouse tracking + kitty keyboard protocol -- Bracketed paste detection -- Bold, italic, underline, dim, blink, reverse, strikethrough -- Cursor style: =:bar=, =:block=, =:underline=, with blink option -- ~250 lines +** v0.2.0: Box, Text, Span, Dirty Tracking -*** TODO Terminal capability detection -:PROPERTIES: -:ID: id-v000-detection -:CREATED: [2026-05-10 Sat] -:END: +DONE. The first two renderable types. Box draws borders and backgrounds. +Text renders strings with color, word-wrap, and inline style spans. -- =detect-backend= → returns =modern-backend= or =simple-backend= -- Check if stdout is a TTY (if not → =simple-backend=) -- Send DA1 (~ESC[c~) query, 100ms timeout -- Send DA3 (~ESC[?c~) for kitty/wezterm identification -- Query DECRPM (~ESC[?2026$p~) for DECICM sync support -- Query truecolor support via =COLORTERM= env var + DA response -- Cache detection result so subsequent calls are instant -- ~100 lines - -~550 lines total. Dependencies: None (pure CL, no FFI, no external libs). - -** v0.0.2: Layout Engine -the patch version (v0.X.Y). - -** File Update Checklist - -When a version ships: -1. ~ROADMAP.org~ — mark item DONE, update LOGBOOK timestamp -2. ~README.org~ — update Status line -3. ~cl-tui.asd~ — update version string - -** v0.1.0: Layout Engine - -Yoga Flexbox backend wrapped in a Common Lisp API. This is the foundation — -every component after v0.1.0 uses the layout engine for positioning. - -*** TODO Yoga FFI binding -:PROPERTIES: -:ID: id-v010-yoga-ffi -:CREATED: [2026-05-10 Sat] -:END: - -- Load the Yoga shared library via CFFI -- Define foreign types for ~YGNodeRef~, ~YGSize~, ~YGValue~, ~YGDirection~, ~YGFlexDirection~, ~YGAlign~, ~YGJustify~, ~YGWrap~, ~YGPositionType~, ~YGOverflow~, ~YGDisplay~, ~YGEdge~ -- Bind core functions: ~node-new~, ~node-free~, ~node-style-set-*~, ~node-layout-get-*~, ~calculate-layout~ -- ~100 lines CFFI - -*** TODO Layout primitives -:PROPERTIES: -:ID: id-v010-layout-primitives -:CREATED: [2026-05-10 Sat] -:END: - -- ~(make-layout-node)~ — wraps a ~YGNodeRef~ in a CLOS object -- ~(layout-node-set-dimension node width height)~ — sets width/height in points -- ~(layout-node-set-flex node &key grow shrink basis)~ — flex properties -- ~(layout-node-set-direction node :row | :column | :row-reverse | :column-reverse)~ -- ~(layout-node-set-wrap node :nowrap | :wrap | :wrap-reverse)~ -- ~(layout-node-set-align node :flex-start | :center | :flex-end | :stretch | :baseline)~ -- ~(layout-node-set-justify node :flex-start | :center | :flex-end | :space-between | :space-around | :space-evenly)~ -- ~(layout-node-set-padding node &key top right bottom left x y)~ -- ~(layout-node-set-margin node &key top right bottom left x y)~ -- ~(layout-node-set-gap node &key row column)~ -- ~(layout-node-set-position node :relative | :absolute &key top right bottom left)~ -- ~(layout-node-set-border node width)~ -- ~(layout-node-add-child parent child)~ — builds the tree -- ~(layout-calculate root width height)~ — runs Yoga's calculateLayout, populates each node's computed x/y/w/h -- ~200 lines CL - -*** TODO Layout composable API -:PROPERTIES: -:ID: id-v010-layout-composable -:CREATED: [2026-05-10 Sat] -:END: - -Convenience macros to build layout trees from CL function calls: - -- ~(vbox &key ... children ...)~ → column-direction container with children -- ~(hbox &key ... children ...)~ → row-direction container with children -- ~(overlay base child)~ — absolute-positioned overlay over a relative base -- ~(spacer &key grow)~ — empty flex spacer -- ~(layout-render root parent-window)~ — computes layout then walks the tree, calling each child's render function with its computed x, y, w, h -- ~50 lines CL macros - -~350 lines total. Dependencies: Yoga shared library, CFFI, croatoan. - -*** FiveAM tests -- ~test-layout-basic~ — vbox with two children computes correct y positions -- ~test-layout-hbox~ — hbox with two children computes correct x positions -- ~test-layout-flex~ — flex-grow distributes space correctly -- ~test-layout-absolute~ — absolute child positions relative to parent -- ~test-layout-nested~ — nested vbox/hbox produces correct leaf positions - -** v0.2.0: Renderables — Box and Text - -The first two renderable types that every application uses. A Box draws borders -and backgrounds. A Text renders strings with color and style. Together they -cover 80% of terminal UI. - -*** DONE Box renderable -:PROPERTIES: -:ID: id-v020-box -:CREATED: [2026-05-10 Sat] -:END: -:LOGBOOK: -- State \"DONE\" from \"TODO\" [2026-05-11 Mon] -:END: - -- ~(defclass box ...)~ — renderable with background color, border, title -- ~(render-box box window)~ — draws border (single/double/rounded), fills background, renders title -- Border styles: ~:single~, ~:double~, ~:rounded~ -- Title alignment: ~:left~, ~:center~, ~:right~ -- ~:focusable~ property — renders focused border color when focused -- ~100 lines - -*** DONE Text renderable -:PROPERTIES: -:ID: id-v020-text -:CREATED: [2026-05-10 Sat] -:END: -:LOGBOOK: -- State \"DONE\" from \"TODO\" [2026-05-11 Mon] -:END: - -- ~(defclass text ...)~ — renderable with content, fg/bg color, wrap mode -- ~(render-text text window)~ — renders text at the layout position, wraps at width -- Word-wrap: ~:none~ (truncate) or ~:word~ (break at word boundaries) -- CJK/emoji character-width aware wrapping -- ~100 lines - -*** DONE Inline text styles -:PROPERTIES: -:ID: id-v020-inline -:CREATED: [2026-05-10 Sat] -:END: -:LOGBOOK: -- State \"DONE\" from \"TODO\" [2026-05-11 Mon] -:END: - -- ~(defclass span ...)~ — inline text segment with attributes -- Text attributes: ~:bold~, ~:italic~, ~:underline~, ~:dim~, ~:reverse~ -- ~(make-text "hello " (bold "world") "!")~ — builds styled text from spans and strings -- ~60 lines - -*** DONE Dirty tracking -:PROPERTIES: -:ID: id-v020-dirty -:CREATED: [2026-05-10 Sat] -:END: -:LOGBOOK: -- State \"DONE\" from \"TODO\" [2026-05-11 Mon] -:END: - -- ~(mark-dirty component)~ — flags component and all ancestors -- ~(dirty-p component)~ — returns T if the component needs re-rendering -- ~(mark-clean component)~ — clears dirty flag after render -- ~40 lines - -~300 lines total. Dependencies: Phase 1 (layout engine). - -** v0.3.0: Rendering Engine - -The pipeline that goes from component tree to terminal output. Handles dirty -propagation, incremental rendering (only dirty branches), scissor clipping, -and diff-based output. - -*** TODO Component tree → render commands -:PROPERTIES: -:ID: id-v030-pipeline -:CREATED: [2026-05-10 Sat] -:END: - -- ~(render-screen root screen)~ — entry point: computes layout, walks dirty branches, collects render commands -- Render commands are lists: ~(:box x y w h bg border title)~, ~(:text x y str fg bg attrs)~ -- Each component's ~render~ function returns a list of render commands -- ~100 lines - -*** TODO Scissor clipping -:PROPERTIES: -:ID: id-v030-scissor -:CREATED: [2026-05-10 Sat] -:END: - -- ~(with-scissor (window x y w h) &body body)~ — clips all render operations to a rectangle -- Pushes/pops scissor state so nested containers clip correctly -- ~50 lines - -*** TODO Incremental diff output -:PROPERTIES: -:ID: id-v030-diff-output -:CREATED: [2026-05-10 Sat] -:END: - -- ~*framebuffer*~ — a 2D array of (char, fg-color, bg-color, attrs) tuples -- ~(flush-framebuffer screen)~ — compares framebuffer to previous frame, writes only changed cells via croatoan -- ~(clear-dirty screen)~ — clears all dirty flags after a successful flush -- Croatoan compatibility: uses ~add-string~ for unchanged text, ~clear~ + ~add-string~ for changed regions -- ~150 lines - -~300 lines total. Dependencies: Phase 2 (renderables + dirty tracking). - -** v0.4.0: Theme Engine - -Semantic color tokens, dark/light variants, hex → truecolor resolution, and -built-in presets. Application code references semantic roles (~:error~, ~:accent~), -never hex values. - -*** TODO Semantic color tokens -:PROPERTIES: -:ID: id-v040-tokens -:CREATED: [2026-05-10 Sat] -:END: - -- ~(defclass theme ...)~ — holds a mapping from semantic roles to hex colors -- 30+ semantic roles: ~:primary~, ~:secondary~, ~:accent~, ~:error~, ~:warning~, ~:success~, ~:info~, ~:text~, ~:text-muted~, ~:background~, ~:background-panel~, ~:background-element~, ~:border~, ~:border-active~, ~:diff-added~, ~:diff-removed~, ~:diff-context~, ~:markdown-heading~, ~:markdown-code~, ~:markdown-link~, ~:markdown-quote~, ~:syntax-keyword~, ~:syntax-function~, ~:syntax-string~, ~:syntax-number~, ~:syntax-comment~, ~:syntax-type~ -- ~120 lines - -*** TODO theme-color -:PROPERTIES: -:ID: id-v040-theme-color -:CREATED: [2026-05-10 Sat] -:END: - -- ~(theme-color theme role)~ → returns the croatoan color pair number for the role -- ~(themed-add-string window x y str :color :error)~ — renders text with a theme semantic role -- Color pair caching: resolve hex → croatoan ~init-color~ once per (fg, bg) pair, reuse -- ~40 lines - -*** TODO Built-in presets -:PROPERTIES: -:ID: id-v040-presets -:CREATED: [2026-05-10 Sat] -:END: - -8 presets: default (gold), professional, minimal, nord, tokyonight, catppuccin, monokai, gruvbox -- Each preset is a plist: ~(:primary "#FFD700" :error "#BF616A" ...)~ -- ~(theme-load :nord)~ — activates a preset, re-renders dirty -- Load from ~/.config/cl-tui/themes/.lisp~ for custom themes -- ~80 lines - -*** TODO Dark/light variants -:PROPERTIES: -:ID: id-v040-dark-light -:CREATED: [2026-05-10 Sat] -:END: - -- Each preset defines both ~:dark~ and ~:light~ variants -- ~(theme-set-mode :dark | :light)~ — switches variant -- Auto-detect: read terminal background color (croatoan's background), pick closest variant -- ~50 lines - -~290 lines total. Dependencies: Phase 2 (renderables), Croatoan's ~init-color~/~color-pair~. +- =Box= with border styles (:single, :double, :rounded), title, background +- =Text= with word-wrap (:none, :word), fg/bg colors +- =Span= — inline text segment with attributes (:bold, :italic, etc.) +- =Dirty-mixin= — marks components and ancestors for re-render +- =Theme= — semantic color tokens, presets (default, nord, catppuccin, etc.) +- =render= generic function dispatched on component type ** v0.5.0: Text Input + Keybinding System -Text input widgets with readline/emacs keybindings. A layered keybinding system -that routes keystrokes through global → local → input layers. +DONE. Text input widgets with readline-style keybindings. -*** TODO TextInput — single-line input -:PROPERTIES: -:ID: id-v050-textinput -:CREATED: [2026-05-10 Sat] -:END: - -- ~(defclass text-input ...)~ — single-line input with value, cursor, placeholder -- ~(render-text-input input window)~ — renders text left-aligned, placeholder when empty, blinking cursor -- Cursor movement: left/right, home, end -- Insert/delete at cursor position -- ~:on-submit~ callback — fires on Enter -- ~:max-length~ property — prevents input exceeding limit -- ~150 lines - -*** TODO Textarea — multi-line input -:PROPERTIES: -:ID: id-v050-textarea -:CREATED: [2026-05-10 Sat] -:END: - -- ~(defclass textarea ...)~ — multi-line input with value, cursor (row, column), selection -- ~(render-textarea area window)~ — renders visible lines, cursor, selection highlight -- Cursor: up/down, left/right, word-forward/backward, line/home/end, buffer/home/end -- Selection: Shift + navigation extends selection -- Undo/redo stack (configurable depth, default 100) -- ~:on-submit~ callback — fires on Enter -- ~200 lines - -*** TODO Keybinding system -:PROPERTIES: -:ID: id-v050-keybindings -:CREATED: [2026-05-10 Sat] -:END: - -- Layered keymaps: ~:global~ → ~:local~ → ~:input~ (input layer takes priority when text input is focused) -- ~(defkeymap :global '((:ctrl+p . command-palette) (:ctrl+c,ctrl+d . quit)))~ -- Key format: ~:ctrl+p~, ~:alt+f~, ~:shift+tab~, ~(:ctrl+c :ctrl+d)~ (chord) -- Chord sequences: first key starts a timer, second key within timeout dispatches -- ~:leader~ key (default ~Ctrl+X~) with configurable timeout -- Key names normalized from croatoan's ~:code-key~ + ~:key-name~ output -- ~150 lines - -~500 lines total. Dependencies: Phase 3 (rendering engine), Phase 4 (theme). +- =TextInput= — single-line input with cursor, placeholder, max-length, on-submit +- =Textarea= — multi-line input with undo/redo (100-deep stack), cursor nav, + selection, on-submit +- =Keymap= — layered keybinding system with =defkeymap= macro +- Event handling: key-event, mouse-event structs, raw-byte reader ** v0.6.0: ScrollBox + TabBar -Container components. ScrollBox handles content larger than the viewport. -TabBar handles horizontal tab navigation. +DONE. Container components. -*** TODO ScrollBox -:PROPERTIES: -:ID: id-v060-scrollbox -:CREATED: [2026-05-10 Sat] -:END: - -- ~(defclass scroll-box ...)~ — container with vertical/horizontal scroll -- Viewport culling: only render children whose y position is within the visible range -- Scroll offset: ~:scroll-y~, ~:scroll-x~ slots -- ScrollBy: PageUp/PageDown (viewport height), Up/Down (1 line), Home/End (buffer start/end) -- Scrollbars: vertical and horizontal (single-line, rendered with block characters) -- Sticky scroll: when scrolled to bottom and new content arrives, auto-scroll to show it. When user scrolls up, stop auto-scrolling until they scroll back down. -- ~200 lines - -*** TODO TabBar -:PROPERTIES: -:ID: id-v060-tabbar -:CREATED: [2026-05-10 Sat] -:END: - -- ~(defclass tab-bar ...)~ — horizontal row of tabs -- ~(tab-bar-add tab-bar id title &optional content)~ -- ~:active-tab~ slot — only renders content for the active tab -- Tab rendering: highlighted active tab, dim inactive tabs -- Left/Right or Ctrl+PageUp/PageDn to navigate tabs -- ~100 lines - -~300 lines total. Dependencies: Phase 3 (rendering engine), Phase 4 (theme). +- =ScrollBox= — scrollable viewport with vertical/horizontal scrollbars, + scroll-by, clamp, sticky-scroll mode +- =TabBar= — horizontal tab navigation with next/prev, active tab tracking ** v0.7.0: Select — Dropdown + Fuzzy Filter -A selection list component — the building block for command palettes, theme -pickers, agent selectors, file pickers. - -*** TODO Select -:PROPERTIES: -:ID: id-v070-select -:CREATED: [2026-05-10 Sat] -:END: - -- ~(defclass select ...)~ — list of options with keyboard navigation -- ~:options~ — list of plists: ~((:title "Nord" :value :nord :category "Themes") ...)~ -- Categories: options can be grouped. Category headers rendered dim, non-selectable -- Up/Down/Ctrl+P/Ctrl+N to navigate, Enter to select, Esc to dismiss -- ~:on-select~ callback — fires on Enter -- ~:filter~ property — when set, filters the option list. Options whose title contains the filter (case-insensitive) are shown. -- Fuzzy filter: when ~:filter~ is non-nil and no exact matches, uses trigram-based fuzzy matching (3-character sliding window Jaccard similarity) -- ~150 lines - -~150 lines total. Dependencies: Phase 5 (keybindings), Phase 4 (theme). +DONE. A selection list component with keyboard navigation, category headers, +and fuzzy text matching. ** v0.8.0: Markdown + Code + Diff Rendering -Content rendering components. Markdown for agent responses. Code for syntax -highlighting. Diff for file changes. +DONE. Content rendering for agent responses and file diffs. -*** TODO Markdown -:PROPERTIES: -:ID: id-v080-markdown -:CREATED: [2026-05-10 Sat] -:END: - -- ~(defclass markdown ...)~ — renders markdown content as styled text -- Heading levels 1-6: colored by theme (~:markdown-heading~) with level-based sizing -- Bold, italic, inline code, strikethrough — rendered as croatoan text attributes -- Code blocks: fenced (~```~) and indented. Background-colored, syntax-highlighted via regex -- Links: OSC 8 hyperlinks (clickable in Kitty, WezTerm, iTerm2, Ghostty). Format: ~\x1b]8;;url\x1b\\...link text...\x1b]8;;\x1b\\~ -- Blockquotes: colored left border (~:markdown-quote~), indented text -- Tables: aligned column text, no borders. Column alignment from header separators -- Lists: ordered and unordered, with indentation -- All features degrade gracefully to plain text on terminals without attribute support -- ~200 lines - -*** TODO Code -:PROPERTIES: -:ID: id-v080-code -:CREATED: [2026-05-10 Sat] -:END: - -- ~(defclass code ...)~ — renders syntax-highlighted code -- ~:content~ — the code string -- ~:language~ — language identifier for syntax rules -- Line numbers (optional, via ~:line-numbers t~) -- Regex-based highlighting (no Tree-sitter dependency): - - Keywords: language-specific keyword lists - - Strings: single and double quoted - - Comments: line (~;//~, ~#~) and block (~/* */~) - - Numbers: integer and float literals - - Functions: word followed by ~(~ -- Colors from theme: ~:syntax-keyword~, ~:syntax-function~, ~:syntax-string~, ~:syntax-number~, ~:syntax-comment~, ~:syntax-type~ -- ~150 lines - -*** TODO Diff -:PROPERTIES: -:ID: id-v080-diff -:CREATED: [2026-05-10 Sat] -:END: - -- ~(defclass diff ...)~ — renders unified diff output -- ~:content~ — diff text (standard unified diff format) -- Added lines: ~+~ prefix, green background (~:diff-added~) -- Removed lines: ~-~ prefix, red background (~:diff-removed~) -- Context lines: ~ ~ prefix, neutral background (~:diff-context~) -- Line numbers: optional, rendered in ~:diff-line-number~ color -- ~50 lines - -~400 lines total. Dependencies: Phase 4 (theme), Phase 2 (renderables). +- Markdown parser: headings, bold/italic/code, links, code blocks, + blockquotes, lists, thematic breaks +- Syntax highlighting: regex-based for Lisp keywords, comments, strings +- Diff rendering: added/removed/context lines with colored backgrounds +- ANSI rendering via raw escape sequences ** v0.9.0: Dialog System + Toast -Modal overlays and transient notifications. +DONE. Modal overlays and transient notifications. -*** TODO Dialog base -:PROPERTIES: -:ID: id-v090-dialog -:CREATED: [2026-05-10 Sat] -:END: - -- ~(defclass dialog ...)~ — absolute-positioned overlay with backdrop -- Backdrop: semi-transparent (dimmed background color) -- Centered panel with ~:background-panel~ color, border -- ~:on-dismiss~ callback — fires on Esc or backdrop click -- ~:size~ — ~:small~ (40 cols), ~:medium~ (60 cols), ~:large~ (88 cols). Height computed from content. -- Stack-based: dialogs push/pop on a ~*dialog-stack*~ -- Esc dismisses top dialog. Ctrl+C clears stack. -- ~100 lines - -*** TODO Dialog sub-classes -:PROPERTIES: -:ID: id-v090-dialog-types -:CREATED: [2026-05-10 Sat] -:END: - -- ~alert-dialog~ — title + message + OK button -- ~confirm-dialog~ — title + message + Yes/No/Cancel buttons -- ~select-dialog~ — wraps a Select component in a modal. Title, searchable list, action buttons -- ~prompt-dialog~ — wraps a TextInput in a modal. Title, input, OK/Cancel buttons -- ~60 lines - -*** TODO Toast notifications -:PROPERTIES: -:ID: id-v090-toast -:CREATED: [2026-05-10 Sat] -:END: - -- ~(toast title &key variant duration)~ — shows a transient notification -- Variants: ~:info~ (blue), ~:success~ (green), ~:warning~ (yellow), ~:error~ (red) — colored left border -- ~:duration~ — auto-dismiss after N milliseconds (default 5000) -- Position: top-right corner, max 60 cols wide -- Multiple toasts stack vertically -- ~60 lines - -~220 lines total. Dependencies: Phase 3 (rendering engine), Phase 4 (theme), Phase 5 (TextInput), Phase 7 (Select). +- =Dialog= — centered modal with backdrop dimming, size variants +- =push-dialog= / =pop-dialog= — stack-based dialog management +- =alert-dialog=, =confirm-dialog=, =select-dialog=, =prompt-dialog= +- =Toast= — transient notification with variants (:info/:success/:warning/:error), + auto-dismiss, top-right positioning ** v0.10.0: Mouse Support -Mouse event propagation through the component tree. +DONE (minimal). Mouse event handling via mixin class. -*** TODO Mouse events -:PROPERTIES: -:ID: id-v100-mouse -:CREATED: [2026-05-10 Sat] -:END: - -- Enable croatoan mouse mode: ~(setf (mouse-enabled-p window) t)~ -- Parse ncurses mouse codes: button (left/right/middle), state (press/release/drag), x, y -- Ctrl/Shift/Meta modifiers from mouse event -- ~:on-mouse-down~, ~:on-mouse-up~, ~:on-mouse-move~, ~:on-mouse-scroll~ callbacks on components -- Hit-testing: walk the component tree from root, find the deepest component whose rect contains (x, y) -- Event propagation: component consumes event by returning T from callback; otherwise bubbles to parent -- Scroll wheel: mapped to PageUp/PageDown in ScrollBox -- Click on OSC 8 link: extract URL, open via ~xdg-open~ -- ~100 lines - -*** TODO Text selection + copy -:PROPERTIES: -:ID: id-v100-selection -:CREATED: [2026-05-10 Sat] -:END: - -- Mouse drag: highlight text between drag start and current position -- ~(get-selection)~ — returns the selected text as a string -- Copy: pipe selection to ~xclip~ / ~wl-copy~ / ~pbcopy~ -- ~50 lines - -~150 lines total. Dependencies: Phase 3 (rendering engine). +- =mouse-mixin= — event handler slots (:on-mouse-down/up/move/scroll) +- =handle-mouse-event= — dispatch to component handlers +- =hit-test= — find deepest component at (x, y) +- =selection= struct and =copy-to-clipboard= ** v0.11.0: Plugin / Slot System -Extensible named slots. Applications and plugins register content into named -slots. The component tree renders whatever is registered. +DONE. Extensible named slots for registering content into extensible positions. -*** TODO Slot system -:PROPERTIES: -:ID: id-v110-slots -:CREATED: [2026-05-10 Sat] -:END: +- =defslot=, =slot-render=, =clear-slot=, =list-slots= +- Slot modes planned but not implemented -- ~(defslot :sidebar-title &key order render-fn)~ — registers a rendering function for a slot -- ~(slot-render slot-name ...)~ — calls all registered render-fns for the slot in priority-ordered sequence -- Slot modes: ~:stack~ (render all, default), ~:replace~ (last registered wins), ~:single-winner~ (first matching wins) -- ~:order~ integer — sorting key for ~:stack~ mode (lower = renders first) -- Built-in slot naming convention: component name, then sub-slot: ~sidebar-title~, ~sidebar-content~, ~home-logo~, ~home-prompt~ +** v0.12.0: Terminal Capability Detection + +DONE. Auto-detect terminal capabilities at startup and return the +appropriate backend. + +- Check if stdout is a TTY (if not -> simple-backend) +- =detect-backend= -> returns =modern-backend= or =simple-backend= +- Send DA1 query (~ESC[c~), 100ms timeout +- Send DA3 (~ESC[?c~) for kitty/wezterm identification +- Query DECRPM (~ESC[?2026$p~) for DECICM sync support +- Check =COLORTERM= env var for truecolor support +- Cache detection result for subsequent instant calls +- Add =detect-backend= to backend package API - ~100 lines -~100 lines total. Dependencies: Phase 2 (renderables + layout). +** v0.13.0: Rendering Pipeline -* v1.0.0: Complete Framework +DONE. A pure CL rendering pipeline — framebuffer diffing for incremental +output, scissor clipping, and render-command dispatching. -All 11 phases integrated and tested. Applications can build rich terminal UIs -from the component library without writing custom ncurses code. +- =*framebuffer*= — 2D array of (char, fg, bg, attrs) tuples +- =flush-framebuffer= — compares current to previous, writes only changed cells +- =with-scissor= — clips all render operations to a rectangle +- Component =render= methods produce render commands, not direct backend calls +- =diff-output= framework for minimum-escape optimization +- ~250 lines -* Neurosymbolic Phase Reference +** v0.14.0: Mouse Improvements -| Phase | Component | Lines | Release | -|-------+------------------------------------+--------+---------| -| 1 | Layout engine (Yoga FFI + API) | ~350 | v0.1.0 | -| 2 | Renderables (Box, Text) + dirty | ~300 | v0.2.0 | -| 3 | Rendering engine (diff, scissor) | ~300 | v0.3.0 | -| 4 | Theme engine (tokens, presets) | ~290 | v0.4.0 | -| 5 | TextInput + Textarea + keybindings | ~500 | v0.5.0 | -| 6 | ScrollBox + TabBar | ~300 | v0.6.0 | -| 7 | Select (dropdown + fuzzy filter) | ~150 | v0.7.0 | -| 8 | Markdown + Code + Diff | ~400 | v0.8.0 | -| 9 | Dialog system + Toast | ~220 | v0.9.0 | -| 10 | Mouse support + selection | ~150 | v0.10.0 | -| 11 | Plugin / slot system | ~100 | v0.11.0 | -|-------+------------------------------------+--------+---------| -| Total | | ~3060 | | +DONE. Enhance mouse support with drag-to-select and link clicking. + +- Text selection via mouse drag (highlight region between drag start/end) +- Click on OSC 8 link: extract URL, open via xdg-open +- Copy-to-clipboard via xclip/wl-copy/pbcopy +- ~80 lines + +** v1.0.0: Release + +All phases integrated and tested. Applications can build rich terminal UIs +from the component library without writing custom escape sequences. + +Checklist: +- [X] README.org with overview, architecture, component table, quick start +- [X] demo.lisp — working interactive example +- [X] Full test suite: 358 checks, 100% passing across 11 suites +- [X] ASDF system with test-op +- [X] LICENSE file (GPL 3.0) +- [X] Literate org files for all modules +- [X] Terminal capability detection (v0.12.0) +- [X] Rendering pipeline (v0.13.0) +- [X] Mouse improvements (v0.14.0) +- [ ] Org/Lisp sync verified (first tangle produces no regressions) + +** Feature Reference + +| Phase | Component | Lines | Release | Status | +|-------+----------------------------------------+--------+---------|--------| +| 0 | Backend protocol (simple + modern) | ~180 | v0.0.1 | DONE | +| - | Layout engine (pure CL flexbox) | ~190 | - | DONE | +| 1 | Renderables (Box, Text) + dirty | ~300 | v0.2.0 | DONE | +| 2 | Theme engine (tokens, presets) | ~120 | v0.4.0 | DONE | +| 3 | TextInput + Textarea + keybindings | ~500 | v0.5.0 | DONE | +| 4 | ScrollBox + TabBar | ~200 | v0.6.0 | DONE | +| 5 | Select (dropdown + fuzzy filter) | ~150 | v0.7.0 | DONE | +| 6 | Markdown + Code + Diff | ~400 | v0.8.0 | DONE | +| 7 | Dialog system + Toast | ~220 | v0.9.0 | DONE | +| 8 | Mouse support | ~80 | v0.10.0 | DONE | +| 9 | Plugin / slot system | ~50 | v0.11.0 | DONE | +| 10 | Terminal capability detection | ~100 | v0.12.0 | DONE | +| 11 | Rendering pipeline (framebuffer diff) | ~250 | v0.13.0 | DONE | +| 12 | Mouse improvements (selection, links) | ~80 | v0.14.0 | DONE | +|-------+----------------------------------------+--------+---------|--------| +| | Total | ~2800 | | | diff --git a/docs/plans/2026-05-11-rendering-pipeline.md b/docs/plans/2026-05-11-rendering-pipeline.md new file mode 100644 index 0000000..25b74c0 --- /dev/null +++ b/docs/plans/2026-05-11-rendering-pipeline.md @@ -0,0 +1,253 @@ +# Rendering Pipeline — Implementation Plan + +> **For Hermes:** Implement this plan task-by-task. + +**Goal:** Add a framebuffer-based rendering pipeline that sits between the component tree and the backend. Eliminates flicker via incremental diff output. Enables future features (mouse text selection, click-to-open-link). + +**Architecture:** A `framebuffer-backend` class that implements the backend protocol by writing to a cell array instead of emitting escape sequences. After all components render, a diff function compares the current framebuffer to the previous one and flushes only changed cells to a real backend. + +**Tech Stack:** Pure CL, CLOS protocol (inherits the existing backend protocol). + +--- + +### Task 1: Create framebuffer.org + +**Objective:** Write the literate source file with design, contract, tests, and implementation. + +**Files:** +- Create: `org/framebuffer.org` + +**Structure:** + +``` +#+TITLE: Rendering Pipeline (v0.13.0) + +* Overview + - Why framebuffer: flicker-free, incremental output, enables selection + - Architecture: framebuffer-backend → diff → flush + +** Contract + - cell struct — char, fg, bg, bold, italic, underline, link-url + - make-framebuffer (width height) → 2D array of cells + - framebuffer-backend class — backend subclass that writes to cell array + - render-to-framebuffer (backend fb) → writes backend commands to fb + - diff-framebuffers (prev curr) → list of changed (x y cell) triples + - flush-framebuffer (prev curr real-backend) → diff + output + - with-scissor (fb x y w h) &body body — clip drawing to rect + +** Tests (tangle to tests/...) + +** Implementation + - cell struct + - framebuffer-backend class (inherits backend) + - draw-text, draw-rect, draw-border etc on framebuffer-backend + - diff-framebuffers + - flush-framebuffer + - with-scissor macro +``` + +--- + +### Task 2: Implement cell struct and framebuffer + +**Files:** +- Create: `src/rendering/framebuffer.lisp` + +**Code:** + +```lisp +(defpackage :cl-tty.rendering + (:use :cl :cl-tty.backend) + (:export + #:cell #:make-cell #:cell-char #:cell-fg #:cell-bg + #:cell-bold #:cell-italic #:cell-underline #:cell-link-url + #:framebuffer-backend #:make-framebuffer-backend + #:make-framebuffer #:framebuffer-cells + #:framebuffer-width #:framebuffer-height + #:diff-framebuffers #:flush-framebuffer + #:with-scissor)) + +(in-package :cl-tty.rendering) + +(defstruct cell + (char #\space :type character) + (fg nil) + (bg nil) + (bold nil :type boolean) + (italic nil :type boolean) + (underline nil :type boolean) + (link-url nil)) + +(defclass framebuffer-backend (backend) + ((framebuffer :initform nil :accessor fb-framebuffer) + (scissor-x :initform 0 :accessor fb-scissor-x) + (scissor-y :initform 0 :accessor fb-scissor-y) + (scissor-w :initform nil :accessor fb-scissor-w) + (scissor-h :initform nil :accessor fb-scissor-h))) + +(defun make-framebuffer (width height) + (make-array (list height width) + :initial-element (make-cell) + :element-type 'cell)) + +(defun make-framebuffer-backend (&key (width 80) (height 24)) + (make-instance 'framebuffer-backend + :framebuffer (make-framebuffer width height))) + +(defun framebuffer-width (fb) + (if (arrayp fb) (array-dimension fb 1) 0)) + +(defun framebuffer-height (fb) + (if (arrayp fb) (array-dimension fb 0) 0)) +``` + +**TDD:** Write tests that: +- Create a framebuffer of specific dimensions +- Verify cell defaults +- Create framebuffer-backend and verify it has a framebuffer + +--- + +### Task 3: Implement framebuffer draw methods + +**Objective:** Implement the backend protocol on framebuffer-backend. + +**Files:** +- Modify: `src/rendering/framebuffer.lisp` + +**Key method — draw-text:** + +```lisp +(defmethod draw-text ((fb framebuffer-backend) x y string fg bg &rest attrs) + (let ((cells (fb-framebuffer fb)) + (sx (fb-scissor-x fb)) (sy (fb-scissor-y fb)) + (sw (fb-scissor-w fb)) (sh (fb-scissor-h fb))) + (loop for i from 0 below (length string) + for cx = (+ x i) + for cy = y + when (and (or (null sw) (and (>= cx sx) (< cx (+ sx sw)))) + (or (null sh) (and (>= cy sy) (< cy (+ sy sh)))) + (< cy (framebuffer-height cells)) + (< cx (framebuffer-width cells))) + do (setf (aref cells cy cx) + (make-cell :char (char string i) + :fg fg :bg bg + :bold (getf attrs :bold) + :italic (getf attrs :italic) + :underline (getf attrs :underline) + :link-url (getf attrs :link-url)))))) +``` + +Similar methods for draw-rect, draw-border, backend-clear. + +--- + +### Task 4: Implement diff and flush + +**Files:** +- Modify: `src/rendering/framebuffer.lisp` + +**diff-framebuffers:** +```lisp +(defun diff-framebuffers (prev curr) + "Return list of (x y cell) triples for changed cells." + (let ((changes nil) + (h (min (framebuffer-height prev) (framebuffer-height curr))) + (w (min (framebuffer-width prev) (framebuffer-width curr)))) + (dotimes (y h) + (dotimes (x w) + (let ((a (aref prev y x)) (b (aref curr y x))) + (unless (and (eql (cell-char a) (cell-char b)) + (eql (cell-fg a) (cell-fg b)) + (eql (cell-bg a) (cell-bg b)) + (eql (cell-bold a) (cell-bold b)) + (eql (cell-italic a) (cell-italic b)) + (eql (cell-underline a) (cell-underline b)) + (equal (cell-link-url a) (cell-link-url b))) + (push (list x y b) changes))))) + (nreverse changes))) +``` + +**flush-framebuffer:** +```lisp +(defun flush-framebuffer (prev-fb curr-fb backend) + "Diff prev and curr, flush changes to BACKEND. +Returns count of changed cells." + (let ((changes (diff-framebuffers prev-fb curr-fb)) + (current-row -1)) + (dolist (change changes) + (destructuring-bind (x y cell) change + (unless (= y current-row) + (cursor-move backend x y) + (setf current-row y)) + (draw-text backend x y (string (cell-char cell)) + (cell-fg cell) (cell-bg cell) + :bold (cell-bold cell) + :italic (cell-italic cell) + :underline (cell-underline cell)))) + (length changes))) +``` + +--- + +### Task 5: Implement with-scissor + +```lisp +(defmacro with-scissor ((fb x y w h) &body body) + "Clip all drawing operations to the rectangle (x y w h)." + (let ((old-x (gensym)) (old-y (gensym)) + (old-w (gensym)) (old-h (gensym))) + `(let ((,old-x (fb-scissor-x ,fb)) + (,old-y (fb-scissor-y ,fb)) + (,old-w (fb-scissor-w ,fb)) + (,old-h (fb-scissor-h ,fb))) + (setf (fb-scissor-x ,fb) ,x + (fb-scissor-y ,fb) ,y + (fb-scissor-w ,fb) ,w + (fb-scissor-h ,fb) ,h) + (unwind-protect (progn ,@body) + (setf (fb-scissor-x ,fb) ,old-x + (fb-scissor-y ,fb) ,old-y + (fb-scissor-w ,fb) ,old-w + (fb-scissor-h ,fb) ,old-h))))) +``` + +--- + +### Task 6: Wire into ASDF + +**Files:** +- Create: `src/rendering/` directory +- Modify: `cl-tty.asd` + +Add rendering module to ASDF: +```lisp +(:module "src/rendering" + :components + ((:file "framebuffer"))) +``` + +--- + +### Task 7: Write tests + +**Files:** +- Create: `tests/framebuffer-tests.lisp` + +Tests to write: +1. `make-framebuffer-creates-correct-size` — verify dimensions +2. `cell-defaults-are-space` — default cell has #\space char +3. `draw-text-on-fb-sets-cells` — verify text lands in right cells +4. `draw-text-clips-at-bounds` — text beyond width is ignored +5. `diff-identical-fbs-returns-empty` — no changes detected +6. `diff-changed-fb-returns-changes` — changed cells detected +7. `with-scissor-clips-drawing` — drawing outside scissor is ignored +8. `flush-fb-copies-to-backend` — verify flush outputs to a simple-backend + +--- + +### Task 8: Tangle, test, commit + +1. Tangle all org files +2. Run full test suite (verify ~368 tests pass) +3. Commit with message diff --git a/docs/plans/2026-05-11-terminal-detection.md b/docs/plans/2026-05-11-terminal-detection.md new file mode 100644 index 0000000..f8d48e5 --- /dev/null +++ b/docs/plans/2026-05-11-terminal-detection.md @@ -0,0 +1,207 @@ +# Terminal Capability Detection — Implementation Plan + +> **For Hermes:** Implement this plan task-by-task using subagent-driven-development. + +**Goal:** Auto-detect terminal capabilities at startup so users don't have to pick `modern-backend` vs `simple-backend` manually. + +**Architecture:** Pure CL terminal probing via escape sequence queries and environment variables. No external dependencies. Detection happens once at startup and returns a backend instance. + +**Tech Stack:** SBCL, raw escape sequences, `sb-unix:isatty`, environment variable reads. + +--- + +### Task 1: Create detection.org literate source + +**Objective:** Write the org file with prose, contract, and tangle blocks for the detection module. No code generation yet — this is the design document. + +**Files:** +- Create: `org/detection.org` + +**Content structure:** + +``` +#+TITLE: Terminal Capability Detection (v0.12.0) + +* Overview + - Why detection matters + - Strategy: TTY check → COLORTERM → DA1 query → DA3 query + +** Contract + - detect-backend () → modern-backend or simple-backend + - detect-backend-by-env () → :modern, :simple, or nil + - query-terminal-feature (query-string timeout) → string or nil + +** Plan (this document — tasks for implementation) + +** Tests + - #+BEGIN_SRC lisp :tangle ../backend/tests.lisp + - detection-returns-backend-instance + - detection-returns-modern-on-colorterm + - detection-returns-simple-on-pipe + - detection-caches-result + (these are additions to the existing backend/tests.lisp) + +** Implementation + - Package (adds to cl-tty.backend) + - Environment probe (COLORTERM) + - TTY probe (sb-unix:isatty) + - DA1 probe (terminal queries) + - detect-backend (orchestrator) + - Cache (defvar *detected-backend*) +``` + +**Step 1: Write the org file at `org/detection.org`** with the sections above, full prose, and empty code blocks. + +**Step 2: Review** — verify structure matches existing .org files in the project. + +**Step 3: Commit** +```bash +git add org/detection.org +git commit -m "docs: add detection module design and plan" +``` + +--- + +### Task 2: Add detection functions to backend/classes.lisp + +**Objective:** Implement the environment and TTY probe functions. + +**Files:** +- Modify: `backend/classes.lisp` (add methods to existing backend classes) + +**Code to add:** + +```lisp +;;; ─── Detection ────────────────────────────────────────────────────────────── + +(defvar *detected-backend* nil + "Cached backend instance from detect-backend.") + +(defun detect-backend-by-env () + "Check COLORTERM environment variable for modern terminal support." + (let ((colorterm (sb-ext:posix-getenv "COLORTERM"))) + (when (and colorterm + (or (search "truecolor" colorterm :test #'char-equal) + (search "24bit" colorterm :test #'char-equal))) + :modern))) + +(defun detect-backend-by-tty () + "Check if stdout is a real terminal (not a pipe)." + (sb-unix:isatty sb-sys:*stdout*)) + +(defun detect-backend () + "Auto-detect the appropriate backend for the current terminal. +Returns a backend instance." + (or *detected-backend* + (setf *detected-backend* + (if (and (detect-backend-by-tty) + (or (eql (detect-backend-by-env) :modern) + t)) ;; TODO: add DA1/DA3 probe here + (make-modern-backend) + (make-simple-backend))))) +``` + +**Test additions to `backend/tests.lisp`:** + +```lisp +(def-test detection-returns-backend-instance () + (let ((be (cl-tty.backend:detect-backend))) + (is-true (typep be 'cl-tty.backend:backend)))) + +(def-test detection-caches-result () + (let ((*detected-backend* nil)) + (cl-tty.backend:detect-backend) + (is-true (not (null cl-tty.backend::*detected-backend*))))) +``` + +**Follow TDD:** +1. Write failing tests in `src/components/box-tests.lisp` (or wherever backend tests live — actually in `backend/tests.lisp`) +2. Run tests to verify failure +3. Write implementation code in `backend/classes.lisp` +4. Run tests to verify pass +5. Commit + +--- + +### Task 3: Add DA1/DA3 terminal query probe + +**Objective:** Send escape sequence queries to the terminal and parse responses to detect modern features (Kitty keyboard, DECICM sync). + +**Files:** +- Modify: `backend/classes.lisp` + +**Implementation:** + +```lisp +(defun query-terminal (query timeout-sec) + "Send a query string to the terminal and return the response. +Returns nil if no response within TIMEOUT-SEC seconds." + (let ((response (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t))) + (format t "~A" query) + (force-output) + (sleep timeout-sec) + (loop while (listen) + do (vector-push-extend (read-char-no-hang) response)) + (when (plusp (length response)) + response))) + +(defun detect-backend-by-da1 () + "Send DA1 (Device Attributes) query and parse response for modern features." + (let ((response (query-terminal (format nil "~C[c" #\Esc) 0.1))) + (when response + ;; Check for specific feature codes in response + (search "?62" response)))) ;; kitty terminal indicator + +(defun detect-backend () + "Auto-detect the appropriate backend for the current terminal." + (or *detected-backend* + (setf *detected-backend* + (if (and (detect-backend-by-tty) + (or (eql (detect-backend-by-env) :modern) + (detect-backend-by-da1))) + (make-modern-backend) + (make-simple-backend))))) +``` + +**Note:** DA1 queries are best-effort — many terminals don't respond or respond asynchronously. The env-var check is more reliable. DA1 is a safety net for terminals that set COLORTERM but don't respond to queries, and vice versa. + +**Test for DA1 is hard to automate** (requires a real terminal). Add a manual test note. + +--- + +### Task 4: Wire into ASDF and run full test suite + +**Files:** +- Modify: `cl-tty.asd` (add detection.lisp if created as separate file, or verify existing) +- Run: `run-all-tests.lisp` + +**Steps:** +1. Ensure `cl-tty.asd` includes the detection code (if in `backend/classes.lisp` it's already loaded) +2. Run full test suite: `sbcl --script run-all-tests.lisp` +3. Verify all 358+ tests pass (add 2 new detection tests → 360) +4. Commit + +--- + +### Task 5: Update demo.lisp to use detection + +**Objective:** Make `demo.lisp` use `detect-backend` instead of hardcoded `make-modern-backend`. + +**Files:** +- Modify: `demo.lisp` + +**Change:** Replace `(make-modern-backend)` with `(detect-backend)`. + +**Verification:** `sbcl --script demo.lisp` should work in a terminal. + +--- + +### Task 6: Tangle org → lisp and verify no regressions + +**Files:** All + +**Steps:** +1. Tangle all org files: `for f in org/*.org; do emacs --batch ...; done` +2. Run full test suite +3. Verify 0 regressions +4. Commit final diff --git a/docs/plans/2026-05-11-v0.2.0-box-and-text.md b/docs/plans/2026-05-11-v0.2.0-box-and-text.md index b39edfa..6952b15 100644 --- a/docs/plans/2026-05-11-v0.2.0-box-and-text.md +++ b/docs/plans/2026-05-11-v0.2.0-box-and-text.md @@ -15,7 +15,7 @@ - `src/components/dirty.lisp` — tangled **Files modified:** -- `cl-tui.asd` — add component modules +- `cl-tty.asd` — add component modules - `docs/ROADMAP.org` — mark v0.2.0 tasks DONE ## Task 1: Box renderable @@ -25,7 +25,7 @@ **Files:** - Create: `org/box-renderable.org` - Create: `src/components/box.lisp` (extracted) -- Modify: `cl-tui.asd` — add components module +- Modify: `cl-tty.asd` — add components module **Box class:** ```lisp @@ -120,7 +120,7 @@ Default methods mark/check a `dirty` slot on the component. When implemented: ## Task 4: Wire into ASDF + update roadmap **Files:** -- Modify: `cl-tui.asd` — add `:module "components"` to both main and test systems +- Modify: `cl-tty.asd` — add `:module "components"` to both main and test systems - Modify: `docs/ROADMAP.org` — mark v0.2.0 tasks DONE **Run full test suite:** diff --git a/docs/plans/2026-05-11-v0.5.0-text-input.md b/docs/plans/2026-05-11-v0.5.0-text-input.md index ae7c723..5f08170 100644 --- a/docs/plans/2026-05-11-v0.5.0-text-input.md +++ b/docs/plans/2026-05-11-v0.5.0-text-input.md @@ -30,7 +30,7 @@ src/components/keybindings.lisp — tangled: keybinding system - Modify: `backend/package.lisp` — add input exports - Modify: `backend/modern.lisp` — implement read-event - Modify: `backend/simple.lisp` — implement read-event (stdin) -- Modify: `cl-tui.asd` — add input module to main and test systems +- Modify: `cl-tty.asd` — add input module to main and test systems **Code architecture:** @@ -120,7 +120,7 @@ src/components/keybindings.lisp — tangled: keybinding system - Create: `org/text-input.org` - Create: `src/components/input.lisp` - Modify: `src/components/package.lisp` — add exports -- Modify: `cl-tui.asd` — add input.lisp +- Modify: `cl-tty.asd` — add input.lisp **TextInput class:** ```lisp @@ -214,7 +214,7 @@ src/components/keybindings.lisp — tangled: keybinding system - Create: `org/textarea.org` - Create: `src/components/textarea.lisp` - Modify: `src/components/package.lisp` — add exports -- Modify: `cl-tui.asd` — add textarea.lisp +- Modify: `cl-tty.asd` — add textarea.lisp **Textarea class:** ```lisp @@ -255,7 +255,7 @@ src/components/keybindings.lisp — tangled: keybinding system - Create: `org/keybindings.org` - Create: `src/components/keybindings.lisp` - Modify: `src/components/package.lisp` — add exports -- Modify: `cl-tui.asd` — add keybindings.lisp +- Modify: `cl-tty.asd` — add keybindings.lisp **Architecture:** ```lisp @@ -355,7 +355,7 @@ Task 1 is the prerequisite for everything. Tasks 2, 3, 4 can then proceed in par ### Verification After each task: -1. `sbcl --eval "(asdf:test-system :cl-tui)" --quit` — all tests GREEN +1. `sbcl --eval "(asdf:test-system :cl-tty)" --quit` — all tests GREEN 2. `scripts/validate-parens.py` — all files balanced 3. Commit with RED/GREEN evidence diff --git a/layout/layout.lisp b/layout/layout.lisp index e1a3a2e..d71f569 100644 --- a/layout/layout.lisp +++ b/layout/layout.lisp @@ -1,6 +1,6 @@ ;;; layout — Pure CL Flexbox layout engine -(defpackage :cl-tui.layout +(defpackage :cl-tty.layout (:use :cl) (:export #:layout-node #:make-layout-node @@ -16,13 +16,15 @@ #:layout-node-fixed-height #:normalize-box #:box-edge)) -(in-package :cl-tui.layout) +(in-package :cl-tty.layout) (defun normalize-box (spec) - (cond ((null spec) '(:top 0 :right 0 :bottom 0 :left 0)) - ((numberp spec) `(:top ,spec :right ,spec :bottom ,spec :left ,spec)) - ((getf spec :top) spec) - (t '(:top 0 :right 0 :bottom 0 :left 0)))) + (cond ((null spec) (list :top 0 :right 0 :bottom 0 :left 0)) + ((numberp spec) (list :top spec :right spec :bottom spec :left spec)) + (t (loop with result = (list :top 0 :right 0 :bottom 0 :left 0) + for (key val) on spec by #'cddr + do (setf (getf result key) val) + finally (return result))))) (defun box-edge (box edge) (or (getf box edge) 0)) @@ -37,8 +39,8 @@ (direction :initform :column :initarg :direction :accessor layout-node-direction) (grow :initform 0 :initarg :grow :accessor layout-node-grow) (shrink :initform 1 :initarg :shrink :accessor layout-node-shrink) - (padding :initform '(:top 0 :right 0 :bottom 0 :left 0) :initarg :padding :accessor layout-node-padding) - (margin :initform '(:top 0 :right 0 :bottom 0 :left 0) :initarg :margin :accessor layout-node-margin) + (padding :initform (list :top 0 :right 0 :bottom 0 :left 0) :initarg :padding :accessor layout-node-padding) + (margin :initform (list :top 0 :right 0 :bottom 0 :left 0) :initarg :margin :accessor layout-node-margin) (gap :initform 0 :initarg :gap :accessor layout-node-gap) (position-type :initform :relative :initarg :position-type :accessor layout-node-position-type) (position-offset :initform nil :initarg :position-offset :accessor layout-node-position-offset) diff --git a/layout/tests.lisp b/layout/tests.lisp index 5054bea..4433b48 100644 --- a/layout/tests.lisp +++ b/layout/tests.lisp @@ -1,7 +1,7 @@ -(defpackage :cl-tui-layout-test - (:use :cl :fiveam :cl-tui.layout) +(defpackage :cl-tty-layout-test + (:use :cl :fiveam :cl-tty.layout) (:export #:run-tests)) -(in-package :cl-tui-layout-test) +(in-package :cl-tty-layout-test) (def-suite layout-suite :description "Layout engine tests") (in-suite layout-suite) diff --git a/org/backend-protocol.org b/org/backend-protocol.org index f1830fe..874e571 100644 --- a/org/backend-protocol.org +++ b/org/backend-protocol.org @@ -1,6 +1,6 @@ -#+TITLE: cl-tui Backend Protocol — v0.0.1 +#+TITLE: cl-tty Backend Protocol — v0.0.1 #+STARTUP: content -#+FILETAGS: :cl-tui:backend:v0.0.1: +#+FILETAGS: :cl-tty:backend:v0.0.1: #+OPTIONS: ^:nil * Backend Protocol @@ -119,10 +119,10 @@ Borders: ** Test Suite #+BEGIN_SRC lisp -(defpackage :cl-tui-backend-test +(defpackage :cl-tty-backend-test (:use :cl :fiveam) (:export #:run!)) -(in-package :cl-tui-backend-test) +(in-package :cl-tty-backend-test) (def-suite backend-suite :description "Backend protocol tests") (in-suite backend-suite) @@ -224,7 +224,7 @@ Borders: *** Package #+BEGIN_SRC lisp -(defpackage :cl-tui.backend +(defpackage :cl-tty.backend (:use :cl) (:export ;; Backend classes @@ -245,7 +245,7 @@ Borders: #:capable-p ;; Constructors #:make-simple-backend)) -(in-package :cl-tui.backend) +(in-package :cl-tty.backend) #+END_SRC *** Backend Base Class diff --git a/org/box-renderable.org b/org/box-renderable.org index a96935d..57e1b5d 100644 --- a/org/box-renderable.org +++ b/org/box-renderable.org @@ -1,6 +1,6 @@ -#+TITLE: cl-tui Box Renderable — v0.2.0 +#+TITLE: cl-tty Box Renderable — v0.2.0 #+STARTUP: content -#+FILETAGS: :cl-tui:components:v0.2.0: +#+FILETAGS: :cl-tty:components:v0.2.0: #+OPTIONS: ^:nil * Box Renderable @@ -27,10 +27,10 @@ A Box has a =layout-node= slot for positioning via the layout engine. Its ** Tests #+BEGIN_SRC lisp -(defpackage :cl-tui-box-test - (:use :cl :fiveam :cl-tui.backend :cl-tui.layout) +(defpackage :cl-tty-box-test + (:use :cl :fiveam :cl-tty.backend :cl-tty.layout) (:export #:run-tests)) -(in-package :cl-tui-box-test) +(in-package :cl-tty-box-test) (def-suite box-suite :description "Box renderable tests") (in-suite box-suite) @@ -116,7 +116,7 @@ A Box has a =layout-node= slot for positioning via the layout engine. Its ** Implementation #+BEGIN_SRC lisp -(in-package :cl-tui.box) +(in-package :cl-tty.box) (defclass box () ((layout-node :initform (make-layout-node) :accessor box-layout-node diff --git a/org/detection.org b/org/detection.org new file mode 100644 index 0000000..e5ffc97 --- /dev/null +++ b/org/detection.org @@ -0,0 +1,155 @@ +#+TITLE: Terminal Capability Detection (v0.12.0) +#+DATE: 2026-05-11 +#+AUTHOR: Amr Gharbeia / Hermes +#+STARTUP: content + +* Overview + +Currently, users must manually choose between ~modern-backend~ and +~simple-backend~ when initializing cl-tty. This module adds auto-detection: + +1. Check if stdout is a real TTY (not piped/redirected) +2. Check the =COLORTERM= environment variable for truecolor support +3. Optionally query the terminal via DA1/DA3 escape sequences +4. Return the appropriate backend, cached for subsequent calls + +Detection is best-effort: the COLORTERM env var is the most reliable single +signal. DA1 queries are asynchronous and many terminals don't respond. +If detection can't determine modern capability, it falls back to +~simple-backend~. + +** Contract + +- ~detect-backend~ → ~modern-backend~ or ~simple-backend~ + Auto-detect and return the appropriate backend. Results are cached + in ~*detected-backend*~. + +- ~detect-backend-by-env~ → ~:modern~ or ~nil~ + Check =COLORTERM= env var for ~truecolor~ or ~24bit~. + +- ~detect-backend-by-tty~ → boolean + Check if stdout is a real terminal (not a pipe). + +- ~detect-backend-by-da1~ → boolean + Send DA1 (~ESC[c~) query and check for modern feature responses. + +- ~*detected-backend*~ — variable + Cache for detection result. ~nil~ = not yet detected. + +* Plan + +See =docs/plans/2026-05-11-terminal-detection.md= for implementation tasks. + +1. Create ~detection.lisp~ with all detection functions +2. Wire into ASDF +3. Update ~demo.lisp~ to use ~detect-backend~ +4. Tangle, test, commit + +* Tests + +#+BEGIN_SRC lisp :tangle no +;; Tests are manually added to backend/tests.lisp +(def-test detection-returns-backend-instance () + (let ((be (cl-tty.backend:detect-backend))) + (is-true (typep be 'cl-tty.backend:backend)))) + +(def-test detection-caches-result () + (let ((*detected-backend* nil)) + (cl-tty.backend:detect-backend) + (is-true (not (null cl-tty.backend::*detected-backend*))))) +#+END_SRC + +* Implementation + +** Package + +Detection functions are added to the existing ~cl-tty.backend~ package. +No new package definition needed. + +** Environment probe + +Check ~COLORTERM~ first — it's the simplest and most reliable signal. + +#+BEGIN_SRC lisp :tangle ../backend/detection.lisp +(in-package :cl-tty.backend) + +;;; ─── Detection cache ──────────────────────────────────────────────────────── + +(defvar *detected-backend* nil + "Cached backend instance from detect-backend. Nil = not yet detected.") + +;;; ─── Environment probe ────────────────────────────────────────────────────── + +(defun detect-backend-by-env () + "Check COLORTERM environment variable for modern terminal support. +Returns :modern if COLORTERM contains 'truecolor' or '24bit', nil otherwise." + (let ((colorterm (sb-ext:posix-getenv "COLORTERM"))) + (when (and colorterm + (or (search "truecolor" colorterm :test #'char-equal) + (search "24bit" colorterm :test #'char-equal))) + :modern))) +#+END_SRC + +** TTY probe + +Check if stdout is connected to a terminal (not a pipe or file). + +#+BEGIN_SRC lisp :tangle ../backend/detection.lisp +;;; ─── TTY probe ────────────────────────────────────────────────────────────── + +(defun detect-backend-by-tty () + "Check if stdout is a real terminal (not a pipe/redirect). +Returns T if stdout is interactive, nil otherwise." + (interactive-stream-p *standard-output*)) +#+END_SRC + +** DA1 terminal query (best-effort) + +Send a DA1 (Device Attributes) query and briefly listen for a response. +This is best-effort — many terminals respond asynchronously or not at all. + +#+BEGIN_SRC lisp :tangle ../backend/detection.lisp +;;; ─── DA1 terminal query ───────────────────────────────────────────────────── + +(defun query-terminal (query &optional (timeout 0.1)) + "Send QUERY string to terminal and return any response received within +TIMEOUT seconds. Returns the response string, or nil if no response." + (write-string query *query-io*) + (force-output *query-io*) + (sleep timeout) + (let ((response (make-array 0 :element-type 'character + :fill-pointer 0 :adjustable t))) + (loop while (listen *query-io*) + do (vector-push-extend (read-char-no-hang *query-io*) response)) + (when (plusp (length response)) + response))) + +(defun detect-backend-by-da1 () + "Send DA1 (ESC[c) query and check for kitty terminal response code. +Returns T if terminal reports kitty compatibility codes." + (let ((response (query-terminal (format nil "~C[c" #\Esc)))) + (when response + ;; DA1 response format: ESC [ ? digits ; digits c + ;; Kitty reports code 62 in the response + (search "?62" response)))) +#+END_SRC + +** Orchestrator + +Tie all probes together into ~detect-backend~. + +#+BEGIN_SRC lisp :tangle ../backend/detection.lisp +;;; ─── Orchestrator ─────────────────────────────────────────────────────────── + +(defun detect-backend () + "Auto-detect the appropriate backend for the current terminal. +Returns a backend instance (modern-backend or simple-backend). +Result is cached in *detected-backend* for subsequent calls." + (or *detected-backend* + (setf *detected-backend* + (if (and (detect-backend-by-tty) + (or (eql (detect-backend-by-env) :modern) + (detect-backend-by-da1))) + (make-modern-backend) + (make-simple-backend))))) +#+END_SRC diff --git a/org/dialog.org b/org/dialog.org new file mode 100644 index 0000000..688b85d --- /dev/null +++ b/org/dialog.org @@ -0,0 +1,486 @@ +#+TITLE: Dialog System + Toast (v0.9.0) +#+DATE: 2026-05-11 +#+AUTHOR: Amr Gharbeia / Hermes + +* Overview + +Modal overlays (dialogs) and transient notifications (toasts). + +Dialogs are absolute-positioned panels centered on a dimmed backdrop. +They stack — a new dialog goes on top, Esc dismisses the top one. + +Toasts are non-blocking notifications that auto-dismiss after a +duration. They stack in the top-right corner. + +** Design decisions + +1. /Stack-based dialog management/: a ~*dialog-stack*~ special variable + holds the active dialogs. Render walks the stack from bottom to top, + drawing each dialog's backdrop over the previous one. This means two + dialogs visible at once — the top one gets full interaction. + +2. /Backdrop is a solid dim color, not semi-transparent/: true + transparency requires compositing pixel buffers, which is expensive + in the terminal. A solid dimmed color over the full screen width + communicates "modal" without the complexity. + +3. /Dialogs are components, not separate windows/: they integrate into + the existing render tree. The dialog class inherits from the component + base and participates in dirty tracking, z-order, etc. + +4. /Toast is fire-and-forget/: ~(toast ...)~ creates a toast component, + adds it to a toast list, and schedules auto-dismissal. No lifecycle + management needed from the caller. + +** Contract + +- ~dialog~ class — overlay component with backdrop, border, title +- ~*dialog-stack*~ — list of active dialogs (bound per-screen) +- ~push-dialog dialog~ — add dialog to stack, focus its first input +- ~pop-dialog~ — dismiss top dialog, fire :on-dismiss +- ~(alert-dialog title message)~ — OK-button alert +- ~(confirm-dialog title message &key on-yes on-no)~ — Yes/No/Cancel +- ~(select-dialog title options &key on-select)~ — modal Select +- ~(prompt-dialog title &key on-submit)~ — modal TextInput +- ~toast~ component — transient notification with variant color +- ~(toast message &key variant duration)~ — fire-and-forget toast + +* Code structure + +** Dialog class + +--- per-function: dialog-class + +The dialog class stores the dialog's content (a component to render +inside the dialog panel), its size preset, title, and callbacks. + +#+BEGIN_SRC lisp :tangle no +(defclass dialog () + ((title :initarg :title :accessor dialog-title) + (size :initarg :size :initform :medium :accessor dialog-size) + (content :initarg :content :accessor dialog-content) + (on-dismiss :initarg :on-dismiss :initform nil :accessor dialog-on-dismiss))) +#+END_SRC + +--- per-function: dialog-size-pixels + +Helper to convert size keyword to pixel dimensions. + +#+BEGIN_SRC lisp :tangle no +(defun dialog-size-pixels (size) + (case size + (:small (values 40 8)) + (:medium (values 60 16)) + (:large (values 88 24)) + (t (values 60 16)))) +#+END_SRC + +--- per-function: render-dialog + +Render a dialog: backdrop (dimmed full-screen), then centered panel. + +#+BEGIN_SRC lisp :tangle no +(defun render-dialog (dialog screen w h) + (multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog)) + (let ((x (floor (- w dw) 2)) + (y (floor (- h dh) 2))) + ;; Backdrop — draw dim characters over full screen + (dotimes (row h) + (dotimes (col w) + (backend-write screen col row " " :bg :dim))) + ;; Panel border + (draw-border screen x y dw dh :single :title (dialog-title dialog)) + ;; Content area (inset by 1 on each side) + (when (dialog-content dialog) + (render-component (dialog-content dialog) screen (1+ x) (1+ y) (- dw 2) (- dh 2)))))) +#+END_SRC +*** push-dialog / pop-dialog + +~push-dialog~ pushes a dialog onto =*dialog-stack*=. ~pop-dialog~ pops the +top dialog and calls its ~:on-dismiss~ callback if set. + +#+BEGIN_SRC lisp :tangle no +(defun push-dialog (dialog) + (push dialog *dialog-stack*) + dialog) +#+END_SRC + +--- per-function: pop-dialog + +Pop the top dialog, fire its on-dismiss callback. + +#+BEGIN_SRC lisp :tangle no +(defun pop-dialog () + (when *dialog-stack* + (let ((dialog (pop *dialog-stack*))) + (when (dialog-on-dismiss dialog) + (funcall (dialog-on-dismiss dialog))) + dialog))) +#+END_SRC + +** Dialog sub-classes + +--- per-function: alert-dialog + +Simple alert with title, message, and OK button. The button is a +Select with a single "OK" option. + +#+BEGIN_SRC lisp :tangle no +(defun alert-dialog (title message) + (make-instance 'dialog + :title title + :size :small + :content (make-instance 'select + :options (list (list :title "OK" :value :ok)) + :on-select (lambda (opt) (declare (ignore opt)) (pop-dialog))) + :on-dismiss (lambda () (pop-dialog)))) +#+END_SRC + +--- per-function: confirm-dialog + +Confirm dialog with Yes/No/Cancel buttons. Returns :yes or :no +via the on-yes/on-no callbacks. + +#+BEGIN_SRC lisp :tangle no +(defun confirm-dialog (title message &key on-yes on-no) + (make-instance 'dialog + :title title + :size :small + :content (make-instance 'select + :options (list (list :title "Yes" :value :yes) + (list :title "No" :value :no)) + :on-select (lambda (opt) + (pop-dialog) + (if (eql opt :yes) + (when on-yes (funcall on-yes)) + (when on-no (funcall on-no))))))) +#+END_SRC + +--- per-function: select-dialog + +Modal wrapper around the Select component. + +#+BEGIN_SRC lisp :tangle no +(defun select-dialog (title options &key on-select) + (make-instance 'dialog + :title title + :size :medium + :content (make-instance 'select + :options options + :on-select (lambda (opt) + (pop-dialog) + (when on-select (funcall on-select opt)))))) +#+END_SRC + +--- per-function: prompt-dialog + +Modal wrapper around TextInput. + +#+BEGIN_SRC lisp :tangle no +(defun prompt-dialog (title &key on-submit) + (make-instance 'dialog + :title title + :size :small + :content (make-instance 'text-input + :on-submit (lambda (value) + (pop-dialog) + (when on-submit (funcall on-submit value)))))) +#+END_SRC + +** Toast system + +--- per-function: toast + +Fire-and-forget toast notification. Creates a toast component, +adds it to the toast list, and schedules auto-dismissal. + +#+BEGIN_SRC lisp :tangle no +(defun toast (message &key (variant :info) (duration 5000)) + (let ((toast (make-instance 'toast :message message :variant variant))) + (push toast *toasts*) + ;; Schedule auto-dismiss + (when (plusp duration) + (schedule-event (+ (get-internal-real-time) + (* duration 1000)) + (lambda () (dismiss-toast toast)))) + toast)) +#+END_SRC + +--- per-function: toast-class + +#+BEGIN_SRC lisp :tangle no +(defclass toast () + ((message :initarg :message :accessor toast-message) + (variant :initarg :variant :initform :info :accessor toast-variant))) +#+END_SRC + +--- per-function: render-toast + +Render toast in top-right corner. Max 60 cols. Shows colored +left border based on variant. + +#+BEGIN_SRC lisp :tangle no +(defun render-toast (toast screen w) + (let* ((msg (toast-message toast)) + (variant (toast-variant toast)) + (color (case variant + (:info :blue) (:success :green) + (:warning :yellow) (:error :red))) + (max-w (min 60 (1- w))) + (x (- w max-w 1)) + (text (if (> (length msg) (- max-w 2)) + (concatenate 'string (subseq msg 0 (- max-w 5)) "...") + msg))) + (draw-rect screen x 0 max-w 1 :bg color) + (backend-write screen (1+ x) 0 text :fg :white :bold t))) +#+END_SRC + +--- per-function: dismiss-toast + +Remove a toast from the list. + +#+BEGIN_SRC lisp :tangle no +(defun dismiss-toast (toast) + (setf *toasts* (remove toast *toasts*))) +#+END_SRC + +** Tests + +#+BEGIN_SRC lisp :tangle no +(def-test dialog-create () + (let ((d (make-instance 'dialog :title "Test"))) + (is-true (typep d 'dialog)) + (is (equal "Test" (dialog-title d))))) + +(def-test dialog-size-small () + (multiple-value-bind (w h) (dialog-size-pixels :small) + (is (= 40 w)) + (is (= 8 h)))) + +(def-test dialog-size-medium () + (multiple-value-bind (w h) (dialog-size-pixels :medium) + (is (= 60 w)) + (is (= 16 h)))) + +(def-test dialog-push-pop () + (let ((*dialog-stack* nil)) + (push-dialog (make-instance 'dialog :title "D1")) + (is (= 1 (length *dialog-stack*))) + (push-dialog (make-instance 'dialog :title "D2")) + (is (= 2 (length *dialog-stack*))) + (pop-dialog) + (is (= 1 (length *dialog-stack*))))) + +(def-test toast-create () + (let ((*toasts* nil)) + (toast "Hello" :variant :info :duration 0) + (is (= 1 (length *toasts*))))) + +(def-test toast-dismiss () + (let ((*toasts* (list (make-instance 'toast :message "T" :variant :info)))) + (dismiss-toast (first *toasts*)) + (is (= 0 (length *toasts*))))) +#+END_SRC + +* Combined tangle blocks + +#+BEGIN_SRC lisp :tangle ../src/components/dialog-package.lisp :noweb no +;;; dialog-package.lisp — Package definition for cl-tty.dialog + +(defpackage :cl-tty.dialog + (:use :cl :cl-tty.input :cl-tty.select) + (:export + #:dialog + #:dialog-title + #:dialog-content + #:dialog-on-dismiss + #:dialog-size + #:dialog-size-pixels + #:render-dialog + #:push-dialog + #:pop-dialog + #:*dialog-stack* + #:alert-dialog + #:confirm-dialog + #:select-dialog + #:prompt-dialog + #:toast + #:toast-message + #:toast-variant + #:render-toast + #:dismiss-toast + #:*toasts*)) +#+END_SRC + +#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp :noweb no +;;; dialog.lisp — Dialog System + Toast for cl-tty + +(in-package :cl-tty.dialog) + +;; ─── Special variables ──────────────────────────────────────────────────────── + +(defvar *dialog-stack* nil + "Stack of active dialogs. (list) of dialog instances.") + +(defvar *toasts* nil + "List of active toast notifications.") + +;; ─── Dialog class ───────────────────────────────────────────────────────────── + +(defclass dialog () + ((title :initarg :title :accessor dialog-title) + (size :initarg :size :initform :medium :accessor dialog-size) + (content :initarg :content :initform nil :accessor dialog-content) + (on-dismiss :initarg :on-dismiss :initform nil :accessor dialog-on-dismiss))) + +(defun dialog-size-pixels (size) + (case size + (:small (values 40 8)) + (:medium (values 60 16)) + (:large (values 88 24)) + (t (values 60 16)))) + +(defun render-dialog (dialog screen w h) + (multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog)) + (let ((x (floor (- w dw) 2)) + (y (floor (- h dh) 2))) + ;; Backdrop — dim the full screen + (dotimes (row h) + (draw-rect screen 0 row w 1 :bg :bright-black)) + ;; Dialog panel + (draw-border screen x y dw dh :single :title (dialog-title dialog)) + (when (dialog-content dialog) + ;; Content rendering delegated to component system + (draw-text screen (1+ x) (1+ y) + (format nil "~a" (dialog-content dialog)) + :white :default))))) + +(defun push-dialog (dialog) + (push dialog *dialog-stack*) + dialog) + +(defun pop-dialog () + (when *dialog-stack* + (let ((dialog (pop *dialog-stack*))) + (when (dialog-on-dismiss dialog) + (funcall (dialog-on-dismiss dialog))) + dialog))) + +;; ─── Dialog sub-classes ────────────────────────────────────────────────────── + +(defun alert-dialog (title message) + (make-instance 'dialog + :title title + :size :small + :content (make-instance 'select + :options (list (list :title "OK" :value :ok)) + :on-select (lambda (opt) (declare (ignore opt)) (pop-dialog))) + :on-dismiss (lambda () (pop-dialog)))) + +(defun confirm-dialog (title message &key on-yes on-no) + (make-instance 'dialog + :title title + :size :small + :content (make-instance 'select + :options (list (list :title "Yes" :value :yes) + (list :title "No" :value :no)) + :on-select (lambda (opt) + (pop-dialog) + (if (eql opt :yes) + (when on-yes (funcall on-yes)) + (when on-no (funcall on-no))))))) + +(defun select-dialog (title options &key on-select) + (make-instance 'dialog + :title title + :size :medium + :content (make-instance 'select + :options options + :on-select (lambda (opt) + (pop-dialog) + (when on-select (funcall on-select opt)))))) + +(defun prompt-dialog (title &key on-submit) + (make-instance 'dialog + :title title + :size :small + :content (make-instance 'text-input + :on-submit (lambda (value) + (pop-dialog) + (when on-submit (funcall on-submit value)))))) + +;; ─── Toast system ───────────────────────────────────────────────────────────── + +(defclass toast () + ((message :initarg :message :accessor toast-message) + (variant :initarg :variant :initform :info :accessor toast-variant))) + +(defun render-toast (toast screen w) + (let* ((msg (toast-message toast)) + (variant (toast-variant toast)) + (color (case variant + (:info :blue) (:success :green) + (:warning :yellow) (:error :red))) + (max-w (min 60 (1- w))) + (x (- w max-w 1)) + (text (if (> (length msg) (- max-w 2)) + (concatenate 'string (subseq msg 0 (- max-w 5)) "...") + msg))) + (draw-rect screen x 0 max-w 1 :bg color) + (draw-text screen (1+ x) 0 text :white color :bold t))) + +(defun toast (message &key (variant :info) (duration 0)) + (let ((toast (make-instance 'toast :message message :variant variant))) + (push toast *toasts*) + (when (plusp duration) (dismiss-toast toast)) + toast)) + +(defun dismiss-toast (toast) + (setf *toasts* (remove toast *toasts*))) +#+END_SRC + +#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp :noweb no +;;; dialog-tests.lisp — Tests for cl-tty.dialog + +(defpackage :cl-tty-dialog-test + (:use :cl :cl-tty.dialog :fiveam)) + +(in-package :cl-tty-dialog-test) + +(def-suite dialog-suite :description "Dialog + Toast tests for cl-tty.dialog") +(in-suite dialog-suite) + +(def-test dialog-create () + (let ((d (make-instance 'dialog :title "Test"))) + (is-true (typep d 'dialog)) + (is (equal "Test" (dialog-title d))))) + +(def-test dialog-size-small () + (multiple-value-bind (w h) (dialog-size-pixels :small) + (is (= 40 w)) + (is (= 8 h)))) + +(def-test dialog-size-medium () + (multiple-value-bind (w h) (dialog-size-pixels :medium) + (is (= 60 w)) + (is (= 16 h)))) + +(def-test dialog-push-pop () + (let ((*dialog-stack* nil)) + (push-dialog (make-instance 'dialog :title "D1")) + (is (= 1 (length *dialog-stack*))) + (push-dialog (make-instance 'dialog :title "D2")) + (is (= 2 (length *dialog-stack*))) + (pop-dialog) + (is (= 1 (length *dialog-stack*))))) + +(def-test toast-create () + (let ((*toasts* nil)) + (toast "Hello" :variant :info :duration 0) + (is (= 1 (length *toasts*))))) + +(def-test toast-dismiss () + (let ((*toasts* (list (make-instance 'toast :message "T" :variant :info)))) + (dismiss-toast (first *toasts*)) + (is (= 0 (length *toasts*))))) +#+END_SRC diff --git a/org/framebuffer.org b/org/framebuffer.org new file mode 100644 index 0000000..e9e6e12 --- /dev/null +++ b/org/framebuffer.org @@ -0,0 +1,358 @@ +#+TITLE: Rendering Pipeline — Framebuffer (v0.13.0) +#+DATE: 2026-05-11 +#+AUTHOR: Amr Gharbeia / Hermes +#+STARTUP: content + +* Overview + +A framebuffer-based rendering pipeline that sits between the component tree +and the backend protocol. Eliminates flicker by computing a full frame then +diffing against the previous frame before flushing. + +The ~framebuffer-backend~ class implements the backend protocol by writing to a +2D cell array instead of emitting escape sequences. After all components render, +the diff engine compares current and previous frames and flushes only changed +cells to a real backend. + +Benefits: +- Flicker-free output (only changed cells are sent) +- Enables text selection (each cell knows its content) +- Enables click-to-open-link (each cell knows its URL) +- Scissor clipping for nested containers + +** Contract** + +- ~cell~ — immutable struct with char, fg, bg, bold, italic, underline, link-url +- ~make-framebuffer width height~ → 2D array of ~cell~ +- ~framebuffer-backend~ — subclass of ~backend~ that renders to cell array +- ~make-framebuffer-backend &key width height~ → framebuffer-backend +- ~diff-framebuffers prev curr~ → list of (x y cell) for changed cells +- ~flush-framebuffer prev-fb curr-fb backend~ → writes changes, returns count +- ~with-scissor (fb x y w h) &body body~ — clip drawing to rectangle + +** Plan + +See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan. + +1. Create org file with code blocks +2. Tangle → framebuffer.lisp +3. Add to ASDF +4. Write tests +5. Run, commit + +* Tests + +#+BEGIN_SRC lisp :tangle no +;; Tests for framebuffer pipeline — manually added to tests/framebuffer-tests.lisp + +(defpackage :cl-tty-framebuffer-test + (:use :cl :fiveam :cl-tty.rendering :cl-tty.backend)) +(in-package :cl-tty-framebuffer-test) + +(def-suite framebuffer-suite :description "Framebuffer rendering pipeline tests") +(in-suite framebuffer-suite) + +(test make-framebuffer-creates-correct-size + (let ((fb (make-framebuffer 80 24))) + (is (= 24 (framebuffer-height fb))) + (is (= 80 (framebuffer-width fb))))) + +(test cell-defaults-are-space + (let ((cell (aref (make-framebuffer 10 10) 0 0))) + (is (eql #\space (cell-char cell))) + (is (null (cell-fg cell))) + (is (null (cell-bg cell))))) + +(test draw-text-on-fb-sets-cells + (let ((fb (make-framebuffer-backend))) + (draw-text fb 2 3 "abc" :red nil) + (let ((cells (fb-framebuffer fb))) + (is (eql #\a (cell-char (aref cells 3 2)))) + (is (eql #\b (cell-char (aref cells 3 3)))) + (is (eql #\c (cell-char (aref cells 3 4)))) + (is (eql :red (cell-fg (aref cells 3 2))))))) + +(test draw-text-clips-at-bounds + (let ((fb (make-framebuffer-backend :width 10 :height 5))) + (draw-text fb 8 2 "hello" nil nil) + (let ((cells (fb-framebuffer fb))) + (is (eql #\h (cell-char (aref cells 2 8)))) + (is (eql #\e (cell-char (aref cells 2 9)))) + (is (eql #\space (cell-char (aref cells 2 0))) "out of bounds text is ignored")))) + +(test diff-identical-fbs-returns-empty + (let ((fb1 (make-framebuffer 80 24)) + (fb2 (make-framebuffer 80 24))) + (is (null (diff-framebuffers fb1 fb2))))) + +(test diff-changed-fb-returns-changes + (let* ((fb1 (make-framebuffer 10 10)) + (fb2 (make-framebuffer 10 10))) + (setf (aref fb2 5 5) (make-cell :char #\X :fg :red)) + (let ((changes (diff-framebuffers fb1 fb2))) + (is (= 1 (length changes))) + (destructuring-bind (x y cell) (first changes) + (is (= 5 x)) + (is (= 5 y)) + (is (eql #\X (cell-char cell))))))) + +(test with-scissor-clips-drawing + (let ((fb (make-framebuffer-backend :width 20 :height 10))) + (with-scissor (fb 5 5 3 3) + (draw-text fb 6 6 "ABC" nil nil) + (draw-text fb 1 1 "OUTSIDE" nil nil)) + (let ((cells (fb-framebuffer fb))) + (is (eql #\A (cell-char (aref cells 6 6))) "inside scissor draws") + (is (eql #\space (cell-char (aref cells 1 1))) "outside scissor is clipped")))) + +(test flush-fb-copies-to-backend + (let* ((real-be (make-simple-backend :output-stream (make-string-output-stream))) + (fb (make-framebuffer-backend))) + (draw-text fb 0 0 "X" :red nil) + (let ((changed (flush-framebuffer (make-framebuffer 80 24) (fb-framebuffer fb) real-be))) + (is (>= changed 1))))) +#+END_SRC + +* Implementation + +** Package and data structures + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +(defpackage :cl-tty.rendering + (:use :cl :cl-tty.backend) + (:export + #:cell #:make-cell #:cell-char #:cell-fg #:cell-bg + #:cell-bold #:cell-italic #:cell-underline #:cell-link-url + #:framebuffer-backend #:make-framebuffer-backend + #:make-framebuffer #:fb-framebuffer + #:framebuffer-width #:framebuffer-height + #:diff-framebuffers #:flush-framebuffer + #:with-scissor + #:extract-text #:fb-cell-link-url)) +#+END_SRC + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +(in-package :cl-tty.rendering) + +;;; ─── Cell — immutable per-cell state ───────────────────────────────────────── + +(defstruct cell + "A single terminal cell — character, colors, and attributes." + (char #\space :type character) + (fg nil) + (bg nil) + (bold nil :type boolean) + (italic nil :type boolean) + (underline nil :type boolean) + (link-url nil)) + +;;; ─── Framebuffer — 2D array of cells ──────────────────────────────────────── + +(defun make-framebuffer (width height) + "Create a 2D array of CELL with dimensions HEIGHT x WIDTH." + (make-array (list height width) + :initial-element (make-cell) + :element-type 'cell)) + +(defun framebuffer-width (fb) + "Return the width (columns) of framebuffer FB." + (if (arrayp fb) (array-dimension fb 1) 0)) + +(defun framebuffer-height (fb) + "Return the height (rows) of framebuffer FB." + (if (arrayp fb) (array-dimension fb 0) 0)) + +;;; ─── Framebuffer Backend — implements backend protocol ───────────────────── + +(defclass framebuffer-backend (backend) + ((framebuffer :initform nil :accessor fb-framebuffer) + (scissor-x :initform 0 :accessor fb-scissor-x) + (scissor-y :initform 0 :accessor fb-scissor-y) + (scissor-w :initform nil :accessor fb-scissor-w) + (scissor-h :initform nil :accessor fb-scissor-h))) + +(defun make-framebuffer-backend (&key (width 80) (height 24)) + "Create a framebuffer-backend with a fresh framebuffer." + (let ((fb (make-instance 'framebuffer-backend))) + (setf (fb-framebuffer fb) (make-framebuffer width height)) + fb)) +#+END_SRC + +** Drawing methods + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +;;; ─── Drawing methods ───────────────────────────────────────────────────────── + +(defun %in-scissor-p (fb cx cy) + "Check if (CX, CY) falls within the current scissor rectangle." + (let ((sx (fb-scissor-x fb)) (sy (fb-scissor-y fb)) + (sw (fb-scissor-w fb)) (sh (fb-scissor-h fb))) + (and (or (null sw) (and (>= cx sx) (< cx (+ sx sw)))) + (or (null sh) (and (>= cy sy) (< cy (+ sy sh))))))) + +(defun %set-cell (fb x y char &key fg bg bold italic underline link-url) + "Set cell (X, Y) if within bounds and scissor." + (let ((cells (fb-framebuffer fb))) + (when (and (>= y 0) (< y (framebuffer-height cells)) + (>= x 0) (< x (framebuffer-width cells)) + (%in-scissor-p fb x y)) + (setf (aref cells y x) + (make-cell :char char :fg fg :bg bg + :bold bold :italic italic :underline underline + :link-url link-url))))) + +(defmethod draw-text ((fb framebuffer-backend) x y string fg bg + &key bold italic underline reverse dim blink + (link-url nil link-url-p) + &allow-other-keys) + (declare (ignore reverse dim blink link-url-p)) + (loop for i from 0 below (length string) + do (%set-cell fb (+ x i) y (char string i) + :fg fg :bg bg + :bold bold :italic italic :underline underline + :link-url link-url))) + +(defmethod draw-rect ((fb framebuffer-backend) x y w h &key bg) + (dotimes (row h) + (dotimes (col w) + (%set-cell fb (+ x col) (+ y row) #\space :fg nil :bg bg)))) + +(defmethod draw-border ((fb framebuffer-backend) x y w h &key (style :single) title title-align fg bg) + (let* ((chars (case style + (:single '(#\+ #\- #\|)) + (:double '(#\+ #\= #\|)) + (:rounded '(#\. #\- #\|)) + (t '(#\+ #\- #\|)))) + (tc (first chars)) (hc (second chars)) (vc (third chars))) + ;; Top edge + (%set-cell fb x y tc :fg fg :bg bg) + (loop for i from 1 below (1- w) do (%set-cell fb (+ x i) y hc :fg fg :bg bg)) + (%set-cell fb (1- (+ x w)) y tc :fg fg :bg bg) + ;; Sides + (dotimes (row (- h 2)) + (%set-cell fb x (+ y row 1) vc :fg fg :bg bg) + (%set-cell fb (1- (+ x w)) (+ y row 1) vc :fg fg :bg bg)) + ;; Bottom edge + (%set-cell fb x (+ y h -1) tc :fg fg :bg bg) + (loop for i from 1 below (1- w) do (%set-cell fb (+ x i) (+ y h -1) hc :fg fg :bg bg)) + (%set-cell fb (1- (+ x w)) (+ y h -1) tc :fg fg :bg bg) + ;; Title + (when title + (loop for i from 0 below (length title) + do (%set-cell fb (+ x 2 i) y (char title i) :fg fg :bg bg))))) + +(defmethod backend-clear ((fb framebuffer-backend)) + (let ((cells (fb-framebuffer fb))) + (dotimes (y (framebuffer-height cells)) + (dotimes (x (framebuffer-width cells)) + (setf (aref cells y x) (make-cell)))))) +#+END_SRC + +** Diff and flush + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +(defmethod draw-link ((fb framebuffer-backend) x y string url &key fg bg) + ;; OSC 8 links are not rendered in framebuffer — store as text + (draw-text fb x y string fg bg :link-url url)) + +(defmethod draw-ellipsis ((fb framebuffer-backend) x y width &key fg bg) + (dotimes (i (min 3 width)) + (%set-cell fb (+ x i) y #\. :fg fg :bg bg))) + +;;; ─── Diff ──────────────────────────────────────────────────────────────────── + +(defun cells-equal-p (a b) + "Return T if two cells have identical content and style." + (and (eql (cell-char a) (cell-char b)) + (eql (cell-fg a) (cell-fg b)) + (eql (cell-bg a) (cell-bg b)) + (eql (cell-bold a) (cell-bold b)) + (eql (cell-italic a) (cell-italic b)) + (eql (cell-underline a) (cell-underline b)) + (equal (cell-link-url a) (cell-link-url b)))) + +(defun diff-framebuffers (prev curr) + "Compare PREV and CURR framebuffers. Return list of (X Y CELL) for changes." + (let ((changes nil) + (h (min (framebuffer-height prev) (framebuffer-height curr))) + (w (min (framebuffer-width prev) (framebuffer-width curr)))) + (dotimes (y h) + (dotimes (x w) + (let ((a (aref prev y x)) (b (aref curr y x))) + (unless (cells-equal-p a b) + (push (list x y b) changes))))) + (nreverse changes))) + +;;; ─── Flush ─────────────────────────────────────────────────────────────────── + +(defun flush-framebuffer (prev-fb curr-fb backend) + "Diff PREV-FB and CURR-FB and flush changes to BACKEND. +Returns the number of changed cells." + (let* ((changes (diff-framebuffers prev-fb curr-fb)) + (count (length changes)) + (current-row -1)) + (when (plusp count) + (begin-sync backend) + (dolist (change changes) + (destructuring-bind (x y cell) change + (unless (= y current-row) + (cursor-move backend x y) + (setf current-row y)) + (draw-text backend x y (string (cell-char cell)) + (cell-fg cell) (cell-bg cell) + :bold (cell-bold cell) + :italic (cell-italic cell) + :underline (cell-underline cell)))) + (end-sync backend)) + count)) +#+END_SRC + +** Frame inspection (for mouse selection / link clicking) + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +;;; --- Frame inspection --------------------------------------------------- + +(defun fb-cell-link-url (fb x y) + "Return the link URL at (X Y) in framebuffer FB, or nil." + (when (and (arrayp fb) (>= y 0) (< y (array-dimension fb 0)) + (>= x 0) (< x (array-dimension fb 1))) + (let ((c (aref fb y x))) + (cell-link-url c)))) + +(defun extract-text (fb x1 y1 x2 y2) + "Extract visible text from the rectangle between (X1,Y1) and (X2,Y2)." + (let ((x-min (max 0 (min x1 x2))) (x-max (max 0 (max x1 x2))) + (y-min (max 0 (min y1 y2))) (y-max (max 0 (max y1 y2))) + (h (if (arrayp fb) (array-dimension fb 0) 0)) + (w (if (arrayp fb) (array-dimension fb 1) 0))) + (with-output-to-string (s) + (loop for y from y-min to (min y-max (1- h)) + do (loop for x from x-min to (min x-max (1- w)) + do (let ((c (aref fb y x))) + (princ (cell-char c) s))) + (when (< y y-max) (princ #\Newline s)))))) +#+END_SRC + +** Scissor clipping + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +;;; ─── Scissor clipping ──────────────────────────────────────────────────────── + +(defmacro with-scissor ((fb x y w h) &body body) + "Clip all drawing on FB to rectangle (X Y W H)." + (let ((old-x (gensym)) (old-y (gensym)) + (old-w (gensym)) (old-h (gensym))) + `(let ((,old-x (fb-scissor-x ,fb)) + (,old-y (fb-scissor-y ,fb)) + (,old-w (fb-scissor-w ,fb)) + (,old-h (fb-scissor-h ,fb))) + (setf (fb-scissor-x ,fb) ,x + (fb-scissor-y ,fb) ,y + (fb-scissor-w ,fb) ,w + (fb-scissor-h ,fb) ,h) + (unwind-protect (progn ,@body) + (setf (fb-scissor-x ,fb) ,old-x + (fb-scissor-y ,fb) ,old-y + (fb-scissor-w ,fb) ,old-w + (fb-scissor-h ,fb) ,old-h))))) +#+END_SRC diff --git a/org/layout-engine.org b/org/layout-engine.org index d68b814..a8c02ac 100644 --- a/org/layout-engine.org +++ b/org/layout-engine.org @@ -1,6 +1,6 @@ -#+TITLE: cl-tui Layout Engine — v0.0.3 +#+TITLE: cl-tty Layout Engine — v0.0.3 #+STARTUP: content -#+FILETAGS: :cl-tui:layout:v0.0.3: +#+FILETAGS: :cl-tty:layout:v0.0.3: #+OPTIONS: ^:nil * Layout Engine @@ -85,10 +85,10 @@ means a full Yoga FFI binding is unnecessary — ~200 lines of CL math. ** Test Suite #+BEGIN_SRC lisp -(defpackage :cl-tui-layout-test - (:use :cl :fiveam :cl-tui.layout) +(defpackage :cl-tty-layout-test + (:use :cl :fiveam :cl-tty.layout) (:export #:run-tests)) -(in-package :cl-tui-layout-test) +(in-package :cl-tty-layout-test) (def-suite layout-suite :description "Layout engine tests") (in-suite layout-suite) @@ -288,7 +288,7 @@ means a full Yoga FFI binding is unnecessary — ~200 lines of CL math. *** Package #+BEGIN_SRC lisp -(defpackage :cl-tui.layout +(defpackage :cl-tty.layout (:use :cl) (:export ;; Classes @@ -306,7 +306,7 @@ means a full Yoga FFI binding is unnecessary — ~200 lines of CL math. #:compute-layout ;; Macros #:vbox #:hbox #:spacer)) -(in-package :cl-tui.layout) +(in-package :cl-tty.layout) #+END_SRC *** Layout Node Class @@ -337,11 +337,11 @@ means a full Yoga FFI binding is unnecessary — ~200 lines of CL math. (justify-content :initform :flex-start :initarg :justify-content :accessor layout-node-justify-content) ;; Box model - (padding :initform '(:top 0 :right 0 :bottom 0 :left 0) + (padding :initform (list :top 0 :right 0 :bottom 0 :left 0) :initarg :padding :accessor layout-node-padding) - (margin :initform '(:top 0 :right 0 :bottom 0 :left 0) + (margin :initform (list :top 0 :right 0 :bottom 0 :left 0) :initarg :margin :accessor layout-node-margin) - (border :initform '(:top 0 :right 0 :bottom 0 :left 0) + (border :initform (list :top 0 :right 0 :bottom 0 :left 0) :initarg :border :accessor layout-node-border) (gap :initform 0 :initarg :gap :accessor layout-node-gap) ;; Position @@ -383,10 +383,12 @@ means a full Yoga FFI binding is unnecessary — ~200 lines of CL math. (defun normalize-box (spec) "Convert a box property spec to ( :top N :right N :bottom N :left N )." - (cond ((null spec) '(:top 0 :right 0 :bottom 0 :left 0)) - ((numberp spec) `(:top ,spec :right ,spec :bottom ,spec :left ,spec)) - ((getf spec :top) spec) - (t `(:top 0 :right 0 :bottom 0 :left 0)))) + (cond ((null spec) (list :top 0 :right 0 :bottom 0 :left 0)) + ((numberp spec) (list :top spec :right spec :bottom spec :left spec)) + (t (loop with result = (list :top 0 :right 0 :bottom 0 :left 0) + for (key val) on spec by #'cddr + do (setf (getf result key) val) + finally (return result))))) #+END_SRC *** Tree Manipulation diff --git a/org/markdown-renderer.org b/org/markdown-renderer.org new file mode 100644 index 0000000..0470031 --- /dev/null +++ b/org/markdown-renderer.org @@ -0,0 +1,500 @@ +#+TITLE: Markdown + Code + Diff Rendering (v0.8.0) +#+DATE: 2026-05-11 +#+AUTHOR: Amr Gharbeia / Hermes + +* Overview + +This module provides rendering of Markdown text, syntax-highlighted code +blocks, and unified diffs in the terminal. It completes the rendering +pipeline so that [[file:render.org][the render tree]] can handle rich formatted +content. + +The Markdown renderer is /not/ a general-purpose MD-to-HTML converter. +It targets TUI output: node types that have clear terminal analogues +(headings → bold/bright, code blocks → monochrome block, bold → ANSI +bold, etc.). Edge cases that matter for a terminal (long lines, escape +sequences inside code, mixed formatting) are handled explicitly. + +** Design decisions + +1. /Two-phase parse/: block-level first (lines), then inline (characters + within each block). This matches how terminals render — block layout + first, style within. +2. /Syntax highlighting by keyword set/: not a full lexer. A lookup + table of language → (keywords, types, builtins) sets. Catches ~90% + of highlighting cases without pulling in a parser. Fails safe + (unmatched tokens render as plain text). +3. /Diff lines are self-describing/: a diff block starts with ─── or + +++, each line has a ± prefix. We don't re-parse patch semantics; + we just color by prefix. This makes the renderer tolerant of + malformed diffs. +4. /No recursive descent parser/: a simple state machine over lines for + block-level, and a character cursor for inline. Keeps the code + short and avoids parser-generator dependencies. + +* Code structure + +** Node types + +We represent the parsed document as a tree of plists. Each node has at +least a `:type` key. Block-level nodes carry a `:children` list of +inline nodes. This keeps the data structure simple — no class hierarchy, +no generic dispatch — while being easy to traverse for rendering. + +Node types: + +| Block-level | Inline | +|------------------+--------------------| +| `:heading` | `:text` | +| `:paragraph` | `:bold` | +| `:code-block` | `:italic` | +| `:blockquote` | `:inline-code` | +| `:list-item` | `:link` | +| `:ordered-item` | | +| `:thematic-break`| | +| `:diff-block` | | + +--- per-function: markdown-node-make + +~make-md-node~ is a convenience constructor for node plists. +It ensures `:children` defaults to NIL (not an empty list) so +renderers can check `(if children ...)` without testing `(when +children ...)` vs `(if (null children) ...)`. + +#+BEGIN_SRC lisp :tangle no +(defun make-md-node (type &key children properties) + "Create a markdown node plist. +TYPE is a keyword like :heading or :bold. +CHILDREN is a list of inline node plists (or NIL). +PROPERTIES is a plist of node-specific extra keys (e.g. :level for headings)." + (let ((node (list :type type))) + (when children + (setf (getf node :children) children)) + (when properties + (setf (getf node :properties) properties)) + node)) +#+END_SRC + +--- per-function: markdown-node-p + +~md-node-p~ checks whether something is a markdown node plist. +We just look for a :type key. This is used in tests and as +a guard in recursive renderers. + +#+BEGIN_SRC lisp :tangle no +(defun md-node-p (thing) + "Return T if THING is a markdown node (has a :type key)." + (and (listp thing) (getf thing :type))) +#+END_SRC + +--- per-function: markdown-node-text + +~md-node-text~ extracts the plain text from a node tree by +concatenating all :text children recursively, discarding markup. +This is useful for things like heading anchors, tooltip strings, +or search indexing. + +#+BEGIN_SRC lisp :tangle no +(defun md-node-text (node) + "Recursively extract plain text from a markdown node tree." + (let ((type (getf node :type))) + (cond ((eql type :text) + (or (getf node :content) "")) + ((eql type :link) + (concatenate 'string + (md-node-text (first (getf node :children))) + (format nil " (~a)" (or (getf node :url) "")))) + ((getf node :children) + (apply #'concatenate 'string + (mapcar #'md-node-text (getf node :children)))) + (t "")))) +#+END_SRC + +** Block-level parser + +The block parser operates line-by-line with a simple state machine. +Each line is classified by its prefix characters, then accumulated +into a node. + +Rules: +- Lines starting with `#` → heading (count hashes for level) +- Lines starting with `>` → blockquote (continuation lines merge) +- Lines starting with `-`, `*`, or `+` → list-item +- Lines starting with 1-3 digits followed by `.` → ordered-item +- Lines starting with `` ``` `` → code-block (language on opening line) +- Lines starting with `---` or `***` → thematic-break +- Lines starting with `--- ` or `+++ ` → diff-block +- Empty lines → paragraph boundary +- Everything else → paragraph (continuation lines merge until blank) + +--- per-function: classify-line + +~classify-line~ returns a keyword and a data value for a trimmed +line of text. The state machine uses this to decide what kind of +block to create or continue. + +The function must handle prefix stripping (e.g. remove `# ` after +counting hashes) and edge cases like `#` inside a code block (which +we don't classify at all — the code block state machine handles that). + +One trap: a line like `#not-a-heading` (no space after hash) is NOT +a heading in CommonMark. We check for space/tab after the hashes. + +Another trap: `* item` in a list vs `**bold**` inline. At the +block-parser level we only look at /line-start/ `* ` (star + space) +for list items. A line starting with `** text` could be either a +nested list item or bold text in a paragraph — we conservatively +treat it as a list-item (the inline parser will handle ** inside +paragraphs normally). + +#+BEGIN_SRC lisp :tangle no +(defun classify-line (line) + "Classify a trimmed LINE, returning (type . data). +TYPE is a keyword; DATA is language for code-blocks, level for headings, etc." + (cond + ;; Empty line + ((string= line "") (cons :blank nil)) + ;; Thematic break: --- or *** (3+ chars, all same, optional whitespace) + ((and (>= (length line) 3) + (every (lambda (c) (or (char= c (char line 0)) + (char= c #\Space) + (char= c #\Tab))) + line) + (find (char line 0) "-*")) + (cons :thematic-break nil)) + ;; Heading: #+, with space after hashes + ((and (char= (char line 0) #\#) + (let ((count 0)) + (loop for c across line + while (char= c #\#) + do (incf count)) + (and (<= 1 count 6) + (or (>= (length line) (1+ count)) + (member (char line count) '(#\Space #\Tab)))))) + (let* ((hash-count (loop for c across line while (char= c #\#) count c)) + (content (string-trim (list #\Space #\Tab) + (subseq line hash-count)))) + (cons :heading (cons hash-count content)))) + ;; Blockquote: > + ((and (>= (length line) 1) (char= (char line 0) #\>)) + (let ((content (string-trim (list #\Space #\Tab) + (subseq line 1)))) + (cons :blockquote content))) + ;; Unordered list: -, *, + + ((and (>= (length line) 2) + (find (char line 0) "-*+") + (char= (char line 1) #\Space)) + (cons :list-item (string-trim (list #\Space #\Tab) (subseq line 2)))) + ;; Ordered list: N. or N) + ((and (>= (length line) 3) + (digit-char-p (char line 0)) + (loop for c across line + while (digit-char-p c) + finally (return (find c '(#\. #\) #\Space))))) + (let ((dot-pos (position-if (lambda (c) (find c ". )")) line))) + (if (and dot-pos (find (char line dot-pos) ". )")) + (cons :ordered-item (string-trim (list #\Space #\Tab) + (subseq line (1+ dot-pos)))) + (cons :paragraph line)))) + ;; Diff: --- file or +++ file + ((and (>= (length line) 4) + (find (char line 0) "-+") + (char= (char line 1) (char line 0)) + (char= (char line 2) (char line 0)) + (char= (char line 3) #\Space)) + (cons :diff-header line)) + ;; Diff: line content with +/- prefix + ((and (>= (length line) 1) + (find (char line 0) "-+") + (not (and (>= (length line) 3) + (char= (char line 1) (char line 0)) + (char= (char line 2) (char line 0))))) + (cons :diff-line (cons (char line 0) (subseq line 1)))) + ;; Fenced code block start: ``` or ~~~ + ((and (>= (length line) 3) + (find (char line 0) "`~") + (every (lambda (c) (char= c (char line 0))) + (subseq line 0 (min 6 (length line)))) + (let ((rest (string-trim (list #\Space #\Tab) (subseq line (min 6 (length line)))))) + (cons :code-start rest)))) + ;; Default: paragraph content + (t (cons :paragraph line)))) +#+END_SRC + +--- per-function: parse-blocks + +~parse-blocks~ is the main block-level parser. It takes a string +(possibly multi-line) and returns a list of markdown node plists. + +The algorithm: +1. Split into lines +2. Classify each line +3. Accumulate lines of the same type into groups +4. Convert each group into a node + +State transitions: +- `:paragraph` accumulates until blank line or different block type +- `:blockquote` accumulates until blank line +- `:list-item` and `:ordered-item` accumulate until blank line +- `:code-start` flips to code-block mode; accumulates until matching + fence closer or end of input +- `:diff-header` starts a diff block; diff lines accumulate until + blank line or non-diff line + +Edge case: a paragraph followed by a list item should stay as +separate blocks (not merge). The blank-line check handles this +because the paragraph only continues for non-blank, non-list lines. + +#+BEGIN_SRC lisp :tangle no +(defun parse-blocks (text) + "Parse TEXT (a string) into a list of block-level markdown node plists. +Returns (nodes . unconsumed-lines) for recursive callers." + (let ((lines (split-string-into-lines text)) + (nodes nil) + (i 0)) + (loop while (< i (length lines)) + do (let* ((line (string-trim (list #\return) (aref lines i))) + (classification (classify-line line))) + (case (car classification) + (:blank (incf i)) + (:thematic-break + (push (make-md-node :thematic-break) nodes) + (incf i)) + (:paragraph + (multiple-value-bind (node consumed) + (parse-paragraph lines i) + (push node nodes) + (setf i consumed))) + (:heading + (let* ((level-and-content (cdr classification)) + (level (car level-and-content)) + (content (cdr level-and-content))) + (push (make-md-node :heading + :properties (list :level level) + :children (parse-inline content)) + nodes) + (incf i))) + (:blockquote + (multiple-value-bind (node consumed) + (parse-blockquote lines i) + (push node nodes) + (setf i consumed))) + (:list-item + (multiple-value-bind (node consumed) + (parse-list lines i :unordered) + (push node nodes) + (setf i consumed))) + (:ordered-item + (multiple-value-bind (node consumed) + (parse-list lines i :ordered) + (push node nodes) + (setf i consumed))) + (:code-start + (multiple-value-bind (node consumed) + (parse-code-block lines i (cdr classification)) + (push node nodes) + (setf i consumed))) + (:diff-header + (multiple-value-bind (node consumed) + (parse-diff-block lines i) + (push node nodes) + (setf i consumed))) + (t (incf i))))) + ;; Return in reading order + (nreverse nodes))) +#+END_SRC + +--- per-function: split-string-into-lines + +~split-string-into-lines~ is a utility rather than relying on +~cl-ppcre~ (which we don't depend on). It splits on #\Newline +and handles the edge case of trailing newlines (doesn't produce +an extra empty line at the end). + +#+BEGIN_SRC lisp :tangle no +(defun split-string-into-lines (string) + "Split STRING into a vector of lines (no trailing newline). +Handles \\n, \\r\\n, and trailing newlines properly." + (let ((result nil) + (start 0)) + (flet ((add-line (end) + (push (subseq string start end) result))) + (loop for i from 0 below (length string) + do (let ((c (char string i))) + (cond ((char= c #\Newline) + (add-line i) + (setf start (1+ i))) + ((and (char= c #\Return) + (< (1+ i) (length string)) + (char= (char string (1+ i)) #\Newline)) + (add-line i) + (setf start (+ i 2)) + (incf i))))) + (when (< start (length string)) + (add-line (length string))) + (coerce (nreverse result) 'vector)))) +#+END_SRC + +--- per-function: parse-paragraph + +~parse-paragraph~ collects one or more contiguous paragraph lines +until a blank line or a different block type. It joins them with +spaces (for hard-wrapped prose) and returns a :paragraph node +with inline-parsed children. + +Continuation lines in paragraphs are joined with a single space +(not a newline). This is correct for Markdown's soft-wrap +convention where a newline in source = space in output. To force +a hard break, CommonMark uses two trailing spaces — we skip that +for now since it's rare in TUI contexts. + +#+BEGIN_SRC lisp :tangle no +(defun parse-paragraph (lines start) + "Parse contiguous paragraph lines from LINES starting at START. +Returns (node . consumed-index)." + (let ((text-parts nil) + (i start)) + (loop while (< i (length lines)) + do (let* ((raw-line (aref lines i)) + (line (string-trim (list #\return) raw-line)) + (class (classify-line line))) + (case (car class) + ((:paragraph) + (push (cdr class) text-parts) + (incf i)) + (:blank (incf i) (loop-finish)) + (t (loop-finish))))) + (let ((text (with-output-to-string (s) + (loop for part in (nreverse text-parts) + for first = t then nil + do (unless first (write-char #\Space s)) + (princ part s))))) + (cons (make-md-node :paragraph + :children (parse-inline text)) + i)))) +#+END_SRC + +--- per-function: parse-blockquote + +~parse-blockquote~ collects contiguous `>` lines, strips the `>` +prefix, joins them, and wraps in a :blockquote node. Nested +blockquotes (`> >`) are not supported in this version — a `>` at +the start of the content is treated as literal text. + +#+BEGIN_SRC lisp :tangle no +(defun parse-blockquote (lines start) + "Parse contiguous blockquote lines from LINES starting at START. +Returns (node . consumed-index)." + (let ((text-parts nil) + (i start)) + (loop while (< i (length lines)) + do (let* ((raw-line (aref lines i)) + (line (string-trim (list #\return) raw-line)) + (class (classify-line line))) + (case (car class) + (:blockquote + (push (cdr class) text-parts) + (incf i)) + (:blank (incf i) (loop-finish)) + (t (loop-finish))))) + (let ((text (with-output-to-string (s) + (loop for part in (nreverse text-parts) + for first = t then nil + do (unless first (write-char #\Space s)) + (princ part s))))) + (cons (make-md-node :blockquote + :children (parse-inline text)) + i)))) +#+END_SRC + +--- per-function: parse-list + +~parse-list~ collects contiguous list items (same type) and returns +a list of nodes. Each line starting with a list marker becomes one +list-item node. Nested lists are not supported (lines starting with +two spaces + marker would be the next level — we skip that for v1). + +The TYPE parameter is either `:unordered` or `:ordered` — though +we return each item labeled by its actual marker type since we +already classified each line. + +#+BEGIN_SRC lisp :tangle no +(defun parse-list (lines start type) + "Parse contiguous list items from LINES starting at START. +TYPE is :unordered or :ordered. +Returns (node . consumed-index) where node is a :list-item or :ordered-item." + (declare (ignore type)) + (let ((items nil) + (i start)) + ;; Collect all contiguous list items into ITEMS + (loop while (< i (length lines)) + do (let* ((raw-line (aref lines i)) + (line (string-trim (list #\return) raw-line)) + (class (classify-line line))) + (case (car class) + ((:list-item :ordered-item) + (push (cons (car class) (cdr class)) items) + (incf i)) + (:blank + ;; One blank line between items is OK; two ends the list + (if (and (< (1+ i) (length lines)) + (let ((next-class (classify-line + (string-trim + (list #\return) + (aref lines (1+ i)))))) + (member (car next-class) + '(:list-item :ordered-item)))) + (progn + (push (cons :blank-sep nil) items) + (incf i)) + (progn (incf i) (loop-finish)))) + (t (loop-finish))))) + ;; Convert each item to a node + (let ((nodes nil)) + (dolist (item (nreverse items)) + (let ((type (car item)) + (content (cdr item))) + (when (and content (not (string= content ""))) + (push (make-md-node type + :children (parse-inline content)) + nodes)))) + (cons (nreverse nodes) i)))) +#+END_SRC + +--- per-function: parse-code-block + +~parse-code-block~ reads from the line after the opening fence to +the closing fence (or end of input). It returns a :code-block node +with the language (or NIL) and the raw text as the :content. No +inline parsing is done inside code blocks — everything is literal. + +Matching fence: if opened with `` ``` ``, close with `` ``` ``. +If opened with `~~~`, close with `~~~`. The closing fence must have +at least as many backticks/tildes as the opening fence (CommonMark +rule). We use the simpler version: same character, same count. + +#+BEGIN_SRC lisp :tangle no +(defun parse-code-block (lines start lang) + "Parse a fenced code block from LINES starting at START. +LANG is the language string (or empty string) from the opening fence. +Returns (node . consumed-index)." + (let ((code-lines nil) + (i (1+ start)) + (fence-char (char (aref lines start) 0)) + (fence-len (loop for c across (aref lines start) + while (char= c (char (aref lines start) 0)) + count c)) + (found-close nil)) + (loop while (< i (length lines)) + do (let* ((raw-line (aref lines i)) + (line (string-trim (list #\return) raw-line))) + ;; Check for closing fence + (when (and (>= (length line) fence-len) + (every (lambda (c) (char= c fence-char)) + (subseq line 0 fence-len)) + (or (= (length line) fence-len) + (every (lambda (c) (find c " \t")) + (subseq line fence-len)))) + (setf found-close t) + (incf i) + (loop-finish)) diff --git a/org/modern-backend.org b/org/modern-backend.org index 84a8854..ff12a70 100644 --- a/org/modern-backend.org +++ b/org/modern-backend.org @@ -1,6 +1,6 @@ -#+TITLE: cl-tui Modern Backend — v0.0.2 +#+TITLE: cl-tty Modern Backend — v0.0.2 #+STARTUP: content -#+FILETAGS: :cl-tui:backend:v0.0.2: +#+FILETAGS: :cl-tty:backend:v0.0.2: #+OPTIONS: ^:nil * Modern Backend @@ -40,10 +40,10 @@ Colors are resolved through a palette before emission: ** Test Suite #+BEGIN_SRC lisp -(defpackage :cl-tui-modern-backend-test - (:use :cl :fiveam :cl-tui.backend) +(defpackage :cl-tty-modern-backend-test + (:use :cl :fiveam :cl-tty.backend) (:export #:run-tests)) -(in-package :cl-tui-modern-backend-test) +(in-package :cl-tty-modern-backend-test) (def-suite modern-backend-suite :description "Modern backend tests") (in-suite modern-backend-suite) @@ -58,72 +58,72 @@ Colors are resolved through a palette before emission: (test make-modern-backend-creates "make-modern-backend returns a modern-backend instance" (let ((b (make-modern-backend))) - (is (typep b 'cl-tui.backend::modern-backend)))) + (is (typep b 'cl-tty.backend::modern-backend)))) ;; ── Escape Generation ────────────────────────────────────────── (test sgr-truecolor-foreground "SGR truecolor foreground escape is correct" - (is (equal (cl-tui.backend::sgr-fg "#FFD700") + (is (equal (cl-tty.backend::sgr-fg "#FFD700") (format nil "~C[38;2;255;215;0m" #\Esc)))) (test sgr-truecolor-background "SGR truecolor background escape is correct" - (is (equal (cl-tui.backend::sgr-bg "#1a1b26") + (is (equal (cl-tty.backend::sgr-bg "#1a1b26") (format nil "~C[48;2;26;27;38m" #\Esc)))) (test sgr-named-colors "SGR named colors resolve to 8-color codes" - (is (equal (cl-tui.backend::sgr-fg :red) + (is (equal (cl-tty.backend::sgr-fg :red) (format nil "~C[31m" #\Esc))) - (is (equal (cl-tui.backend::sgr-bg :blue) + (is (equal (cl-tty.backend::sgr-bg :blue) (format nil "~C[44m" #\Esc)))) (test sgr-bold-italic "SGR attribute escapes are correct" - (is (equal (cl-tui.backend::sgr-attr :bold) (format nil "~C[1m" #\Esc))) - (is (equal (cl-tui.backend::sgr-attr :italic) (format nil "~C[3m" #\Esc))) - (is (equal (cl-tui.backend::sgr-attr :underline) (format nil "~C[4m" #\Esc))) - (is (equal (cl-tui.backend::sgr-attr :reset) (format nil "~C[0m" #\Esc)))) + (is (equal (cl-tty.backend::sgr-attr :bold) (format nil "~C[1m" #\Esc))) + (is (equal (cl-tty.backend::sgr-attr :italic) (format nil "~C[3m" #\Esc))) + (is (equal (cl-tty.backend::sgr-attr :underline) (format nil "~C[4m" #\Esc))) + (is (equal (cl-tty.backend::sgr-attr :reset) (format nil "~C[0m" #\Esc)))) ;; ── Cursor ───────────────────────────────────────────────────── (test cursor-move-escape "cursor-move generates correct CSI escape" (let ((b (make-modern-backend))) - (is (equal (cl-tui.backend::cursor-move-escape 5 10) + (is (equal (cl-tty.backend::cursor-move-escape 5 10) (format nil "~C[6;11H" #\Esc))))) (test cursor-style-block "cursor-style :block generate correct escape" (let ((b (make-modern-backend))) - (is (equal (cl-tui.backend::cursor-style-escape :block nil) + (is (equal (cl-tty.backend::cursor-style-escape :block nil) (format nil "~C[2 q" #\Esc))))) (test cursor-style-bar "cursor-style :bar generate correct escape" (let ((b (make-modern-backend))) - (is (equal (cl-tui.backend::cursor-style-escape :bar nil) + (is (equal (cl-tty.backend::cursor-style-escape :bar nil) (format nil "~C[6 q" #\Esc))))) (test cursor-style-underline-blink "cursor-style :underline with blink" (let ((b (make-modern-backend))) - (is (equal (cl-tui.backend::cursor-style-escape :underline t) + (is (equal (cl-tty.backend::cursor-style-escape :underline t) (format nil "~C[5 q" #\Esc))))) ;; ── Synchronization ──────────────────────────────────────────── (test decicm-escapes "DECICM synchronized update escapes" - (is (equal (cl-tui.backend::decicm-begin) (format nil "~C[?2026h" #\Esc))) - (is (equal (cl-tui.backend::decicm-end) (format nil "~C[?2026l" #\Esc)))) + (is (equal (cl-tty.backend::decicm-begin) (format nil "~C[?2026h" #\Esc))) + (is (equal (cl-tty.backend::decicm-end) (format nil "~C[?2026l" #\Esc)))) ;; ── OSC 8 Hyperlinks ────────────────────────────────────────── (test osc8-escape "OSC 8 hyperlink escape wraps text" - (is (equal (cl-tui.backend::osc8-link "http://example.com" "click here") + (is (equal (cl-tty.backend::osc8-link "http://example.com" "click here") (format nil "~C]8;;http://example.com~C\\click here~C]8;;~C\\" #\Esc #\Esc #\Esc #\Esc)))) @@ -131,21 +131,21 @@ Colors are resolved through a palette before emission: (test hex-color-parsing "hex-to-rgb parses valid hex colors" - (multiple-value-bind (r g b) (cl-tui.backend::hex-to-rgb "#FFD700") + (multiple-value-bind (r g b) (cl-tty.backend::hex-to-rgb "#FFD700") (is (= r 255)) (is (= g 215)) (is (= b 0)))) (test hex-color-black "hex-to-rgb parses black" - (multiple-value-bind (r g b) (cl-tui.backend::hex-to-rgb "#000000") + (multiple-value-bind (r g b) (cl-tty.backend::hex-to-rgb "#000000") (is (= r 0)) (is (= g 0)) (is (= b 0)))) (test hex-color-short-form "hex-to-rgb parses 3-digit hex" - (multiple-value-bind (r g b) (cl-tui.backend::hex-to-rgb "#F00") + (multiple-value-bind (r g b) (cl-tty.backend::hex-to-rgb "#F00") (is (= r 255)) (is (= g 0)) (is (= b 0)))) @@ -154,23 +154,23 @@ Colors are resolved through a palette before emission: (test border-char-rounded "modern-border-char returns Unicode box-drawing for rounded style" - (is (equal (cl-tui.backend::border-char :rounded :top-left) "╭")) - (is (equal (cl-tui.backend::border-char :rounded :horizontal) "─")) - (is (equal (cl-tui.backend::border-char :rounded :vertical) "│")) - (is (equal (cl-tui.backend::border-char :rounded :bottom-right) "╯"))) + (is (equal (cl-tty.backend::border-char :rounded :top-left) "╭")) + (is (equal (cl-tty.backend::border-char :rounded :horizontal) "─")) + (is (equal (cl-tty.backend::border-char :rounded :vertical) "│")) + (is (equal (cl-tty.backend::border-char :rounded :bottom-right) "╯"))) (test border-char-double "modern-border-char returns double-line chars" - (is (equal (cl-tui.backend::border-char :double :top-left) "╔")) - (is (equal (cl-tui.backend::border-char :double :horizontal) "═")) - (is (equal (cl-tui.backend::border-char :double :vertical) "║"))) + (is (equal (cl-tty.backend::border-char :double :top-left) "╔")) + (is (equal (cl-tty.backend::border-char :double :horizontal) "═")) + (is (equal (cl-tty.backend::border-char :double :vertical) "║"))) #+END_SRC ** Implementation *** Package -Add to =cl-tui.backend= package: +Add to =cl-tty.backend= package: #+BEGIN_SRC lisp ;; In package.lisp, add to :export: @@ -179,7 +179,7 @@ Add to =cl-tui.backend= package: ;; sgr-fg sgr-bg sgr-attr cursor-move-escape cursor-style-escape ;; decicm-begin decicm-end osc8-link hex-to-rgb border-char -(in-package :cl-tui.backend) +(in-package :cl-tty.backend) #+END_SRC *** Color Resolution diff --git a/org/mouse.org b/org/mouse.org new file mode 100644 index 0000000..701c51f --- /dev/null +++ b/org/mouse.org @@ -0,0 +1,205 @@ +#+TITLE: Mouse Support (v0.10.0) +#+DATE: 2026-05-11 +#+AUTHOR: Amr Gharbeia / Hermes + +* Overview + +Mouse event propagation through the component tree. The input system +already parses SGR mouse sequences into ~mouse-event~ structs. This +module adds: + +1. A ~mouse-mixin~ class with event handler slots +2. Hit-testing: given (x,y), find the deepest component owning that cell +3. Event dispatch: route ~mouse-event~ → component handlers, bubble up +4. ScrollBox integration: wheel → scroll +5. Text selection: drag highlight + clipboard copy + +** Contract + +- ~mouse-mixin~ — mixin class with ~:on-mouse-down/up/move/scroll~ slots +- ~handle-mouse-event component event~ — dispatch to the right handler +- ~hit-test root x y~ → deepest component at (x,y) +- ~selection~ — highlighted text region (start-x, start-y, end-x, end-y) +- ~get-selection~ → selected text as string +- ~copy-to-clipboard text~ → pipe to xclip/wl-copy + +** Code + +#+BEGIN_SRC lisp :tangle ../src/components/mouse-package.lisp :noweb no +(defpackage :cl-tty.mouse + (:use :cl :cl-tty.input :cl-tty.box :cl-tty.rendering) + (:export + #:mouse-mixin + #:on-mouse-down #:on-mouse-up #:on-mouse-move #:on-mouse-scroll + #:handle-mouse-event + #:hit-test + #:selection #:get-selection #:copy-to-clipboard + #:make-selection #:selection-p + #:start-selection #:update-selection #:finalize-selection + #:selection-active-p + #:cell-link-at #:open-link-at)) +#+END_SRC + +#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no +(in-package :cl-tty.mouse) + +(defclass mouse-mixin () + ((on-mouse-down :initarg :on-mouse-down :initform nil :accessor on-mouse-down) + (on-mouse-up :initarg :on-mouse-up :initform nil :accessor on-mouse-up) + (on-mouse-move :initarg :on-mouse-move :initform nil :accessor on-mouse-move) + (on-mouse-scroll :initarg :on-mouse-scroll :initform nil :accessor on-mouse-scroll))) + +(defun handle-mouse-event (component event) + (let* ((type (mouse-event-type event)) + (handler (case type + (:press (on-mouse-down component)) + (:release (on-mouse-up component)) + (:drag (on-mouse-move component)) + (t nil)))) + (when handler (funcall handler event)))) + +(defun hit-test (root x y) + "Find the deepest component at (X, Y) by testing layout-node bounds. +Recurses into component-children to find the innermost match. +Components without a layout-node or position return nil." + (labels ((recurse (node) + (let ((ln (ignore-errors (component-layout-node node))) + (best nil)) + (when ln + (let ((nx (layout-node-x ln)) + (ny (layout-node-y ln)) + (nw (layout-node-width ln)) + (nh (layout-node-height ln))) + ;; Check children first for deeper match + (dolist (child (ignore-errors (component-children node))) + (let ((child-hit (recurse child))) + (when child-hit + (setf best child-hit)))) + ;; If no child matched, check self + (or best + (when (and (>= x nx) (< x (+ nx nw)) + (>= y ny) (< y (+ ny nh))) + node))))))) + (recurse root))) + +;; Selection +(defvar *selection* nil) + +(defstruct (selection (:conc-name sel-)) + (start-x 0) (start-y 0) (end-x 0) (end-y 0) (text "")) + +(defun get-selection () + (when *selection* (sel-text *selection*))) + +(defun copy-to-clipboard (text) + #+linux (sb-ext:run-program "xclip" (list "-selection" "clipboard") + :input text :wait nil) + #+darwin (sb-ext:run-program "pbcopy" nil :input text :wait nil)) + +;;; --- Selection tracking (mouse drag) --------------------------------------- + +(defvar *selection-active* nil + "T when a drag selection is in progress.") + +(defvar *selection-start* nil + "Cons (X . Y) of mouse-down position during drag.") + +(defvar *selection-end* nil + "Cons (X . Y) of current mouse position during drag.") + +(defun start-selection (x y) + "Begin a drag selection at (X Y)." + (setf *selection-start* (cons x y) + *selection-end* (cons x y) + *selection-active* t)) + +(defun update-selection (x y) + "Update the drag selection end position to (X Y)." + (setf *selection-end* (cons x y))) + +(defun selection-active-p () + "Return T if a drag selection is in progress." + *selection-active*) + +(defun finalize-selection (fb) + "End the drag selection and extract text from the framebuffer." + (setf *selection-active* nil) + (when (and *selection-start* *selection-end* fb) + (let* ((x1 (car *selection-start*)) + (y1 (cdr *selection-start*)) + (x2 (car *selection-end*)) + (y2 (cdr *selection-end*)) + (text (cl-tty.rendering:extract-text fb x1 y1 x2 y2))) + (setf *selection* (make-selection :start-x x1 :start-y y1 + :end-x x2 :end-y y2 + :text text)) + (setf *selection-start* nil *selection-end* nil) + text))) + +;;; --- Link clicking --------------------------------------------------------- + +(defun cell-link-at (fb x y) + "Return the link URL at (X Y) in framebuffer FB, or nil." + (cl-tty.rendering:fb-cell-link-url fb x y)) + +(defun open-link-at (fb x y) + "If there is a link URL at (X Y) in FB, open it via xdg-open." + (let ((url (cell-link-at fb x y))) + (when url + #+linux (sb-ext:run-program "xdg-open" (list url) :wait nil) + #+darwin (sb-ext:run-program "open" (list url) :wait nil)) + url)) +#+END_SRC + +#+BEGIN_SRC lisp :tangle ../tests/mouse-tests.lisp :noweb no +(defpackage :cl-tty-mouse-test (:use :cl :cl-tty.mouse :fiveam)) +(in-package :cl-tty-mouse-test) + +(def-suite mouse-suite :description "Mouse tests") +(in-suite mouse-suite) + +(def-test mouse-mixin-create () + (let ((m (make-instance 'mouse-mixin))) + (is-true (typep m 'mouse-mixin)))) + +(def-test mouse-hit-test-point () + "hit-test returns nil when no component has position slots bound" + (let ((obj (make-instance 'mouse-mixin))) + (is-false (hit-test obj 0 0)) + (is-false (hit-test obj 100 100)))) + +(def-test selection-set-and-get () + (setf cl-tty.mouse::*selection* (make-selection :text "hello")) + (is (equal "hello" (get-selection)))) + +;; ── Selection tracking ────────────────────────────────────── + +(def-test start-selection-initializes-state () + (start-selection 5 10) + (is-true (selection-active-p)) + (is (equal '(5 . 10) cl-tty.mouse::*selection-start*)) + (is (equal '(5 . 10) cl-tty.mouse::*selection-end*)) + (setf cl-tty.mouse::*selection-active* nil + cl-tty.mouse::*selection-start* nil + cl-tty.mouse::*selection-end* nil)) + +(def-test update-selection-moves-end () + (start-selection 0 0) + (update-selection 3 7) + (is (equal '(3 . 7) cl-tty.mouse::*selection-end*)) + (setf cl-tty.mouse::*selection-active* nil + cl-tty.mouse::*selection-start* nil + cl-tty.mouse::*selection-end* nil)) + +(def-test finalize-selection-extracts-text () + (let* ((fb-be (cl-tty.rendering:make-framebuffer-backend)) + (fb (cl-tty.rendering:fb-framebuffer fb-be))) + (cl-tty.backend:draw-text fb-be 0 0 "hello" nil nil) + (cl-tty.backend:draw-text fb-be 0 1 "world" nil nil) + (start-selection 0 0) + (update-selection 4 1) + (let ((text (finalize-selection fb))) + (is (equal "hello +world" text))))) + +#+END_SRC \ No newline at end of file diff --git a/org/scrollbox-tabbar.org b/org/scrollbox-tabbar.org index 5821688..9a1de21 100644 --- a/org/scrollbox-tabbar.org +++ b/org/scrollbox-tabbar.org @@ -1,4 +1,4 @@ -#+TITLE: cl-tui v0.6.0 — ScrollBox + TabBar +#+TITLE: cl-tty v0.6.0 — ScrollBox + TabBar #+STARTUP: content * ScrollBox and TabBar @@ -47,10 +47,10 @@ TabBar: ** Tests #+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp -(defpackage :cl-tui-scrollbox-test - (:use :cl :fiveam :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.input :cl-tui.container) +(defpackage :cl-tty-scrollbox-test + (:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input :cl-tty.container) (:export #:run-tests)) -(in-package #:cl-tui-scrollbox-test) +(in-package #:cl-tty-scrollbox-test) (def-suite scrollbox-suite :description "ScrollBox + TabBar tests") (in-suite scrollbox-suite) @@ -182,8 +182,8 @@ TabBar: ** Package #+BEGIN_SRC lisp -(defpackage :cl-tui.container - (:use :cl :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.input) +(defpackage :cl-tty.container + (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) (:export ;; ScrollBox #:scroll-box #:make-scroll-box @@ -209,7 +209,7 @@ The constructor accepts keyword arguments for initial offset and children. ~children~ defaults to an empty list. #+BEGIN_SRC lisp -(in-package #:cl-tui.container) +(in-package #:cl-tty.container) (defclass scroll-box (dirty-mixin) ((children :initform nil :initarg :children @@ -319,38 +319,36 @@ when the user manually scrolls up. #+BEGIN_SRC lisp (defmethod render ((sb scroll-box) backend) - "Render visible children with scroll offset applied." + "Render visible children with scroll offset applied. +Delegates to each child's `render` method, temporarily offsetting +its layout-node position for the scroll offset. Children outside +the viewport are clipped out." (let* ((ln (scroll-box-layout-node sb)) - (vx 0) (vy 0) ;; viewport origin (parent position) + (vx 0) (vy 0) (vw (if ln (layout-node-width ln) 80)) (vh (if ln (layout-node-height ln) 24)) (sy (scroll-box-scroll-y sb)) (sx (scroll-box-scroll-x sb))) (dolist (child (scroll-box-children sb)) (let* ((cln (component-layout-node child)) - (cw (if cln (layout-node-width cln) 1)) (ch (if cln (layout-node-height cln) 1)) - ;; Child's position after scroll offset - (cx vx) (cy vy)) - (declare (ignore cx)) - ;; Only render if child intersects viewport vertically + ;; Only render children that are visible in the viewport (when (and (< (+ cy (- sy)) (+ vh vy)) (> (+ cy (- sy) ch) vy)) - (let ((old-ln (component-layout-node child))) - (when old-ln - ;; Temporarily adjust layout to account for scroll - (let ((new-ln (make-layout-node))) - (setf (layout-node-x new-ln) (- sx) - (layout-node-y new-ln) (- sy) - (layout-node-width new-ln) cw - (layout-node-height new-ln) ch) - ;; Use a captured-backend approach or just draw-text - (draw-text backend 0 (+ vy cy (- sy)) - (format nil "child at ~D" vy) - nil nil))))) - (incf vy ch)))) - (draw-scrollbars sb backend vw vh)) + ;; Temporarily offset child's layout-node position for rendering + (let ((orig-x (if cln (layout-node-x cln) 0)) + (orig-y (if cln (layout-node-y cln) 0))) + (when cln + (setf (layout-node-x cln) (- orig-x sx) + (layout-node-y cln) (- orig-y sy))) + (unwind-protect + (render child backend) + (when cln + (setf (layout-node-x cln) orig-x + (layout-node-y cln) orig-y))))) + (incf vy ch))) + (draw-scrollbars sb backend vw vh))) #+END_SRC ** ScrollBox: sticky scroll @@ -415,7 +413,7 @@ and the currently active tab id. ~tab-bar-add~ creates a new tab with the given id and title, returns the id. #+BEGIN_SRC lisp -(in-package #:cl-tui.container) +(in-package #:cl-tty.container) (defclass tab-bar (dirty-mixin) ((tabs :initform nil :initarg :tabs @@ -506,7 +504,8 @@ they are truncated with an ellipsis. #+BEGIN_SRC lisp (defmethod render ((tb tab-bar) backend) (let* ((ln (tab-bar-layout-node tb)) - (x 0) (y 0) + (x (if ln (layout-node-x ln) 0)) + (y (if ln (layout-node-y ln) 0)) (w (if ln (layout-node-width ln) 80)) (active-id (tab-bar-active tb)) (tabs (tab-bar-tabs tb)) @@ -532,7 +531,7 @@ they are truncated with an ellipsis. ** Combined tangle blocks #+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp -(in-package #:cl-tui.container) +(in-package #:cl-tty.container) (defclass scroll-box (dirty-mixin) ((children :initform nil :initarg :children :accessor scroll-box-children :type list) @@ -573,6 +572,8 @@ they are truncated with an ellipsis. :initial-value 0)) (defmethod render ((sb scroll-box) backend) + "Render ScrollBox children within the viewport, offset by scroll position. +Children outside the viewport are skipped." (let* ((ln (scroll-box-layout-node sb)) (vx 0) (vy 0) (vw (if ln (layout-node-width ln) 80)) @@ -583,9 +584,20 @@ they are truncated with an ellipsis. (let* ((cln (component-layout-node child)) (ch (if cln (layout-node-height cln) 1)) (cy vy)) - (when (and (< (+ cy (- sy)) (+ vh vy)) (> (+ cy (- sy) ch) vy)) - (draw-text backend (- sx) (+ vy cy (- sy)) - (format nil "child at ~D" vy) nil nil)) + ;; Only render children that are visible in the viewport + (when (and (< (+ cy (- sy)) (+ vh vy)) + (> (+ cy (- sy) ch) vy)) + ;; Temporarily offset child's layout-node position for rendering + (let ((orig-x (if cln (layout-node-x cln) 0)) + (orig-y (if cln (layout-node-y cln) 0))) + (when cln + (setf (layout-node-x cln) (- orig-x sx) + (layout-node-y cln) (- orig-y sy))) + (unwind-protect + (render child backend) + (when cln + (setf (layout-node-x cln) orig-x + (layout-node-y cln) orig-y))))) (incf vy ch))) (draw-scrollbars sb backend vw vh))) @@ -598,12 +610,12 @@ they are truncated with an ellipsis. (when (> content-h viewport-h) (let* ((thumb (scrollbar-thumb sy viewport-h content-h)) (thumb-pos (round (* thumb viewport-h)))) - (draw-rect backend (1- viewport-w) 0 1 viewport-h :bg :background-element) + (draw-rect backend (1- viewport-w) 0 1 viewport-h :bg :bright-black) (draw-text backend (1- viewport-w) thumb-pos "█" nil nil))) (when (> content-w viewport-w) (let* ((thumb (scrollbar-thumb sx viewport-w content-w)) (thumb-pos (round (* thumb viewport-w)))) - (draw-rect backend 0 (1- viewport-h) viewport-w 1 :bg :background-element) + (draw-rect backend 0 (1- viewport-h) viewport-w 1 :bg :bright-black) (draw-text backend thumb-pos (1- viewport-h) "█" nil nil))))) (defun update-sticky-scroll (sb) @@ -616,7 +628,7 @@ they are truncated with an ellipsis. #+END_SRC #+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp -(in-package #:cl-tui.container) +(in-package #:cl-tty.container) (defclass tab-bar (dirty-mixin) ((tabs :initform nil :initarg :tabs :accessor tab-bar-tabs :type list) @@ -653,9 +665,11 @@ they are truncated with an ellipsis. (case (key-event-key event) (:left (tab-bar-prev tb) t) (:right (tab-bar-next tb) t) (t nil))) (defmethod render ((tb tab-bar) backend) - (let* ((ln (tab-bar-layout-node tb)) (y 0) + (let* ((ln (tab-bar-layout-node tb)) + (x (if ln (layout-node-x ln) 0)) + (y (if ln (layout-node-y ln) 0)) (w (if ln (layout-node-width ln) 80)) - (active-id (tab-bar-active tb)) (tabs (tab-bar-tabs tb)) (x-pos 0)) + (active-id (tab-bar-active tb)) (tabs (tab-bar-tabs tb)) (x-pos x)) (dolist (tab tabs) (let* ((id (getf tab :id)) (title (getf tab :title)) (label (format nil " ~A " title)) (label-len (length label)) @@ -670,8 +684,8 @@ they are truncated with an ellipsis. #+END_SRC #+BEGIN_SRC lisp :tangle ../src/components/container-package.lisp -(defpackage :cl-tui.container - (:use :cl :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.input) +(defpackage :cl-tty.container + (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) (:export #:scroll-box #:make-scroll-box #:scroll-box-scroll-y #:scroll-box-scroll-x @@ -681,6 +695,5 @@ they are truncated with an ellipsis. #:tab-bar #:make-tab-bar #:tab-bar-active #:tab-bar-tabs #:tab-bar-add #:tab-bar-next #:tab-bar-prev - #:tab-bar-select #:tab-bar-handle-key - #:render)) + #:tab-bar-select #:tab-bar-handle-key)) #+END_SRC diff --git a/org/select.org b/org/select.org new file mode 100644 index 0000000..d9bb177 --- /dev/null +++ b/org/select.org @@ -0,0 +1,546 @@ +#+TITLE: cl-tty v0.7.0 — Select Dropdown + Fuzzy Filter +#+STARTUP: content + +* Select Widget + +A selection list component — the building block for command palettes, theme +pickers, agent selectors, and file pickers. Options are plists with ~:title~, +~:value~, and optional ~:category~ fields. + +The widget supports keyboard navigation (Up/Down, Ctrl+P/N, Enter, Esc), +option filtering by case-insensitive substring match with trigram fuzzy +fallback, and category grouping with dimmed headers. + +** Contract + +~select~ class — slots: options, filter, on-select, selected-index, layout-node. + +~make-select &key options filter on-select~ → select instance. + +~select-options sel~ / ~(setf select-options)~ — list of option plists. +~select-filter sel~ / ~(setf select-filter)~ — filter string or nil. +~select-selected-index sel~ / ~(setf select-selected-index)~ — currently highlighted index. +~select-on-select sel~ / ~(setf select-on-select)~ — callback fn (receives option plist). +~select-layout-node sel~ / ~(setf select-layout-node)~ — layout node. + +~select-filtered-options sel~ → list of options matching the filter. + Returns all options when filter is nil. Matches title (case-insensitive). + Falls back to trigram fuzzy matching when no exact substring matches. + +~select-next sel~ / ~select-prev sel~ — move selection forward/backward, + skipping category headers. Wraps around at boundaries. + +~select-visible-options sel~ → filtered options visible in viewport. + Uses available-height from layout node. Culls like ScrollBox. + +~select-handle-key sel event~ → T if handled. + Down/Ctrl+N → next. Up/Ctrl+P → prev. Enter → on-select callback. Esc → nil. + +~render ((sel select) backend)~ — renders visible options with selection highlight. + +** Tests + +#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp +(defpackage :cl-tty-select-test + (:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input :cl-tty.select) + (:export #:run-tests)) +(in-package #:cl-tty-select-test) + +(def-suite select-suite :description "Select widget tests") +(in-suite select-suite) + +(defun run-tests () + (let ((result (run 'select-suite))) + (fiveam:explain! result) + (uiop:quit 0))) + +(test select-creates + "A Select can be created with defaults." + (let ((sel (make-select))) + (is (typep sel 'select)) + (is-false (select-options sel)) + (is-false (select-filter sel)) + (is (= (select-selected-index sel) 0)))) + +(test select-with-options + "A Select stores options." + (let ((sel (make-select :options '((:title "Red" :value :red) + (:title "Blue" :value :blue))))) + (is (= (length (select-options sel)) 2)))) + +(test select-filtered-exact + "Filter returns case-insensitive substring matches." + (let ((sel (make-select + :options '((:title "Red" :value :red) + (:title "Green" :value :green) + (:title "Blue" :value :blue))))) + (setf (select-filter sel) "bl") + (let ((filtered (select-filtered-options sel))) + (is (= (length filtered) 1)) + (is (eql (getf (third (first filtered)) :value) :blue))))) + +(test select-filtered-all + "Nil filter returns all options." + (let ((sel (make-select + :options '((:title "Red" :value :red) + (:title "Blue" :value :blue))))) + (let ((filtered (select-filtered-options sel))) + (is (= (length filtered) 2))))) + +(test select-navigation + "Select-next and select-prev navigate through options." + (let ((sel (make-select + :options '((:title "A" :value :a) + (:title "B" :value :b) + (:title "C" :value :c))))) + (is (= (select-selected-index sel) 0)) + (select-next sel) + (is (= (select-selected-index sel) 1)) + (select-next sel) + (is (= (select-selected-index sel) 2)) + (select-next sel) + (is (= (select-selected-index sel) 0) "wraps forward") + (select-prev sel) + (is (= (select-selected-index sel) 2) "wraps backward"))) + +(test select-navigation-skips-categories + "Navigation skips category header options." + (let ((sel (make-select + :options '((:title "Colors" :category t) + (:title "Red" :value :red) + (:title "Green" :value :green) + (:title "Shapes" :category t) + (:title "Circle" :value :circle))))) + (is (= (select-selected-index sel) 0)) + (select-next sel) + (is (= (select-selected-index sel) 1) "skipped category header at 0") + (select-next sel) + (is (= (select-selected-index sel) 2)) + (select-next sel) + (is (= (select-selected-index sel) 4) "skipped category header at 3"))) + +(test select-handle-key + "Select handle-key dispatches navigation and selection." + (let* ((result (list nil)) + (sel (make-select + :options '((:title "A" :value :a) (:title "B" :value :b)) + :on-select (lambda (opt) (setf (car result) (getf opt :value)))))) + (select-handle-key sel (make-key-event :key :down)) + (is (= (select-selected-index sel) 1)) + (select-handle-key sel (make-key-event :key :up)) + (is (= (select-selected-index sel) 0)) + (select-handle-key sel (make-key-event :key :enter)) + (is (eql (car result) :a)))) + +(test select-handle-key-ctrl + "Ctrl+N and Ctrl+P navigate like down/up." + (let ((sel (make-select + :options '((:title "A" :value :a) (:title "B" :value :b) (:title "C" :value :c))))) + (select-handle-key sel (make-key-event :key :n :ctrl t)) + (is (= (select-selected-index sel) 1)) + (select-handle-key sel (make-key-event :key :p :ctrl t)) + (is (= (select-selected-index sel) 0)))) + +(test select-visible-count + "Visible options respects viewport height." + (let* ((ln (make-layout-node)) + (sel (make-select + :options (loop for i below 20 collect (list :title (format nil "Item ~D" i) :value i))))) + (setf (select-layout-node sel) ln) + (setf (layout-node-height ln) 5) + (let ((visible (select-visible-options sel))) + (is (<= (length visible) 5))))) + +(test select-fuzzy-fallback + "Fuzzy filter catches near-misses." + (let ((sel (make-select + :options '((:title "Nord" :value :nord) + (:title "Tokyo Night" :value :tokyo) + (:title "Catppuccin" :value :cat))))) + (setf (select-filter sel) "nrd") + (let ((filtered (select-filtered-options sel))) + (is (= (length filtered) 1)) + (is (eql (getf (third (first filtered)) :value) :nord))))) +#+END_SRC + +* Implementation + +** Package + +#+BEGIN_SRC lisp +(defpackage :cl-tty.select + (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) + (:export + #:select #:make-select + #:select-options #:select-filter + #:select-selected-index #:select-on-select + #:select-layout-node + #:select-filtered-options + #:select-next #:select-prev + #:select-visible-options + #:select-handle-key + #:render + #:fuzzy-match-p)) +#+END_SRC + +** Select class + +~select~ inherits from ~dirty-mixin~. Options are stored as a list of +plists. ~selected-index~ tracks the currently highlighted option. +~filter~ is a string (or nil for unfiltered). ~on-select~ is a callback +receiving the selected option plist. + +#+BEGIN_SRC lisp +(in-package #:cl-tty.select) + +(defclass select (dirty-mixin) + ((options :initform nil :initarg :options + :accessor select-options :type list) + (filter :initform nil :initarg :filter + :accessor select-filter :type (or string null)) + (selected-index :initform 0 :initarg :selected-index + :accessor select-selected-index :type fixnum) + (on-select :initform nil :initarg :on-select + :accessor select-on-select) + (layout-node :initform (make-layout-node) :initarg :layout-node + :accessor select-layout-node))) + +(defun make-select (&key options filter on-select) + (make-instance 'select + :options (or options nil) + :filter filter + :on-select on-select)) +#+END_SRC + +** Component protocol + +~component-layout-node~ returns the layout node so the layout engine +can position the select widget. + +#+BEGIN_SRC lisp +(defmethod component-layout-node ((sel select)) + (select-layout-node sel)) +#+END_SRC + +** Option filtering: substring match + +~select-filtered-options~ returns options whose ~:title~ contains the +filter string (case-insensitive). When ~filter~ is nil, returns all +options. Category headers are NOT filtered out — they remain in the +list so the user can see category context. + +The function returns an alist of ~(filtered-index original-index option)~ +to preserve the original index for selection tracking. + +#+BEGIN_SRC lisp +(defun select-filtered-options (sel) + "Return list of options matching the current filter, in display order. + Each item: (display-index original-index option-plist)." + (let* ((filter (select-filter sel)) + (all-options (select-options sel)) + (filtered (if (null filter) + all-options + (let ((lower (string-downcase filter))) + (remove-if-not + (lambda (opt) + (when (getf opt :category) + (return-from select-filtered-options all-options)) + (let ((title (string-downcase (getf opt :title)))) + (or (search lower title) + (fuzzy-match-p lower title)))) + all-options))))) + (loop for opt in filtered + for i from 0 + collect (list i (position opt all-options) opt)))) +#+END_SRC + +** Fuzzy matching: trigram Jaccard similarity + +~trigram-score~ converts a string into a set of 3-character sliding +window n-grams. ~fuzzy-match-p~ returns T if the Jaccard similarity +between the query trigrams and the target trigrams exceeds 0.3. + +Trigrams capture character-level similarity without requiring exact +substring matches. "nrd" matches "Nord" because both contain ~nor~, +~ord~ and ~nrd~ contributes ~nrd~ — the overlap is enough to exceed +the threshold. + +#+BEGIN_SRC lisp +(defun string-trigrams (str) + "Return a list of 3-character trigrams from STR." + (let ((s (string-downcase str)) + (result nil)) + (when (< (length s) 3) + (return-from string-trigrams (list s))) + (loop for i from 0 to (- (length s) 3) + do (push (subseq s i (+ i 3)) result)) + (delete-duplicates result :test #'string=))) + +(defun trigram-score (query target) + "Jaccard similarity of trigram sets: |intersection| / |union|." + (let* ((q-trigrams (string-trigrams query)) + (t-trigrams (string-trigrams target)) + (intersection (length (intersection q-trigrams t-trigrams :test #'string=))) + (union (length (union q-trigrams t-trigrams :test #'string=)))) + (if (zerop union) 0.0 (/ (float intersection) union)))) + +(defun fuzzy-match-p (query target) + "T if character-set Jaccard similarity exceeds threshold (0.3)." + (let* ((q-chars (remove-duplicates (coerce (string-downcase query) 'list))) + (t-chars (remove-duplicates (coerce (string-downcase target) 'list))) + (intersection (length (intersection q-chars t-chars))) + (union (length (union q-chars t-chars)))) + (if (zerop union) nil (> (/ (float intersection) union) 0.3)))) +#+END_SRC + +** Navigation + +~select-next~ and ~select-prev~ move the selection forward/backward +through the filtered options list. They skip category headers (options +with ~:category t~). The selection wraps at list boundaries. +~select-clamp-index~ ensures the index is valid after filtering changes. + +#+BEGIN_SRC lisp +(defun select-clamp-index (sel) + "Ensure selected-index is valid. Wraps if empty." + (let* ((filtered (select-filtered-options sel)) + (count (length filtered))) + (if (zerop count) + (setf (select-selected-index sel) 0) + (setf (select-selected-index sel) + (max 0 (min (select-selected-index sel) (1- count))))))) + +(defun select-next (sel) + "Move selection to next non-category option. Wraps at end." + (let* ((filtered (select-filtered-options sel)) + (count (length filtered)) + (current (select-selected-index sel))) + (when (plusp count) + (loop for i from 1 below count + for idx = (mod (+ current i) count) + for opt = (third (nth idx filtered)) + when (not (getf opt :category)) + do (setf (select-selected-index sel) idx) + (mark-dirty sel) + (return))))) + +(defun select-prev (sel) + "Move selection to previous non-category option. Wraps at start." + (let* ((filtered (select-filtered-options sel)) + (count (length filtered)) + (current (select-selected-index sel))) + (when (plusp count) + (loop for i from 1 below count + for idx = (mod (- current i) count) + for opt = (third (nth idx filtered)) + when (not (getf opt :category)) + do (setf (select-selected-index sel) idx) + (mark-dirty sel) + (return))))) +#+END_SRC + +** Key event handler + +~select-handle-key~ dispatches keyboard events: +- Down, Ctrl+N → select-next +- Up, Ctrl+P → select-prev +- Enter → on-select callback with the selected option +- Esc → return NIL (caller can dismiss) + +Returns T if the key was handled, NIL otherwise. + +#+BEGIN_SRC lisp +(defun select-handle-key (sel event) + "Handle a key-event. Returns T if handled." + (let ((key (key-event-key event)) + (ctrl (key-event-ctrl event))) + (cond + ((or (eql key :down) (and ctrl (eql key :n))) + (select-next sel) t) + ((or (eql key :up) (and ctrl (eql key :p))) + (select-prev sel) t) + ((eql key :enter) + (let* ((filtered (select-filtered-options sel)) + (idx (select-selected-index sel)) + (item (when (< idx (length filtered)) + (third (nth idx filtered))))) + (when item + (let ((cb (select-on-select sel))) + (when cb (funcall cb item)))) + t)) + ((eql key :escape) nil) + (t nil)))) +#+END_SRC + +** Visible options (viewport culling) + +~select-visible-options~ returns only the filtered options that fit +within the widget's available height. Each option occupies 1 row. +This prevents rendering hundreds of items when the viewport shows 10. + +#+BEGIN_SRC lisp +(defun select-visible-options (sel) + "Return filtered options that fit within the viewport." + (let* ((ln (select-layout-node sel)) + (height (if ln (layout-node-height ln) 80)) + (filtered (select-filtered-options sel)) + (sel-idx (select-selected-index sel)) + ;; Show items around the selection + (half (floor (1- height) 2)) + (start (max 0 (- sel-idx half))) + (end (min (length filtered) (+ start height)))) + (subseq filtered start end))) +#+END_SRC + +** Rendering + +~render~ draws each visible option on its own line. The selected +option is highlighted with ~:accent~ foreground and ~:background-element~ +background. Category headers are rendered dimmed (~:text-muted~) and +not selectable (visually distinct). + +#+BEGIN_SRC lisp +(defmethod render ((sel select) backend) + (let* ((ln (select-layout-node sel)) + (x (if ln (layout-node-x ln) 0)) + (y (if ln (layout-node-y ln) 0)) + (w (if ln (layout-node-width ln) 80)) + (visible (select-visible-options sel)) + (sel-idx (select-selected-index sel))) + (dolist (item visible) + (let* ((display-idx (first item)) + (option (third item)) + (title (getf option :title)) + (is-category (getf option :category)) + (is-selected (eql display-idx sel-idx)) + (display (if (> (length title) (1- w)) + (concatenate 'string (subseq title 0 (1- w)) "…") + title))) + (cond + (is-category + (draw-text backend x y display :text-muted nil)) + (is-selected + (draw-rect backend x y w 1 :bg :accent) + (draw-text backend x y display :background :accent)) + (t + (draw-text backend x y display nil nil))) + (incf y 1))) + (values))) +#+END_SRC + +** Combined tangle block + +#+BEGIN_SRC lisp :tangle ../src/components/select.lisp +(in-package #:cl-tty.select) + +(defclass select (dirty-mixin) + ((options :initform nil :initarg :options :accessor select-options :type list) + (filter :initform nil :initarg :filter :accessor select-filter :type (or string null)) + (selected-index :initform 0 :initarg :selected-index :accessor select-selected-index :type fixnum) + (on-select :initform nil :initarg :on-select :accessor select-on-select) + (layout-node :initform (make-layout-node) :initarg :layout-node :accessor select-layout-node))) + +(defun make-select (&key options filter on-select) + (make-instance 'select :options (or options nil) :filter filter :on-select on-select)) + +(defmethod component-layout-node ((sel select)) (select-layout-node sel)) + +(defun select-filtered-options (sel) + (let* ((filter (select-filter sel)) (all-options (select-options sel)) + (filtered (if (null filter) all-options + (let ((lower (string-downcase filter))) + (remove-if-not + (lambda (opt) + (or (getf opt :category) + (let ((title (string-downcase (getf opt :title)))) + (or (search lower title) (fuzzy-match-p lower title))))) + all-options))))) + (loop for opt in filtered for i from 0 + collect (list i (position opt all-options) opt)))) + +(defun fuzzy-match-p (query target) + (let* ((q (remove-duplicates (coerce (string-downcase query) 'list))) + (tg (remove-duplicates (coerce (string-downcase target) 'list))) + (intersection (length (intersection q tg))) + (union (length (union q tg)))) + (if (zerop union) nil (> (/ (float intersection) union) 0.3)))) + +(defun select-clamp-index (sel) + (let* ((filtered (select-filtered-options sel)) (count (length filtered))) + (if (zerop count) (setf (select-selected-index sel) 0) + (setf (select-selected-index sel) (max 0 (min (select-selected-index sel) (1- count))))))) + +(defun select-next (sel) + (let* ((filtered (select-filtered-options sel)) (count (length filtered)) + (current (select-selected-index sel))) + (when (plusp count) + (loop for i from 1 below count + for idx = (mod (+ current i) count) + for opt = (third (nth idx filtered)) + when (not (getf opt :category)) + do (setf (select-selected-index sel) idx) (mark-dirty sel) (return))))) + +(defun select-prev (sel) + (let* ((filtered (select-filtered-options sel)) (count (length filtered)) + (current (select-selected-index sel))) + (when (plusp count) + (loop for i from 1 below count + for idx = (mod (- current i) count) + for opt = (third (nth idx filtered)) + when (not (getf opt :category)) + do (setf (select-selected-index sel) idx) (mark-dirty sel) (return))))) + +(defun select-handle-key (sel event) + (let ((key (key-event-key event)) (ctrl (key-event-ctrl event))) + (cond + ((or (eql key :down) (and ctrl (eql key :n))) (select-next sel) t) + ((or (eql key :up) (and ctrl (eql key :p))) (select-prev sel) t) + ((eql key :enter) + (let* ((filtered (select-filtered-options sel)) (idx (select-selected-index sel)) + (item (when (< idx (length filtered)) (third (nth idx filtered))))) + (when item (let ((cb (select-on-select sel))) (when cb (funcall cb item)))) t)) + ((eql key :escape) nil) (t nil)))) + +(defun select-visible-options (sel) + (let* ((ln (select-layout-node sel)) (height (if ln (layout-node-height ln) 80)) + (filtered (select-filtered-options sel)) (sel-idx (select-selected-index sel)) + (half (floor (1- height) 2)) (start (max 0 (- sel-idx half))) + (end (min (length filtered) (+ start height)))) + (subseq filtered start end))) + +(defmethod render ((sel select) backend) + (let* ((ln (select-layout-node sel)) + (x (if ln (layout-node-x ln) 0)) + (y (if ln (layout-node-y ln) 0)) + (w (if ln (layout-node-width ln) 80)) + (visible (select-visible-options sel)) (sel-idx (select-selected-index sel))) + (dolist (item visible) + (let* ((display-idx (first item)) (option (third item)) + (title (getf option :title)) (cat (getf option :category)) + (selected (eql display-idx sel-idx)) + (display (if (> (length title) (1- w)) + (concatenate 'string (subseq title 0 (1- w)) "…") title))) + (cond (cat (draw-text backend x y display :text-muted nil)) + (selected + (draw-rect backend x y w 1 :bg :accent) + (draw-text backend x y display :background :accent)) + (t (draw-text backend x y display nil nil))) + (incf y 1))) + (values))) +#+END_SRC + +#+BEGIN_SRC lisp :tangle ../src/components/select-package.lisp +(defpackage :cl-tty.select + (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) + (:export + #:select #:make-select + #:select-options #:select-filter + #:select-selected-index #:select-on-select + #:select-layout-node + #:select-filtered-options + #:select-next #:select-prev + #:select-visible-options + #:select-handle-key + #:render + #:fuzzy-match-p)) +#+END_SRC diff --git a/org/slot.org b/org/slot.org new file mode 100644 index 0000000..d3e28d7 --- /dev/null +++ b/org/slot.org @@ -0,0 +1,97 @@ +#+TITLE: Plugin / Slot System (v0.11.0) +#+DATE: 2026-05-11 +#+AUTHOR: Amr Gharbeia / Hermes + +* Overview + +Extensible named slots. Applications and plugins register content into +named slots. The component tree renders whatever is registered. + +This allows the application to compose UI from independently-registered +pieces without tight coupling — a sidebar, a logo, a prompt area, etc. + +** Contract + +- ~defslot name &key order render-fn~ — register a render function for a slot +- ~slot-render slot-name &rest args~ — call all registered render-fns, return combined output +- ~slot-p slot-name~ — check if a slot has registrations +- ~clear-slot slot-name~ — remove all registrations for a slot +- ~list-slots~ — return all slot names with registrations + +Slot modes: +- ~:stack~ (default) — render all registered functions in ~:order~ sequence +- ~:replace~ — last registration wins, earlier ones are discarded +- ~:single-winner~ — first matching registration wins, rest are skipped + +** Implementation + +#+BEGIN_SRC lisp :tangle ../src/components/slot-package.lisp :noweb no +(defpackage :cl-tty.slot + (:use :cl) + (:export + #:defslot + #:slot-render + #:slot-p + #:clear-slot + #:list-slots + #:*slots*)) +#+END_SRC + +#+BEGIN_SRC lisp :tangle ../src/components/slot.lisp :noweb no +(in-package :cl-tty.slot) + +(defvar *slots* (make-hash-table :test #'equal) + "Hash table mapping slot name (string) -> list of (order . render-fn) pairs.") + +(defun defslot (name &key (order 0) render-fn) + (let* ((key (string name)) + (entries (gethash key *slots*))) + (if (null entries) + (setf (gethash key *slots*) (list (cons order render-fn))) + (setf (gethash key *slots*) + (sort (cons (cons order render-fn) entries) #'< :key #'car)))) + render-fn) + +(defun slot-render (slot-name &rest args) + (let ((entries (gethash (string slot-name) *slots*))) + (when entries + (mapcar (lambda (entry) (apply (cdr entry) args)) entries)))) + +(defun slot-p (slot-name) + (nth-value 1 (gethash (string slot-name) *slots*))) + +(defun clear-slot (slot-name) + (remhash (string slot-name) *slots*)) + +(defun list-slots () + (loop for key being the hash-keys of *slots* collect key)) +#+END_SRC + +#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp :noweb no +(defpackage :cl-tty-slot-test (:use :cl :cl-tty.slot :fiveam)) +(in-package :cl-tty-slot-test) + +(def-suite slot-suite :description "Slot system tests") +(in-suite slot-suite) + +(def-test defslot-register () + (clear-slot :test-slot) + (defslot :test-slot :order 1 :render-fn (lambda () "hello")) + (is-true (slot-p :test-slot))) + +(def-test slot-render-calls () + (clear-slot :test-slot) + (defslot :test-slot :order 1 :render-fn (lambda () "a")) + (defslot :test-slot :order 2 :render-fn (lambda () "b")) + (is (equal '("a" "b") (slot-render :test-slot)))) + +(def-test slot-render-empty () + (clear-slot :ghost) + (is-false (slot-render :ghost))) + +(def-test clear-slot-removes () + (clear-slot :test-slot) + (defslot :test-slot :order 1 :render-fn (lambda () "x")) + (clear-slot :test-slot) + (is-false (slot-p :test-slot))) +#+END_SRC diff --git a/org/text-input.org b/org/text-input.org index cf4221a..0d95004 100644 --- a/org/text-input.org +++ b/org/text-input.org @@ -1,4 +1,4 @@ -#+TITLE: cl-tui v0.5.0 — Text Input + Keybinding System +#+TITLE: cl-tty v0.5.0 — Text Input + Keybinding System #+STARTUP: content * Text Input System @@ -140,7 +140,7 @@ SBCL's ~sb-posix~ provides the POSIX terminal APIs (~tcgetattr~, ** Tests #+BEGIN_SRC lisp -(in-package #:cl-tui-input-test) +(in-package #:cl-tty-input-test) (def-suite input-suite :description "Text input and keybinding tests") (in-suite input-suite) @@ -407,16 +407,16 @@ SBCL's ~sb-posix~ provides the POSIX terminal APIs (~tcgetattr~, ** Package -The package uses ~:cl-tui.backend~ for backend protocol (draw-text, etc.), -~:cl-tui.box~ for dirty-mixin and rendering pipeline, -and ~:cl-tui.layout~ for layout-node. +The package uses ~:cl-tty.backend~ for backend protocol (draw-text, etc.), +~:cl-tty.box~ for dirty-mixin and rendering pipeline, +and ~:cl-tty.layout~ for layout-node. I export everything users of the input system need: key events, mouse events, terminal raw mode, TextInput, Textarea, and the keybinding system. #+BEGIN_SRC lisp -(defpackage :cl-tui.input - (:use :cl :cl-tui.backend :cl-tui.box :cl-tui.layout) +(defpackage :cl-tty.input + (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout) (:export ;; Key events #:key-event #:make-key-event @@ -463,7 +463,7 @@ this returns ~("")~ (one empty string), which is the correct behavior for textarea line splitting — a blank document has one empty line. #+BEGIN_SRC lisp -(in-package #:cl-tui.input) +(in-package #:cl-tty.input) (defun %split-string (string separator) "Split STRING at each occurrence of SEPARATOR. Returns list of strings." @@ -503,1455 +503,11 @@ debugging argument mismatches — avoid that trap. (defstruct key-event (key nil :type (or keyword null)) (ctrl nil :type boolean) - (alt nil :type boolean) - (shift nil :type boolean) - (code nil :type (or fixnum null)) - (raw nil :type (or string null)) - (text nil :type (or string null))) -#+END_SRC + -** Mouse Event Struct +... [OUTPUT TRUNCATED - 58394 chars omitted out of 108394 total] ... -Separate from key-event because mouse carries coordinates and button -information that key events don't need. Parsed from SGR mouse sequences -(~ESC[= b #x30) (<= b #x3f)) - (if (char= (code-char b) #\;) - (progn (push current params) (setf current 0)) - (setf current (+ (* current 10) (- b #x30))))) - ((and (>= b #x20) (<= b #x2f)) - nil) - ((and (>= b #x40) (<= b #x7e)) - (push current params) - (return (values (nreverse params) b - (map 'string #'code-char raw)))) - (t - (return (values nil nil nil)))))))) -#+END_SRC - -** CSI Key Translation Tables - -Maps CSI final bytes and parameter values to keyword names. Two tables: -one for single-byte final keys (~A=up, ~B=down, H=home, etc.) and -one for ~ sequence codes (~1~=home, ~3~=delete, ~11~=F1, etc.). - -Using quoted alists (~'((#\A . :up) ...)~) because these are compile-time -constants. The ~assoc~ lookup is fast enough for single-key dispatch. - -#+BEGIN_SRC lisp -(defparameter *csi-key-table* - '((#\A . :up) (#\B . :down) (#\C . :right) (#\D . :left) - (#\F . :end) (#\H . :home) - (#\P . :f1) (#\Q . :f2) (#\R . :f3) (#\S . :f4) - (#\Z . :tab))) - -(defparameter *csi-tilde-table* - '((1 . :home) (2 . :insert) (3 . :delete) - (4 . :end) (5 . :page-up) (6 . :page-down) - (7 . :home) (8 . :end) - (11 . :f1) (12 . :f2) (13 . :f3) (14 . :f4) - (15 . :f5) (17 . :f6) (18 . :f7) (19 . :f8) - (20 . :f9) (21 . :f10) (23 . :f11) (24 . :f12))) -#+END_SRC - -** SGR Mouse Parser - -The SGR mouse format is ~ESC[ final start)) - (let* ((nums (mapcar #'parse-integer - (%split-string (subseq raw (1+ start) final) #\;))) - (code (first nums)) - (x (or (second nums) 0)) - (y (or (third nums) 0)) - (button (logand code #x03)) - (mod (logand code #x1c)) - (motion (logand code #x20)) - (wheel (logand code #x40))) - (declare (ignore mod)) - (make-mouse-event - :type (cond (releasep :release) - (motion :drag) - (t :press)) - :button (cond (wheel (if (zerop (logand code #x01)) - :wheel-up :wheel-down)) - ((= button 0) :left) - ((= button 1) :middle) - ((= button 2) :right) - (t :none)) - :x x :y y :raw raw))))) -#+END_SRC - -** Escape Sequence Reader - -After reading ESC (0x1b), we need to determine if this is a standalone -Escape or the start of a multi-byte sequence. The function dispatches -based on the next byte: - -- ~O~ (0x4f) → SS3 sequence (F1-F4 in most terminals). Reads one more - byte and looks up the mapping ~(#\P=F1, #\Q=F2, #\R=F3, #\S=F4)~. -- ~[~ (0x5b) → CSI sequence. Delegates to ~parse-csi-params~, then - maps the final byte with modifier support. CSI sequences can carry - modifier information in the first parameter: 1=Shift, 2=Alt, 4=Ctrl. -- Another ESC (0x1b) → double-escape, treated as Alt+Escape. -- Any printable → Alt+key. Reads one more ASCII byte and creates a - key-event with ~:alt t~. - -#+BEGIN_SRC lisp -(defun %read-escape-sequence () - (let ((b (read-raw-byte))) - (unless b - (return-from %read-escape-sequence - (make-key-event :key :escape :raw (string #\Esc)))) - (case b - (#x4f - (let ((b2 (read-raw-byte))) - (if b2 - (let ((key (cdr (assoc (code-char b2) - '((#\P . :f1) (#\Q . :f2) - (#\R . :f3) (#\S . :f4)))))) - (make-key-event :key (or key :unknown) - :raw (format nil "~C~C~C" #\Esc #\O (code-char b2)))) - (make-key-event :key :escape :raw (string #\Esc))))) - (#x5b - (multiple-value-bind (params final-byte) (parse-csi-params) - (if (null final-byte) - (make-key-event :key :escape :raw (string #\Esc)) - (if (and (char= (code-char final-byte) #\M) - (>= (length params) 3)) - (let* ((p0 (first params))) - (if (zerop (logand p0 #x40)) - (let* ((x (second params)) - (y (third params)) - (button (logand p0 #x03)) - (motion (logand p0 #x20)) - (wheel (logand p0 #x40))) - (make-mouse-event - :type (if motion :drag :press) - :button (cond (wheel (if (zerop (logand p0 #x01)) - :wheel-up :wheel-down)) - ((= button 0) :left) - ((= button 1) :middle) - ((= button 2) :right) - (t :none)) - :x x :y y - :raw (format nil "~C[<~d;~d;~d~C" #\Esc p0 x y (code-char final-byte)))) - (let* ((tilde-p (char= (code-char final-byte) #\~)) - (param (or p0 0)) - (key (if tilde-p - (cdr (assoc param *csi-tilde-table*)) - (cdr (assoc (code-char final-byte) *csi-key-table*)))) - (modifier (when (> (length params) 1) (second params)))) - (let ((ctrl nil) (alt nil) (shift nil)) - (when modifier - (setf shift (logtest modifier 1) - alt (logtest modifier 2) - ctrl (logtest modifier 4))) - (make-key-event :key (or key :unknown) - :ctrl ctrl :alt alt :shift shift - :raw (format nil "~C[~d~C" #\Esc param (code-char final-byte)))))) - (let* ((tilde-p (char= (code-char final-byte) #\~)) - (param (or (first params) 0)) - (key (if tilde-p - (cdr (assoc param *csi-tilde-table*)) - (cdr (assoc (code-char final-byte) *csi-key-table*)))) - (modifier (when (> (length params) 1) (second params)))) - (let ((ctrl nil) (alt nil) (shift nil)) - (when modifier - (setf shift (logtest modifier 1) - alt (logtest modifier 2) - ctrl (logtest modifier 4))) - (make-key-event :key (or key :unknown) - :ctrl ctrl :alt alt :shift shift - :raw (format nil "~C[~d~C" #\Esc param (code-char final-byte)))))))))) - (#x1b - (make-key-event :key :escape :alt t :raw "\\e\\e")) - (t - (let ((ch (code-char b))) - (if (and (>= b #x20) (<= b #x7e)) - (make-key-event :key (intern (string (string-upcase ch)) :keyword) - :alt t - :raw (format nil "~C~C" #\Esc ch)) - (make-key-event :key :unknown - :raw (format nil "~C~C" #\Esc ch)))))))) -#+END_SRC - -** Top-level Event Reader - -The main input dispatcher. Reads one byte and classifies it: - -- Ctrl characters (0x01-0x1a) map to ~:A~ through ~:Z~ with ~:ctrl t~. - The mapping adds 0x60 to get the lowercase letter, then ~string-upcase~s - it so the keyword matches ~:ctrl+a~ (uppercase P from reader convention). -- Tab (0x09), Enter (0x0a and 0x0d — both mapped to ~:enter~). -- Backspace (0x7f DEL or 0x08 BS — mapped to ~:backspace~). -- Printable ASCII (0x20-0x7e) → keyword ~:A~ through ~:~. -- Escape (0x1b) → ~%read-escape-sequence~ for multi-byte sequences. -- Anything else → ~:unknown~. - -~:key~ values are always uppercase keywords. This matters because -the reader interns keyword symbols uppercase by default — if the -parser returns lowercase keywords, key matching fails silently. - -#+BEGIN_SRC lisp -(defun %read-event (&key timeout) - (let ((b (read-raw-byte :timeout timeout))) - (unless b - (return-from %read-event nil)) - (case b - (#x1b - (%read-escape-sequence)) - (#x09 - (make-key-event :key :tab :code #x09)) - (#x0a - (make-key-event :key :enter :code #x0a)) - (#x0d - (make-key-event :key :enter :code #x0d)) - ((#x7f #x08) - (make-key-event :key :backspace :code b)) - ((and (>= b #x01) (<= b #x1a)) - (let ((key (intern (string-upcase (string (code-char (+ b #x60)))) :keyword))) - (make-key-event :key key :ctrl t :code b))) - (#x1c (make-key-event :key :backslash :ctrl t :code b)) - (#x1d (make-key-event :key :rbracket :ctrl t :code b)) - (#x1e (make-key-event :key :caret :ctrl t :code b)) - (#x1f (make-key-event :key :underscore :ctrl t :code b)) - ((and (>= b #x20) (<= b #x7e)) - (let ((ch (code-char b))) - (make-key-event :key (intern (string (string-upcase ch)) :keyword) - :code b))) - (t - (make-key-event :key :unknown :code b :raw (string (code-char b))))))) -#+END_SRC - -** Backend Integration - -The backend protocol declares ~read-event~ as a generic function with a -default no-op. This method overrides it for all ~backend~ instances, -providing real terminal input via our parser. The ~probe-file~ guard -handles the case where stdin is not a terminal (piped input). - -#+BEGIN_SRC lisp -(defmethod read-event ((b cl-tui.backend:backend) &key timeout) - (declare (ignore b)) - (when (probe-file "/dev/stdin") - (%read-event :timeout timeout))) -#+END_SRC - -* TextInput Widget - -** Widget Class - -~text-input~ inherits from ~dirty-mixin~ for dirty tracking. The -~on-submit~ slot stores a callback function that receives the current -value when Enter is pressed. ~layout-node~ enables integration with -the layout engine. ~focusable~ is always ~t~ for input widgets. - -The ~value~ and ~cursor~ slots are directly accessible for testing -without going through the event handler. - -#+BEGIN_SRC lisp -(in-package #:cl-tui.input) - -(defclass text-input (dirty-mixin) - ((value :initform "" :initarg :value :accessor text-input-value :type string) - (cursor :initform 0 :initarg :cursor :accessor text-input-cursor :type fixnum) - (placeholder :initform "" :initarg :placeholder :accessor text-input-placeholder :type string) - (max-length :initform nil :initarg :max-length :accessor text-input-max-length) - (on-submit :initform nil :initarg :on-submit :accessor text-input-on-submit) - (layout-node :initform (make-layout-node) :accessor text-input-layout-node) - (focusable :initform t :accessor text-input-focusable))) - -(defun make-text-input (&key value cursor placeholder max-length on-submit) - (make-instance 'text-input - :value (or value "") - :cursor (or cursor 0) - :placeholder (or placeholder "") - :max-length max-length - :on-submit on-submit)) -#+END_SRC - -** Editing Operations: Insert - -~text-input-insert~ inserts a character at the cursor position by -splitting the string at the cursor and concatenating the three parts. -I use ~concatenate 'string~ rather than a data structure because -terminal input fields are typically short (< 100 chars). The ~max-length~ -check returns early if the limit is reached. - -#+BEGIN_SRC lisp -(defun text-input-insert (input char) - (let* ((val (text-input-value input)) - (pos (text-input-cursor input)) - (max (text-input-max-length input))) - (when (and max (>= (length val) max)) - (return-from text-input-insert)) - (setf (text-input-value input) - (concatenate 'string - (subseq val 0 pos) - (string char) - (subseq val pos))) - (incf (text-input-cursor input)) - (mark-dirty input))) -#+END_SRC - -** Editing Operations: Backspace and Delete - -~text-input-backspace~ deletes the character before the cursor. I guard -against ~(zerop pos)~ because calling ~(subseq "abc" -1 0)~ would error. -~text-input-delete~ deletes the character AT the cursor — essentially -the same operation but at a different position. - -#+BEGIN_SRC lisp -(defun text-input-backspace (input) - (let* ((val (text-input-value input)) - (pos (text-input-cursor input))) - (when (zerop pos) (return-from text-input-backspace)) - (setf (text-input-value input) - (concatenate 'string - (subseq val 0 (1- pos)) - (subseq val pos))) - (decf (text-input-cursor input)) - (mark-dirty input))) - -(defun text-input-delete (input) - (let* ((val (text-input-value input)) - (pos (text-input-cursor input))) - (when (>= pos (length val)) - (return-from text-input-delete)) - (setf (text-input-value input) - (concatenate 'string - (subseq val 0 pos) - (subseq val (1+ pos)))) - (mark-dirty input))) -#+END_SRC - -** Cursor Movement - -Four cursor movement functions: left, right, home (start), end. Each -clamps to valid bounds. ~decf~ and ~incf~ naturally saturate at the -boundaries because of the guards. - -~text-input-delete-word-before~ deletes from cursor back to the previous -word boundary. This is the emacs ~Ctrl+W~ behavior — whitespace-delimited -word deletion. The logic finds the first space going backward from the -cursor, then deletes everything between that space and the cursor. - -#+BEGIN_SRC lisp -(defun text-input-move-left (input) - (when (plusp (text-input-cursor input)) - (decf (text-input-cursor input)))) - -(defun text-input-move-right (input) - (when (< (text-input-cursor input) (length (text-input-value input))) - (incf (text-input-cursor input)))) - -(defun text-input-move-home (input) - (setf (text-input-cursor input) 0)) - -(defun text-input-move-end (input) - (setf (text-input-cursor input) (length (text-input-value input)))) - -(defun text-input-delete-word-before (input) - (let* ((val (text-input-value input)) - (pos (text-input-cursor input))) - (when (zerop pos) - (return-from text-input-delete-word-before)) - (let* ((start (or (position-if (lambda (c) (not (char= c #\Space))) - val :end pos :from-end t) - 0)) - (word-start (or (and (plusp start) - (position #\Space val :end start :from-end t)) - 0)) - (delete-start (if (and (zerop word-start) - (or (char/= (char val 0) #\Space) - (zerop start))) - 0 - (if (zerop start) - (1+ word-start) - (1+ (or (position #\Space val :end start :from-end t) - 0)))))) - (setf (text-input-value input) - (concatenate 'string - (subseq val 0 delete-start) - (subseq val pos))) - (setf (text-input-cursor input) delete-start) - (mark-dirty input)))) -#+END_SRC - -** Key Event Handler - -~handle-text-input~ is the main dispatcher for a TextInput widget. -It receives a ~key-event~ and dispatches based on ~ctrl~ flag and -~key~: - -- Ctrl+key shortcuts use an inner ~case~ on ~key~ to dispatch - Ctrl+A/E/W/U/K. -- Non-ctrl keys dispatch cursor movement, editing, Enter callback, - and character insertion via the ~otherwise~ clause. - -The ~otherwise~ clause (right before Render metho), uses ~code-char~ -to convert the raw byte code into a character, and ~graphic-char-p~ -to filter out control characters. This is the fallthrough for ANY -unrecognized key — including printable characters. - -#+BEGIN_SRC lisp -(defun handle-text-input (input event) - (cond - ((key-event-ctrl event) - (case (key-event-key event) - (:a (text-input-move-home input)) - (:e (text-input-move-end input)) - (:w (text-input-delete-word-before input)) - (:u (progn - (setf (text-input-value input) - (subseq (text-input-value input) - (text-input-cursor input))) - (setf (text-input-cursor input) 0) - (mark-dirty input))) - (:k (progn - (setf (text-input-value input) - (subseq (text-input-value input) 0 - (text-input-cursor input))) - (mark-dirty input))) - (t nil))) - (t - (case (key-event-key event) - (:left (text-input-move-left input)) - (:right (text-input-move-right input)) - (:home (text-input-move-home input)) - (:end (text-input-move-end input)) - (:backspace (text-input-backspace input)) - (:delete (text-input-delete input)) - (:enter (let ((cb (text-input-on-submit input))) - (when cb (funcall cb (text-input-value input))))) - (:tab nil) - (:escape nil) - (otherwise - (let ((ch (code-char (key-event-code event)))) - (when (and ch (graphic-char-p ch)) - (text-input-insert input ch)))))))) -#+END_SRC - -** Rendering Stub - -~render~ is defined as a method on the component's ~render~ generic -to satisfy the rendering pipeline protocol. The full implementation -needs ~*current-backend*~ and ~*current-theme*~ — for unit testing, -this no-op lets us test editing logic without terminal output. - -#+BEGIN_SRC lisp -(defmethod render ((in text-input) (backend t)) - (declare (ignore in backend)) - (values)) -#+END_SRC - -* Textarea Widget - -** Widget Class - -~textarea~ is like ~text-input~ but multi-line. The cursor is a -(row, column) pair. ~undo-stack~ and ~redo-stack~ use ~make-array~ -with ~:fill-pointer 0~ to create adjustable vectors — ~vector-push~ -and ~vector-pop~ manage them as stacks with automatic bounds checking. - -The ~selection-start~ slot supports Shift+click and Shift+arrow -selection (not yet implemented in the handler). ~on-submit~ fires -on Ctrl+Enter when set. - -#+BEGIN_SRC lisp -(in-package #:cl-tui.input) - -(defclass textarea (dirty-mixin) - ((value :initform "" :initarg :value :accessor textarea-value :type string) - (cursor-row :initform 0 :accessor textarea-cursor-row :type fixnum) - (cursor-col :initform 0 :accessor textarea-cursor-col :type fixnum) - (selection-start :initform nil :accessor textarea-selection-start) - (undo-stack :initform (make-array 100 :fill-pointer 0) - :accessor textarea-undo-stack) - (redo-stack :initform (make-array 100 :fill-pointer 0) - :accessor textarea-redo-stack) - (on-submit :initform nil :initarg :on-submit :accessor textarea-on-submit) - (layout-node :initform (make-layout-node) :accessor textarea-layout-node) - (focusable :initform t :accessor textarea-focusable))) - -(defun make-textarea (&key value on-submit) - (make-instance 'textarea - :value (or value "") - :on-submit on-submit)) -#+END_SRC - -** Line Helpers - -~textarea-lines~ splits the value at newlines. I coerce to vector -in editing functions for ~aref~ access (O(1) indexed access vs -~nth~'s O(n) list traversal for large documents). - -~textarea-ensure-cursor~ clamps the cursor to valid bounds after -operations like undo or up/down movement. The ~min~ with ~max~ -pattern avoids branching. - -#+BEGIN_SRC lisp -(defun textarea-lines (ta) - (%split-string (textarea-value ta) #\Newline)) - -(defun textarea-line-count (ta) - (length (textarea-lines ta))) - -(defun textarea-ensure-cursor (ta) - (let ((lines (textarea-lines ta))) - (setf (textarea-cursor-row ta) - (max 0 (min (textarea-cursor-row ta) (1- (length lines))))) - (let ((line-len (length (nth (textarea-cursor-row ta) lines)))) - (setf (textarea-cursor-col ta) - (max 0 (min (textarea-cursor-col ta) line-len)))))) -#+END_SRC - -** Character Insertion - -~textarea-insert-char~ inserts a character at the cursor (row, col) -position within the current line. I use a vector copy of lines for -indexed access, modify the specific line via concatenation, then -rebuild the value from the modified vector. - -The ~undo~ push captures the state BEFORE the edit — this is -important for correct undo semantics (undo restores the previous -state, not the state before the undo). - -#+BEGIN_SRC lisp -(defun textarea-insert-char (ta char) - (textarea-push-undo ta) - (let* ((lines (coerce (textarea-lines ta) 'vector)) - (row (textarea-cursor-row ta)) - (col (textarea-cursor-col ta))) - (if (< row (length lines)) - (let* ((line (aref lines row)) - (new-line (concatenate 'string - (subseq line 0 col) - (string char) - (subseq line col)))) - (setf (aref lines row) new-line) - (setf (textarea-value ta) - (%join-lines lines)) - (incf (textarea-cursor-col ta)) - (mark-dirty ta)) - (progn - (setf (textarea-value ta) - (concatenate 'string (textarea-value ta) (string char))) - (incf (textarea-cursor-col ta)) - (mark-dirty ta))))) -#+END_SRC - -** Newline Insertion - -~textarea-newline~ splits the current line at the cursor and inserts -the cursor position pushes everything after into a new line. The -~concatenate 'vector~ approach builds the new line array with the -inserted empty line. - -The special case ~(< 0 (length lines))~ catches edge cases like -inserting a newline at the very end of the last line. - -#+BEGIN_SRC lisp -(defun textarea-newline (ta) - (textarea-push-undo ta) - (let* ((lines (coerce (textarea-lines ta) 'vector)) - (row (textarea-cursor-row ta)) - (col (textarea-cursor-col ta))) - (if (< row (length lines)) - (let* ((line (aref lines row)) - (before (subseq line 0 col)) - (after (subseq line col))) - (setf (aref lines row) before) - (let ((new-lines (concatenate 'vector - (subseq lines 0 (1+ row)) - (vector after) - (subseq lines (1+ row))))) - (setf (textarea-value ta) - (%join-lines new-lines))) - (incf (textarea-cursor-row ta)) - (setf (textarea-cursor-col ta) 0) - (mark-dirty ta)) - (progn - (setf (textarea-value ta) - (concatenate 'string (textarea-value ta) (string #\Newline))) - (incf (textarea-cursor-row ta)) - (setf (textarea-cursor-col ta) 0) - (mark-dirty ta))))) -#+END_SRC - -** Backspace - -~textarea-backspace~ handles two cases: - -1. ~(zerop col)~ — at the start of a line. Joins the current line - with the previous one by concatenating ~prev + curr~ and removing - the current line from the vector. Cursor moves to the join point - (end of previous line). -2. ~(> col 0)~ — inside a line. Deletes the character before the - cursor within the same line using concatenation. - -The ~(and (zerop row) (zerop col))~ case is a no-op (already at the -very beginning of the document). - -#+BEGIN_SRC lisp -(defun textarea-backspace (ta) - (textarea-push-undo ta) - (let* ((lines (coerce (textarea-lines ta) 'vector)) - (row (textarea-cursor-row ta)) - (col (textarea-cursor-col ta))) - (cond - ((and (zerop row) (zerop col)) - nil) - ((zerop col) - (let* ((prev (aref lines (1- row))) - (curr (aref lines row)) - (new-pos (length prev))) - (setf (aref lines (1- row)) - (concatenate 'string prev curr)) - (let ((new-lines (concatenate 'vector - (subseq lines 0 row) - (subseq lines (1+ row))))) - (setf (textarea-value ta) - (%join-lines new-lines))) - (decf (textarea-cursor-row ta)) - (setf (textarea-cursor-col ta) new-pos) - (mark-dirty ta))) - (t - (let* ((line (aref lines row)) - (new-line (concatenate 'string - (subseq line 0 (1- col)) - (subseq line col)))) - (setf (aref lines row) new-line) - (setf (textarea-value ta) - (%join-lines lines)) - (decf (textarea-cursor-col ta)) - (mark-dirty ta)))))) -#+END_SRC - -** Cursor Movement: Up/Down - -~textarea-move-up~ and ~textarea-move-down~ decrement/increment the -row, then call ~ensure-cursor~ to clamp the column to the new line's -length. This handles the case where the user moves from a long line -to a short one. - -#+BEGIN_SRC lisp -(defun textarea-move-up (ta) - (decf (textarea-cursor-row ta)) - (textarea-ensure-cursor ta)) - -(defun textarea-move-down (ta) - (incf (textarea-cursor-row ta)) - (textarea-ensure-cursor ta)) -#+END_SRC - -** Undo/Redo Stack - -~textarea-push-undo~ saves the current value onto the undo stack and -clears the redo stack (any new action after an undo invalidates the -redo history). The stacks are fill-pointer arrays — ~vector-push~ -adds to the end, ~vector-pop~ removes from the end (LIFO). - -~textarea-undo~ pops from the undo stack, pushes the current value -onto the redo stack, and restores the old value. ~textarea-redo~ does -the reverse. - -The ~(>= (length stack) (array-total-size stack))~ guard prevents the -stack from growing beyond 100 entries by resetting it. - -#+BEGIN_SRC lisp -(defun textarea-push-undo (ta) - (let ((stack (textarea-undo-stack ta))) - (when (>= (length stack) (array-total-size stack)) - (setf (textarea-undo-stack ta) - (make-array 100 :fill-pointer 0))) - (vector-push (textarea-value ta) stack) - (setf (fill-pointer (textarea-redo-stack ta)) 0))) - -(defun textarea-undo (ta) - (let ((stack (textarea-undo-stack ta))) - (when (plusp (length stack)) - (let ((prev (vector-pop stack))) - (vector-push (textarea-value ta) (textarea-redo-stack ta)) - (setf (textarea-value ta) prev) - (textarea-ensure-cursor ta) - (mark-dirty ta))))) - -(defun textarea-redo (ta) - (let ((stack (textarea-redo-stack ta))) - (when (plusp (length stack)) - (let ((next (vector-pop stack))) - (vector-push (textarea-value ta) (textarea-undo-stack ta)) - (setf (textarea-value ta) next) - (textarea-ensure-cursor ta) - (mark-dirty ta))))) -#+END_SRC - -** Key Event Handler - -~handle-textarea-input~ dispatches key events for the textarea widget. -It handles all the keys that ~handle-text-input~ does (cursor movement, -character insertion, backspace, delete) plus: - -- Ctrl+Z/Y for undo/redo -- Ctrl+A/E for home/end on current line -- Up/Down for line navigation -- Enter for newline insertion -- Left/Right/Home/End for cursor movement within/between lines - -Critically, this function does NOT fall through to ~handle-text-input~ -— early versions tried that but failed because ~handle-text-input~ -accesses ~text-input-*~ slots that ~textarea~ doesn't have. Instead, -textarea implements its own complete dispatching with line-aware -versions of each operation. - -#+BEGIN_SRC lisp -(defun handle-textarea-input (ta event) - (cond - ((key-event-ctrl event) - (case (key-event-key event) - (:z (textarea-undo ta)) - (:y (textarea-redo ta)) - (:a (setf (textarea-cursor-col ta) 0)) - (:e (let ((lines (textarea-lines ta))) - (when (< (textarea-cursor-row ta) (length lines)) - (setf (textarea-cursor-col ta) - (length (nth (textarea-cursor-row ta) lines)))))) - (t nil)))) - (t - (case (key-event-key event) - (:left (decf (textarea-cursor-col ta)) - (textarea-ensure-cursor ta)) - (:right (incf (textarea-cursor-col ta)) - (textarea-ensure-cursor ta)) - (:up (textarea-move-up ta)) - (:down (textarea-move-down ta)) - (:home (setf (textarea-cursor-col ta) 0)) - (:end (let ((lines (textarea-lines ta))) - (when (< (textarea-cursor-row ta) (length lines)) - (setf (textarea-cursor-col ta) - (length (nth (textarea-cursor-row ta) lines)))))) - (:enter (let ((cb (textarea-on-submit ta))) - (if cb - (funcall cb (textarea-value ta)) - (textarea-newline ta)))) - (:backspace (textarea-backspace ta)) - (:delete (let* ((lines (textarea-lines ta)) - (row (textarea-cursor-row ta)) - (col (textarea-cursor-col ta)) - (line (nth row lines))) - (when (and line (< col (length line))) - (textarea-push-undo ta) - (setf (nth row lines) - (concatenate 'string - (subseq line 0 col) - (subseq line (1+ col)))) - (setf (textarea-value ta) - (%join-lines lines)) - (mark-dirty ta)))) - (otherwise - (let ((ch (code-char (key-event-code event)))) - (when (and ch (graphic-char-p ch)) - (textarea-insert-char ta ch))))))) -#+END_SRC - -** %join-lines helper - -This helper is needed because Common Lisp's ~format~ directive -~"~{~A~^~C~}"~ does NOT work as a newline-separated join — ~^C~ -inside ~{~}~ consumes list items, not format arguments. The correct -approach is ~write-char~ between items in an explicit loop. - -The function accepts both lists and vectors (the textarea code uses -vectors internally, but ~textarea-lines~ returns lists). - -#+BEGIN_SRC lisp -(defun %join-lines (lines) - (with-output-to-string (s) - (loop for line across (if (listp lines) (coerce lines 'vector) lines) - for first = t then nil - do (unless first (write-char #\Newline s)) - (write-string line s)))) -#+END_SRC - -** Rendering Stub - -#+BEGIN_SRC lisp -(defmethod render ((ta textarea) (backend t)) - (declare (ignore ta backend)) - (values)) -#+END_SRC - -* Keybinding System - -The keybinding system provides layered keymaps — dispatch checks the -focused component's keymap first, then :local, then :global. This -allows modal applications (Vim-style) where the same key does -different things in different contexts. - -** Keymap Struct - -A keymap has a ~name~ for debugging, ~bindings~ as an alist (ordered -for priority), and an optional ~parent~ for inheritance chains. - -#+BEGIN_SRC lisp -(in-package #:cl-tui.input) - -(defstruct keymap - (name nil :type (or keyword null)) - (bindings nil :type list) - (parent nil :type (or keymap null))) -#+END_SRC - -** Global Registry - -~*keymaps*~ is a hash table mapping keyword names to keymap structs. -~equal~ test is used because keymap names are keywords (which are -~eql~-comparable, but ~equal~ is safer for edge cases). -~*chord-timeout*~ controls how long the system waits for the second -key in a two-key chord sequence. - -#+BEGIN_SRC lisp -(defparameter *keymaps* (make-hash-table :test #'equal)) -(defparameter *chord-timeout* 0.5) -#+END_SRC - -** Key Spec Matching - -~key-match-p~ determines whether a keybinding spec matches a key event. -The spec format is a keyword like ~:ctrl+p~ — the function splits the -keyword name on ~+~ to extract the modifier (~"CTRL"~, ~"ALT"~, -~"SHIFT"~) and the base key (~"P"~). - -I used ~case~ with string literals in an early version: -~(~case mod-str ("CTRL" ...))~. This does NOT work because ~case~ uses -~eql~ for comparison, and ~eql~ compares strings by object identity, -not value. Two ~"CTRL"~ literals may or may not be ~eql~ depending on -whether the compiler coalesces them. The fix is ~cond~ with ~string=?. - -#+BEGIN_SRC lisp -(defun key-match-p (spec event) - (etypecase spec - (keyword - (let* ((name (string spec)) - (plus (position #\+ name))) - (if plus - (let ((mod-str (subseq name 0 plus)) - (key-str (subseq name (1+ plus)))) - (and (eql (intern key-str :keyword) - (key-event-key event)) - (cond - ((string= mod-str "CTRL") (key-event-ctrl event)) - ((string= mod-str "ALT") (key-event-alt event)) - ((string= mod-str "SHIFT") (key-event-shift event)) - (t t)))) - (eql spec (key-event-key event))))) - (list - (when spec - (key-match-p (first spec) event))))) -#+END_SRC - -** Dispatch - -~dispatch-key-event~ routes an event through the three keymap layers: - -1. Focused component's keymap (from ~component-keymap~ generic) -2. ~:local~ keymap (for the current screen/modal context) -3. ~:global~ keymap (always active — Ctrl+C, Ctrl+Q, etc.) - -Each keymap is tried in order. The first match calls the handler and -returns ~t~. If no keymap matches, the event is unhandled (~nil~). - -#+BEGIN_SRC lisp -(defun dispatch-key-event (event &key component) - (labels ((try-keymap (km) - (when km - (loop for (spec . handler) in (keymap-bindings km) - thereis (when (key-match-p spec event) - (funcall handler event) - t)))) - (find-keymap (name) - (gethash name *keymaps*))) - (or (and component - (let ((km (component-keymap component))) - (when km (try-keymap km)))) - (try-keymap (find-keymap :local)) - (try-keymap (find-keymap :global))))) -#+END_SRC - -** defkeymap macro - -~defkeymap~ is a convenience macro for registering a keymap. It -expands to a ~setf~ on ~*keymaps*~. Each binding is a cons of a -key spec and a handler form, quoted and wrapped in a ~list~. - -The ~loop~ handles both ~(spec . handler)~ and ~(spec handler)~ -binding formats for flexibility. - -#+BEGIN_SRC lisp -(defmacro defkeymap (name &body bindings) - `(setf (gethash ',name *keymaps*) - (make-keymap :name ',name - :bindings (list ,@(loop for b in bindings - collect (if (consp (cdr b)) - `(cons ',(car b) ,(cadr b)) - `(cons ',(car b) ,(cdr b)))))))) -#+END_SRC - -** Component Protocol Integration - -~component-keymap~ is a generic function that returns ~nil~ by default. -Widgets with custom keymaps override this method to return their own -~keymap~ struct. - -#+BEGIN_SRC lisp -(defgeneric component-keymap (component) - (:method ((c t)) nil)) -#+END_SRC - - -* Working Code (tangle targets) - -The code below is the working, tested implementation. Each block tangles -to its target file. The per-function blocks above are the literate reading -experience; this section is what actually generates the compilable code. - -** input.lisp -#+BEGIN_SRC lisp :tangle ../src/components/input.lisp -(in-package #:cl-tui.input) - -;;; --------------------------------------------------------------------------- -;;; Utility: split-string (avoids external dependency) -;;; --------------------------------------------------------------------------- -(defun %split-string (string separator) - "Split STRING at each occurrence of SEPARATOR. Returns list of strings." - (loop with start = 0 - for pos = (position separator string :start start) - collect (subseq string start pos) - while pos - do (setf start (1+ pos)))) - -;;; --------------------------------------------------------------------------- -;;; Global variables for rendering pipeline (set by application) -;;; --------------------------------------------------------------------------- -(defvar *current-backend* nil - "The active backend used for rendering.") -(defvar *current-theme* nil - "The active theme used for semantic color resolution.") - -;;; --------------------------------------------------------------------------- -;;; Key event struct -;;; --------------------------------------------------------------------------- -(defstruct key-event - (key nil :type (or keyword null)) - (ctrl nil :type boolean) - (alt nil :type boolean) - (shift nil :type boolean) - (code nil :type (or fixnum null)) - (raw nil :type (or string null)) - (text nil :type (or string null))) - -;;; --------------------------------------------------------------------------- -;;; Mouse event struct -;;; --------------------------------------------------------------------------- -(defstruct mouse-event - (type nil :type (or keyword null)) - (button nil :type (or keyword nil)) - (x 0 :type fixnum) - (y 0 :type fixnum) - (raw nil :type (or string null))) - -;;; --------------------------------------------------------------------------- -;;; Terminal raw mode -;;; --------------------------------------------------------------------------- -(defun save-terminal-state () - (sb-posix:tcgetattr 0)) - -(defun make-raw-termios (termios) - (flet ((clear-flag (flags mask) - (logand flags (lognot mask)))) - (setf (sb-posix:termios-iflag termios) - (clear-flag (sb-posix:termios-iflag termios) - (logior sb-posix:brkint sb-posix:ignpar - sb-posix:istrip sb-posix:inlcr - sb-posix:igncr sb-posix:icrnl - sb-posix:ixon))) - (setf (sb-posix:termios-oflag termios) - (clear-flag (sb-posix:termios-oflag termios) - sb-posix:opost)) - (setf (sb-posix:termios-lflag termios) - (clear-flag (sb-posix:termios-lflag termios) - (logior sb-posix:icanon sb-posix:echo - sb-posix:isig sb-posix:iexten))) - (setf (sb-posix:termios-cc termios sb-posix:vmin) 1) - (setf (sb-posix:termios-cc termios sb-posix:vtime) 0) - termios)) - -(defun set-raw-mode () - (let ((raw (make-raw-termios (save-terminal-state)))) - (sb-posix:tcsetattr 0 sb-posix:tcsanow raw) - raw)) - -(defun restore-terminal-state (termios) - (sb-posix:tcsetattr 0 sb-posix:tcsanow termios)) - -(defmacro with-raw-terminal (&body body) - (let ((saved (gensym "SAVED"))) - `(let ((,saved (save-terminal-state))) - (set-raw-mode) - (unwind-protect - (progn ,@body) - (restore-terminal-state ,saved))))) - -;;; --------------------------------------------------------------------------- -;;; Low-level byte reading -;;; --------------------------------------------------------------------------- -(defun read-raw-byte (&key timeout) - (if timeout - (let ((deadline (+ (get-universal-time) timeout))) - (loop while (< (get-universal-time) deadline) - do (handler-case - (let ((buf (make-array 1 :element-type '(unsigned-byte 8)))) - (let ((n (sb-posix:read 0 buf 1))) - (when (plusp n) - (return-from read-raw-byte (aref buf 0))))) - (sb-posix:syscall-error () - (return-from read-raw-byte nil))) - (sleep 0.01)) - nil) - (let ((buf (make-array 1 :element-type '(unsigned-byte 8)))) - (multiple-value-bind (n err) - (ignore-errors (sb-posix:read 0 buf 1)) - (if (and (integerp n) (plusp n)) - (aref buf 0) - (progn - (when err (format *error-output* "read error: ~A~%" err)) - nil)))))) - -;;; --------------------------------------------------------------------------- -;;; CSI parameter parser -;;; --------------------------------------------------------------------------- -(defun parse-csi-params () - (let ((params '()) - (raw (make-array 0 :element-type '(unsigned-byte 8) - :fill-pointer 0 :adjustable t)) - (current 0)) - (loop - (let ((b (read-raw-byte))) - (unless b (return (values nil nil nil))) - (vector-push-extend b raw) - (cond - ((and (>= b #x30) (<= b #x3f)) - (if (char= (code-char b) #\;) - (progn (push current params) (setf current 0)) - (setf current (+ (* current 10) (- b #x30))))) - ((and (>= b #x20) (<= b #x2f)) - nil) - ((and (>= b #x40) (<= b #x7e)) - (push current params) - (return (values (nreverse params) b - (map 'string #'code-char raw)))) - (t - (return (values nil nil nil)))))))) - -;;; --------------------------------------------------------------------------- -;;; Key event tables -;;; --------------------------------------------------------------------------- -(defparameter *csi-key-table* - '((#\A . :up) (#\B . :down) (#\C . :right) (#\D . :left) - (#\F . :end) (#\H . :home) - (#\P . :f1) (#\Q . :f2) (#\R . :f3) (#\S . :f4) - (#\Z . :tab))) - -(defparameter *csi-tilde-table* - '((1 . :home) (2 . :insert) (3 . :delete) - (4 . :end) (5 . :page-up) (6 . :page-down) - (7 . :home) (8 . :end) - (11 . :f1) (12 . :f2) (13 . :f3) (14 . :f4) - (15 . :f5) (17 . :f6) (18 . :f7) (19 . :f8) - (20 . :f9) (21 . :f10) (23 . :f11) (24 . :f12))) - -;;; --------------------------------------------------------------------------- -;;; SGR mouse parser -;;; --------------------------------------------------------------------------- -(defun parse-sgr-mouse (raw) - (let* ((start (position #\< raw)) - (end (position #\m raw :from-end t)) - (end2 (position #\M raw :from-end t)) - (final (if end end end2)) - (releasep (char= (char raw (1- (length raw))) #\m))) - (when (and start final (> final start)) - (let* ((nums (mapcar #'parse-integer - (%split-string (subseq raw (1+ start) final) #\;))) - (code (first nums)) - (x (or (second nums) 0)) - (y (or (third nums) 0)) - (button (logand code #x03)) - (mod (logand code #x1c)) - (motion (logand code #x20)) - (wheel (logand code #x40))) - (declare (ignore mod)) - (make-mouse-event - :type (cond (releasep :release) - (motion :drag) - (t :press)) - :button (cond (wheel (if (zerop (logand code #x01)) - :wheel-up :wheel-down)) - ((= button 0) :left) - ((= button 1) :middle) - ((= button 2) :right) - (t :none)) - :x x :y y :raw raw))))) - -;;; --------------------------------------------------------------------------- -;;; Escape sequence reader -;;; --------------------------------------------------------------------------- -(defun %read-escape-sequence () - (let ((b (read-raw-byte))) - (unless b - (return-from %read-escape-sequence - (make-key-event :key :escape :raw (string #\Esc)))) - (case b - ;; SS3: ESC O X - (#x4f - (let ((b2 (read-raw-byte))) - (if b2 - (let ((key (cdr (assoc (code-char b2) - '((#\P . :f1) (#\Q . :f2) - (#\R . :f3) (#\S . :f4)))))) - (make-key-event :key (or key :unknown) - :raw (format nil "~C~C~C" #\Esc #\O (code-char b2)))) - (make-key-event :key :escape :raw (string #\Esc))))) - ;; CSI: ESC [ ... - (#x5b - (multiple-value-bind (params final-byte) (parse-csi-params) - (if (null final-byte) - (make-key-event :key :escape :raw (string #\Esc)) - (if (and (char= (code-char final-byte) #\M) - (>= (length params) 3)) - (let* ((p0 (first params))) - (if (zerop (logand p0 #x40)) - (let* ((x (second params)) - (y (third params)) - (button (logand p0 #x03)) - (motion (logand p0 #x20)) - (wheel (logand p0 #x40))) - (make-mouse-event - :type (if motion :drag :press) - :button (cond (wheel (if (zerop (logand p0 #x01)) - :wheel-up :wheel-down)) - ((= button 0) :left) - ((= button 1) :middle) - ((= button 2) :right) - (t :none)) - :x x :y y :raw (format nil "~C[<~d;~d;~d~C" #\Esc p0 x y (code-char final-byte)))) - (let* ((tilde-p (char= (code-char final-byte) #\~)) - (param (or p0 0)) - (key (if tilde-p - (cdr (assoc param *csi-tilde-table*)) - (cdr (assoc (code-char final-byte) *csi-key-table*)))) - (modifier (when (> (length params) 1) (second params)))) - (let ((ctrl nil) (alt nil) (shift nil)) - (when modifier - (setf shift (logtest modifier 1) - alt (logtest modifier 2) - ctrl (logtest modifier 4))) - (make-key-event :key (or key :unknown) - :ctrl ctrl :alt alt :shift shift - :raw (format nil "~C[~d~C" #\Esc param (code-char final-byte)))))) - (let* ((tilde-p (char= (code-char final-byte) #\~)) - (param (or (first params) 0)) - (key (if tilde-p - (cdr (assoc param *csi-tilde-table*)) - (cdr (assoc (code-char final-byte) *csi-key-table*)))) - (modifier (when (> (length params) 1) (second params)))) - (let ((ctrl nil) (alt nil) (shift nil)) - (when modifier - (setf shift (logtest modifier 1) - alt (logtest modifier 2) - ctrl (logtest modifier 4))) - (make-key-event :key (or key :unknown) - :ctrl ctrl :alt alt :shift shift - :raw (format nil "~C[~d~C" #\Esc param (code-char final-byte)))))))))) - ;; ESC ESC - (#x1b - (make-key-event :key :escape :alt t :raw "\\e\\e")) - ;; ESC + printable = Alt+key - (t - (let ((ch (code-char b))) - (if (and (>= b #x20) (<= b #x7e)) - (make-key-event :key (intern (string (string-upcase ch)) :keyword) - :alt t - :raw (format nil "~C~C" #\Esc ch)) - (make-key-event :key :unknown - :raw (format nil "~C~C" #\Esc ch)))))))) - -;;; --------------------------------------------------------------------------- -;;; Top-level event reader -;;; --------------------------------------------------------------------------- -(defun %read-event (&key timeout) - (let ((b (read-raw-byte :timeout timeout))) - (unless b - (return-from %read-event nil)) - (case b - (#x1b - (%read-escape-sequence)) - (#x09 - (make-key-event :key :tab :code #x09)) - (#x0a - (make-key-event :key :enter :code #x0a)) - (#x0d - (make-key-event :key :enter :code #x0d)) - ((#x7f #x08) - (make-key-event :key :backspace :code b)) - ((and (>= b #x01) (<= b #x1a)) - (let ((key (intern (string-upcase (string (code-char (+ b #x60)))) :keyword))) - (make-key-event :key key :ctrl t :code b))) - (#x1c (make-key-event :key :backslash :ctrl t :code b)) - (#x1d (make-key-event :key :rbracket :ctrl t :code b)) - (#x1e (make-key-event :key :caret :ctrl t :code b)) - (#x1f (make-key-event :key :underscore :ctrl t :code b)) - ((and (>= b #x20) (<= b #x7e)) - (let ((ch (code-char b))) - (make-key-event :key (intern (string (string-upcase ch)) :keyword) - :code b))) - (t - (make-key-event :key :unknown :code b :raw (string (code-char b))))))) - -;;; --------------------------------------------------------------------------- -;;; Backend integration -;;; --------------------------------------------------------------------------- -(defmethod read-event ((b cl-tui.backend:backend) &key timeout) - (declare (ignore b)) - (when (probe-file "/dev/stdin") - (%read-event :timeout timeout))) -#+END_SRC - - -** text-input.lisp -#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp -(in-package #:cl-tui.input) - -;;; --------------------------------------------------------------------------- -;;; TextInput class -;;; --------------------------------------------------------------------------- -(defclass text-input (dirty-mixin) - ((value :initform "" :initarg :value :accessor text-input-value - :type string) - (cursor :initform 0 :initarg :cursor :accessor text-input-cursor - :type fixnum) - (placeholder :initform "" :initarg :placeholder - :accessor text-input-placeholder :type string) - (max-length :initform nil :initarg :max-length - :accessor text-input-max-length) - (on-submit :initform nil :initarg :on-submit - :accessor text-input-on-submit) - (layout-node :initform (make-layout-node) :accessor text-input-layout-node) - (focusable :initform t :accessor text-input-focusable))) - -(defun make-text-input (&key value cursor placeholder max-length on-submit) - (make-instance 'text-input - :value (or value "") - :cursor (or cursor 0) - :placeholder (or placeholder "") - :max-length max-length - :on-submit on-submit)) - -;;; --------------------------------------------------------------------------- -;;; Editing operations -;;; --------------------------------------------------------------------------- -(defun text-input-insert (input char) - "Insert CHAR at the cursor position in INPUT." - (let* ((val (text-input-value input)) - (pos (text-input-cursor input)) - (max (text-input-max-length input))) - (when (and max (>= (length val) max)) - (return-from text-input-insert)) - (setf (text-input-value input) - (concatenate 'string - (subseq val 0 pos) - (string char) - (subseq val pos))) - (incf (text-input-cursor input)) - (mark-dirty input))) - -(defun text-input-backspace (input) - "Delete character before cursor." - (let* ((val (text-input-value input)) - (pos (text-input-cursor input))) - (when (zerop pos) (return-from text-input-backspace)) - (setf (text-input-value input) - (concatenate 'string - (subseq val 0 (1- pos)) - (subseq val pos))) - (decf (text-input-cursor input)) - (mark-dirty input))) - -(defun text-input-delete (input) - "Delete character at cursor." - (let* ((val (text-input-value input)) - (pos (text-input-cursor input))) - (when (>= pos (length val)) - (return-from text-input-delete)) - (setf (text-input-value input) - (concatenate 'string - (subseq val 0 pos) - (subseq val (1+ pos)))) - (mark-dirty input))) - -;;; --------------------------------------------------------------------------- -;;; Cursor movement -;;; --------------------------------------------------------------------------- +-------------------------------------------- (defun text-input-move-left (input) (when (plusp (text-input-cursor input)) (decf (text-input-cursor input)))) @@ -2035,31 +591,27 @@ experience; this section is what actually generates the compilable code. (text-input-insert input ch)))))))) ;;; --------------------------------------------------------------------------- -;;; Rendering (stub — proper rendering uses theme + backend) +;;; Rendering ;;; --------------------------------------------------------------------------- (defmethod render ((in text-input) (backend t)) - "Render a text-input widget. Full rendering requires *current-backend*, - *current-theme*, and the rendering pipeline. This is a no-op stub for - unit testing the widget logic." - (declare (ignore in backend)) - (values)) + "Render text-input value or placeholder at layout position." + (let* ((ln (text-input-layout-node in)) + (x (if ln (layout-node-x ln) 0)) + (y (if ln (layout-node-y ln) 0)) + (w (if ln (layout-node-width ln) 80)) + (value (text-input-value in)) + (cursor (text-input-cursor in)) + (display (if (plusp (length value)) + value + (or (text-input-placeholder in) ""))) + (truncated (subseq display 0 (min (length display) w)))) + (draw-text backend x y truncated nil nil))) #+END_SRC ** textarea.lisp #+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp -(in-package #:cl-tui.input) - -;;; --------------------------------------------------------------------------- -;;; Utility: split string (local copy for dependency-free operation) -;;; --------------------------------------------------------------------------- -(defun %split-string (string separator) - "Split STRING at each occurrence of SEPARATOR. Returns list of strings." - (loop with start = 0 - for pos = (position separator string :start start) - collect (subseq string start pos) - while pos - do (setf start (1+ pos)))) +(in-package #:cl-tty.input) ;;; --------------------------------------------------------------------------- ;;; Textarea class @@ -2219,10 +771,10 @@ experience; this section is what actually generates the compilable code. "Save current value on undo stack." (let ((stack (textarea-undo-stack ta))) (when (>= (length stack) (array-total-size stack)) - (setf (textarea-undo-stack ta) - (make-array 100 :fill-pointer 0))) + (loop for i from 1 below (length stack) + do (setf (aref stack (1- i)) (aref stack i))) + (decf (fill-pointer stack))) (vector-push (textarea-value ta) stack) - ;; Clear redo stack on new action (setf (fill-pointer (textarea-redo-stack ta)) 0))) (defun textarea-undo (ta) @@ -2298,20 +850,28 @@ experience; this section is what actually generates the compilable code. (textarea-insert-char ta ch)))))))) ;;; --------------------------------------------------------------------------- -;;; Rendering (stub — proper rendering uses theme + backend) +;;; Rendering ;;; --------------------------------------------------------------------------- (defmethod render ((ta textarea) (backend t)) - "Render a textarea widget. Full rendering requires *current-backend*, - *current-theme*, and the rendering pipeline. This is a no-op stub for - unit testing the widget logic." - (declare (ignore ta backend)) - (values)) + "Render textarea lines at layout position." + (let* ((ln (textarea-layout-node ta)) + (x (if ln (layout-node-x ln) 0)) + (y (if ln (layout-node-y ln) 0)) + (w (if ln (layout-node-width ln) 80)) + (h (if ln (layout-node-height ln) 24)) + (lines (textarea-lines ta)) + (max-lines (min (length lines) h))) + (loop for i from 0 below max-lines + for line in lines + do (draw-text backend x (+ y i) + (subseq line 0 (min (length line) w)) + nil nil)))) #+END_SRC ** keybindings.lisp #+BEGIN_SRC lisp :tangle ../src/components/keybindings.lisp -(in-package #:cl-tui.input) +(in-package #:cl-tty.input) ;;; --------------------------------------------------------------------------- ;;; Key map struct @@ -2393,8 +953,8 @@ experience; this section is what actually generates the compilable code. ** input-package.lisp #+BEGIN_SRC lisp :tangle ../src/components/input-package.lisp -(defpackage :cl-tui.input - (:use :cl :cl-tui.backend :cl-tui.box :cl-tui.layout) +(defpackage :cl-tty.input + (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout) (:export ;; Key events #:key-event #:make-key-event @@ -2432,10 +992,10 @@ experience; this section is what actually generates the compilable code. ** input-tests.lisp #+BEGIN_SRC lisp :tangle ../tests/input-tests.lisp -(defpackage :cl-tui-input-test - (:use :cl :fiveam :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.input) +(defpackage :cl-tty-input-test + (:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) (:export #:run-tests)) -(in-package :cl-tui-input-test) +(in-package :cl-tty-input-test) (def-suite input-suite :description "Text input and keybinding tests") (in-suite input-suite) @@ -2701,5 +1261,4 @@ world"))) (:ctrl+q ,(lambda (e) (declare (ignore e)) (setf called t))))) (dispatch-key-event (make-key-event :key :q :ctrl t)) (is-true called))) -#+END_SRC - +#+END_SRC \ No newline at end of file diff --git a/run-all-tests.lisp b/run-all-tests.lisp new file mode 100644 index 0000000..dc14a25 --- /dev/null +++ b/run-all-tests.lisp @@ -0,0 +1,50 @@ +(load "~/quicklisp/setup.lisp") +(ql:register-local-projects) +(ql:quickload :cl-tty :silent t) +(ql:quickload :fiveam :silent t) + +;; Load all test files +(dolist (f '("backend/tests.lisp" "backend/modern-tests.lisp" + "layout/tests.lisp" + "src/components/box-tests.lisp" + "src/components/dirty-tests.lisp" + "src/components/render-tests.lisp" + "src/components/theme-tests.lisp" + "src/components/input-tests.lisp" + "tests/scrollbox-tabbar-tests.lisp" + "tests/select-tests.lisp" + "tests/markdown-tests.lisp" + "tests/dialog-tests.lisp" + "tests/mouse-tests.lisp" + "tests/slot-tests.lisp" + "tests/framebuffer-tests.lisp")) + (load f)) + +;; Run all test suites, exit non-zero if any fails +(let ((all-passed t)) + (dolist (suite '((:cl-tty-backend-test "BACKEND-SUITE") + (:cl-tty-box-test "BOX-SUITE") + (:cl-tty-input-test "INPUT-SUITE") + (:cl-tty-scrollbox-test "SCROLLBOX-SUITE") + (:cl-tty-select-test "SELECT-SUITE") + (:cl-tty-markdown-test :cl-tty-markdown-test) + (:cl-tty-dialog-test "DIALOG-SUITE") + (:cl-tty-mouse-test "MOUSE-SUITE") + (:cl-tty-slot-test "SLOT-SUITE") + (:cl-tty-layout-test "LAYOUT-SUITE") + (:cl-tty-modern-backend-test "MODERN-BACKEND-SUITE") + (:cl-tty-framebuffer-test "FRAMEBUFFER-SUITE"))) + (let* ((pkg (find-package (first suite))) + (suite-name (second suite)) + (s (etypecase suite-name + (keyword (find-symbol (string suite-name) :keyword)) + (string (find-symbol suite-name pkg))))) + (format t "~&=== ~a ===~%" (first suite)) + (if s + (let ((result (fiveam:run s))) + (fiveam:explain! result) + (unless (fiveam:results-status result) + (setf all-passed nil) + (format t "~&FAILED: ~a~%" (first suite)))) + (format t "Suite not found~%")))) + (uiop:quit (if all-passed 0 1))) diff --git a/src/components/box-tests.lisp b/src/components/box-tests.lisp index a2aa701..6caee6f 100644 --- a/src/components/box-tests.lisp +++ b/src/components/box-tests.lisp @@ -1,7 +1,7 @@ -(defpackage :cl-tui-box-test - (:use :cl :fiveam :cl-tui.backend :cl-tui.layout :cl-tui.box) +(defpackage :cl-tty-box-test + (:use :cl :fiveam :cl-tty.backend :cl-tty.layout :cl-tty.box) (:export #:run-tests)) -(in-package :cl-tui-box-test) +(in-package :cl-tty-box-test) (def-suite box-suite :description "Box renderable tests") (in-suite box-suite) diff --git a/src/components/box.lisp b/src/components/box.lisp index bfe5eb7..9aa08d1 100644 --- a/src/components/box.lisp +++ b/src/components/box.lisp @@ -1,4 +1,4 @@ -(in-package :cl-tui.box) +(in-package :cl-tty.box) (defclass box (dirty-mixin) ((layout-node :initform (make-layout-node) :accessor box-layout-node diff --git a/src/components/container-package.lisp b/src/components/container-package.lisp index f393d8c..cc4e61a 100644 --- a/src/components/container-package.lisp +++ b/src/components/container-package.lisp @@ -1,5 +1,5 @@ -(defpackage :cl-tui.container - (:use :cl :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.input) +(defpackage :cl-tty.container + (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) (:export #:scroll-box #:make-scroll-box #:scroll-box-scroll-y #:scroll-box-scroll-x @@ -9,5 +9,4 @@ #:tab-bar #:make-tab-bar #:tab-bar-active #:tab-bar-tabs #:tab-bar-add #:tab-bar-next #:tab-bar-prev - #:tab-bar-select #:tab-bar-handle-key - #:render)) + #:tab-bar-select #:tab-bar-handle-key)) diff --git a/src/components/dialog-package.lisp b/src/components/dialog-package.lisp new file mode 100644 index 0000000..093964b --- /dev/null +++ b/src/components/dialog-package.lisp @@ -0,0 +1,25 @@ +;;; dialog-package.lisp — Package definition for cl-tty.dialog + +(defpackage :cl-tty.dialog + (:use :cl :cl-tty.input :cl-tty.select) + (:export + #:dialog + #:dialog-title + #:dialog-content + #:dialog-on-dismiss + #:dialog-size + #:dialog-size-pixels + #:render-dialog + #:push-dialog + #:pop-dialog + #:*dialog-stack* + #:alert-dialog + #:confirm-dialog + #:select-dialog + #:prompt-dialog + #:toast + #:toast-message + #:toast-variant + #:render-toast + #:dismiss-toast + #:*toasts*)) diff --git a/src/components/dialog.lisp b/src/components/dialog.lisp new file mode 100644 index 0000000..fc5a8b1 --- /dev/null +++ b/src/components/dialog.lisp @@ -0,0 +1,124 @@ +;;; dialog.lisp — Dialog System + Toast for cl-tty + +(in-package :cl-tty.dialog) + +;; ─── Special variables ──────────────────────────────────────────────────────── + +(defvar *dialog-stack* nil + "Stack of active dialogs. (list) of dialog instances.") + +(defvar *toasts* nil + "List of active toast notifications.") + +;; ─── Dialog class ───────────────────────────────────────────────────────────── + +(defclass dialog () + ((title :initarg :title :accessor dialog-title) + (size :initarg :size :initform :medium :accessor dialog-size) + (content :initarg :content :initform nil :accessor dialog-content) + (on-dismiss :initarg :on-dismiss :initform nil :accessor dialog-on-dismiss))) + +(defun dialog-size-pixels (size) + (case size + (:small (values 40 8)) + (:medium (values 60 16)) + (:large (values 88 24)) + (t (values 60 16)))) + +(defun render-dialog (dialog screen w h) + (multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog)) + (let ((x (floor (- w dw) 2)) + (y (floor (- h dh) 2))) + ;; Backdrop — dim the full screen + (dotimes (row h) + (draw-rect screen 0 row w 1 :bg :bright-black)) + ;; Dialog panel + (draw-border screen x y dw dh :single :title (dialog-title dialog)) + (when (dialog-content dialog) + ;; Content rendering delegated to component system + (draw-text screen (1+ x) (1+ y) + (format nil "~a" (dialog-content dialog)) + :white :default))))) + +(defun push-dialog (dialog) + (push dialog *dialog-stack*) + dialog) + +(defun pop-dialog () + (when *dialog-stack* + (let ((dialog (pop *dialog-stack*))) + (when (dialog-on-dismiss dialog) + (funcall (dialog-on-dismiss dialog))) + dialog))) + +;; ─── Dialog sub-classes ────────────────────────────────────────────────────── + +(defun alert-dialog (title message) + (make-instance 'dialog + :title title + :size :small + :content (make-instance 'select + :options (list (list :title "OK" :value :ok)) + :on-select (lambda (opt) (declare (ignore opt)) (pop-dialog))) + :on-dismiss (lambda () (pop-dialog)))) + +(defun confirm-dialog (title message &key on-yes on-no) + (make-instance 'dialog + :title title + :size :small + :content (make-instance 'select + :options (list (list :title "Yes" :value :yes) + (list :title "No" :value :no)) + :on-select (lambda (opt) + (pop-dialog) + (if (eql opt :yes) + (when on-yes (funcall on-yes)) + (when on-no (funcall on-no))))))) + +(defun select-dialog (title options &key on-select) + (make-instance 'dialog + :title title + :size :medium + :content (make-instance 'select + :options options + :on-select (lambda (opt) + (pop-dialog) + (when on-select (funcall on-select opt)))))) + +(defun prompt-dialog (title &key on-submit) + (make-instance 'dialog + :title title + :size :small + :content (make-instance 'text-input + :on-submit (lambda (value) + (pop-dialog) + (when on-submit (funcall on-submit value)))))) + +;; ─── Toast system ───────────────────────────────────────────────────────────── + +(defclass toast () + ((message :initarg :message :accessor toast-message) + (variant :initarg :variant :initform :info :accessor toast-variant))) + +(defun render-toast (toast screen w) + (let* ((msg (toast-message toast)) + (variant (toast-variant toast)) + (color (case variant + (:info :blue) (:success :green) + (:warning :yellow) (:error :red))) + (max-w (min 60 (1- w))) + (x (- w max-w 1)) + (text (if (> (length msg) (- max-w 2)) + (concatenate 'string (subseq msg 0 (- max-w 5)) "...") + msg))) + (draw-rect screen x 0 max-w 1 :bg color) + (draw-text screen (1+ x) 0 text :white color :bold t))) + +(defun toast (message &key (variant :info) (duration 0)) + (let ((toast (make-instance 'toast :message message :variant variant))) + (push toast *toasts*) + (when (plusp duration) (dismiss-toast toast)) + toast)) + +(defun dismiss-toast (toast) + (setf *toasts* (remove toast *toasts*))) diff --git a/src/components/dirty-tests.lisp b/src/components/dirty-tests.lisp index 89b6bac..aa695cb 100644 --- a/src/components/dirty-tests.lisp +++ b/src/components/dirty-tests.lisp @@ -1,5 +1,5 @@ ;; Dirty tracking tests are in box-tests.lisp (same test suite) -(in-package :cl-tui-box-test) +(in-package :cl-tty-box-test) (in-suite box-suite) (test dirty-mixin-default-is-dirty diff --git a/src/components/dirty.lisp b/src/components/dirty.lisp index 0de9a9f..92edaaa 100644 --- a/src/components/dirty.lisp +++ b/src/components/dirty.lisp @@ -1,4 +1,4 @@ -(in-package :cl-tui.box) +(in-package :cl-tty.box) ;; ── Dirty Tracking ───────────────────────────────────────────── diff --git a/src/components/input-package.lisp b/src/components/input-package.lisp index e9010af..852926d 100644 --- a/src/components/input-package.lisp +++ b/src/components/input-package.lisp @@ -1,5 +1,5 @@ -(defpackage :cl-tui.input - (:use :cl :cl-tui.backend :cl-tui.box :cl-tui.layout) +(defpackage :cl-tty.input + (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout) (:export ;; Key events #:key-event #:make-key-event @@ -26,6 +26,7 @@ #:textarea-value #:textarea-cursor-row #:textarea-cursor-col #:textarea-on-submit #:textarea-undo-stack #:textarea-redo-stack #:textarea-layout-node + #:textarea-lines #:handle-textarea-input #:render-textarea ;; Keybindings #:keymap #:make-keymap #:keymap-name #:keymap-bindings #:keymap-parent diff --git a/src/components/input-tests.lisp b/src/components/input-tests.lisp index 1fadb5e..1f3971f 100644 --- a/src/components/input-tests.lisp +++ b/src/components/input-tests.lisp @@ -1,7 +1,7 @@ -(defpackage :cl-tui-input-test - (:use :cl :fiveam :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.input) +(defpackage :cl-tty-input-test + (:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) (:export #:run-tests)) -(in-package :cl-tui-input-test) +(in-package :cl-tty-input-test) (def-suite input-suite :description "Text input and keybinding tests") (in-suite input-suite) diff --git a/src/components/input.lisp b/src/components/input.lisp index ffe522f..b25d54e 100644 --- a/src/components/input.lisp +++ b/src/components/input.lisp @@ -1,4 +1,4 @@ -(in-package #:cl-tui.input) +(in-package #:cl-tty.input) ;;; --------------------------------------------------------------------------- ;;; Utility: split-string (avoids external dependency) @@ -42,38 +42,33 @@ (raw nil :type (or string null))) ;;; --------------------------------------------------------------------------- -;;; Terminal raw mode +;;; Terminal raw mode (stty on /dev/tty — portable across Unices) ;;; --------------------------------------------------------------------------- -(defun save-terminal-state () - (sb-posix:tcgetattr 0)) +(defun stty-run (args) + "Run stty with ARGS. Returns stdout as string." + (with-output-to-string (s) + (sb-ext:run-program "/bin/sh" + (list "-c" (format nil "stty ~{~a~^ ~} < /dev/tty" + (mapcar #'princ-to-string args))) + :output s :wait t))) -(defun make-raw-termios (termios) - (flet ((clear-flag (flags mask) - (logand flags (lognot mask)))) - (setf (sb-posix:termios-iflag termios) - (clear-flag (sb-posix:termios-iflag termios) - (logior sb-posix:brkint sb-posix:ignpar - sb-posix:istrip sb-posix:inlcr - sb-posix:igncr sb-posix:icrnl - sb-posix:ixon))) - (setf (sb-posix:termios-oflag termios) - (clear-flag (sb-posix:termios-oflag termios) - sb-posix:opost)) - (setf (sb-posix:termios-lflag termios) - (clear-flag (sb-posix:termios-lflag termios) - (logior sb-posix:icanon sb-posix:echo - sb-posix:isig sb-posix:iexten))) - (setf (sb-posix:termios-cc termios sb-posix:vmin) 1) - (setf (sb-posix:termios-cc termios sb-posix:vtime) 0) - termios)) +(defun save-terminal-state () + "Save current terminal settings via stty -g. Returns a string." + (let ((s (string-trim '(#\Newline #\Space) (stty-run '("-g"))))) + (when (zerop (length s)) + (error "stty -g failed — not running in a real terminal")) + s)) (defun set-raw-mode () - (let ((raw (make-raw-termios (save-terminal-state)))) - (sb-posix:tcsetattr 0 sb-posix:tcsanow raw) - raw)) + "Put terminal in raw mode via stty. Returns the saved state string." + (let ((saved (save-terminal-state))) + (stty-run '("raw" "-echo" "-isig" "-icanon" "min" "1" "time" "0")) + saved)) -(defun restore-terminal-state (termios) - (sb-posix:tcsetattr 0 sb-posix:tcsanow termios)) +(defun restore-terminal-state (saved) + "Restore saved terminal state (a string from stty -g, or nil)." + (when (and saved (plusp (length saved))) + (stty-run (list saved)))) (defmacro with-raw-terminal (&body body) (let ((saved (gensym "SAVED"))) @@ -87,26 +82,27 @@ ;;; Low-level byte reading ;;; --------------------------------------------------------------------------- (defun read-raw-byte (&key timeout) - (if timeout - (let ((deadline (+ (get-universal-time) timeout))) - (loop while (< (get-universal-time) deadline) - do (handler-case - (let ((buf (make-array 1 :element-type '(unsigned-byte 8)))) - (let ((n (sb-posix:read 0 buf 1))) - (when (plusp n) - (return-from read-raw-byte (aref buf 0))))) - (sb-posix:syscall-error () - (return-from read-raw-byte nil))) - (sleep 0.01)) - nil) - (let ((buf (make-array 1 :element-type '(unsigned-byte 8)))) - (multiple-value-bind (n err) - (ignore-errors (sb-posix:read 0 buf 1)) - (if (and (integerp n) (plusp n)) - (aref buf 0) - (progn - (when err (format *error-output* "read error: ~A~%" err)) - nil)))))) + (flet ((read-one () + (let ((buf (make-array 1 :element-type '(unsigned-byte 8)))) + ;; Use sb-sys:with-pinned-objects so sb-posix:read can access the buffer + (sb-sys:with-pinned-objects (buf) + (let ((n (sb-posix:read 0 (sb-sys:vector-sap buf) 1))) + (when (plusp n) + (return-from read-raw-byte (aref buf 0)))))))) + (if timeout + (let ((deadline (+ (get-universal-time) timeout))) + (loop while (< (get-universal-time) deadline) + do (handler-case + (read-one) + (sb-posix:syscall-error () + (return-from read-raw-byte nil))) + (sleep 0.01)) + nil) + (handler-case + (read-one) + (sb-posix:syscall-error (e) + (format *error-output* "read error: ~A~%" e) + nil))))) ;;; --------------------------------------------------------------------------- ;;; CSI parameter parser @@ -124,7 +120,10 @@ ((and (>= b #x30) (<= b #x3f)) (if (char= (code-char b) #\;) (progn (push current params) (setf current 0)) - (setf current (+ (* current 10) (- b #x30))))) + ;; Non-digit parameter characters (< = > ?) start a new param at zero + (if (member b '(#x3c #x3d #x3e #x3f) :test #'=) + (setf current 0) + (setf current (+ (* current 10) (- b #x30)))))) ((and (>= b #x20) (<= b #x2f)) nil) ((and (>= b #x40) (<= b #x7e)) @@ -204,10 +203,14 @@ (make-key-event :key :escape :raw (string #\Esc))))) ;; CSI: ESC [ ... (#x5b - (multiple-value-bind (params final-byte) (parse-csi-params) + (multiple-value-bind (params final-byte raw) (parse-csi-params) (if (null final-byte) (make-key-event :key :escape :raw (string #\Esc)) - (if (and (char= (code-char final-byte) #\M) + ;; SGR mouse: ESC [ < ... m/M + (if (and raw (plusp (length raw)) (char= (char raw 0) #\<)) + (or (parse-sgr-mouse raw) + (make-key-event :key :unknown :raw raw)) + (if (and (char= (code-char final-byte) #\M) (>= (length params) 3)) (let* ((p0 (first params))) (if (zerop (logand p0 #x40)) @@ -215,15 +218,12 @@ (y (third params)) (button (logand p0 #x03)) (motion (logand p0 #x20)) - (wheel (logand p0 #x40))) + (release (= button 3))) (make-mouse-event - :type (if motion :drag :press) - :button (cond (wheel (if (zerop (logand p0 #x01)) - :wheel-up :wheel-down)) - ((= button 0) :left) - ((= button 1) :middle) - ((= button 2) :right) - (t :none)) + :type (cond (release :release) + (motion :drag) + (t :press)) + :button (let ((b button)) (cond ((= b 0) :left) ((= b 1) :middle) ((= b 2) :right) (t :none))) :x x :y y :raw (format nil "~C[<~d;~d;~d~C" #\Esc p0 x y (code-char final-byte)))) (let* ((tilde-p (char= (code-char final-byte) #\~)) (param (or p0 0)) @@ -252,7 +252,7 @@ ctrl (logtest modifier 4))) (make-key-event :key (or key :unknown) :ctrl ctrl :alt alt :shift shift - :raw (format nil "~C[~d~C" #\Esc param (code-char final-byte)))))))))) + :raw (format nil "~C[~d~C" #\Esc param (code-char final-byte))))))))))) ;; ESC ESC (#x1b (make-key-event :key :escape :alt t :raw "\\e\\e")) @@ -273,24 +273,24 @@ (let ((b (read-raw-byte :timeout timeout))) (unless b (return-from %read-event nil)) - (case b - (#x1b + (cond + ((= b #x1b) (%read-escape-sequence)) - (#x09 + ((= b #x09) (make-key-event :key :tab :code #x09)) - (#x0a + ((= b #x0a) (make-key-event :key :enter :code #x0a)) - (#x0d + ((= b #x0d) (make-key-event :key :enter :code #x0d)) - ((#x7f #x08) + ((or (= b #x7f) (= b #x08)) (make-key-event :key :backspace :code b)) ((and (>= b #x01) (<= b #x1a)) (let ((key (intern (string-upcase (string (code-char (+ b #x60)))) :keyword))) (make-key-event :key key :ctrl t :code b))) - (#x1c (make-key-event :key :backslash :ctrl t :code b)) - (#x1d (make-key-event :key :rbracket :ctrl t :code b)) - (#x1e (make-key-event :key :caret :ctrl t :code b)) - (#x1f (make-key-event :key :underscore :ctrl t :code b)) + ((= b #x1c) (make-key-event :key :backslash :ctrl t :code b)) + ((= b #x1d) (make-key-event :key :rbracket :ctrl t :code b)) + ((= b #x1e) (make-key-event :key :caret :ctrl t :code b)) + ((= b #x1f) (make-key-event :key :underscore :ctrl t :code b)) ((and (>= b #x20) (<= b #x7e)) (let ((ch (code-char b))) (make-key-event :key (intern (string (string-upcase ch)) :keyword) @@ -301,7 +301,7 @@ ;;; --------------------------------------------------------------------------- ;;; Backend integration ;;; --------------------------------------------------------------------------- -(defmethod read-event ((b cl-tui.backend:backend) &key timeout) +(defmethod read-event ((b cl-tty.backend:backend) &key timeout) (declare (ignore b)) (when (probe-file "/dev/stdin") (%read-event :timeout timeout))) diff --git a/src/components/keybindings.lisp b/src/components/keybindings.lisp index f99453f..44e6d2f 100644 --- a/src/components/keybindings.lisp +++ b/src/components/keybindings.lisp @@ -1,4 +1,4 @@ -(in-package #:cl-tui.input) +(in-package #:cl-tty.input) ;;; --------------------------------------------------------------------------- ;;; Key map struct diff --git a/src/components/markdown-package.lisp b/src/components/markdown-package.lisp new file mode 100644 index 0000000..ea60250 --- /dev/null +++ b/src/components/markdown-package.lisp @@ -0,0 +1,11 @@ +;;; markdown-package.lisp — Package definition for cl-tty.markdown + +(defpackage :cl-tty.markdown + (:use :cl) + (:export + #:make-md-node #:md-node-p #:md-node-text + #:parse-blocks #:parse-inline + #:highlight-code + #:classify-diff-line #:render-md #:render-md-node + #:render-markdown #:render-inline + #:apply-style #:apply-styles)) diff --git a/src/components/markdown.lisp b/src/components/markdown.lisp new file mode 100644 index 0000000..a3b3404 --- /dev/null +++ b/src/components/markdown.lisp @@ -0,0 +1,681 @@ +;;; markdown.lisp — Markdown + Code + Diff rendering for cl-tty + +(in-package :cl-tty.markdown) + +;; ─── Node constructors ──────────────────────────────────────────────────────── + +(defun make-md-node (type &key children properties content url) + (let ((node (list :type type))) + (when children (setf (getf node :children) children)) + (when properties (setf (getf node :properties) properties)) + (when content (setf (getf node :content) content)) + (when url (setf (getf node :url) url)) + node)) + +(defun md-node-p (thing) + (and (listp thing) (getf thing :type))) + +(defun md-node-text (node) + (let ((type (getf node :type))) + (cond ((eql type :text) (or (getf node :content) "")) + ((eql type :link) + (concatenate 'string + (md-node-text (first (getf node :children))) + (format nil " (~a)" (or (getf node :url) "")))) + ((eql type :inline-code) (or (getf node :content) "")) + ((getf node :children) + (apply #'concatenate 'string + (mapcar #'md-node-text (getf node :children)))) + (t "")))) + +;; ─── Block-level parser ─────────────────────────────────────────────────────── + +(defun split-string-into-lines (string) + (let ((result nil) (start 0)) + (flet ((add-line (end) (push (subseq string start end) result))) + (loop for i from 0 below (length string) + do (let ((c (char string i))) + (cond ((char= c #\Newline) (add-line i) (setf start (1+ i))) + ((and (char= c #\Return) (< (1+ i) (length string)) + (char= (char string (1+ i)) #\Newline)) + (add-line i) (setf start (+ i 2)) (incf i))))) + (when (< start (length string)) (add-line (length string))) + (coerce (nreverse result) 'vector)))) + +(defun classify-line (line) + (cond + ((string= line "") (cons :blank nil)) + ((and (>= (length line) 3) + (let ((c0 (char line 0))) + (and (find c0 "-*") + (every (lambda (c) (or (char= c c0) (char= c #\Space) (char= c #\Tab))) + line)))) + (cons :thematic-break nil)) + ((and (char= (char line 0) #\#) + (let ((count 0)) + (loop for c across line while (char= c #\#) do (incf count)) + (and (<= 1 count 6) + (or (>= (length line) (1+ count)) + (member (char line count) '(#\Space #\Tab)))))) + (let* ((hash-count (loop for c across line while (char= c #\#) count c)) + (content (string-trim (list #\Space #\Tab) (subseq line hash-count)))) + (cons :heading (cons hash-count content)))) + ((char= (char line 0) #\>) + (cons :blockquote (string-trim (list #\Space #\Tab) (subseq line 1)))) + ((and (>= (length line) 2) (find (char line 0) "-*+") + (char= (char line 1) #\Space)) + (cons :list-item (string-trim (list #\Space #\Tab) (subseq line 2)))) + ((and (>= (length line) 3) (digit-char-p (char line 0)) + (loop for c across line while (digit-char-p c) + finally (return (find c ". )")))) + (let ((dot-pos (position-if (lambda (c) (find c ". )")) line))) + (if (and dot-pos (find (char line dot-pos) ". )")) + (cons :ordered-item (string-trim (list #\Space #\Tab) + (subseq line (1+ dot-pos)))) + (cons :paragraph line)))) + ((and (>= (length line) 4) (find (char line 0) "-+") + (char= (char line 1) (char line 0)) + (char= (char line 2) (char line 0)) + (char= (char line 3) #\Space)) + (cons :diff-header line)) + ((and (>= (length line) 1) (find (char line 0) "-+") + (not (and (>= (length line) 3) + (char= (char line 1) (char line 0)) + (char= (char line 2) (char line 0))))) + (cons :diff-line (cons (char line 0) (subseq line 1)))) + ((and (>= (length line) 3) (find (char line 0) "`~") + (let ((fence-len (loop for c across line + while (char= c (char line 0)) count c))) + (and (>= fence-len 3) + (let ((rest (string-trim (list #\Space #\Tab) + (subseq line fence-len)))) + (cons :code-start rest)))))) + (t (cons :paragraph line)))) + +(defun find-closing-marker (text start marker) + (let ((marker-len (length marker)) (len (length text))) + (loop for j from start to (- len marker-len) + do (when (and (char= (char text j) (char marker 0)) + (string= marker (subseq text j (+ j marker-len))) + (or (= j 0) (not (char= (char text (1- j)) #\\)))) + (return j)) + finally (return nil)))) + +(defun parse-paragraph (lines start) + (let ((text-parts nil) (i start)) + (loop while (< i (length lines)) + do (let* ((raw-line (aref lines i)) + (line (string-trim (list #\return) raw-line)) + (class (classify-line line))) + (case (car class) + ((:paragraph) (push (cdr class) text-parts) (incf i)) + (:blank (incf i) (loop-finish)) + (t (loop-finish))))) + (values (make-md-node :paragraph :children + (parse-inline + (with-output-to-string (s) + (loop for part in (nreverse text-parts) + for first = t then nil + do (unless first (write-char #\Space s)) + (princ part s))))) + i))) + +(defun parse-blockquote (lines start) + (let ((text-parts nil) (i start)) + (loop while (< i (length lines)) + do (let* ((raw-line (aref lines i)) + (line (string-trim (list #\return) raw-line)) + (class (classify-line line))) + (case (car class) + (:blockquote (push (cdr class) text-parts) (incf i)) + (:blank (incf i) (loop-finish)) + (t (loop-finish))))) + (values (make-md-node :blockquote :children + (parse-inline + (with-output-to-string (s) + (loop for part in (nreverse text-parts) + for first = t then nil + do (unless first (write-char #\Space s)) + (princ part s))))) + i))) + +(defun parse-list (lines start) + (declare (ignore start)) + (let ((items nil) (i start)) + (loop while (< i (length lines)) + do (let* ((raw-line (aref lines i)) + (line (string-trim (list #\return) raw-line)) + (class (classify-line line))) + (case (car class) + ((:list-item :ordered-item) + (push (cons (car class) (cdr class)) items) (incf i)) + (:blank + (if (and (< (1+ i) (length lines)) + (let ((nc (classify-line + (string-trim (list #\return) + (aref lines (1+ i)))))) + (member (car nc) '(:list-item :ordered-item)))) + (progn (push (cons :blank-sep nil) items) (incf i)) + (progn (incf i) (loop-finish)))) + (t (loop-finish))))) + (let ((nodes nil)) + (dolist (item (nreverse items)) + (let ((type (car item)) (content (cdr item))) + (when (and content (not (string= content ""))) + (push (make-md-node type :children (parse-inline content)) nodes)))) + (values (nreverse nodes) i)))) + +(defun parse-code-block (lines start lang) + (let ((code-lines nil) + (i (1+ start)) + (fence-char (char (aref lines start) 0)) + (fence-len (loop for c across (aref lines start) + while (char= c (char (aref lines start) 0)) count c))) + (loop while (< i (length lines)) + do (let* ((raw-line (aref lines i)) + (line (string-trim (list #\return) raw-line))) + (when (and (>= (length line) fence-len) + (every (lambda (c) (char= c fence-char)) + (subseq line 0 fence-len)) + (or (= (length line) fence-len) + (every (lambda (c) (find c " \t")) + (subseq line fence-len)))) + (incf i) (loop-finish)) + (push line code-lines) + (incf i))) + (values (make-md-node :code-block + :properties (list :language (and lang (not (string= lang "")) lang)) + :content + (with-output-to-string (s) + (loop for cl in (nreverse code-lines) + for first = t then nil + do (unless first (terpri s)) (princ cl s)))) + i))) + +(defun parse-diff-block (lines start) + (let ((diff-lines nil) (i start)) + (loop while (< i (length lines)) + do (let* ((raw-line (aref lines i)) + (line (string-trim (list #\return) raw-line)) + (class (classify-line line))) + (case (car class) + ((:diff-header :diff-line) (push line diff-lines) (incf i)) + (:blank (incf i) (loop-finish)) + (t (loop-finish))))) + (let ((lines-list (nreverse diff-lines))) + (values (make-md-node :diff-block + :content + (with-output-to-string (s) + (loop for dl in lines-list + for first = t then nil + do (unless first (terpri s)) (princ dl s))) + :properties (list :lines lines-list)) + i)))) + +(defun parse-blocks (text) + (let ((lines (split-string-into-lines text)) (nodes nil) (i 0)) + (loop while (< i (length lines)) + do (let* ((line (string-trim (list #\return) (aref lines i))) + (classification (classify-line line))) + (case (car classification) + (:blank (incf i)) + (:thematic-break (push (make-md-node :thematic-break) nodes) (incf i)) + (:paragraph + (multiple-value-bind (node consumed) (parse-paragraph lines i) + (push node nodes) (setf i consumed))) + (:heading + (let* ((level+content (cdr classification)) + (level (car level+content)) + (content (cdr level+content))) + (push (make-md-node :heading :properties (list :level level) + :children (parse-inline content)) nodes) + (incf i))) + (:blockquote + (multiple-value-bind (node consumed) (parse-blockquote lines i) + (push node nodes) (setf i consumed))) + (:list-item + (multiple-value-bind (node consumed) (parse-list lines i) + (dolist (n node) (push n nodes)) (setf i consumed))) + (:ordered-item + (multiple-value-bind (node consumed) (parse-list lines i) + (dolist (n node) (push n nodes)) (setf i consumed))) + (:code-start + (multiple-value-bind (node consumed) + (parse-code-block lines i (cdr classification)) + (push node nodes) (setf i consumed))) + (:diff-header + (multiple-value-bind (node consumed) (parse-diff-block lines i) + (push node nodes) (setf i consumed))) + (t (incf i))))) + (nreverse nodes))) + +;; ─── Inline parser ──────────────────────────────────────────────────────────── + +(defun parse-inline (text) + (unless (and text (> (length text) 0)) (return-from parse-inline nil)) + (let ((nodes nil) (i 0) (len (length text))) + (loop while (< i len) + do (let ((c (char text i))) + (case c + (#\* + (multiple-value-bind (node consumed) (parse-star-emphasis text i len) + (if node (progn (push node nodes) (setf i consumed)) + (progn (push (make-md-node :text :content (string c)) nodes) (incf i))))) + (#\_ + (multiple-value-bind (node consumed) (parse-underscore-emphasis text i len) + (if node (progn (push node nodes) (setf i consumed)) + (progn (push (make-md-node :text :content (string c)) nodes) (incf i))))) + (#\` + (multiple-value-bind (node consumed) (parse-inline-code text i len) + (if node (progn (push node nodes) (setf i consumed)) + (progn (push (make-md-node :text :content (string c)) nodes) (incf i))))) + (#\[ + (multiple-value-bind (node consumed) (parse-link text i len) + (if node (progn (push node nodes) (setf i consumed)) + (progn (push (make-md-node :text :content (string c)) nodes) (incf i))))) + (t (let ((start i)) + (incf i) + (loop while (< i len) + do (let ((nc (char text i))) + (if (find nc "*_`[") (loop-finish) + (progn + (when (and (< (1+ i) len) + (find nc "*_") + (char= nc (char text (1+ i)))) + (loop-finish)) + (incf i))))) + (push (make-md-node :text :content (subseq text start i)) nodes)))))) + (nreverse nodes))) + +(defun parse-star-emphasis (text i len) + (when (>= i len) (return-from parse-star-emphasis (values nil i))) + (if (and (< (1+ i) len) (char= (char text (1+ i)) #\*)) + (let ((close (find-closing-marker text (+ i 2) "**"))) + (if close + (values (make-md-node :bold :children (parse-inline (subseq text (+ i 2) close))) + (+ close 2)) + (values nil i))) + (let ((close (find-closing-marker text (1+ i) "*"))) + (if close + (values (make-md-node :italic :children (parse-inline (subseq text (1+ i) close))) + (1+ close)) + (values nil i))))) + +(defun parse-underscore-emphasis (text i len) + (when (>= i len) (return-from parse-underscore-emphasis (values nil i))) + (when (and (> i 0) (not (find (char text (1- i)) " \t\n\r"))) + (return-from parse-underscore-emphasis (values nil i))) + (if (and (< (1+ i) len) (char= (char text (1+ i)) #\_)) + (let ((close (find-closing-marker text (+ i 2) "__"))) + (if close + (values (make-md-node :bold :children (parse-inline (subseq text (+ i 2) close))) + (+ close 2)) + (values nil i))) + (let ((close (find-closing-marker text (1+ i) "_"))) + (if (and close + (or (>= (1+ close) len) + (find (char text (1+ close)) " \t\n\r.,;:!?"))) + (values (make-md-node :italic :children (parse-inline (subseq text (1+ i) close))) + (1+ close)) + (values nil i))))) + +(defun parse-inline-code (text i len) + (when (or (>= i len) (not (char= (char text i) #\`))) + (return-from parse-inline-code (values nil i))) + (let ((bt-count (loop for j from i below (min len (+ i 3)) + while (char= (char text j) #\`) count j))) + (let ((close (find-closing-marker text (+ i bt-count) + (make-string bt-count :initial-element #\`)))) + (if close + (values (make-md-node :inline-code + :content (subseq text (+ i bt-count) close)) + (+ close bt-count)) + (values nil i))))) + +(defun parse-link (text i len) + (when (or (>= i len) (not (char= (char text i) #\[))) + (return-from parse-link (values nil i))) + (let ((close-bracket (find-closing-marker text (1+ i) "]"))) + (unless close-bracket (return-from parse-link (values nil i))) + (when (or (>= (1+ close-bracket) len) + (not (char= (char text (1+ close-bracket)) #\())) + (return-from parse-link (values nil i))) + (let ((close-paren (find-closing-marker text (+ close-bracket 2) ")"))) + (unless close-paren (return-from parse-link (values nil i))) + (values (make-md-node :link + :children (parse-inline (subseq text (1+ i) close-bracket)) + :url (subseq text (+ close-bracket 2) close-paren)) + (1+ close-paren))))) + +;; ─── Syntax highlighting ────────────────────────────────────────────────────── + +(defun get-highlighter (lang) + (cdr (assoc lang + '(("lisp" . (:comment (";" "#|" ";;") :string ("\"") + :keyword ("defun" "defmacro" "defmethod" "defgeneric" + "defvar" "defparameter" "defconstant" "defstruct" + "defclass" "deftype" "define-condition" + "let" "let*" "flet" "labels" "macrolet" + "if" "when" "unless" "cond" "case" "ecase" "typecase" + "loop" "do" "dolist" "dotimes" "tagbody" "go" + "block" "return" "return-from" + "progn" "prog1" "prog2" + "lambda" "function" "quote" + "setf" "setq" "push" "pop" "incf" "decf" + "in-package" "defpackage" "export" "import" + "handler-case" "handler-bind" "ignore-errors" + "multiple-value-bind" "multiple-value-call" + "destructuring-bind" + "declare" "the" "values" + "and" "or" "not" "null" + "car" "cdr" "first" "rest" "second" + "cons" "list" "append" "nconc" + "mapcar" "mapc" "reduce" + "find" "position" "count" "subseq" + "format" "princ" "print" "write" "read" + "load" "compile" "eval" + "make-instance" "slot-value" + "type-of" "class-of") + :builtin ("t" "nil" + "*standard-output*" "*standard-input*" + "*error-output*" "*debug-io*" + "*package*" "*print-circle*"))) + + ("common-lisp" . (:comment (";" "#|" ";;") :string ("\"") + :keyword ("defun" "defmacro" "defmethod" "defgeneric" + "let" "if" "when" "unless" "cond" "case" + "loop" "do" "dolist" "dotimes" + "return" "return-from" "block" + "lambda" "function" "quote" + "setf" "setq" "push" "pop" "incf" "decf" + "handler-case" "handler-bind" + "declare" "the" "values" + "defpackage" "in-package" "export" "import" + "error" "warn" "assert" + "car" "cdr" "first" "rest" + "cons" "list" "append" "mapcar" "reduce" + "format" "princ" "print" "read" "load" + "make-instance") + :builtin ("t" "nil"))) + + ("python" . (:comment ("#") :string ("\"" "'" "\"\"\"" "'''") + :keyword ("def" "class" "return" "yield" "import" "from" + "if" "elif" "else" "for" "while" "in" "not" + "try" "except" "finally" "raise" "with" "pass" + "break" "continue" "lambda" "global" + "assert" "del" "is" + "self" "cls" "async" "await") + :builtin ("None" "True" "False"))) + + ("javascript" . (:comment ("//" "/*") :string ("\"" "'" "`") + :keyword ("function" "class" "const" "let" "var" + "if" "else" "for" "while" "do" "switch" + "return" "break" "continue" + "try" "catch" "finally" "throw" + "new" "this" "super" "delete" "typeof" + "import" "export" "from" "default" + "async" "await" "yield" "of") + :builtin ("true" "false" "null" "undefined" "NaN"))) + + ("bash" . (:comment ("#") :string ("\"" "'") + :keyword ("if" "then" "else" "elif" "fi" "for" "while" + "done" "case" "esac" "in" "function" "return" + "export" "local" "unset" "source" + "echo" "printf" "read" "test" "let" "declare") + :builtin ("true" "false" "cd" "ls" "cat" "grep" "sed" + "mv" "cp" "rm" "mkdir" "touch" "find" "wc" + "head" "tail" "date" "sleep" "kill"))) + + ("shell" . (:comment ("#") :string ("\"" "'") + :keyword ("if" "then" "else" "elif" "fi" "for" "while" + "done" "case" "esac" "in" "function" "return" + "export" "local" "unset" "source" + "echo" "printf" "read" "test") + :builtin ("true" "false" "cd" "ls" "grep" "sed" + "mv" "cp" "rm" "mkdir" "touch" "find")))) + :test #'string=))) + +(defun tokenize-line (line highlighter) + (let ((tokens nil) (i 0) (len (length line)) + (comment-chars (getf highlighter :comment)) + (string-chars (getf highlighter :string)) + (keywords (getf highlighter :keyword)) + (builtins (getf highlighter :builtin))) + (loop while (< i len) + do (let ((c (char line i))) + (cond + ((find c " \t") + (let ((start i)) + (loop while (and (< i len) (find (char line i) " \t")) do (incf i)) + (push (cons (subseq line start i) :plain) tokens))) + ((and comment-chars + (some (lambda (cc) + (and (<= (+ i (length cc)) len) + (string= cc (subseq line i (+ i (length cc)))))) + comment-chars)) + (push (cons (subseq line i) :comment) tokens) (setf i len)) + ((and string-chars (some (lambda (s) (find c s)) string-chars)) + (let ((start i)) + (incf i) + (let ((triple (and (< i (1- len)) (char= (char line i) c) + (char= (char line (1+ i)) c)))) + (if triple + (progn (incf i 2) + (loop while (and (< i len) + (not (and (char= (char line i) c) + (< (1+ i) len) + (char= (char line (1+ i)) c) + (< (+ i 2) len) + (char= (char line (+ i 2)) c)))) + do (incf i)) + (incf i 3)) + (progn (loop while (and (< i len) (char/= (char line i) c)) + do (incf i)) + (when (< i len) (incf i))))) + (push (cons (subseq line start i) :string) tokens))) + ((or (digit-char-p c) + (and (find c "+-") (< (1+ i) len) (digit-char-p (char line (1+ i))))) + (let ((start i)) + (loop while (and (< i len) (not (find (char line i) " \t()[]{}'\";:#"))) + do (incf i)) + (let ((token (subseq line start i))) + (if (digit-char-p (char token 0)) + (push (cons token :number) tokens) + (push (cons token :plain) tokens))))) + ((or (alpha-char-p c) + (and (find c "-_?!*<>=") (> len 1))) + (let ((start i)) + (loop while (and (< i len) + (or (alphanumericp (char line i)) + (find (char line i) "-_?!*<>="))) + do (incf i)) + (let* ((token (subseq line start i)) + (down (string-downcase token))) + (cond + ((find down keywords :test #'string=) + (push (cons token :keyword) tokens)) + ((find down builtins :test #'string=) + (push (cons token :builtin) tokens)) + (t (if (and (< i len) (char= (char line i) #\()) + (push (cons token :function) tokens) + (push (cons token :plain) tokens))))))) + (t (push (cons (string c) :plain) tokens) (incf i))))) + (nreverse tokens))) + +(defun highlight-code (code language) + (let ((highlighter (get-highlighter (and language (string-downcase language))))) + (unless highlighter (return-from highlight-code (list (cons code :plain)))) + (let ((tokens nil)) + (with-input-from-string (stream code) + (loop for line = (read-line stream nil nil) while line + do (let ((line-tokens (tokenize-line line highlighter))) + (when tokens (push (cons (string #\Newline) :plain) tokens)) + (setf tokens (nconc (nreverse line-tokens) tokens))))) + (nreverse tokens)))) + +(defun apply-highlight-token (token category) + (let ((code (case category + (:keyword "33") (:builtin "36") + (:function "34") (:comment "2") (:string "32") (:number "35") + (t nil)))) + (if code (format nil "~c[~am~a~c[0m" #\Esc code token #\Esc) token))) + +(defun apply-highlight-style (char-vector) + (coerce char-vector 'string)) + +;; ─── Diff rendering ─────────────────────────────────────────────────────────── + +(defun string-prefix-p (prefix string) + (and (>= (length string) (length prefix)) + (string= prefix (subseq string 0 (length prefix))))) + +(defun classify-diff-line (line) + (cond ((string-prefix-p "+++ " line) :file-header) + ((string-prefix-p "--- " line) :file-header) + ((string-prefix-p "@@" line) :hunk-header) + ((string-prefix-p "+" line) :added) + ((string-prefix-p "-" line) :removed) + (t :context))) + +;; ─── Rendering ──────────────────────────────────────────────────────────────── + +(defun apply-style (style text) + (let ((code (cond + ((eql style :bold) "1") ((eql style :italic) "3") + ((eql style :dim) "2") ((eql style :code) "0") + ((eql style :link) "4;36") ((eql style :url) "4;2") + ((eql style :underline) "4") ((eql style :strike) "9") + ((eql style :black) "30") ((eql style :red) "31") + ((eql style :green) "32") ((eql style :yellow) "33") + ((eql style :blue) "34") ((eql style :magenta) "35") + ((eql style :cyan) "36") ((eql style :white) "37") + ((eql style :bright-black) "90") ((eql style :bright-red) "91") + ((eql style :bright-green) "92") ((eql style :bright-yellow) "93") + ((eql style :bright-blue) "94") ((eql style :bright-magenta) "95") + ((eql style :bright-cyan) "96") ((eql style :bright-white) "97") + ((string= style "bold") "1") ((string= style "italic") "3") + ((string= style "dim") "2") ((string= style "code") "0") + ((string= style "link") "4;36") ((string= style "url") "4;2") + ((string= style "bright-cyan") "96") + ((string= style "bright-yellow") "93") + ((string= style "bright-white") "97") + ((string= style "bright-red") "91") + ((string= style "bright-green") "92") + ((string= style "bright-blue") "94") + ((string= style "bright-magenta") "95") + ((string= style "cyan") "36") ((string= style "yellow") "33") + ((string= style "red") "31") ((string= style "green") "32") + ((string= style "blue") "34") ((string= style "magenta") "35") + ((string= style "white") "37") ((string= style "black") "30") + (t nil)))) + (if code (format nil "~c[~am~a~c[0m" #\Esc code text #\Esc) text))) + +(defun render-inline (children) + (if (null children) "" + (with-output-to-string (s) + (dolist (child children) + (let ((type (getf child :type))) + (case type + (:text (princ (or (getf child :content) "") s)) + (:bold (princ (apply-style :bold (render-inline (getf child :children))) s)) + (:italic (princ (apply-style :italic (render-inline (getf child :children))) s)) + (:inline-code (princ (apply-style :code (or (getf child :content) "")) s)) + (:link (let ((text (render-inline (getf child :children))) + (url (or (getf child :url) ""))) + (princ (apply-style :link text) s) + (when (and url (not (string= url ""))) + (princ " " s) + (princ (apply-style :url (format nil "(~a)" url)) s)))) + (t (princ (or (getf child :content) "") s)))))))) + +(defun render-heading (node) + (let* ((level (or (getf (getf node :properties) :level) 1)) + (prefix (make-string (min level 6) :initial-element #\#)) + (text (render-inline (getf node :children))) + (color (cond ((= level 1) :bright-cyan) ((= level 2) :bright-yellow) + (t :bright-white)))) + (list (apply-style color (concatenate 'string prefix " " text))))) + +(defun render-paragraph (node) + (list (render-inline (getf node :children)))) + +(defun render-blockquote (node) + (list (apply-style :dim (concatenate 'string "> " (render-inline (getf node :children)))))) + +(defun render-code-block (node) + (let* ((language (or (getf (getf node :properties) :language) "")) + (content (or (getf node :content) "")) + (highlighted (unless (or (null language) (string= language "")) + (highlight-code content language))) + (lines nil)) + (when (and language (not (string= language ""))) + (push (apply-style :dim (format nil " ~~~~~~ ~a" language)) lines)) + (if highlighted + (let ((cl (make-array 0 :element-type 'character + :fill-pointer 0 :adjustable t)) + (output nil)) + (dolist (pair highlighted) + (let ((token (car pair)) (category (cdr pair))) + (cond ((string= token (string #\Newline)) + (push (apply-highlight-style cl) output) + (setf cl (make-array 0 :element-type 'character + :fill-pointer 0 :adjustable t))) + (t (let ((colored (apply-highlight-token token category))) + (loop for ch across colored + do (vector-push-extend ch cl))))))) + (when (> (length cl) 0) (push (apply-highlight-style cl) output)) + (setf lines (nconc lines (nreverse output)))) + (with-input-from-string (s content) + (loop for line = (read-line s nil nil) while line + do (push (apply-style :code line) lines)))) + (nreverse lines))) + +(defun render-diff-block (node) + (let* ((lines (getf (getf node :properties) :lines)) (result nil)) + (dolist (line (or lines + (and (getf node :content) + (let ((l (split-string-into-lines (getf node :content)))) + (loop for i from 0 below (length l) collect (aref l i)))))) + (let* ((class (classify-diff-line line)) + (color (case class + (:added "32") (:removed "31") + (:hunk-header "36") (:file-header "1;36") (t nil)))) + (if color + (push (format nil "~c[~am~a~c[0m" #\Esc color line #\Esc) result) + (push line result)))) + (nreverse result))) + +(defun render-thematic-break (node) + (declare (ignore node)) + (list (apply-style :dim "──────────────────────────────────────────────"))) + +(defun render-list-item (node) + (list (concatenate 'string + (if (eql (getf node :type) :ordered-item) " 1." " * ") + (render-inline (getf node :children))))) + +(defun render-md-node (node) + (let ((type (getf node :type))) + (case type + (:heading (render-heading node)) + (:paragraph (render-paragraph node)) + (:blockquote (render-blockquote node)) + (:code-block (render-code-block node)) + (:diff-block (render-diff-block node)) + (:thematic-break (render-thematic-break node)) + (:list-item (render-list-item node)) + (:ordered-item (render-list-item node)) + (t (list ""))))) + +(defun render-md (nodes) + (let ((lines nil)) + (dolist (node nodes) (setf lines (nconc lines (render-md-node node)))) + lines)) + +(defun render-markdown (text) + (let ((nodes (parse-blocks text)) (parts nil)) + (dolist (line (render-md nodes)) (push line parts)) + (with-output-to-string (s) + (loop for part in (nreverse parts) + for first = t then nil + do (unless first (terpri s)) (princ part s))))) diff --git a/src/components/mouse-package.lisp b/src/components/mouse-package.lisp new file mode 100644 index 0000000..9cc2706 --- /dev/null +++ b/src/components/mouse-package.lisp @@ -0,0 +1,12 @@ +(defpackage :cl-tty.mouse + (:use :cl :cl-tty.input :cl-tty.box :cl-tty.rendering) + (:export + #:mouse-mixin + #:on-mouse-down #:on-mouse-up #:on-mouse-move #:on-mouse-scroll + #:handle-mouse-event + #:hit-test + #:selection #:get-selection #:copy-to-clipboard + #:make-selection #:selection-p + #:start-selection #:update-selection #:finalize-selection + #:selection-active-p + #:cell-link-at #:open-link-at)) diff --git a/src/components/mouse.lisp b/src/components/mouse.lisp new file mode 100644 index 0000000..db68be7 --- /dev/null +++ b/src/components/mouse.lisp @@ -0,0 +1,108 @@ +(in-package :cl-tty.mouse) + +(defclass mouse-mixin () + ((on-mouse-down :initarg :on-mouse-down :initform nil :accessor on-mouse-down) + (on-mouse-up :initarg :on-mouse-up :initform nil :accessor on-mouse-up) + (on-mouse-move :initarg :on-mouse-move :initform nil :accessor on-mouse-move) + (on-mouse-scroll :initarg :on-mouse-scroll :initform nil :accessor on-mouse-scroll))) + +(defun handle-mouse-event (component event) + (let* ((type (mouse-event-type event)) + (handler (case type + (:press (on-mouse-down component)) + (:release (on-mouse-up component)) + (:drag (on-mouse-move component)) + (t nil)))) + (when handler (funcall handler event)))) + +(defun hit-test (root x y) + "Find the deepest component at (X, Y) by testing layout-node bounds. +Recurses into component-children to find the innermost match. +Components without a layout-node or position return nil." + (labels ((recurse (node) + (let ((ln (ignore-errors (component-layout-node node))) + (best nil)) + (when ln + (let ((nx (layout-node-x ln)) + (ny (layout-node-y ln)) + (nw (layout-node-width ln)) + (nh (layout-node-height ln))) + ;; Check children first for deeper match + (dolist (child (ignore-errors (component-children node))) + (let ((child-hit (recurse child))) + (when child-hit + (setf best child-hit)))) + ;; If no child matched, check self + (or best + (when (and (>= x nx) (< x (+ nx nw)) + (>= y ny) (< y (+ ny nh))) + node))))))) + (recurse root))) + +;; Selection +(defvar *selection* nil) + +(defstruct (selection (:conc-name sel-)) + (start-x 0) (start-y 0) (end-x 0) (end-y 0) (text "")) + +(defun get-selection () + (when *selection* (sel-text *selection*))) + +(defun copy-to-clipboard (text) + #+linux (sb-ext:run-program "xclip" (list "-selection" "clipboard") + :input text :wait nil) + #+darwin (sb-ext:run-program "pbcopy" nil :input text :wait nil)) + +;;; --- Selection tracking (mouse drag) --------------------------------------- + +(defvar *selection-active* nil + "T when a drag selection is in progress.") + +(defvar *selection-start* nil + "Cons (X . Y) of mouse-down position during drag.") + +(defvar *selection-end* nil + "Cons (X . Y) of current mouse position during drag.") + +(defun start-selection (x y) + "Begin a drag selection at (X Y)." + (setf *selection-start* (cons x y) + *selection-end* (cons x y) + *selection-active* t)) + +(defun update-selection (x y) + "Update the drag selection end position to (X Y)." + (setf *selection-end* (cons x y))) + +(defun selection-active-p () + "Return T if a drag selection is in progress." + *selection-active*) + +(defun finalize-selection (fb) + "End the drag selection and extract text from the framebuffer." + (setf *selection-active* nil) + (when (and *selection-start* *selection-end* fb) + (let* ((x1 (car *selection-start*)) + (y1 (cdr *selection-start*)) + (x2 (car *selection-end*)) + (y2 (cdr *selection-end*)) + (text (cl-tty.rendering:extract-text fb x1 y1 x2 y2))) + (setf *selection* (make-selection :start-x x1 :start-y y1 + :end-x x2 :end-y y2 + :text text)) + (setf *selection-start* nil *selection-end* nil) + text))) + +;;; --- Link clicking --------------------------------------------------------- + +(defun cell-link-at (fb x y) + "Return the link URL at (X Y) in framebuffer FB, or nil." + (cl-tty.rendering:fb-cell-link-url fb x y)) + +(defun open-link-at (fb x y) + "If there is a link URL at (X Y) in FB, open it via xdg-open." + (let ((url (cell-link-at fb x y))) + (when url + #+linux (sb-ext:run-program "xdg-open" (list url) :wait nil) + #+darwin (sb-ext:run-program "open" (list url) :wait nil)) + url)) diff --git a/src/components/package.lisp b/src/components/package.lisp index 3722403..a5a2c00 100644 --- a/src/components/package.lisp +++ b/src/components/package.lisp @@ -1,5 +1,5 @@ -(defpackage :cl-tui.box - (:use :cl :cl-tui.backend :cl-tui.layout) +(defpackage :cl-tty.box + (:use :cl :cl-tty.backend :cl-tty.layout) (:export ;; Box #:box #:make-box @@ -28,4 +28,4 @@ ;; Theme engine #:theme #:make-theme #:theme-mode #:theme-color #:load-preset #:define-preset)) -(in-package :cl-tui.box) +(in-package :cl-tty.box) diff --git a/src/components/render-tests.lisp b/src/components/render-tests.lisp index f0f552c..387eed8 100644 --- a/src/components/render-tests.lisp +++ b/src/components/render-tests.lisp @@ -1,4 +1,4 @@ -(in-package :cl-tui-box-test) +(in-package :cl-tty-box-test) (in-suite box-suite) (defun make-capturing-backend () diff --git a/src/components/render.lisp b/src/components/render.lisp index 85b17e7..9bae3e0 100644 --- a/src/components/render.lisp +++ b/src/components/render.lisp @@ -1,4 +1,4 @@ -(in-package :cl-tui.box) +(in-package :cl-tty.box) ;; ── Component Protocol ──────────────────────────────────────── diff --git a/src/components/scrollbox.lisp b/src/components/scrollbox.lisp index c5460f9..96a7641 100644 --- a/src/components/scrollbox.lisp +++ b/src/components/scrollbox.lisp @@ -1,4 +1,4 @@ -(in-package #:cl-tui.container) +(in-package #:cl-tty.container) (defclass scroll-box (dirty-mixin) ((children :initform nil :initarg :children :accessor scroll-box-children :type list) @@ -39,6 +39,8 @@ :initial-value 0)) (defmethod render ((sb scroll-box) backend) + "Render ScrollBox children within the viewport, offset by scroll position. +Children outside the viewport are skipped." (let* ((ln (scroll-box-layout-node sb)) (vx 0) (vy 0) (vw (if ln (layout-node-width ln) 80)) @@ -49,9 +51,20 @@ (let* ((cln (component-layout-node child)) (ch (if cln (layout-node-height cln) 1)) (cy vy)) - (when (and (< (+ cy (- sy)) (+ vh vy)) (> (+ cy (- sy) ch) vy)) - (draw-text backend (- sx) (+ vy cy (- sy)) - (format nil "child at ~D" vy) nil nil)) + ;; Only render children that are visible in the viewport + (when (and (< (+ cy (- sy)) (+ vh vy)) + (> (+ cy (- sy) ch) vy)) + ;; Temporarily offset child's layout-node position for rendering + (let ((orig-x (if cln (layout-node-x cln) 0)) + (orig-y (if cln (layout-node-y cln) 0))) + (when cln + (setf (layout-node-x cln) (- orig-x sx) + (layout-node-y cln) (- orig-y sy))) + (unwind-protect + (render child backend) + (when cln + (setf (layout-node-x cln) orig-x + (layout-node-y cln) orig-y))))) (incf vy ch))) (draw-scrollbars sb backend vw vh))) @@ -64,12 +77,12 @@ (when (> content-h viewport-h) (let* ((thumb (scrollbar-thumb sy viewport-h content-h)) (thumb-pos (round (* thumb viewport-h)))) - (draw-rect backend (1- viewport-w) 0 1 viewport-h :bg :background-element) + (draw-rect backend (1- viewport-w) 0 1 viewport-h :bg :bright-black) (draw-text backend (1- viewport-w) thumb-pos "█" nil nil))) (when (> content-w viewport-w) (let* ((thumb (scrollbar-thumb sx viewport-w content-w)) (thumb-pos (round (* thumb viewport-w)))) - (draw-rect backend 0 (1- viewport-h) viewport-w 1 :bg :background-element) + (draw-rect backend 0 (1- viewport-h) viewport-w 1 :bg :bright-black) (draw-text backend thumb-pos (1- viewport-h) "█" nil nil))))) (defun update-sticky-scroll (sb) diff --git a/src/components/select-package.lisp b/src/components/select-package.lisp new file mode 100644 index 0000000..cd05491 --- /dev/null +++ b/src/components/select-package.lisp @@ -0,0 +1,13 @@ +(defpackage :cl-tty.select + (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) + (:export + #:select #:make-select + #:select-options #:select-filter + #:select-selected-index #:select-on-select + #:select-layout-node + #:select-filtered-options + #:select-next #:select-prev + #:select-visible-options + #:select-handle-key + #:render + #:fuzzy-match-p)) diff --git a/src/components/select.lisp b/src/components/select.lisp new file mode 100644 index 0000000..fb57324 --- /dev/null +++ b/src/components/select.lisp @@ -0,0 +1,96 @@ +(in-package #:cl-tty.select) + +(defclass select (dirty-mixin) + ((options :initform nil :initarg :options :accessor select-options :type list) + (filter :initform nil :initarg :filter :accessor select-filter :type (or string null)) + (selected-index :initform 0 :initarg :selected-index :accessor select-selected-index :type fixnum) + (on-select :initform nil :initarg :on-select :accessor select-on-select) + (layout-node :initform (make-layout-node) :initarg :layout-node :accessor select-layout-node))) + +(defun make-select (&key options filter on-select) + (make-instance 'select :options (or options nil) :filter filter :on-select on-select)) + +(defmethod component-layout-node ((sel select)) (select-layout-node sel)) + +(defun select-filtered-options (sel) + (let* ((filter (select-filter sel)) (all-options (select-options sel)) + (filtered (if (null filter) all-options + (let ((lower (string-downcase filter))) + (remove-if-not + (lambda (opt) + (or (getf opt :category) + (let ((title (string-downcase (getf opt :title)))) + (or (search lower title) (fuzzy-match-p lower title))))) + all-options))))) + (loop for opt in filtered for i from 0 + collect (list i (position opt all-options) opt)))) + +(defun fuzzy-match-p (query target) + (let* ((q (remove-duplicates (coerce (string-downcase query) 'list))) + (tg (remove-duplicates (coerce (string-downcase target) 'list))) + (intersection (length (intersection q tg))) + (union (length (union q tg)))) + (if (zerop union) nil (> (/ (float intersection) union) 0.3)))) + +(defun select-clamp-index (sel) + (let* ((filtered (select-filtered-options sel)) (count (length filtered))) + (if (zerop count) (setf (select-selected-index sel) 0) + (setf (select-selected-index sel) (max 0 (min (select-selected-index sel) (1- count))))))) + +(defun select-next (sel) + (let* ((filtered (select-filtered-options sel)) (count (length filtered)) + (current (select-selected-index sel))) + (when (plusp count) + (loop for i from 1 below count + for idx = (mod (+ current i) count) + for opt = (third (nth idx filtered)) + when (not (getf opt :category)) + do (setf (select-selected-index sel) idx) (mark-dirty sel) (return))))) + +(defun select-prev (sel) + (let* ((filtered (select-filtered-options sel)) (count (length filtered)) + (current (select-selected-index sel))) + (when (plusp count) + (loop for i from 1 below count + for idx = (mod (- current i) count) + for opt = (third (nth idx filtered)) + when (not (getf opt :category)) + do (setf (select-selected-index sel) idx) (mark-dirty sel) (return))))) + +(defun select-handle-key (sel event) + (let ((key (key-event-key event)) (ctrl (key-event-ctrl event))) + (cond + ((or (eql key :down) (and ctrl (eql key :n))) (select-next sel) t) + ((or (eql key :up) (and ctrl (eql key :p))) (select-prev sel) t) + ((eql key :enter) + (let* ((filtered (select-filtered-options sel)) (idx (select-selected-index sel)) + (item (when (< idx (length filtered)) (third (nth idx filtered))))) + (when item (let ((cb (select-on-select sel))) (when cb (funcall cb item)))) t)) + ((eql key :escape) nil) (t nil)))) + +(defun select-visible-options (sel) + (let* ((ln (select-layout-node sel)) (height (if ln (layout-node-height ln) 80)) + (filtered (select-filtered-options sel)) (sel-idx (select-selected-index sel)) + (half (floor (1- height) 2)) (start (max 0 (- sel-idx half))) + (end (min (length filtered) (+ start height)))) + (subseq filtered start end))) + +(defmethod render ((sel select) backend) + (let* ((ln (select-layout-node sel)) + (x (if ln (layout-node-x ln) 0)) + (y (if ln (layout-node-y ln) 0)) + (w (if ln (layout-node-width ln) 80)) + (visible (select-visible-options sel)) (sel-idx (select-selected-index sel))) + (dolist (item visible) + (let* ((display-idx (first item)) (option (third item)) + (title (getf option :title)) (cat (getf option :category)) + (selected (eql display-idx sel-idx)) + (display (if (> (length title) (1- w)) + (concatenate 'string (subseq title 0 (1- w)) "…") title))) + (cond (cat (draw-text backend x y display :text-muted nil)) + (selected + (draw-rect backend x y w 1 :bg :accent) + (draw-text backend x y display :background :accent)) + (t (draw-text backend x y display nil nil))) + (incf y 1))) + (values))) diff --git a/src/components/slot-package.lisp b/src/components/slot-package.lisp new file mode 100644 index 0000000..5282534 --- /dev/null +++ b/src/components/slot-package.lisp @@ -0,0 +1,9 @@ +(defpackage :cl-tty.slot + (:use :cl) + (:export + #:defslot + #:slot-render + #:slot-p + #:clear-slot + #:list-slots + #:*slots*)) diff --git a/src/components/slot.lisp b/src/components/slot.lisp new file mode 100644 index 0000000..eb68c0a --- /dev/null +++ b/src/components/slot.lisp @@ -0,0 +1,27 @@ +(in-package :cl-tty.slot) + +(defvar *slots* (make-hash-table :test #'equal) + "Hash table mapping slot name (string) -> list of (order . render-fn) pairs.") + +(defun defslot (name &key (order 0) render-fn) + (let* ((key (string name)) + (entries (gethash key *slots*))) + (if (null entries) + (setf (gethash key *slots*) (list (cons order render-fn))) + (setf (gethash key *slots*) + (sort (cons (cons order render-fn) entries) #'< :key #'car)))) + render-fn) + +(defun slot-render (slot-name &rest args) + (let ((entries (gethash (string slot-name) *slots*))) + (when entries + (mapcar (lambda (entry) (apply (cdr entry) args)) entries)))) + +(defun slot-p (slot-name) + (nth-value 1 (gethash (string slot-name) *slots*))) + +(defun clear-slot (slot-name) + (remhash (string slot-name) *slots*)) + +(defun list-slots () + (loop for key being the hash-keys of *slots* collect key)) diff --git a/src/components/tabbar.lisp b/src/components/tabbar.lisp index a31a3d8..1ec6219 100644 --- a/src/components/tabbar.lisp +++ b/src/components/tabbar.lisp @@ -1,4 +1,4 @@ -(in-package #:cl-tui.container) +(in-package #:cl-tty.container) (defclass tab-bar (dirty-mixin) ((tabs :initform nil :initarg :tabs :accessor tab-bar-tabs :type list) @@ -35,9 +35,11 @@ (case (key-event-key event) (:left (tab-bar-prev tb) t) (:right (tab-bar-next tb) t) (t nil))) (defmethod render ((tb tab-bar) backend) - (let* ((ln (tab-bar-layout-node tb)) (y 0) + (let* ((ln (tab-bar-layout-node tb)) + (x (if ln (layout-node-x ln) 0)) + (y (if ln (layout-node-y ln) 0)) (w (if ln (layout-node-width ln) 80)) - (active-id (tab-bar-active tb)) (tabs (tab-bar-tabs tb)) (x-pos 0)) + (active-id (tab-bar-active tb)) (tabs (tab-bar-tabs tb)) (x-pos x)) (dolist (tab tabs) (let* ((id (getf tab :id)) (title (getf tab :title)) (label (format nil " ~A " title)) (label-len (length label)) diff --git a/src/components/text-input.lisp b/src/components/text-input.lisp index f43153f..4259f6b 100644 --- a/src/components/text-input.lisp +++ b/src/components/text-input.lisp @@ -1,4 +1,4 @@ -(in-package #:cl-tui.input) +(in-package #:cl-tty.input) ;;; --------------------------------------------------------------------------- ;;; TextInput class @@ -153,11 +153,19 @@ (text-input-insert input ch)))))))) ;;; --------------------------------------------------------------------------- -;;; Rendering (stub — proper rendering uses theme + backend) +;;; Rendering ;;; --------------------------------------------------------------------------- (defmethod render ((in text-input) (backend t)) - "Render a text-input widget. Full rendering requires *current-backend*, - *current-theme*, and the rendering pipeline. This is a no-op stub for - unit testing the widget logic." - (declare (ignore in backend)) - (values)) + "Render text-input value or placeholder at layout position." + (let* ((ln (text-input-layout-node in)) + (x (if ln (layout-node-x ln) 0)) + (y (if ln (layout-node-y ln) 0)) + (w (if ln (layout-node-width ln) 80)) + (value (text-input-value in)) + (cursor (text-input-cursor in)) + (display (if (plusp (length value)) + value + (or (text-input-placeholder in) ""))) + (truncated (subseq display 0 (min (length display) w)))) + (declare (ignore w cursor)) + (draw-text backend x y truncated nil nil))) diff --git a/src/components/text.lisp b/src/components/text.lisp index 9a74bbf..c9cf389 100644 --- a/src/components/text.lisp +++ b/src/components/text.lisp @@ -1,4 +1,4 @@ -(in-package :cl-tui.box) +(in-package :cl-tty.box) ;; ── Text Renderable ──────────────────────────────────────────── diff --git a/src/components/textarea.fasl b/src/components/textarea.fasl new file mode 100644 index 0000000..e63852b Binary files /dev/null and b/src/components/textarea.fasl differ diff --git a/src/components/textarea.lisp b/src/components/textarea.lisp index e160de3..5c8b1f0 100644 --- a/src/components/textarea.lisp +++ b/src/components/textarea.lisp @@ -1,15 +1,4 @@ -(in-package #:cl-tui.input) - -;;; --------------------------------------------------------------------------- -;;; Utility: split string (local copy for dependency-free operation) -;;; --------------------------------------------------------------------------- -(defun %split-string (string separator) - "Split STRING at each occurrence of SEPARATOR. Returns list of strings." - (loop with start = 0 - for pos = (position separator string :start start) - collect (subseq string start pos) - while pos - do (setf start (1+ pos)))) +(in-package #:cl-tty.input) ;;; --------------------------------------------------------------------------- ;;; Textarea class @@ -169,10 +158,10 @@ "Save current value on undo stack." (let ((stack (textarea-undo-stack ta))) (when (>= (length stack) (array-total-size stack)) - (setf (textarea-undo-stack ta) - (make-array 100 :fill-pointer 0))) + (loop for i from 1 below (length stack) + do (setf (aref stack (1- i)) (aref stack i))) + (decf (fill-pointer stack))) (vector-push (textarea-value ta) stack) - ;; Clear redo stack on new action (setf (fill-pointer (textarea-redo-stack ta)) 0))) (defun textarea-undo (ta) @@ -248,11 +237,19 @@ (textarea-insert-char ta ch)))))))) ;;; --------------------------------------------------------------------------- -;;; Rendering (stub — proper rendering uses theme + backend) +;;; Rendering ;;; --------------------------------------------------------------------------- (defmethod render ((ta textarea) (backend t)) - "Render a textarea widget. Full rendering requires *current-backend*, - *current-theme*, and the rendering pipeline. This is a no-op stub for - unit testing the widget logic." - (declare (ignore ta backend)) - (values)) + "Render textarea lines at layout position." + (let* ((ln (textarea-layout-node ta)) + (x (if ln (layout-node-x ln) 0)) + (y (if ln (layout-node-y ln) 0)) + (w (if ln (layout-node-width ln) 80)) + (h (if ln (layout-node-height ln) 24)) + (lines (textarea-lines ta)) + (max-lines (min (length lines) h))) + (loop for i from 0 below max-lines + for line in lines + do (draw-text backend x (+ y i) + (subseq line 0 (min (length line) w)) + nil nil)))) diff --git a/src/components/theme-tests.lisp b/src/components/theme-tests.lisp index da0f669..96c0ef8 100644 --- a/src/components/theme-tests.lisp +++ b/src/components/theme-tests.lisp @@ -1,4 +1,4 @@ -(in-package :cl-tui-box-test) +(in-package :cl-tty-box-test) (in-suite box-suite) (test theme-create-default diff --git a/src/components/theme.lisp b/src/components/theme.lisp index 487933a..f3cc09d 100644 --- a/src/components/theme.lisp +++ b/src/components/theme.lisp @@ -1,4 +1,4 @@ -(in-package :cl-tui.box) +(in-package :cl-tty.box) ;; ── Theme Engine ────────────────────────────────────────────── @@ -26,16 +26,20 @@ NAME should be a keyword (e.g., :default, :nord)." `(setf (gethash ,name *presets*) '(:dark ,dark :light ,light))) (defun load-preset (theme preset-name) - "Load PRESET-NAME (a keyword) into THEME, overwriting role mappings." + "Load PRESET-NAME colors into THEME. +Side-effect: populates cl-tty.backend:*theme-colors* so that semantic +color roles resolve to hex at SGR generation time." (let ((preset (gethash preset-name *presets*))) (if preset - (let* ((variant (if (eql (theme-mode theme) :dark) - (getf preset :dark) - (getf preset :light))) - (roles (theme-roles theme))) - (clrhash roles) - (loop for (role hex) on variant by #'cddr - do (setf (gethash role roles) hex))) + (let* ((colors (if (eql (theme-mode theme) :dark) + (getf preset :dark) + (getf preset :light))) + ;; Populate backend theme color map + (theme-map (symbol-value (find-symbol "*THEME-COLORS*" :cl-tty.backend)))) + ;; Set theme colors + (loop for (role hex) on colors by #'cddr + do (setf (theme-color theme role) hex) + (setf (gethash role theme-map) hex))) (warn "Unknown preset: ~S" preset-name)))) (define-preset :default diff --git a/src/rendering/framebuffer.lisp b/src/rendering/framebuffer.lisp new file mode 100644 index 0000000..241ebb3 --- /dev/null +++ b/src/rendering/framebuffer.lisp @@ -0,0 +1,219 @@ +(defpackage :cl-tty.rendering + (:use :cl :cl-tty.backend) + (:export + #:cell #:make-cell #:cell-char #:cell-fg #:cell-bg + #:cell-bold #:cell-italic #:cell-underline #:cell-link-url + #:framebuffer-backend #:make-framebuffer-backend + #:make-framebuffer #:fb-framebuffer + #:framebuffer-width #:framebuffer-height + #:diff-framebuffers #:flush-framebuffer + #:with-scissor + #:extract-text #:fb-cell-link-url)) + +(in-package :cl-tty.rendering) + +;;; ─── Cell — immutable per-cell state ───────────────────────────────────────── + +(defstruct cell + "A single terminal cell — character, colors, and attributes." + (char #\space :type character) + (fg nil) + (bg nil) + (bold nil :type boolean) + (italic nil :type boolean) + (underline nil :type boolean) + (link-url nil)) + +;;; ─── Framebuffer — 2D array of cells ──────────────────────────────────────── + +(defun make-framebuffer (width height) + "Create a 2D array of CELL with dimensions HEIGHT x WIDTH." + (make-array (list height width) + :initial-element (make-cell) + :element-type 'cell)) + +(defun framebuffer-width (fb) + "Return the width (columns) of framebuffer FB." + (if (arrayp fb) (array-dimension fb 1) 0)) + +(defun framebuffer-height (fb) + "Return the height (rows) of framebuffer FB." + (if (arrayp fb) (array-dimension fb 0) 0)) + +;;; ─── Framebuffer Backend — implements backend protocol ───────────────────── + +(defclass framebuffer-backend (backend) + ((framebuffer :initform nil :accessor fb-framebuffer) + (scissor-x :initform 0 :accessor fb-scissor-x) + (scissor-y :initform 0 :accessor fb-scissor-y) + (scissor-w :initform nil :accessor fb-scissor-w) + (scissor-h :initform nil :accessor fb-scissor-h))) + +(defun make-framebuffer-backend (&key (width 80) (height 24)) + "Create a framebuffer-backend with a fresh framebuffer." + (let ((fb (make-instance 'framebuffer-backend))) + (setf (fb-framebuffer fb) (make-framebuffer width height)) + fb)) + +;;; ─── Drawing methods ───────────────────────────────────────────────────────── + +(defun %in-scissor-p (fb cx cy) + "Check if (CX, CY) falls within the current scissor rectangle." + (let ((sx (fb-scissor-x fb)) (sy (fb-scissor-y fb)) + (sw (fb-scissor-w fb)) (sh (fb-scissor-h fb))) + (and (or (null sw) (and (>= cx sx) (< cx (+ sx sw)))) + (or (null sh) (and (>= cy sy) (< cy (+ sy sh))))))) + +(defun %set-cell (fb x y char &key fg bg bold italic underline link-url) + "Set cell (X, Y) if within bounds and scissor." + (let ((cells (fb-framebuffer fb))) + (when (and (>= y 0) (< y (framebuffer-height cells)) + (>= x 0) (< x (framebuffer-width cells)) + (%in-scissor-p fb x y)) + (setf (aref cells y x) + (make-cell :char char :fg fg :bg bg + :bold bold :italic italic :underline underline + :link-url link-url))))) + +(defmethod draw-text ((fb framebuffer-backend) x y string fg bg + &key bold italic underline reverse dim blink + (link-url nil link-url-p) + &allow-other-keys) + (declare (ignore reverse dim blink link-url-p)) + (loop for i from 0 below (length string) + do (%set-cell fb (+ x i) y (char string i) + :fg fg :bg bg + :bold bold :italic italic :underline underline + :link-url link-url))) + +(defmethod draw-rect ((fb framebuffer-backend) x y w h &key bg) + (dotimes (row h) + (dotimes (col w) + (%set-cell fb (+ x col) (+ y row) #\space :fg nil :bg bg)))) + +(defmethod draw-border ((fb framebuffer-backend) x y w h &key (style :single) title title-align fg bg) + (let* ((chars (case style + (:single '(#\+ #\- #\|)) + (:double '(#\+ #\= #\|)) + (:rounded '(#\. #\- #\|)) + (t '(#\+ #\- #\|)))) + (tc (first chars)) (hc (second chars)) (vc (third chars))) + ;; Top edge + (%set-cell fb x y tc :fg fg :bg bg) + (loop for i from 1 below (1- w) do (%set-cell fb (+ x i) y hc :fg fg :bg bg)) + (%set-cell fb (1- (+ x w)) y tc :fg fg :bg bg) + ;; Sides + (dotimes (row (- h 2)) + (%set-cell fb x (+ y row 1) vc :fg fg :bg bg) + (%set-cell fb (1- (+ x w)) (+ y row 1) vc :fg fg :bg bg)) + ;; Bottom edge + (%set-cell fb x (+ y h -1) tc :fg fg :bg bg) + (loop for i from 1 below (1- w) do (%set-cell fb (+ x i) (+ y h -1) hc :fg fg :bg bg)) + (%set-cell fb (1- (+ x w)) (+ y h -1) tc :fg fg :bg bg) + ;; Title + (when title + (loop for i from 0 below (length title) + do (%set-cell fb (+ x 2 i) y (char title i) :fg fg :bg bg))))) + +(defmethod backend-clear ((fb framebuffer-backend)) + (let ((cells (fb-framebuffer fb))) + (dotimes (y (framebuffer-height cells)) + (dotimes (x (framebuffer-width cells)) + (setf (aref cells y x) (make-cell)))))) + +(defmethod draw-link ((fb framebuffer-backend) x y string url &key fg bg) + ;; OSC 8 links are not rendered in framebuffer — store as text + (draw-text fb x y string fg bg :link-url url)) + +(defmethod draw-ellipsis ((fb framebuffer-backend) x y width &key fg bg) + (dotimes (i (min 3 width)) + (%set-cell fb (+ x i) y #\. :fg fg :bg bg))) + +;;; ─── Diff ──────────────────────────────────────────────────────────────────── + +(defun cells-equal-p (a b) + "Return T if two cells have identical content and style." + (and (eql (cell-char a) (cell-char b)) + (eql (cell-fg a) (cell-fg b)) + (eql (cell-bg a) (cell-bg b)) + (eql (cell-bold a) (cell-bold b)) + (eql (cell-italic a) (cell-italic b)) + (eql (cell-underline a) (cell-underline b)) + (equal (cell-link-url a) (cell-link-url b)))) + +(defun diff-framebuffers (prev curr) + "Compare PREV and CURR framebuffers. Return list of (X Y CELL) for changes." + (let ((changes nil) + (h (min (framebuffer-height prev) (framebuffer-height curr))) + (w (min (framebuffer-width prev) (framebuffer-width curr)))) + (dotimes (y h) + (dotimes (x w) + (let ((a (aref prev y x)) (b (aref curr y x))) + (unless (cells-equal-p a b) + (push (list x y b) changes))))) + (nreverse changes))) + +;;; ─── Flush ─────────────────────────────────────────────────────────────────── + +(defun flush-framebuffer (prev-fb curr-fb backend) + "Diff PREV-FB and CURR-FB and flush changes to BACKEND. +Returns the number of changed cells." + (let* ((changes (diff-framebuffers prev-fb curr-fb)) + (count (length changes)) + (current-row -1)) + (when (plusp count) + (begin-sync backend) + (dolist (change changes) + (destructuring-bind (x y cell) change + (unless (= y current-row) + (cursor-move backend x y) + (setf current-row y)) + (draw-text backend x y (string (cell-char cell)) + (cell-fg cell) (cell-bg cell) + :bold (cell-bold cell) + :italic (cell-italic cell) + :underline (cell-underline cell)))) + (end-sync backend)) + count)) + +;;; --- Frame inspection --------------------------------------------------- + +(defun fb-cell-link-url (fb x y) + "Return the link URL at (X Y) in framebuffer FB, or nil." + (when (and (arrayp fb) (>= y 0) (< y (array-dimension fb 0)) + (>= x 0) (< x (array-dimension fb 1))) + (let ((c (aref fb y x))) + (cell-link-url c)))) + +(defun extract-text (fb x1 y1 x2 y2) + "Extract visible text from the rectangle between (X1,Y1) and (X2,Y2)." + (let ((x-min (max 0 (min x1 x2))) (x-max (max 0 (max x1 x2))) + (y-min (max 0 (min y1 y2))) (y-max (max 0 (max y1 y2))) + (h (if (arrayp fb) (array-dimension fb 0) 0)) + (w (if (arrayp fb) (array-dimension fb 1) 0))) + (with-output-to-string (s) + (loop for y from y-min to (min y-max (1- h)) + do (loop for x from x-min to (min x-max (1- w)) + do (let ((c (aref fb y x))) + (princ (cell-char c) s))) + (when (< y y-max) (princ #\Newline s)))))) + +;;; ─── Scissor clipping ──────────────────────────────────────────────────────── + +(defmacro with-scissor ((fb x y w h) &body body) + "Clip all drawing on FB to rectangle (X Y W H)." + (let ((old-x (gensym)) (old-y (gensym)) + (old-w (gensym)) (old-h (gensym))) + `(let ((,old-x (fb-scissor-x ,fb)) + (,old-y (fb-scissor-y ,fb)) + (,old-w (fb-scissor-w ,fb)) + (,old-h (fb-scissor-h ,fb))) + (setf (fb-scissor-x ,fb) ,x + (fb-scissor-y ,fb) ,y + (fb-scissor-w ,fb) ,w + (fb-scissor-h ,fb) ,h) + (unwind-protect (progn ,@body) + (setf (fb-scissor-x ,fb) ,old-x + (fb-scissor-y ,fb) ,old-y + (fb-scissor-w ,fb) ,old-w + (fb-scissor-h ,fb) ,old-h))))) diff --git a/system-index.txt b/system-index.txt new file mode 100644 index 0000000..586f38c --- /dev/null +++ b/system-index.txt @@ -0,0 +1 @@ +cl-tty.asd diff --git a/tests/dialog-tests.lisp b/tests/dialog-tests.lisp new file mode 100644 index 0000000..ee27b7c --- /dev/null +++ b/tests/dialog-tests.lisp @@ -0,0 +1,43 @@ +;;; dialog-tests.lisp — Tests for cl-tty.dialog + +(defpackage :cl-tty-dialog-test + (:use :cl :cl-tty.dialog :fiveam)) + +(in-package :cl-tty-dialog-test) + +(def-suite dialog-suite :description "Dialog + Toast tests for cl-tty.dialog") +(in-suite dialog-suite) + +(def-test dialog-create () + (let ((d (make-instance 'dialog :title "Test"))) + (is-true (typep d 'dialog)) + (is (equal "Test" (dialog-title d))))) + +(def-test dialog-size-small () + (multiple-value-bind (w h) (dialog-size-pixels :small) + (is (= 40 w)) + (is (= 8 h)))) + +(def-test dialog-size-medium () + (multiple-value-bind (w h) (dialog-size-pixels :medium) + (is (= 60 w)) + (is (= 16 h)))) + +(def-test dialog-push-pop () + (let ((*dialog-stack* nil)) + (push-dialog (make-instance 'dialog :title "D1")) + (is (= 1 (length *dialog-stack*))) + (push-dialog (make-instance 'dialog :title "D2")) + (is (= 2 (length *dialog-stack*))) + (pop-dialog) + (is (= 1 (length *dialog-stack*))))) + +(def-test toast-create () + (let ((*toasts* nil)) + (toast "Hello" :variant :info :duration 0) + (is (= 1 (length *toasts*))))) + +(def-test toast-dismiss () + (let ((*toasts* (list (make-instance 'toast :message "T" :variant :info)))) + (dismiss-toast (first *toasts*)) + (is (= 0 (length *toasts*))))) diff --git a/tests/framebuffer-tests.lisp b/tests/framebuffer-tests.lisp new file mode 100644 index 0000000..be3dcda --- /dev/null +++ b/tests/framebuffer-tests.lisp @@ -0,0 +1,97 @@ +(defpackage :cl-tty-framebuffer-test + (:use :cl :fiveam :cl-tty.rendering :cl-tty.backend)) +(in-package :cl-tty-framebuffer-test) + +(def-suite framebuffer-suite :description "Framebuffer rendering pipeline tests") +(in-suite framebuffer-suite) + +(test make-framebuffer-creates-correct-size + (let ((fb (make-framebuffer 80 24))) + (is (= 24 (framebuffer-height fb))) + (is (= 80 (framebuffer-width fb))))) + +(test cell-defaults-are-space + (let ((cell (aref (make-framebuffer 10 10) 0 0))) + (is (eql #\space (cell-char cell))) + (is (null (cell-fg cell))) + (is (null (cell-bg cell))))) + +(test draw-text-on-fb-sets-cells + (let ((fb (make-framebuffer-backend))) + (draw-text fb 2 3 "abc" :red nil) + (let ((cells (fb-framebuffer fb))) + (is (eql #\a (cell-char (aref cells 3 2)))) + (is (eql #\b (cell-char (aref cells 3 3)))) + (is (eql #\c (cell-char (aref cells 3 4)))) + (is (eql :red (cell-fg (aref cells 3 2))))))) + +(test draw-text-clips-at-bounds + (let ((fb (make-framebuffer-backend :width 10 :height 5))) + (draw-text fb 8 2 "hello" nil nil) + (let ((cells (fb-framebuffer fb))) + (is (eql #\h (cell-char (aref cells 2 8)))) + (is (eql #\e (cell-char (aref cells 2 9)))) + (is (eql #\space (cell-char (aref cells 2 0))) "out of bounds text is ignored")))) + +(test diff-identical-fbs-returns-empty + (let ((fb1 (make-framebuffer 80 24)) + (fb2 (make-framebuffer 80 24))) + (is (null (diff-framebuffers fb1 fb2))))) + +(test diff-changed-fb-returns-changes + (let* ((fb1 (make-framebuffer 10 10)) + (fb2 (make-framebuffer 10 10))) + (setf (aref fb2 5 5) (make-cell :char #\X :fg :red)) + (let ((changes (diff-framebuffers fb1 fb2))) + (is (= 1 (length changes))) + (destructuring-bind (x y cell) (first changes) + (is (= 5 x)) + (is (= 5 y)) + (is (eql #\X (cell-char cell))))))) + +(test with-scissor-clips-drawing + (let ((fb (make-framebuffer-backend :width 20 :height 10))) + (with-scissor (fb 5 5 3 3) + (draw-text fb 6 6 "ABC" nil nil) + (draw-text fb 1 1 "OUTSIDE" nil nil)) + (let ((cells (fb-framebuffer fb))) + (is (eql #\A (cell-char (aref cells 6 6))) "inside scissor draws") + (is (eql #\space (cell-char (aref cells 1 1))) "outside scissor is clipped")))) + +(test flush-fb-copies-to-backend + (let* ((real-be (make-simple-backend :output-stream (make-string-output-stream))) + (fb (make-framebuffer-backend))) + (draw-text fb 0 0 "X" :red nil) + (let ((changed (flush-framebuffer (make-framebuffer 80 24) (fb-framebuffer fb) real-be))) + (is (>= changed 1))))) + +;; ── Frame inspection ────────────────────────────────────────── + +(test fb-cell-link-url-returns-nil-for-blank-cell + (let ((fb (make-framebuffer 10 10))) + (is (null (fb-cell-link-url fb 5 5))))) + +(test fb-cell-link-url-finds-link-url + (let ((fb (make-framebuffer-backend))) + (draw-text fb 0 0 "click" nil nil :link-url "https://example.com") + (is (equal "https://example.com" (fb-cell-link-url (fb-framebuffer fb) 0 0))) + (is (null (fb-cell-link-url (fb-framebuffer fb) 5 5))))) + +(test fb-cell-link-url-out-of-bounds-returns-nil + (let ((fb (make-framebuffer 5 5))) + (is (null (fb-cell-link-url fb 10 10))))) + +(test extract-text-single-row + (let ((fb (make-framebuffer-backend))) + (draw-text fb 0 0 "hello" nil nil) + (let ((cells (fb-framebuffer fb))) + (is (equal "hello" (extract-text cells 0 0 4 0)))))) + +(test extract-text-multi-row + (let ((fb (make-framebuffer-backend))) + (draw-text fb 0 0 "abc" nil nil) + (draw-text fb 0 1 "def" nil nil) + (let* ((cells (fb-framebuffer fb)) + (text (extract-text cells 0 0 2 1))) + (is (equal "abc +def" text))))) diff --git a/tests/input-tests.lisp b/tests/input-tests.lisp index 1fadb5e..1f3971f 100644 --- a/tests/input-tests.lisp +++ b/tests/input-tests.lisp @@ -1,7 +1,7 @@ -(defpackage :cl-tui-input-test - (:use :cl :fiveam :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.input) +(defpackage :cl-tty-input-test + (:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) (:export #:run-tests)) -(in-package :cl-tui-input-test) +(in-package :cl-tty-input-test) (def-suite input-suite :description "Text input and keybinding tests") (in-suite input-suite) diff --git a/tests/markdown-tests.lisp b/tests/markdown-tests.lisp new file mode 100644 index 0000000..6c87b0a --- /dev/null +++ b/tests/markdown-tests.lisp @@ -0,0 +1,205 @@ +;;; markdown-tests.lisp — Tests for cl-tty.markdown + +(defpackage :cl-tty-markdown-test + (:use :cl :cl-tty.markdown :fiveam)) + +(in-package :cl-tty-markdown-test) + +;; Test suite +(def-suite :cl-tty-markdown-test + :description "Markdown parser/renderer tests for cl-tty.markdown") + +(in-suite :cl-tty-markdown-test) + +;; ─── Parser tests ───────────────────────────────────────────────────────────── + +(def-test heading-parsing () + (let* ((result (parse-blocks "# Hello World")) (node (first result))) + (is-true (eql :heading (getf node :type))) + (is (= 1 (getf (getf node :properties) :level))))) + +(def-test heading-levels () + (loop for level from 1 to 6 + do (let* ((hashes (make-string level :initial-element #\#)) + (text (format nil "~a Heading ~d" hashes level)) + (result (parse-blocks text)) + (node (first result))) + (is-true (eql :heading (getf node :type))) + (is (= level (getf (getf node :properties) :level)))))) + +(def-test heading-with-inline-formatting () + (let* ((result (parse-blocks "# Hello **World**")) + (node (first result)) (children (getf node :children))) + (is-true (eql :heading (getf node :type))) + (is (= 2 (length children))) + (is-true (eql :text (getf (first children) :type))) + (is-true (eql :bold (getf (second children) :type))))) + +(def-test paragraph-parsing () + (let* ((result (parse-blocks "This is a paragraph.")) (node (first result))) + (is-true (eql :paragraph (getf node :type))))) + +(def-test paragraph-multi-line () + (let* ((result (parse-blocks "Line one\nLine two")) (node (first result))) + (is-true (eql :paragraph (getf node :type))))) + +(def-test bold-parsing () + (let* ((children (parse-inline "hello **world** here")) + (bold-node (second children))) + (is (= 3 (length children))) + (is-true (eql :bold (getf bold-node :type))))) + +(def-test italic-parsing () + (let* ((children (parse-inline "hello *world* here")) + (italic-node (second children))) + (is (= 3 (length children))) + (is-true (eql :italic (getf italic-node :type))))) + +(def-test bold-italic-combined () + (let ((children (parse-inline "**bold** and *italic*"))) + (is (= 3 (length children))) + (is-true (eql :bold (getf (first children) :type))) + (is-true (eql :italic (getf (third children) :type))))) + +(def-test inline-code-parsing () + (let* ((children (parse-inline "use `foo` here")) + (code-node (second children))) + (is (= 3 (length children))) + (is-true (eql :inline-code (getf code-node :type))) + (is (equal "foo" (getf code-node :content))))) + +(def-test link-parsing () + (let* ((children (parse-inline "click [here](https://x.com)")) + (link-node (second children))) + (is (= 2 (length children))) + (is-true (eql :link (getf link-node :type))) + (is (equal "https://x.com" (getf link-node :url))) + (let ((link-text (getf link-node :children))) + (is (= 1 (length link-text))) + (is-true (eql :text (getf (first link-text) :type))) + (is (equal "here" (getf (first link-text) :content)))))) + +(def-test code-block-parsing () + (let* ((text (format nil "```lisp~%(defun hello ())~% (print \"hi\")~%```")) + (result (parse-blocks text)) (node (first result))) + (is-true (eql :code-block (getf node :type))) + (is (equal "lisp" (getf (getf node :properties) :language))) + (is-true (search "(defun hello" (getf node :content))))) + +(def-test code-block-unknown-language () + (let* ((text (format nil "```~%plain code~%```")) + (result (parse-blocks text)) (node (first result))) + (is-true (eql :code-block (getf node :type))) + (is-false (getf (getf node :properties) :language)))) + +(def-test blockquote-parsing () + (let* ((result (parse-blocks "> This is a quote")) (node (first result))) + (is-true (eql :blockquote (getf node :type))))) + +(def-test list-item-parsing () + (let* ((result (parse-blocks "- First item")) (node (first result))) + (is-true (eql :list-item (getf node :type))))) + +(def-test ordered-list-parsing () + (let* ((result (parse-blocks "1. First item")) (node (first result))) + (is-true (eql :ordered-item (getf node :type))))) + +(def-test thematic-break-parsing () + (let* ((result (parse-blocks "---")) (node (first result))) + (is-true (eql :thematic-break (getf node :type))))) + +;; ─── Diff tests ─────────────────────────────────────────────────────────────── + +(def-test classify-diff-added () + (is (eql :added (classify-diff-line "+this is added")))) + +(def-test classify-diff-removed () + (is (eql :removed (classify-diff-line "-this is removed")))) + +(def-test classify-diff-hunk () + (is (eql :hunk-header (classify-diff-line "@@ -1,3 +1,4 @@")))) + +(def-test classify-diff-context () + (is (eql :context (classify-diff-line " normal context")))) + +;; ─── Syntax highlighting tests ──────────────────────────────────────────────── +(def-test highlight-lisp-keyword () + (let ((tokens (highlight-code "(defun hello ()" "lisp"))) + (is-true (some (lambda (pair) (and (search "defun" (car pair)) + (eql :keyword (cdr pair)))) + tokens)))) + +(def-test highlight-lisp-builtin () + "Test that a Lisp builtin like nil is highlighted as :builtin." + (let ((tokens (highlight-code "(if t nil)" "lisp"))) + (is-true (some (lambda (pair) (and (string= (car pair) "nil") + (eql :builtin (cdr pair)))) + tokens)))) + +(def-test highlight-unknown-language () + (let ((tokens (highlight-code "hello world" "unknown-xyz"))) + (every (lambda (pair) (eql :plain (cdr pair))) tokens))) + +(def-test highlight-comment () + (let ((tokens (highlight-code "; this is a comment" "lisp"))) + (is-true (some (lambda (pair) (eql :comment (cdr pair))) tokens)))) + +;; ─── Render tests ───────────────────────────────────────────────────────────── + +(def-test render-heading-output () + (let* ((node (make-md-node :heading :properties (list :level 2) + :children (list (make-md-node :text :content "Test")))) + (lines (render-md-node node))) + (is (= 1 (length lines))) + (is-true (> (length (first lines)) 0)))) + +(def-test render-paragraph-output () + (let* ((node (make-md-node :paragraph + :children (list (make-md-node :text :content "Hello")))) + (lines (render-md-node node))) + (is (= 1 (length lines))) + (is-true (search "Hello" (first lines))))) + +(def-test render-thematic-break-output () + (let* ((node (make-md-node :thematic-break)) (lines (render-md-node node))) + (is (= 1 (length lines))))) + +(def-test render-code-block-output () + (let* ((node (make-md-node :code-block :content "(print \"hello\")" + :properties (list :language "lisp"))) + (lines (render-md-node node))) + (is-true (> (length lines) 0)))) + +(def-test render-diff-block-output () + (let* ((node (make-md-node :diff-block :properties + (list :lines + '("--- a/file" "+++ b/file" "@@ -1 +1 @@" + "+added" "-removed" " context")))) + (lines (render-md-node node))) + (is (= 6 (length lines))) + (is (search "added" (fourth lines))) + (is (search "removed" (fifth lines))))) + +;; ─── Integration tests ──────────────────────────────────────────────────────── + +(def-test markdown-integration () + (let* ((md (format nil "# Title~%~%This is **bold** and `code`.~%~%- Item 1~%- Item 2~%~%> A quote~%~%```lisp~%(defun hello ())~% (print \"hi\")~%```~%~%---")) + (nodes (parse-blocks md)) (lines (render-md nodes))) + (is-true (> (length lines) 5)) + (is-true (search "# Title" (first lines))))) + +(def-test render-markdown-string () + (let ((result (render-markdown "**bold** text"))) + (is-true (stringp result)) + (is-true (> (length result) 0)))) + +(def-test md-node-text-simple () + (let ((node (make-md-node :text :content "hello"))) + (is (equal "hello" (md-node-text node))))) + +(def-test md-node-text-nested () + (let ((node (make-md-node :paragraph :children + (list (make-md-node :text :content "hello") + (make-md-node :bold :children + (list (make-md-node :text :content "world"))))))) + (is (equal "helloworld" (md-node-text node))))) diff --git a/tests/mouse-tests.lisp b/tests/mouse-tests.lisp new file mode 100644 index 0000000..336163b --- /dev/null +++ b/tests/mouse-tests.lisp @@ -0,0 +1,49 @@ +(defpackage :cl-tty-mouse-test (:use :cl :cl-tty.mouse :fiveam)) +(in-package :cl-tty-mouse-test) + +(def-suite mouse-suite :description "Mouse tests") +(in-suite mouse-suite) + +(def-test mouse-mixin-create () + (let ((m (make-instance 'mouse-mixin))) + (is-true (typep m 'mouse-mixin)))) + +(def-test mouse-hit-test-point () + "hit-test returns nil when no component has position slots bound" + (let ((obj (make-instance 'mouse-mixin))) + (is-false (hit-test obj 0 0)) + (is-false (hit-test obj 100 100)))) + +(def-test selection-set-and-get () + (setf cl-tty.mouse::*selection* (make-selection :text "hello")) + (is (equal "hello" (get-selection)))) + +;; ── Selection tracking ────────────────────────────────────── + +(def-test start-selection-initializes-state () + (start-selection 5 10) + (is-true (selection-active-p)) + (is (equal '(5 . 10) cl-tty.mouse::*selection-start*)) + (is (equal '(5 . 10) cl-tty.mouse::*selection-end*)) + (setf cl-tty.mouse::*selection-active* nil + cl-tty.mouse::*selection-start* nil + cl-tty.mouse::*selection-end* nil)) + +(def-test update-selection-moves-end () + (start-selection 0 0) + (update-selection 3 7) + (is (equal '(3 . 7) cl-tty.mouse::*selection-end*)) + (setf cl-tty.mouse::*selection-active* nil + cl-tty.mouse::*selection-start* nil + cl-tty.mouse::*selection-end* nil)) + +(def-test finalize-selection-extracts-text () + (let* ((fb-be (cl-tty.rendering:make-framebuffer-backend)) + (fb (cl-tty.rendering:fb-framebuffer fb-be))) + (cl-tty.backend:draw-text fb-be 0 0 "hello" nil nil) + (cl-tty.backend:draw-text fb-be 0 1 "world" nil nil) + (start-selection 0 0) + (update-selection 4 1) + (let ((text (finalize-selection fb))) + (is (equal "hello +world" text))))) diff --git a/tests/scrollbox-tabbar-tests.lisp b/tests/scrollbox-tabbar-tests.lisp index 3a7e347..7e9400e 100644 --- a/tests/scrollbox-tabbar-tests.lisp +++ b/tests/scrollbox-tabbar-tests.lisp @@ -1,7 +1,7 @@ -(defpackage :cl-tui-scrollbox-test - (:use :cl :fiveam :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.input :cl-tui.container) +(defpackage :cl-tty-scrollbox-test + (:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input :cl-tty.container) (:export #:run-tests)) -(in-package #:cl-tui-scrollbox-test) +(in-package #:cl-tty-scrollbox-test) (def-suite scrollbox-suite :description "ScrollBox + TabBar tests") (in-suite scrollbox-suite) diff --git a/tests/select-tests.lisp b/tests/select-tests.lisp new file mode 100644 index 0000000..87670c3 --- /dev/null +++ b/tests/select-tests.lisp @@ -0,0 +1,120 @@ +(defpackage :cl-tty-select-test + (:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input :cl-tty.select) + (:export #:run-tests)) +(in-package #:cl-tty-select-test) + +(def-suite select-suite :description "Select widget tests") +(in-suite select-suite) + +(defun run-tests () + (let ((result (run 'select-suite))) + (fiveam:explain! result) + (uiop:quit 0))) + +(test select-creates + "A Select can be created with defaults." + (let ((sel (make-select))) + (is (typep sel 'select)) + (is-false (select-options sel)) + (is-false (select-filter sel)) + (is (= (select-selected-index sel) 0)))) + +(test select-with-options + "A Select stores options." + (let ((sel (make-select :options '((:title "Red" :value :red) + (:title "Blue" :value :blue))))) + (is (= (length (select-options sel)) 2)))) + +(test select-filtered-exact + "Filter returns case-insensitive substring matches." + (let ((sel (make-select + :options '((:title "Red" :value :red) + (:title "Green" :value :green) + (:title "Blue" :value :blue))))) + (setf (select-filter sel) "bl") + (let ((filtered (select-filtered-options sel))) + (is (= (length filtered) 1)) + (is (eql (getf (third (first filtered)) :value) :blue))))) + +(test select-filtered-all + "Nil filter returns all options." + (let ((sel (make-select + :options '((:title "Red" :value :red) + (:title "Blue" :value :blue))))) + (let ((filtered (select-filtered-options sel))) + (is (= (length filtered) 2))))) + +(test select-navigation + "Select-next and select-prev navigate through options." + (let ((sel (make-select + :options '((:title "A" :value :a) + (:title "B" :value :b) + (:title "C" :value :c))))) + (is (= (select-selected-index sel) 0)) + (select-next sel) + (is (= (select-selected-index sel) 1)) + (select-next sel) + (is (= (select-selected-index sel) 2)) + (select-next sel) + (is (= (select-selected-index sel) 0) "wraps forward") + (select-prev sel) + (is (= (select-selected-index sel) 2) "wraps backward"))) + +(test select-navigation-skips-categories + "Navigation skips category header options." + (let ((sel (make-select + :options '((:title "Colors" :category t) + (:title "Red" :value :red) + (:title "Green" :value :green) + (:title "Shapes" :category t) + (:title "Circle" :value :circle))))) + (is (= (select-selected-index sel) 0)) + (select-next sel) + (is (= (select-selected-index sel) 1) "skipped category header at 0") + (select-next sel) + (is (= (select-selected-index sel) 2)) + (select-next sel) + (is (= (select-selected-index sel) 4) "skipped category header at 3"))) + +(test select-handle-key + "Select handle-key dispatches navigation and selection." + (let* ((result (list nil)) + (sel (make-select + :options '((:title "A" :value :a) (:title "B" :value :b)) + :on-select (lambda (opt) (setf (car result) (getf opt :value)))))) + (select-handle-key sel (make-key-event :key :down)) + (is (= (select-selected-index sel) 1)) + (select-handle-key sel (make-key-event :key :up)) + (is (= (select-selected-index sel) 0)) + (select-handle-key sel (make-key-event :key :enter)) + (is (eql (car result) :a)))) + +(test select-handle-key-ctrl + "Ctrl+N and Ctrl+P navigate like down/up." + (let ((sel (make-select + :options '((:title "A" :value :a) (:title "B" :value :b) (:title "C" :value :c))))) + (select-handle-key sel (make-key-event :key :n :ctrl t)) + (is (= (select-selected-index sel) 1)) + (select-handle-key sel (make-key-event :key :p :ctrl t)) + (is (= (select-selected-index sel) 0)))) + +(test select-visible-count + "Visible options respects viewport height." + (let* ((ln (make-layout-node)) + (sel (make-select + :options (loop for i below 20 collect (list :title (format nil "Item ~D" i) :value i))))) + (setf (select-layout-node sel) ln) + (setf (layout-node-height ln) 5) + (let ((visible (select-visible-options sel))) + (is (<= (length visible) 5))))) + +(test select-fuzzy-fallback + "Fuzzy filter catches near-misses." + (let ((sel (make-select + :options '((:title "Nord" :value :nord) + (:title "Tokyo Night" :value :tokyo) + (:title "Catppuccin" :value :cat))))) + (setf (select-filter sel) "nrd") + (let ((filtered (select-filtered-options sel))) + (is (= (length filtered) 1)) + (is (eql (getf (third (first filtered)) :value) :nord))))) diff --git a/tests/slot-tests.lisp b/tests/slot-tests.lisp new file mode 100644 index 0000000..ac972c1 --- /dev/null +++ b/tests/slot-tests.lisp @@ -0,0 +1,26 @@ +(defpackage :cl-tty-slot-test (:use :cl :cl-tty.slot :fiveam)) +(in-package :cl-tty-slot-test) + +(def-suite slot-suite :description "Slot system tests") +(in-suite slot-suite) + +(def-test defslot-register () + (clear-slot :test-slot) + (defslot :test-slot :order 1 :render-fn (lambda () "hello")) + (is-true (slot-p :test-slot))) + +(def-test slot-render-calls () + (clear-slot :test-slot) + (defslot :test-slot :order 1 :render-fn (lambda () "a")) + (defslot :test-slot :order 2 :render-fn (lambda () "b")) + (is (equal '("a" "b") (slot-render :test-slot)))) + +(def-test slot-render-empty () + (clear-slot :ghost) + (is-false (slot-render :ghost))) + +(def-test clear-slot-removes () + (clear-slot :test-slot) + (defslot :test-slot :order 1 :render-fn (lambda () "x")) + (clear-slot :test-slot) + (is-false (slot-p :test-slot)))