amr/cl-tty
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

v0.15.0: Critical input/rendering fixes, subagent-reviewed #7

Merged
amr merged 36 commits from feature/v0.11.0-slots into main 2026-05-11 22:03:18 -04:00
Conversation 0 Commits 36 Files Changed 76 +6801 -2485
76 changed files with 6801 additions and 2485 deletions
Download Patch File Download Diff File Expand all files Collapse all files

674
LICENSE Normal file
View File

@@ -0,0 +1,674 @@
GNU GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>
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.
<one line to give the program's name and a brief idea of what it does.>
Copyright (C) <year> <name of author>
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 <https://www.gnu.org/licenses/>.
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:
<program> Copyright (C) <year> <name of author>
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
<https://www.gnu.org/licenses/>.
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
<https://www.gnu.org/licenses/why-not-lgpl.html>.

408
README.org
View File

@@ -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

8
backend/classes.lisp
View File

@@ -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)))

62
backend/detection.lisp Normal file
View File

@@ -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)))))

58
backend/modern-tests.lisp
View File

@@ -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) "║")))

29
backend/modern.lisp
View File

@@ -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)

8
backend/package.lisp
View File

@@ -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)

17
backend/simple.lisp
View File

@@ -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)

19
backend/tests.lisp
View File

@@ -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*)))))

111
cl-tty.asd Normal file
View File

@@ -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)))))

65
cl-tui.asd
View File

@@ -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)))

94
debug-layout.lisp Normal file
View File

@@ -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)))

196
demo.lisp
View File

@@ -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)

17
demo.sh Executable file
View File

@@ -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"

12
docs/ARCHITECTURE.org
View File

@@ -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/

671
docs/ROADMAP.org
View File

@@ -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/<name>.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 | | |

253
docs/plans/2026-05-11-rendering-pipeline.md Normal file
View File

@@ -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

207
docs/plans/2026-05-11-terminal-detection.md Normal file
View File

@@ -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

6
docs/plans/2026-05-11-v0.2.0-box-and-text.md
View File

@@ -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:**

10
docs/plans/2026-05-11-v0.5.0-text-input.md
View File

@@ -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

18
layout/layout.lisp
View File

@@ -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)

6
layout/tests.lisp
View File

@@ -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)

12
org/backend-protocol.org
View File

@@ -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

12
org/box-renderable.org
View File

@@ -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

155
org/detection.org Normal file
View File

@@ -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

486
org/dialog.org Normal file
View File

@@ -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

358
org/framebuffer.org Normal file
View File

@@ -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

30
org/layout-engine.org
View File

@@ -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

500
org/markdown-renderer.org Normal file
View File

@@ -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))

66
org/modern-backend.org
View File

@@ -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

205
org/mouse.org Normal file
View File

@@ -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

99
org/scrollbox-tabbar.org
View File

@@ -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

546
org/select.org Normal file
View File

@@ -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

97
org/slot.org Normal file
View File

@@ -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

1539
org/text-input.org
View File

File diff suppressed because it is too large Load Diff

50
run-all-tests.lisp Normal file
View File

@@ -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)))

6
src/components/box-tests.lisp
View File

@@ -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)

2
src/components/box.lisp
View File

@@ -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

7
src/components/container-package.lisp
View File

@@ -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))

25
src/components/dialog-package.lisp Normal file
View File

@@ -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*))

124
src/components/dialog.lisp Normal file
View File

@@ -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*)))

2
src/components/dirty-tests.lisp
View File

@@ -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

2
src/components/dirty.lisp
View File

@@ -1,4 +1,4 @@
(in-package :cl-tui.box)
(in-package :cl-tty.box)
;; ── Dirty Tracking ─────────────────────────────────────────────

5
src/components/input-package.lisp
View File

@@ -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

6
src/components/input-tests.lisp
View File

@@ -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)

142
src/components/input.lisp
View File

@@ -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)))

2
src/components/keybindings.lisp
View File

@@ -1,4 +1,4 @@
(in-package #:cl-tui.input)
(in-package #:cl-tty.input)
;;; ---------------------------------------------------------------------------
;;; Key map struct

11
src/components/markdown-package.lisp Normal file
View File

@@ -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))

681
src/components/markdown.lisp Normal file
View File

@@ -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)))))

12
src/components/mouse-package.lisp Normal file
View File

@@ -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))

108
src/components/mouse.lisp Normal file
View File

@@ -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))

6
src/components/package.lisp
View File

@@ -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)

2
src/components/render-tests.lisp
View File

@@ -1,4 +1,4 @@
(in-package :cl-tui-box-test)
(in-package :cl-tty-box-test)
(in-suite box-suite)
(defun make-capturing-backend ()

2
src/components/render.lisp
View File

@@ -1,4 +1,4 @@
(in-package :cl-tui.box)
(in-package :cl-tty.box)
;; ── Component Protocol ────────────────────────────────────────

25
src/components/scrollbox.lisp
View File

@@ -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)

13
src/components/select-package.lisp Normal file
View File

@@ -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))

96
src/components/select.lisp Normal file
View File

@@ -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)))

9
src/components/slot-package.lisp Normal file
View File

@@ -0,0 +1,9 @@
(defpackage :cl-tty.slot
(:use :cl)
(:export
#:defslot
#:slot-render
#:slot-p
#:clear-slot
#:list-slots
#:*slots*))

27
src/components/slot.lisp Normal file
View File

@@ -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))

8
src/components/tabbar.lisp
View File

@@ -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))

22
src/components/text-input.lisp
View File

@@ -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)))

2
src/components/text.lisp
View File

@@ -1,4 +1,4 @@
(in-package :cl-tui.box)
(in-package :cl-tty.box)
;; ── Text Renderable ────────────────────────────────────────────

BIN
src/components/textarea.fasl Normal file
View File

Binary file not shown.

39
src/components/textarea.lisp
View File

@@ -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))))

2
src/components/theme-tests.lisp
View File

@@ -1,4 +1,4 @@
(in-package :cl-tui-box-test)
(in-package :cl-tty-box-test)
(in-suite box-suite)
(test theme-create-default

22
src/components/theme.lisp
View File

@@ -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

219
src/rendering/framebuffer.lisp Normal file
View File

@@ -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)))))

1
system-index.txt Normal file
View File

@@ -0,0 +1 @@
cl-tty.asd

43
tests/dialog-tests.lisp Normal file
View File

@@ -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*)))))

97
tests/framebuffer-tests.lisp Normal file
View File

@@ -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)))))

6
tests/input-tests.lisp
View File

@@ -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)

205
tests/markdown-tests.lisp Normal file
View File

@@ -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)))))

49
tests/mouse-tests.lisp Normal file
View File

@@ -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)))))

6
tests/scrollbox-tabbar-tests.lisp
View File

@@ -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)

120
tests/select-tests.lisp Normal file
View File

@@ -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)))))

26
tests/slot-tests.lisp Normal file
View File

@@ -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)))