diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,660 @@
+# GNU AFFERO GENERAL PUBLIC LICENSE
+
+Version 3, 19 November 2007
+
+Copyright (C) 2007 Free Software Foundation, Inc.
+
+
+Everyone is permitted to copy and distribute verbatim copies of this
+license document, but changing it is not allowed.
+
+## Preamble
+
+The GNU Affero General Public License is a free, copyleft license for
+software and other kinds of works, specifically designed to ensure
+cooperation with the community in the case of network server software.
+
+The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works. By contrast,
+our General Public Licenses are 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.
+
+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.
+
+Developers that use our General Public Licenses protect your rights
+with two steps: (1) assert copyright on the software, and (2) offer
+you this License which gives you legal permission to copy, distribute
+and/or modify the software.
+
+A secondary benefit of defending all users' freedom is that
+improvements made in alternate versions of the program, if they
+receive widespread use, become available for other developers to
+incorporate. Many developers of free software are heartened and
+encouraged by the resulting cooperation. However, in the case of
+software used on network servers, this result may fail to come about.
+The GNU General Public License permits making a modified version and
+letting the public access it on a server without ever releasing its
+source code to the public.
+
+The GNU Affero General Public License is designed specifically to
+ensure that, in such cases, the modified source code becomes available
+to the community. It requires the operator of a network server to
+provide the source code of the modified version running there to the
+users of that server. Therefore, public use of a modified version, on
+a publicly accessible server, gives the public access to the source
+code of the modified version.
+
+An older license, called the Affero General Public License and
+published by Affero, was designed to accomplish similar goals. This is
+a different license, not a version of the Affero GPL, but Affero has
+released a new version of the Affero GPL which permits relicensing
+under this license.
+
+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 Affero 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 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. Remote Network Interaction; Use with the GNU General Public License.
+
+Notwithstanding any other provision of this License, if you modify the
+Program, your modified version must prominently offer all users
+interacting with it remotely through a computer network (if your
+version supports such interaction) an opportunity to receive the
+Corresponding Source of your version by providing access to the
+Corresponding Source from a network server at no charge, through some
+standard or customary means of facilitating copying of software. This
+Corresponding Source shall include the Corresponding Source for any
+work covered by version 3 of the GNU General Public License that is
+incorporated pursuant to the following paragraph.
+
+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 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 work with which it is combined will remain governed by version
+3 of the GNU General Public License.
+
+### 14. Revised Versions of this License.
+
+The Free Software Foundation may publish revised and/or new versions
+of the GNU Affero 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 Affero 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 Affero General Public License, you may choose any version ever
+published by the Free Software Foundation.
+
+If the Program specifies that a proxy can decide which future versions
+of the GNU Affero General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+Later license versions may give you additional or different
+permissions. However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+### 15. Disclaimer of Warranty.
+
+THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT
+WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND
+PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE
+DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR
+CORRECTION.
+
+### 16. Limitation of Liability.
+
+IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR
+CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES
+ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT
+NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR
+LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM
+TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER
+PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
+
+### 17. Interpretation of Sections 15 and 16.
+
+If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+END OF TERMS AND CONDITIONS
+
+## How to Apply These Terms to Your New Programs
+
+If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these
+terms.
+
+To do so, attach the following notices to the program. It is safest to
+attach them to the start of each source file to most effectively state
+the exclusion of warranty; and each file should have at least the
+"copyright" line and a pointer to where the full notice is found.
+
+
+ Copyright (C)
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU Affero 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 Affero General Public License for more details.
+
+ You should have received a copy of the GNU Affero General Public License
+ along with this program. If not, see .
+
+Also add information on how to contact you by electronic and paper
+mail.
+
+If your software can interact with users remotely through a computer
+network, you should also make sure that it provides a way for users to
+get its source. For example, if your program is a web application, its
+interface could display a "Source" link that leads users to an archive
+of the code. There are many ways you could offer source, and different
+solutions will be better for different programs; see section 13 for
+the specific requirements.
+
+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 AGPL, see .
diff --git a/protocol/river/river-window-management-v1.xml b/protocol/river/river-window-management-v1.xml
new file mode 100644
--- /dev/null
+++ b/protocol/river/river-window-management-v1.xml
@@ -0,0 +1,1854 @@
+
+
+
+ SPDX-FileCopyrightText: © 2024 Isaac Freund
+ SPDX-License-Identifier: MIT
+
+ Permission is hereby granted, free of charge, to any person obtaining a copy
+ of this software and associated documentation files (the "Software"), to
+ deal in the Software without restriction, including without limitation the
+ rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+ sell copies of the Software, and to permit persons to whom the Software is
+ furnished to do so, subject to the following conditions:
+
+ The above copyright notice and this permission notice shall be included in
+ all copies or substantial portions of the Software.
+
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+ IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+ FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+ AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+ LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+ IN THE SOFTWARE.
+
+
+
+ This protocol allows a single "window manager" client to determine the
+ window management policy of the compositor. State is globally
+ double-buffered allowing for frame perfect state changes involving multiple
+ windows.
+
+ The key words "must", "must not", "required", "shall", "shall not",
+ "should", "should not", "recommended", "may", and "optional" in this
+ document are to be interpreted as described in IETF RFC 2119.
+
+
+
+
+ This global interface should only be advertised to the window manager
+ process. Only one window management client may be active at a time. The
+ compositor should use the unavailable event if necessary to enforce this.
+
+ There are two disjoint categories of state managed by this protocol:
+
+ Window management state influences the communication between the
+ compositor and individual windows (e.g. xdg_toplevels). Window management
+ state includes window dimensions, fullscreen state, keyboard focus,
+ keyboard bindings, and more.
+
+ Rendering state only affects the rendered output of the compositor and
+ does not influence communication between the compositor and individual
+ windows. Rendering state includes the position and rendering order of
+ windows, shell surfaces, decoration surfaces, borders, and more.
+
+ Window management state may only be modified by the window manager as part
+ of a manage sequence. A manage sequence is started with the manage_start
+ event and ended with the manage_finish request. It is a protocol error to
+ modify window management state outside of a manage sequence.
+
+ A manage sequence is always followed by at least one render sequence. A
+ render sequence is started with the render_start event and ended with the
+ render_finish request.
+
+ Rendering state may be modified by the window manager during a manage
+ sequence or a render sequence. Regardless of when the rendering state is
+ modified, it is applied with the next render_finish request. It is a
+ protocol error to modify rendering state outside of a manage or render
+ sequence.
+
+ The server will start a manage sequence by sending new state and the
+ manage_start event as soon as possible whenever there is a change in state
+ that must be communicated with the window manager.
+
+ If the window manager client needs to ensure a manage sequence is started
+ due to a state change the compositor is not aware of, it may send the
+ manage_dirty request.
+
+ The server will start a render sequence by sending new state and the
+ render_start event as soon as possible whenever there is a change in
+ window dimensions that must be communicated with the window manager.
+ Multiple render sequences may be made consecutively without a manage
+ sequence in between, for example if a window independently changes its own
+ dimensions.
+
+ To summarize, the main loop of this protocol is as follows:
+
+ 1. The server sends events indicating all changes since the last
+ manage sequence followed by the manage_start event.
+
+ 2. The client sends requests modifying window management state or
+ rendering state (as defined above) followed by the manage_finish
+ request.
+
+ 3. The server sends new state to windows and waits for responses.
+
+ 4. The server sends new window dimensions to the client followed by the
+ render_start event.
+
+ 5. The client sends requests modifying rendering state (as defined above)
+ followed by the render_finish request.
+
+ 6. If window dimensions change, loop back to step 4.
+ If state that requires a manage sequence changes or if the client makes
+ a manage_dirty request, loop back to step 1.
+
+ For the purposes of frame perfection, the server may delay rendering new
+ state committed by the windows in step 3 until after step 5 is finished.
+
+ It is a protocol error for the client to make a manage_finish or
+ render_finish request that violates this ordering.
+
+
+
+
+
+
+
+
+
+
+ This event indicates that window management is not available to the
+ client, perhaps due to another window management client already running.
+ The circumstances causing this event to be sent are compositor policy.
+
+ If sent, this event is guaranteed to be the first and only event sent by
+ the server.
+
+ The server will send no further events on this object. The client should
+ destroy this object and all objects created through this interface.
+
+
+
+
+
+ This request indicates that the client no longer wishes to receive
+ events on this object.
+
+ The Wayland protocol is asynchronous, which means the server may send
+ further events until the stop request is processed. The client must wait
+ for a river_window_manager_v1.finished event before destroying this
+ object.
+
+
+
+
+
+ This event indicates that the server will send no further events on this
+ object. The client should destroy the object. See
+ river_window_manager_v1.destroy for more information.
+
+
+
+
+
+ This request should be called after the finished event has been received
+ to complete destruction of the object.
+
+ If a client wishes to destroy this object it should send a
+ river_window_manager_v1.stop request and wait for a
+ river_window_manager_v1.finished event. Once the finished event is
+ received it is safe to destroy this object and any other objects created
+ through this interface.
+
+
+
+
+
+ This event indicates that the server has sent events indicating all
+ state changes since the last manage sequence.
+
+ In response to this event, the client should make requests modifying
+ window management state as it chooses. Then, the client must make the
+ manage_finish request.
+
+ See the description of the river_window_manager_v1 interface for a
+ complete overview of the manage/render sequence loop.
+
+
+
+
+
+ This request indicates that the client has made all changes to window
+ management state it wishes to include in the current manage sequence and
+ that the server should atomically send these state changes to the
+ windows and continue with the manage sequence.
+
+ After sending this request, it is a protocol error for the client to
+ make further changes to window management state until the next
+ manage_start event is received.
+
+ See the description of the river_window_manager_v1 interface for a
+ complete overview of the manage/render sequence loop.
+
+
+
+
+
+ This request ensures a manage sequence is started and that a
+ manage_start event is sent by the server. If this request is made during
+ an ongoing manage sequence, a new manage sequence will be started as
+ soon as the current one is completed.
+
+ The client may want to use this request due to an internal state change
+ that the compositor is not aware of (e.g. a dbus event) which should
+ affect window management or rendering state.
+
+
+
+
+
+ This event indicates that the server has sent all river_node_v1.position
+ and river_window_v1.dimensions events necessary.
+
+ In response to this event, the client should make requests modifying
+ rendering state as it chooses. Then, the client must make the
+ render_finish request.
+
+ See the description of the river_window_manager_v1 interface for a
+ complete overview of the manage/render sequence loop.
+
+
+
+
+
+ This request indicates that the client has made all changes to rendering
+ state it wishes to include in the current manage sequence and that the
+ server should atomically apply and display these state changes to the
+ user.
+
+ After sending this request, it is a protocol error for the client to
+ make further changes to rendering state until the next manage_start or
+ render_start event is received, whichever comes first.
+
+ See the description of the river_window_manager_v1 interface for a
+ complete overview of the manage/render sequence loop.
+
+
+
+
+
+ This event indicates that the session has been locked.
+
+ The window manager may wish to restrict which key bindings are available
+ while locked or otherwise use this information.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+ This event indicates that the session has been unlocked.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+ A new window has been created.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+
+ A new logical output has been created, perhaps due to a new physical
+ monitor being plugged in or perhaps due to a change in configuration.
+
+ This event will be followed by river_output_v1.position and dimensions
+ events as well as a manage_start event after all other new state has
+ been sent by the server.
+
+
+
+
+
+
+ A new seat has been created.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+
+ Create a new shell surface for window manager UI and assign the
+ river_shell_surface_v1 role to the surface.
+
+ Providing a wl_surface which already has a role or already has a buffer
+ attached or committed is a protocol error.
+
+
+
+
+
+
+
+ End the current Wayland session and exit the compositor.
+ All Wayland clients running in the current session, including
+ the window manager, will be disconnected.
+
+ Window managers should only make this request if the user explicitly
+ asks to exit the Wayland session, not for example on normal window
+ manager termination.
+
+
+
+
+
+
+ This represents a logical window. For example, a window may correspond to
+ an xdg_toplevel or Xwayland window.
+
+ A newly created window will not be displayed until the window manager
+ makes a propose_dimensions or fullscreen request as part of a manage
+ sequence, the server replies with a dimensions event as part of a render
+ sequence, and that render sequence is finished.
+
+
+
+
+
+
+
+
+
+
+
+ This request indicates that the client will no longer use the window
+ object and that it may be safely destroyed.
+
+ This request should be made after the river_window_v1.closed event or
+ river_window_manager_v1.finished is received to complete destruction of
+ the window.
+
+
+
+
+
+ The window has been closed by the server, perhaps due to an
+ xdg_toplevel.close request or similar.
+
+ The server will send no further events on this object and ignore any
+ request other than river_window_v1.destroy made after this event is
+ sent. The client should destroy this object with the
+ river_window_v1.destroy request to free up resources.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+ Request that the window be closed. The window may ignore this request or
+ only close after some delay, perhaps opening a dialog asking the user to
+ save their work or similar.
+
+ The server will send a river_window_v1.closed event if/when the window
+ has been closed.
+
+ This request modifies window management state and may only be made as
+ part of a manage sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+ Get the node in the render list corresponding to the window.
+
+ It is a protocol error to make this request more than once for a single
+ window.
+
+
+
+
+
+
+ This event informs the window manager of the window's preferred min/max
+ dimensions. These preferences are a hint, and the window manager is free
+ to propose dimensions outside of these bounds.
+
+ All min/max width/height values must be strictly greater than or equal
+ to 0. A value of 0 indicates that the window has no preference for that
+ value.
+
+ The min_width/min_height must be strictly less than or equal to the
+ max_width/max_height.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+
+
+
+
+ This event indicates the dimensions of the window in the compositor's
+ logical coordinate space. The width and height must be strictly greater
+ than zero.
+
+ Note that the dimensions of a river_window_v1 refer to the dimensions of
+ the window content and are unaffected by the presence of borders or
+ decoration surfaces.
+
+ This event is sent as part of a render sequence before the render_start
+ event.
+
+ It may be sent due to a propose_dimensions or fullscreen request in a
+ previous manage sequence or because a window independently decides to
+ change its dimensions.
+
+ The window will not be displayed until the first dimensions event is
+ received and the render sequence is finished.
+
+
+
+
+
+
+
+ This request proposes dimensions for the window in the compositor's
+ logical coordinate space.
+
+ The width and height must be greater than or equal to zero. If the width
+ or height is zero the window will be allowed to decide its own
+ dimensions.
+
+ The window may not take the exact dimensions proposed. The actual
+ dimensions taken by the window will be sent in a subsequent
+ river_window_v1.dimensions event. For example, a terminal emulator may
+ only allow dimensions that are multiple of the cell size.
+
+ When a propose_dimensions request is made, the server must send a
+ dimensions event in response as soon as possible. It may not be possible
+ to send a dimensions event in the very next render sequence if, for
+ example, the window takes too long to respond to the proposed
+ dimensions. In this case, the server will send the dimensions event in a
+ future render sequence.
+
+ Note that the dimensions of a river_window_v1 refer to the dimensions of
+ the window content and are unaffected by the presence of borders or
+ decoration surfaces.
+
+ This request modifies window management state and may only be made as
+ part of a manage sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+
+
+ Request that the window be hidden. Has no effect if the window is
+ already hidden. Hides any window borders and decorations as well.
+
+ Newly created windows are considered shown unless explicitly hidden with
+ the hide request.
+
+ This request modifies rendering state and may only be made as part of a
+ render sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+ Request that the window be shown. Has no effect if the window is not
+ hidden. Does not guarantee that the window is visible as it may be
+ completely obscured by other windows placed above it for example.
+
+ Newly created windows are considered shown unless explicitly hidden with
+ the hide request.
+
+ This request modifies rendering state and may only be made as part of a
+ render sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+ The window set an application ID.
+
+ The app_id argument will be null if the window has never set an
+ application ID or if the window cleared its application ID. (Xwayland
+ windows may do this for example, though xdg-toplevels may not.)
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+
+ The window set a title.
+
+ The title argument will be null if the window has never set a title or
+ if the window cleared its title. (Xwayland windows may do this for
+ example, though xdg-toplevels may not.)
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+
+ The window set a parent window. If this event is never received or if
+ the parent argument is null then the window has no parent.
+
+ A surface with a parent set might be a dialog, file picker, or similar
+ for the parent window.
+
+ Child windows should generally be rendered directly above their parent.
+
+ The compositor must guarantee that there are no loops in the window
+ tree: a parent must not be the descendant of one of its children.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+
+
+
+
+
+
+
+
+ Information from the window about the supported and preferred client
+ side/server side decoration options.
+
+ This event may be sent multiple times over the lifetime of the window if
+ the window changes its preferences.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+
+ Tell the client to use client side decoration and draw its own title
+ bar, borders, etc.
+
+ This is the default if neither this request nor the use_ssd request is
+ ever made.
+
+ This request modifies window management state and may only be made as
+ part of a manage sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+ Tell the client to use server side decoration and not draw any client
+ side decorations.
+
+ This request will have no effect if the client only supports client side
+ decoration, see the decoration_hint event.
+
+ This request modifies window management state and may only be made as
+ part of a manage sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+
+
+
+
+
+
+
+
+ This request decorates the window with borders drawn by the compositor
+ on the specified edges of the window. Borders are drawn above the window
+ content.
+
+ Corners are drawn only between borders on adjacent edges. If e.g. the
+ left edge has a border and the top edge does not, the border drawn on
+ the left edge will not extend vertically beyond the top edge of the
+ window.
+
+ Borders are not drawn while the window is fullscreen.
+
+ The color is defined by four 32-bit RGBA values. Unless specified in
+ another protocol extension, the RGBA values use pre-multiplied alpha.
+
+ Setting the edges to none or the width to 0 disables the borders.
+ Setting a negative width is a protocol error.
+
+ This request completely overrides all previous set_borders requests.
+ Only the most recent set_borders request has an effect.
+
+ Note that the position/dimensions of a river_window_v1 refer to the
+ position/dimensions of the window content and are unaffected by the
+ presence of borders or decoration surfaces.
+
+ This request modifies rendering state and may only be made as part of a
+ render sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+
+
+
+
+
+
+ Inform the window that it is part of a tiled layout and adjacent to
+ other elements in the tiled layout on the given edges.
+
+ The window should use this information to change the style of its client
+ side decorations and avoid drawing e.g. drop shadows outside of the
+ window dimensions on the tiled edges.
+
+ Setting the edges argument to none informs the window that it is not
+ part of a tiled layout. If this request is never made, the window is
+ informed that it is not part of a tiled layout.
+
+ This request modifies window management state and may only be made as
+ part of a manage sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+
+ Create a decoration surface and assign the river_decoration_v1 role to
+ the surface. The created decoration is placed above the window in
+ rendering order, see the description of river_decoration_v1.
+
+ Providing a wl_surface which already has a role or already has a buffer
+ attached or committed is a protocol error.
+
+
+
+
+
+
+
+ Create a decoration surface and assign the river_decoration_v1 role to
+ the surface. The created decoration is placed below the window in
+ rendering order, see the description of river_decoration_v1.
+
+ Providing a wl_surface which already has a role or already has a buffer
+ attached or committed is a protocol error.
+
+
+
+
+
+
+
+ This event informs the window manager that the window has requested to
+ be interactively moved using the pointer. The seat argument indicates the
+ seat for the move.
+
+ The xdg-shell protocol for example allows windows to request that an
+ interactive move be started, perhaps when a client-side rendered
+ titlebar is dragged.
+
+ The window manager may use the river_seat_v1.op_start_pointer request to
+ interactively move the window or ignore this event entirely.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+
+ This event informs the window manager that the window has requested to
+ be interactively resized using the pointer. The seat argument indicates
+ the seat for the resize.
+
+ The edges argument indicates which edges the window has requested to be
+ resized from. The edges argument will never be none and will never have
+ both top and bottom or both left and right edges set.
+
+ The xdg-shell protocol for example allows windows to request that an
+ interactive resize be started, perhaps when the corner of client-side
+ rendered decorations is dragged.
+
+ The window manager may use the river_seat_v1.op_start_pointer request to
+ interactively resize the window or ignore this event entirely.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+
+
+ Inform the window that it is being resized. The window manager should
+ use this request to inform windows that are the target of an interactive
+ resize for example.
+
+ The window manager remains responsible for handling the position and
+ dimensions of the window while it is resizing.
+
+ This request modifies window management state and may only be made as
+ part of a manage sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+ Inform the window that it is no longer being resized. The window manager
+ should use this request to inform windows that are the target of an
+ interactive resize that the interactive resize has ended for example.
+
+ This request modifies window management state and may only be made as
+ part of a manage sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+
+
+
+
+
+
+
+ This request informs the window of the capabilities supported by the
+ window manager. If the window manager, for example, ignores requests to
+ be maximized from the window it should not tell the window that it
+ supports the maximize capability.
+
+ The window might use this information to, for example, only show a
+ maximize button if the window manager supports the maximize capability.
+
+ The window manager client should use this request to set capabilities
+ for all new windows. If this request is never made, the compositor will
+ inform windows that all capabilities are supported.
+
+ This request modifies window management state and may only be made as
+ part of a manage sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+
+ The xdg-shell protocol for example allows windows to request that a
+ window menu be shown, for example when the user right clicks on client
+ side window decorations.
+
+ A window menu might include options to maximize or minimize the window.
+
+ The window manager is free to ignore this request and decide what the
+ window menu contains if it does choose to show one.
+
+ The x and y arguments indicate where the window requested that the
+ window menu be shown.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+
+
+ The xdg-shell protocol for example allows windows to request to be
+ maximized.
+
+ The window manager is free to honor this request using
+ river_window_v1.inform_maximize or ignore it.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+ The xdg-shell protocol for example allows windows to request to be
+ unmaximized.
+
+ The window manager is free to honor this request using
+ river_window_v1.inform_unmaximized or ignore it.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+ Inform the window that it is maximized. The window might use this
+ information to adapt the style of its client-side window decorations for
+ example.
+
+ The window manager remains responsible for handling the position and
+ dimensions of the window while it is maximized.
+
+ This request modifies window management state and may only be made as
+ part of a manage sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+ Inform the window that it is unmaximized. The window might use this
+ information to adapt the style of its client-side window decorations for
+ example.
+
+ This request modifies window management state and may only be made as
+ part of a manage sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+ The xdg-shell protocol for example allows windows to request that they
+ be made fullscreen and allows them to provide an optional output hint.
+
+ If the output argument is null, the window has no preference and the
+ window manager should choose an output.
+
+ The window manager is free to honor this request using
+ river_window_v1.fullscreen or ignore it.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+
+ The xdg-shell protocol for example allows windows to request to exit
+ fullscreen.
+
+ The window manager is free to honor this request using
+ river_window_v1.exit_fullscreen or ignore it.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+ Inform the window that it is fullscreen. The window might use this
+ information to adapt the style of its client-side window decorations for
+ example.
+
+ This request does not affect the size/position of the window or cause it
+ to become the only window rendered, see the river_window_v1.fullscreen
+ and exit_fullscreen requests for that.
+
+ This request modifies window management state and may only be made as
+ part of a manage sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+ Inform the window that it is not fullscreen. The window might use this
+ information to adapt the style of its client-side window decorations for
+ example.
+
+ This request does not affect the size/position of the window or cause it
+ to become the only window rendered, see the river_window_v1.fullscreen
+ and exit_fullscreen requests for that.
+
+ This request modifies window management state and may only be made as
+ part of a manage sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+ Make the window fullscreen on the given output. If multiple windows are
+ fullscreen on the same output at the same time only the "top" window in
+ rendering order shall be displayed.
+
+ All river_shell_surface_v1 objects above the top fullscreen window in
+ the rendering order will continue to be rendered.
+
+ The compositor will handle the position and dimensions of the window
+ while it is fullscreen. The set_position and propose_dimensions requests
+ shall not affect the current position and dimensions of a fullscreen
+ window.
+
+ When a fullscreen request is made, the server must send a dimensions
+ event in response as soon as possible. It may not be possible to send a
+ dimensions event in the very next render sequence if, for example, the
+ window takes too long to respond. In this case, the server will send the
+ dimensions event in a future render sequence.
+
+ The compositor will clip window content, decoration surfaces, and
+ borders to the given output's dimensions while the window is fullscreen.
+ The effects of set_clip_box and set_content_clip_box are ignored while
+ the window is fullscreen.
+
+ If the output on which a window is currently fullscreen is removed, the
+ windowing state is modified as if there were an exit_fullscreen request
+ made in the same manage sequence as the river_output_v1.removed event.
+
+ This request does not inform the window that it is fullscreen, see the
+ river_window_v1.inform_fullscreen and inform_not_fullscreen requests.
+
+ This request modifies window management state and may only be made as
+ part of a manage sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+
+ Make the window not fullscreen.
+
+ The position and dimensions are undefined after this request is made
+ until a manage sequence in which the window manager makes the
+ propose_dimensions and set_position requests is completed.
+
+ The window manager should make propose_dimensions and set_position
+ requests in the same manage sequence as the exit_fullscreen request for
+ frame perfection.
+
+ This request does not inform the window that it is fullscreen, see the
+ river_window_v1.inform_fullscreen and inform_not_fullscreen requests.
+
+ This request modifies window management state and may only be made as
+ part of a manage sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+ The xdg-shell protocol for example allows windows to request to be
+ minimized.
+
+ The window manager is free to ignore this request, hide the window, or
+ do whatever else it chooses.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+ Clip the window, including borders and decoration surfaces, to the box
+ specified by the x, y, width, and height arguments. The x/y position of
+ the box is relative to the top left corner of the window.
+
+ The width and height arguments must be greater than or equal to 0.
+
+ Setting a clip box with 0 width or height disables clipping.
+
+ The clip box is ignored while the window is fullscreen.
+
+ Both set_clip_box and set_content_clip_box may be enabled simultaneously.
+
+ This request modifies rendering state and may only be made as part of a
+ render sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+
+
+
+
+ This event gives an unreliable PID of the process that created the
+ window. Obtaining this information is inherently racy due to PID reuse.
+ Therefore, this PID must not be used for anything security sensitive.
+
+ Note also that a single process may create multiple windows, so there is
+ not necessarily a 1-to-1 mapping from PID to window. Multiple windows
+ may have the same PID.
+
+ This event is sent once when the river_window_v1 is created and never
+ sent again.
+
+
+
+
+
+
+ Clip the content of the window, excluding borders and decoration
+ surfaces, to the box specified by the x, y, width, and height arguments.
+ The x/y position of the box is relative to the top left corner of the
+ window.
+
+ Borders drawn by the compositor (see set_borders) are placed around the
+ intersection of the window content (as defined by the dimensions event)
+ and the content clip box when content clipping is enabled.
+
+ The width and height arguments must be greater than or equal to 0.
+
+ Setting a box with 0 width or height disables content clipping.
+
+ The content clip box is ignored while the window is fullscreen.
+
+ Both set_clip_box and set_content_clip_box may be enabled simultaneously.
+
+ This request modifies rendering state and may only be made as part of a
+ render sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+
+
+
+
+ This event communicates the window's preferred presentation mode.
+
+ This event will be followed by a render_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+
+ The identifier is a string that contains up to 32 printable ASCII bytes.
+ The identifier must not be an empty string.
+
+ It is compositor policy how the identifier is generated, but the following
+ properties must be upheld:
+
+ 1. The identifier must uniquely identify the window. Two windows must not
+ share the same identifier.
+
+ 2. The identifier must not be reused. This avoids races around window
+ creation/destruction when identifiers are used in out-of-band IPC.
+
+ If the compositor implements the ext-foreign-toplevel-list-v1 protocol,
+ the river_window_v1.identifier event must match the corresponding
+ ext_foreign_toplevel_handle_v1.identifier event.
+
+ This event is sent once when the river_window_v1 is created and never
+ sent again.
+
+
+
+
+
+
+ Recommend that the window keep its dimensions within a given
+ maximum width/height. This recommendation is only a hint and the window
+ may ignore it.
+
+ Setting the width and height to 0 indicates that there are no bounds
+ and is equivalent to having never made this request.
+
+ Setting width or height to a negative value is a protocol error.
+
+ The server should communicate this hint to an xdg_toplevel window with
+ the xdg_toplevel.configure_bounds event for example.
+
+ This request modifies window management state and may only be made as
+ part of a manage sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+
+
+
+ The rendering order of windows with decorations is follows:
+
+ 1. Decorations created with get_decoration_below at the bottom
+ 2. Window content
+ 3. Borders configured with river_window_v1.set_borders
+ 4. Decorations created with get_decoration_above at the top
+
+ The relative ordering of decoration surfaces above/below a window is
+ undefined by this protocol and left up to the compositor.
+
+
+
+
+
+
+
+
+ This request indicates that the client will no longer use the decoration
+ object and that it may be safely destroyed.
+
+
+
+
+
+ This request sets the offset of the decoration surface from the top left
+ corner of the window.
+
+ If this request is never sent, the x and y offsets are undefined by this
+ protocol and left up to the compositor.
+
+ This request modifies rendering state and may only be made as part of a
+ render sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+
+
+ Synchronize application of the next wl_surface.commit request on the
+ decoration surface with rest of the state atomically applied with the
+ next river_window_manager_v1.render_finish request.
+
+ The client must make a wl_surface.commit request on the decoration
+ surface after this request and before the render_finish request, failure
+ to do so is a protocol error.
+
+ This request modifies rendering state and may only be made as part of a
+ render sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+
+ The window manager might use a shell surface to display a status bar,
+ background image, desktop notifications, launcher, desktop menu, or
+ whatever else it wants.
+
+
+
+
+
+
+
+
+
+ This request indicates that the client will no longer use the shell
+ surface object and that it may be safely destroyed.
+
+
+
+
+
+ Get the node in the render list corresponding to the shell surface.
+
+ It is a protocol error to make this request more than once for a single
+ shell surface.
+
+
+
+
+
+
+ Synchronize application of the next wl_surface.commit request on the
+ shell surface with rest of the rendering state atomically applied with
+ the next river_window_manager_v1.render_finish request.
+
+ The client must make a wl_surface.commit request on the shell surface
+ after this request and before the render_finish request, failure to do
+ so is a protocol error.
+
+ This request modifies rendering state and may only be made as part of a
+ render sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+
+ The render list is a list of nodes that determines the rendering order of
+ the compositor. Nodes may correspond to windows or shell surfaces. The
+ relative ordering of nodes may be changed with the place_above and
+ place_below requests, changing the rendering order.
+
+ The initial position of a node in the render list is undefined, the window
+ manager client must use the place_above or place_below request to
+ guarantee a specific rendering order.
+
+
+
+
+ This request indicates that the client will no longer use the node
+ object and that it may be safely destroyed.
+
+
+
+
+
+ Set the absolute position of the node in the compositor's logical
+ coordinate space. The x and y coordinates may be positive or negative.
+
+ Note that the position of a river_window_v1 refers to the position of
+ the window content and is unaffected by the presence of borders or
+ decoration surfaces.
+
+ If this request is never sent, the position of the node is undefined by
+ this protocol and left up to the compositor.
+
+ This request modifies rendering state and may only be made as part of a
+ render sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+
+
+ This request places the node above all other nodes in the compositor's
+ render list.
+
+ This request modifies rendering state and may only be made as part of a
+ render sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+ This request places the node below all other nodes in the compositor's
+ render list.
+
+ This request modifies rendering state and may only be made as part of a
+ render sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+ This request places the node directly above another node in the
+ compositor's render list.
+
+ Attempting to place a node above itself has no effect.
+
+ This request modifies rendering state and may only be made as part of a
+ render sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+
+ This request places the node directly below another node in the
+ compositor's render list.
+
+ Attempting to place a node below itself has no effect.
+
+ This request modifies rendering state and may only be made as part of a
+ render sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+
+
+ An area in the compositor's logical coordinate space that should be
+ treated as a single output for window management purposes. This area may
+ correspond to a single physical output or multiple physical outputs in the
+ case of mirroring or tiled monitors depending on the hardware and
+ compositor configuration.
+
+
+
+
+ This request indicates that the client will no longer use the output
+ object and that it may be safely destroyed.
+
+ This request should be made after the river_output_v1.removed event is
+ received to complete destruction of the output.
+
+
+
+
+
+ This event indicates that the logical output is no longer conceptually
+ part of window management space.
+
+ The server will send no further events on this object and ignore any
+ request (other than river_output_v1.destroy) made after this event is
+ sent. The client should destroy this object with the
+ river_output_v1.destroy request to free up resources.
+
+ This event may be sent because a corresponding physical output has been
+ physically unplugged or because some output configuration has changed.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+ The wl_output object corresponding to the river_output_v1. The argument
+ is the global name of the wl_output advertised with wl_registry.global.
+
+ It is guaranteed that the corresponding wl_output is advertised before
+ this event is sent.
+
+ This event is sent exactly once. The wl_output associated with a
+ river_output_v1 cannot change. It is guaranteed that there is a 1-to-1
+ mapping between wl_output and river_output_v1 objects.
+
+ The global_remove event for the corresponding wl_output may be sent
+ before the river_output_v1.remove event. This is due to the fact that
+ river_output_v1 state changes are synced to the river window management
+ manage sequence while changes to globals are not.
+
+ Rationale: The window manager may need information provided by the
+ wl_output interface such as the name/description. It also may need the
+ wl_output object to start screencopy for example.
+
+
+
+
+
+
+ This event indicates the position of the output in the compositor's
+ logical coordinate space. The x and y coordinates may be positive or
+ negative.
+
+ This event is sent once when the river_output_v1 is created and again
+ whenever the position changes.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+ The server must guarantee that the position and dimensions events do not
+ cause the areas of multiple logical outputs to overlap when the
+ corresponding manage_start event is received.
+
+
+
+
+
+
+
+ This event indicates the dimensions of the output in the compositor's
+ logical coordinate space. The width and height will always be strictly
+ greater than zero.
+
+ This event is sent once when the river_output_v1 is created and again
+ whenever the dimensions change.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+ The server must guarantee that the position and dimensions events do not
+ cause the areas of multiple logical outputs to overlap when the
+ corresponding manage_start event is received.
+
+
+
+
+
+
+
+
+
+
+
+
+ Output page-flips should be synchronized to the vertical blanking
+ period, eliminating tearing. This is the default presentation mode.
+
+
+
+
+ Output page-flips should not be synchronized to the vertical blanking
+ period, visual screen tearing may occur.
+
+
+
+
+
+
+ Set the preferred presentation mode of the output. The compositor should
+ always respect the preference of the window manager if possible. If this
+ request is never made, the preferred presentation mode is vsync.
+
+ This request modifies rendering state and may only be made as part of a
+ render sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+
+
+ This object represents a single user's collection of input devices. It
+ allows the window manager to route keyboard input to windows, get
+ high-level information about pointer input, define pointer bindings, etc.
+
+ For keyboard bindings, see the river-xkb-bindings-v1 protocol.
+
+ Since version 4: The cursor surface/shape set by the window manager on the
+ wl_pointer of this seat is used when no client has pointer focus, for
+ example during a pointer operation. Since the window manager is allowed to
+ set cursor surface/shape even when it does not have pointer focus, the
+ compositor must ignore the serial argument of wl_pointer.set_cursor and
+ wp_cursor_shape_device_v1.set_shape requests made by the window manager.
+
+ The most recent cursor surface/shape set by the window manager is
+ remembered by the compositor and restored whenever no client has pointer
+ focus. If the window manager never sets a cursor surface/shape, the
+ "default" shape is used.
+
+
+
+
+ This request indicates that the client will no longer use the seat
+ object and that it may be safely destroyed.
+
+ This request should be made after the river_seat_v1.removed event is
+ received to complete destruction of the seat.
+
+
+
+
+
+ This event indicates that seat is no longer in use and should be
+ destroyed.
+
+ The server will send no further events on this object and ignore any
+ request (other than river_seat_v1.destroy) made after this event is
+ sent. The client should destroy this object with the
+ river_seat_v1.destroy request to free up resources.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+ The wl_seat object corresponding to the river_seat_v1. The argument is
+ the global name of the wl_seat advertised with wl_registry.global.
+
+ It is guaranteed that the corresponding wl_seat is advertised before
+ this event is sent.
+
+ This event is sent exactly once. The wl_seat associated with a
+ river_seat_v1 cannot change. It is guaranteed that there is a 1-to-1
+ mapping between wl_seat and river_seat_v1 objects.
+
+ The global_remove event for the corresponding wl_seat may be sent before
+ the river_seat_v1.remove event. This is due to the fact that
+ river_seat_v1 state changes are synced to the river window management
+ manage sequence while changes to globals are not.
+
+ Rationale: The window manager may want to trigger window management
+ state changes based on normal input events received by its shell
+ surfaces for example.
+
+
+
+
+
+
+ Request that the compositor send keyboard input to the given window.
+
+ This request modifies window management state and may only be made as
+ part of a manage sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+
+ Request that the compositor send keyboard input to the given shell
+ surface.
+
+ This request modifies window management state and may only be made as
+ part of a manage sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+
+ Request that the compositor not send keyboard input to any client.
+
+ This request modifies window management state and may only be made as
+ part of a manage sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+ The seat's pointer entered the given window's area.
+
+ The area of a window is defined to include the area defined by the
+ window dimensions, borders configured using river_window_v1.set_borders,
+ and the input regions of decoration surfaces. In particular, it does not
+ include input regions of surfaces belonging to the window that extend
+ outside the window dimensions.
+
+ The pointer of a seat may only enter a single window at a time. When the
+ pointer moves between windows, the pointer_leave event for the old
+ window must be sent before the pointer_enter event for the new window.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+
+ The seat's pointer left the window for which pointer_enter was most
+ recently sent. See pointer_enter for details.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+ A window has been interacted with beyond the pointer merely passing over
+ it. This event might be sent due to a pointer button press or due to a
+ touch/tablet tool interaction with the window.
+
+ There are no guarantees regarding how this event is sent in relation to
+ the pointer_enter and pointer_leave events as the interaction may use
+ touch or tablet tool input.
+
+ Rationale: this event gives window managers necessary information to
+ determine when to send keyboard focus, raise a window that already has
+ keyboard focus, etc. Rather than expose all pointer, touch, and tablet
+ events to window managers, a policy over mechanism approach is taken.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+
+ A shell surface has been interacted with beyond the pointer merely
+ passing over it. This event might be sent due to a pointer button press
+ or due to a touch/tablet tool interaction with the shell_surface.
+
+ There are no guarantees regarding how this event is sent in relation to
+ the pointer_enter and pointer_leave events as the interaction may use
+ touch or tablet tool input.
+
+ Rationale: While the shell surface does receive all wl_pointer,
+ wl_touch, etc. input events for the surface directly, these events do
+ not necessarily trigger a manage sequence and therefore do not allow the
+ window manager to update focus or perform other actions in response to
+ the input in a race-free way.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+
+ Start an interactive pointer operation. During the operation, op_delta
+ events will be sent based on pointer input.
+
+ When all pointer buttons are released, the op_release event is sent.
+
+ The pointer operation continues until the op_end request is made during
+ a manage sequence and that manage sequence is finished.
+
+ The window manager may use this operation to implement interactive
+ move/resize of windows by setting the position of windows and proposing
+ dimensions based off of the op_delta events.
+
+ This request is ignored if an operation is already in progress.
+
+ The compositor must ensure that no client has pointer focus from this
+ seat during the pointer operation. This means that the window manager
+ has control over the pointer's cursor surface/shape during the pointer
+ operation. See the river_seat_v1 description.
+
+ This request modifies window management state and may only be made as
+ part of a manage sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+ This event indicates the total change in position since the start of the
+ operation of the pointer/touch point/etc.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+
+
+ The input driving the current interactive operation has been released.
+ For a pointer op for example, all pointer buttons have been released.
+
+ Depending on the op type, op_delta events may continue to be sent until
+ the op is ended with the op_end request.
+
+ This event is sent at most once during an interactive operation.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+
+
+
+
+ End an interactive operation.
+
+ This request is ignored if there is no operation in progress.
+
+ This request modifies window management state and may only be made as
+ part of a manage sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+ This enum is used to describe the keyboard modifiers that must be held
+ down to trigger a key binding or pointer binding.
+
+ Note that river and wlroots use the values 2 and 16 for capslock and
+ numlock internally. It doesn't make sense to use locked modifiers for
+ bindings however so these values are not included in this enum.
+
+
+
+
+
+
+
+
+
+
+
+
+ Define a pointer binding in terms of a pointer button, keyboard
+ modifiers, and other configurable properties.
+
+ The button argument is a Linux input event code defined in the
+ linux/input-event-codes.h header file (e.g. BTN_RIGHT).
+
+ The new pointer binding is not enabled until initial configuration is
+ completed and the enable request is made during a manage sequence.
+
+
+
+
+
+
+
+
+ Set the XCursor theme for the seat. This theme is used for cursors
+ rendered by the compositor, but not necessarily for cursors rendered by
+ clients.
+
+ Note: The window manager may also wish to set the XCURSOR_THEME and
+ XCURSOR_SIZE environment variable for programs it starts.
+
+
+
+
+
+
+
+ The current position of the pointer in the compositor's logical
+ coordinate space.
+
+ This state is special in that a change in pointer position alone must
+ not cause the compositor to start a manage sequence.
+
+ Assuming the seat has a pointer, this event must be sent in every manage
+ sequence unless there is no change in x/y position since the last time this
+ event was sent.
+
+
+
+
+
+
+
+ Warp the pointer to the given position in the compositor's logical
+ coordinate space.
+
+ If the given position is outside the bounds of all outputs, the pointer
+ will be warped to the closest point inside an output instead.
+
+ This request modifies window management state and may only be made as
+ part of a manage sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+
+
+
+ This object allows the window manager to configure a pointer binding and
+ receive events when the binding is triggered.
+
+ The new pointer binding is not enabled until the enable request is made
+ during a manage sequence.
+
+ Normally, all pointer button events are sent to the surface with pointer
+ focus by the compositor. Pointer button events that trigger a pointer
+ binding are not sent to the surface with pointer focus.
+
+ If multiple pointer bindings would be triggered by a single physical
+ pointer event on the compositor side, it is compositor policy which
+ pointer binding(s) will receive press/release events or if all of the
+ matched pointer bindings receive press/release events.
+
+
+
+
+ This request indicates that the client will no longer use the pointer
+ binding object and that it may be safely destroyed.
+
+
+
+
+
+ This request should be made after all initial configuration has been
+ completed and the window manager wishes the pointer binding to be able
+ to be triggered.
+
+ This request modifies window management state and may only be made as
+ part of a manage sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+ This request may be used to temporarily disable the pointer binding. It
+ may be later re-enabled with the enable request.
+
+ This request modifies window management state and may only be made as
+ part of a manage sequence, see the river_window_manager_v1 description.
+
+
+
+
+
+ This event indicates that the pointer button triggering the binding has
+ been pressed.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+ The compositor should wait for the manage sequence to complete before
+ processing further input events. This allows the window manager client
+ to, for example, modify key bindings and keyboard focus without racing
+ against future input events. The window manager should of course respond
+ as soon as possible as the capacity of the compositor to buffer incoming
+ input events is finite.
+
+
+
+
+
+ This event indicates that the pointer button triggering the binding has
+ been released.
+
+ Releasing the modifiers for the binding without releasing the pointer
+ button does not trigger the release event. This event is sent when the
+ pointer button is released, even if the modifiers have changed since the
+ pressed event.
+
+ This event will be followed by a manage_start event after all other new
+ state has been sent by the server.
+
+ The compositor should wait for the manage sequence to complete before
+ processing further input events. This allows the window manager client
+ to, for example, modify key bindings and keyboard focus without racing
+ against future input events. The window manager should of course respond
+ as soon as possible as the capacity of the compositor to buffer incoming
+ input events is finite.
+
+
+
+
diff --git a/protocol/river/river-xkb-bindings-v1.xml b/protocol/river/river-xkb-bindings-v1.xml
new file mode 100644
--- /dev/null
+++ b/protocol/river/river-xkb-bindings-v1.xml
@@ -0,0 +1,37 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/src/ControlMain.hs b/src/ControlMain.hs
new file mode 100644
--- /dev/null
+++ b/src/ControlMain.hs
@@ -0,0 +1,37 @@
+module Main where
+
+import Control.Exception (bracketOnError, try)
+import Network.Socket
+import Network.Socket.ByteString qualified as NSB
+
+main :: IO ()
+main = do
+ args <- getArgs
+ case args of
+ ["--socket", socketPath, "send", encoded] -> sendCommand socketPath encoded
+ otherArgs -> die ("usage: ymonadctl --socket /path/to/ymonad.sock send ''; got: " <> show otherArgs)
+
+sendCommand :: FilePath -> String -> IO ()
+sendCommand socketPath encoded = do
+ result <-
+ ( try
+ ( bracketOnError
+ (socket AF_UNIX Stream defaultProtocol)
+ close
+ ( \sock -> do
+ connect sock (SockAddrUnix socketPath)
+ NSB.sendAll sock (encodeUtf8 (toText encoded))
+ close sock
+ )
+ ) ::
+ IO (Either SomeException ())
+ )
+ case result of
+ Left ex ->
+ die
+ ( "Failed to send command to YMonad control socket at "
+ <> socketPath
+ <> ": "
+ <> displayException ex
+ )
+ Right () -> pass
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,6 @@
+module Main where
+
+import YMonad.Launcher
+
+main :: IO ()
+main = launcherMain
diff --git a/src/YMonad.hs b/src/YMonad.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad.hs
@@ -0,0 +1,35 @@
+module YMonad (
+ ymonad,
+ def,
+ defaultKeys,
+ YAction (..),
+ YConfig (..),
+ Layout (..),
+ Border (..),
+ Resize (..),
+ IncMasterN (..),
+ ChangeLayout (..),
+ CLR (..),
+ TitleBarMode (..),
+ Dimension (..),
+ tall,
+ full,
+ mirror,
+ spacingRaw,
+ spacing,
+ spacingWithEdge,
+ smartSpacing,
+ smartSpacingWithEdge,
+ description,
+ (|||),
+ YPConfig (..),
+ defaultYPConfig,
+ module YMonad.Keys,
+) where
+
+import YMonad.Config
+import YMonad.Core.Common (Dimension (..), TitleBarMode (..))
+import YMonad.Core.Layout
+import YMonad.Keys
+import YMonad.Prompt (YPConfig (..), defaultYPConfig)
+import YMonad.Run
diff --git a/src/YMonad/Backend/River.hs b/src/YMonad/Backend/River.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/Backend/River.hs
@@ -0,0 +1,15 @@
+module YMonad.Backend.River
+ ( module YMonad.Backend.River.Decode
+ , module YMonad.Backend.River.Encode
+ , module YMonad.Backend.River.Interpreter
+ , module YMonad.Backend.River.Protocol
+ , module YMonad.Backend.River.Translate
+ , module YMonad.Backend.River.Types
+ ) where
+
+import YMonad.Backend.River.Decode
+import YMonad.Backend.River.Encode
+import YMonad.Backend.River.Interpreter
+import YMonad.Backend.River.Protocol
+import YMonad.Backend.River.Translate
+import YMonad.Backend.River.Types
diff --git a/src/YMonad/Backend/River/Decode.hs b/src/YMonad/Backend/River/Decode.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/Backend/River/Decode.hs
@@ -0,0 +1,301 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module YMonad.Backend.River.Decode (
+ decodeCallback,
+ ingestBytes,
+) where
+
+import Data.ByteString qualified as BS
+import Data.Map.Strict qualified as M
+import Data.Text qualified as T
+
+import YMonad.Backend.River.Types
+import YMonad.Core
+import YMonad.Protocol.Wayland.Types
+import YMonad.Protocol.Wayland.Wire
+
+decodeCallback :: RiverCallback -> Either BackendFault [YEvent]
+decodeCallback cb = Right $ case cb of
+ RiverViewCreated vid meta -> [EvViewMapped vid meta]
+ RiverViewDestroyed vid -> [EvViewUnmapped vid]
+ RiverOutputDiscovered oid info -> [EvOutputAdded oid info]
+ RiverOutputLost oid -> [EvOutputRemoved oid]
+ RiverSeatFocus mvid -> [EvFocusChanged mvid]
+ RiverManageStart -> []
+ RiverRenderStart -> []
+ RiverUserCommand cmd -> [EvUserCommand cmd]
+ RiverActionTriggered _ -> []
+ RiverProtocolFault msg -> [EvBackendFault (BackendFault msg)]
+ RiverTrace _msg -> []
+
+ingestBytes :: RiverRuntime -> BS.ByteString -> Either BackendFault (RiverRuntime, [RiverCallback])
+ingestBytes rt chunk = do
+ let buffered = rrInboundBuffer rt <> chunk
+ (frames, leftover) <- firstFault (decodeRawFrames buffered)
+ processFrames (rt {rrInboundBuffer = leftover}) id frames
+ where
+ processFrames runtime callbacks [] = Right (runtime, callbacks [])
+ processFrames runtime callbacks (frame : rest) = do
+ (runtime', produced) <- processFrame runtime frame
+ processFrames runtime' (callbacks . (produced ++)) rest
+
+processFrame :: RiverRuntime -> RawFrame -> Either BackendFault (RiverRuntime, [RiverCallback])
+processFrame rt frame = do
+ ifaceName <- case M.lookup (rawObjectId frame) (rrObjectInterfaces rt) of
+ Nothing -> Left (BackendFault ("Unknown Wayland object id: " <> tshow (rawObjectId frame)))
+ Just name -> Right name
+ spec <- case lookupEventByOpcode (rrProtocol rt) ifaceName (rawOpcode frame) of
+ Nothing -> Left (BackendFault ("Unknown event opcode " <> tshow (rawOpcode frame) <> " for interface " <> ifaceName))
+ Just found -> Right found
+ args <- firstFault (decodeMessageArgs spec (rawPayload frame))
+ interpretEvent rt frame ifaceName spec args
+
+interpretEvent :: RiverRuntime -> RawFrame -> Text -> MessageSpec -> [ArgValue] -> Either BackendFault (RiverRuntime, [RiverCallback])
+interpretEvent rt frame ifaceName spec args
+ | ifaceName == "wl_registry" && messageSpecName spec == "global" = handleRegistryGlobal rt args
+ | ifaceName == "wl_display" && messageSpecName spec == "error" =
+ Right (rt, [RiverProtocolFault ("wl_display.error: " <> T.intercalate ", " (map renderArg args))])
+ | ifaceName == "wl_callback" = handleCallbackEvent rt (rawObjectId frame) spec args
+ | ifaceName == "river_window_manager_v1" = handleManagerEvent rt spec args
+ | ifaceName == "river_xkb_binding_v1" = handleXkbBindingEvent rt (rawObjectId frame) spec args
+ | ifaceName == "river_window_v1" = handleWindowEvent rt (rawObjectId frame) spec args
+ | ifaceName == "river_output_v1" = handleOutputEvent rt (rawObjectId frame) spec args
+ | ifaceName == "river_seat_v1" = handleSeatEvent rt spec args
+ | otherwise = Right (rt, [])
+
+handleRegistryGlobal :: RiverRuntime -> [ArgValue] -> Either BackendFault (RiverRuntime, [RiverCallback])
+handleRegistryGlobal rt [ArgUintValue globalName, ArgStringValue (Just ifaceName), ArgUintValue version]
+ | ifaceName == "river_window_manager_v1" =
+ case rrManagerObject rt of
+ Just _ -> Right (rt, [])
+ Nothing ->
+ let (managerId, rt1) = allocateObjectId rt
+ bindMessage =
+ WireMessage
+ { wireObjectId = rrRegistryObject rt1
+ , wireInterface = "wl_registry"
+ , wireMessageName = "bind"
+ , wireOpcode = 0
+ , wireArgs =
+ [ ArgUintValue globalName
+ , ArgStringValue (Just ifaceName)
+ , ArgUintValue version
+ , ArgNewIdValue managerId
+ ]
+ }
+ rt2 =
+ rt1
+ { rrManagerObject = Just managerId
+ , rrObjectInterfaces = M.insert managerId ifaceName (rrObjectInterfaces rt1)
+ , rrOutgoing = rrOutgoing rt1 ++ [bindMessage]
+ }
+ in Right (rt2, [RiverTrace ("bound river_window_manager_v1 object " <> tshow managerId)])
+ | ifaceName == "river_xkb_bindings_v1" =
+ case rrXkbBindingsObject rt of
+ Just _ -> Right (rt, [])
+ Nothing ->
+ let (bindingsId, rt1) = allocateObjectId rt
+ bindMessage =
+ WireMessage
+ { wireObjectId = rrRegistryObject rt1
+ , wireInterface = "wl_registry"
+ , wireMessageName = "bind"
+ , wireOpcode = 0
+ , wireArgs =
+ [ ArgUintValue globalName
+ , ArgStringValue (Just ifaceName)
+ , ArgUintValue version
+ , ArgNewIdValue bindingsId
+ ]
+ }
+ rt2 =
+ rt1
+ { rrXkbBindingsObject = Just bindingsId
+ , rrObjectInterfaces = M.insert bindingsId ifaceName (rrObjectInterfaces rt1)
+ , rrOutgoing = rrOutgoing rt1 ++ [bindMessage]
+ }
+ in Right (rt2, [RiverTrace ("bound river_xkb_bindings_v1 object " <> tshow bindingsId)])
+ | otherwise = Right (rt, [])
+handleRegistryGlobal _ _ = Left (BackendFault "Malformed wl_registry.global payload")
+
+handleCallbackEvent :: RiverRuntime -> Word32 -> MessageSpec -> [ArgValue] -> Either BackendFault (RiverRuntime, [RiverCallback])
+handleCallbackEvent rt objectId spec args = case messageSpecName spec of
+ "done" -> case args of
+ [ArgUintValue _callbackData]
+ | Just objectId == rrStartupSyncObject rt ->
+ let rt' =
+ rt
+ { rrStartupSyncObject = Nothing
+ , rrRegistryReady = True
+ , rrObjectInterfaces = M.delete objectId (rrObjectInterfaces rt)
+ }
+ in Right (rt', [RiverTrace "registry roundtrip complete"])
+ [ArgUintValue _callbackData] -> Right (rt, [])
+ unexpectedDoneArgs -> Left (BackendFault ("Malformed wl_callback.done payload: " <> tshow unexpectedDoneArgs))
+ _otherCallbackEvent -> Right (rt, [])
+
+handleManagerEvent :: RiverRuntime -> MessageSpec -> [ArgValue] -> Either BackendFault (RiverRuntime, [RiverCallback])
+handleManagerEvent rt spec args = case messageSpecName spec of
+ "manage_start" -> Right (rt {rrPhase = RiverPhaseManage, rrManageDirtySent = False}, [RiverTrace "manage_start", RiverManageStart])
+ "render_start" -> Right (rt {rrPhase = RiverPhaseRender}, [RiverTrace "render_start", RiverRenderStart])
+ "window" -> case args of
+ [ArgNewIdValue windowId] ->
+ let vid = ViewId (fromIntegral windowId)
+ (nodeId, rt1) = allocateObjectId rt
+ getNode =
+ WireMessage
+ { wireObjectId = windowId
+ , wireInterface = "river_window_v1"
+ , wireMessageName = "get_node"
+ , wireOpcode = opcodeOf rt1 "river_window_v1" "get_node"
+ , wireArgs = [ArgNewIdValue nodeId]
+ }
+ handle = RiverViewHandle windowId (Just nodeId) "" "" Nothing
+ rt2 =
+ rt1
+ { rrViews = M.insert vid handle (rrViews rt1)
+ , rrViewsByObjectId = M.insert windowId vid (rrViewsByObjectId rt1)
+ , rrObjectInterfaces = M.insert nodeId "river_node_v1" (M.insert windowId "river_window_v1" (rrObjectInterfaces rt1))
+ , rrOutgoing = rrOutgoing rt1 ++ [getNode]
+ }
+ meta = ViewMeta "" "" False
+ in Right (rt2, [RiverTrace ("manager announced window " <> tshow (unViewId vid) <> " (object " <> tshow windowId <> ")"), RiverViewCreated vid meta])
+ unexpectedWindowArgs -> Left (BackendFault ("Malformed river_window_manager_v1.window payload: " <> tshow unexpectedWindowArgs))
+ "output" -> case args of
+ [ArgNewIdValue outputObj] ->
+ let oid = OutputId (fromIntegral outputObj)
+ handle = RiverOutputHandle outputObj Nothing Nothing
+ rt' =
+ rt
+ { rrOutputs = M.insert oid handle (rrOutputs rt)
+ , rrOutputsByObjectId = M.insert outputObj oid (rrOutputsByObjectId rt)
+ , rrObjectInterfaces = M.insert outputObj "river_output_v1" (rrObjectInterfaces rt)
+ }
+ in Right (rt', [])
+ unexpectedOutputArgs -> Left (BackendFault ("Malformed river_window_manager_v1.output payload: " <> tshow unexpectedOutputArgs))
+ "seat" -> case args of
+ [ArgNewIdValue seatObj] ->
+ let seat = RiverSeatHandle seatObj
+ rt' =
+ rt
+ { rrSeat = Just seat
+ , rrObjectInterfaces = M.insert seatObj "river_seat_v1" (rrObjectInterfaces rt)
+ }
+ in Right (rt', [RiverTrace ("seat discovered: object " <> tshow seatObj)])
+ unexpectedSeatArgs -> Left (BackendFault ("Malformed river_window_manager_v1.seat payload: " <> tshow unexpectedSeatArgs))
+ "unavailable" -> Right (rt, [RiverProtocolFault "river window management unavailable"])
+ _otherManagerEvent -> Right (rt, [])
+
+handleXkbBindingEvent :: RiverRuntime -> Word32 -> MessageSpec -> [ArgValue] -> Either BackendFault (RiverRuntime, [RiverCallback])
+handleXkbBindingEvent rt objectId spec _args =
+ case bindingActionForObject rt objectId of
+ Nothing -> Right (rt, [])
+ Just action -> case messageSpecName spec of
+ "pressed" -> Right (rt, [RiverActionTriggered action])
+ "released" -> Right (rt, [])
+ "stop_repeat" -> Right (rt, [])
+ _otherBindingEvent -> Right (rt, [])
+
+handleWindowEvent :: RiverRuntime -> Word32 -> MessageSpec -> [ArgValue] -> Either BackendFault (RiverRuntime, [RiverCallback])
+handleWindowEvent rt objectId spec args = case M.lookup objectId (rrViewsByObjectId rt) of
+ Nothing -> Right (rt, [])
+ Just vid -> case messageSpecName spec of
+ "closed" ->
+ let rt' =
+ rt
+ { rrViews = M.delete vid (rrViews rt)
+ , rrViewsByObjectId = M.delete objectId (rrViewsByObjectId rt)
+ }
+ in Right (rt', [RiverViewDestroyed vid])
+ "title" -> case args of
+ [ArgStringValue maybeTitle] ->
+ let title = fromMaybe "" maybeTitle
+ in Right (updateViewMeta rt vid (\h -> h {riverViewTitle = title}), [])
+ unexpectedTitleArgs -> Left (BackendFault ("Malformed river_window_v1.title payload: " <> tshow unexpectedTitleArgs))
+ "app_id" -> case args of
+ [ArgStringValue maybeAppId] ->
+ let appId = fromMaybe "" maybeAppId
+ in Right (updateViewMeta rt vid (\h -> h {riverViewAppId = appId}), [])
+ unexpectedAppIdArgs -> Left (BackendFault ("Malformed river_window_v1.app_id payload: " <> tshow unexpectedAppIdArgs))
+ "dimensions" -> case args of
+ [ArgIntValue w, ArgIntValue h] ->
+ let size = Size (fromIntegral w) (fromIntegral h)
+ rt' = updateViewMeta rt vid (\hnd -> hnd {riverViewDimensions = Just size})
+ in Right (rt', [RiverTrace ("window " <> tshow (unViewId vid) <> " dimensions " <> tshow w <> "x" <> tshow h)])
+ unexpectedDimensionsArgs -> Left (BackendFault ("Malformed river_window_v1.dimensions payload: " <> tshow unexpectedDimensionsArgs))
+ _otherWindowEvent -> Right (rt, [])
+
+handleOutputEvent :: RiverRuntime -> Word32 -> MessageSpec -> [ArgValue] -> Either BackendFault (RiverRuntime, [RiverCallback])
+handleOutputEvent rt objectId spec args = case M.lookup objectId (rrOutputsByObjectId rt) of
+ Nothing -> Right (rt, [])
+ Just oid -> case messageSpecName spec of
+ "removed" ->
+ let rt' =
+ rt
+ { rrOutputs = M.delete oid (rrOutputs rt)
+ , rrOutputsByObjectId = M.delete objectId (rrOutputsByObjectId rt)
+ }
+ in Right (rt', [RiverOutputLost oid])
+ "position" -> case args of
+ [ArgIntValue x, ArgIntValue y] ->
+ emitOutput rt oid (\h -> h {riverOutputPosition = Just (Point (fromIntegral x) (fromIntegral y))})
+ unexpectedPositionArgs -> Left (BackendFault ("Malformed river_output_v1.position payload: " <> tshow unexpectedPositionArgs))
+ "dimensions" -> case args of
+ [ArgIntValue w, ArgIntValue h] ->
+ emitOutput rt oid (\handle -> handle {riverOutputSize = Just (Size (fromIntegral w) (fromIntegral h))})
+ unexpectedDimensionsArgs -> Left (BackendFault ("Malformed river_output_v1.dimensions payload: " <> tshow unexpectedDimensionsArgs))
+ _otherOutputEvent -> Right (rt, [])
+
+handleSeatEvent :: RiverRuntime -> MessageSpec -> [ArgValue] -> Either BackendFault (RiverRuntime, [RiverCallback])
+handleSeatEvent rt spec args = case messageSpecName spec of
+ "pointer_enter" -> Right (rt, [])
+ "window_interaction" -> case args of
+ [ArgObjectValue (Just windowObj)] ->
+ let mVid = M.lookup windowObj (rrViewsByObjectId rt)
+ in Right (rt, [RiverSeatFocus mVid])
+ _unexpectedWindowInteractionArgs -> Right (rt, [])
+ _otherSeatEvent -> Right (rt, [])
+
+emitOutput :: RiverRuntime -> OutputId -> (RiverOutputHandle -> RiverOutputHandle) -> Either BackendFault (RiverRuntime, [RiverCallback])
+emitOutput rt oid f = case M.lookup oid (rrOutputs rt) of
+ Nothing -> Right (rt, [])
+ Just handle ->
+ let updated = f handle
+ rt' = rt {rrOutputs = M.insert oid updated (rrOutputs rt)}
+ in case (riverOutputPosition updated, riverOutputSize updated) of
+ (Just point, Just size) ->
+ let info =
+ OutputInfo
+ { outputName = "river-output-" <> tshow (unOutputId oid)
+ , outputRect = Rect (pointX point) (pointY point) (sizeWidth size) (sizeHeight size)
+ }
+ in Right (rt', [RiverOutputDiscovered oid info])
+ _incompleteOutputInfo -> Right (rt', [])
+
+updateViewMeta :: RiverRuntime -> ViewId -> (RiverViewHandle -> RiverViewHandle) -> RiverRuntime
+updateViewMeta rt vid f = case M.lookup vid (rrViews rt) of
+ Nothing -> rt
+ Just handle -> rt {rrViews = M.insert vid (f handle) (rrViews rt)}
+
+opcodeOf :: RiverRuntime -> Text -> Text -> Word16
+opcodeOf rt ifaceName msgName =
+ maybe
+ 0
+ messageSpecOpcode
+ (lookupRequest (rrProtocol rt) ifaceName msgName)
+
+firstFault :: Either String a -> Either BackendFault a
+firstFault = either (Left . BackendFault . T.pack) Right
+
+renderArg :: ArgValue -> Text
+renderArg arg = case arg of
+ ArgIntValue n -> tshow n
+ ArgUintValue n -> tshow n
+ ArgStringValue Nothing -> ""
+ ArgStringValue (Just txt) -> txt
+ ArgObjectValue Nothing -> "object:null"
+ ArgObjectValue (Just oid) -> "object:" <> tshow oid
+ ArgNewIdValue oid -> "new_id:" <> tshow oid
+
+tshow :: (Show a) => a -> Text
+tshow = T.pack . show
diff --git a/src/YMonad/Backend/River/Encode.hs b/src/YMonad/Backend/River/Encode.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/Backend/River/Encode.hs
@@ -0,0 +1,13 @@
+module YMonad.Backend.River.Encode
+ ( flushOutgoingBytes
+ ) where
+
+import qualified Data.ByteString as BS
+
+import YMonad.Backend.River.Types
+import YMonad.Protocol.Wayland.Wire
+
+flushOutgoingBytes :: RiverRuntime -> (RiverRuntime, BS.ByteString)
+flushOutgoingBytes rt =
+ let bytes = encodeWireBatch (rrOutgoing rt)
+ in (rt { rrOutgoing = [] }, bytes)
diff --git a/src/YMonad/Backend/River/Interpreter.hs b/src/YMonad/Backend/River/Interpreter.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/Backend/River/Interpreter.hs
@@ -0,0 +1,64 @@
+module YMonad.Backend.River.Interpreter (
+ connectRiver,
+ recvEventsIO,
+ flushTransportIO,
+) where
+
+import Control.Exception (bracketOnError, try)
+import Data.ByteString qualified as BS
+import Network.Socket
+import Network.Socket.ByteString qualified as NSB
+import System.FilePath (())
+
+import YMonad.Backend.River.Decode
+import YMonad.Backend.River.Encode
+import YMonad.Backend.River.Translate
+import YMonad.Backend.River.Types
+import YMonad.Core
+
+connectRiver :: Maybe FilePath -> IO (Either BackendFault Socket)
+connectRiver explicitPath = do
+ resolved <- resolveSocketPath explicitPath
+ case resolved of
+ Left err -> pure (Left err)
+ Right path -> do
+ result <- (try (bracketOnError (socket AF_UNIX Stream defaultProtocol) close (\sock -> connect sock (SockAddrUnix path) >> pure sock)) :: IO (Either SomeException Socket))
+ pure $ case result of
+ Left ex -> Left (BackendFault ("Failed to connect to Wayland socket " <> toText path <> ": " <> toText (displayException ex)))
+ Right sock -> Right sock
+
+recvEventsIO :: Socket -> RiverRuntime -> IO (Either BackendFault (RiverRuntime, [YEvent]))
+recvEventsIO sock rt = do
+ recvResult <- (try (NSB.recv sock 65535) :: IO (Either SomeException BS.ByteString))
+ case recvResult of
+ Left ex -> pure (Left (BackendFault ("Wayland recv failed: " <> toText (displayException ex))))
+ Right chunk ->
+ if BS.null chunk
+ then pure (Left (BackendFault "Wayland socket closed by compositor"))
+ else do
+ pure $ do
+ (rt', callbacks) <- ingestBytes rt chunk
+ events <- fmap concat (mapM decodeCallback callbacks)
+ pure (rt', events)
+
+flushTransportIO :: Socket -> RiverRuntime -> IO (Either BackendFault RiverRuntime)
+flushTransportIO sock rt0 = do
+ let rt1 = pumpPending rt0
+ (rt2, bytes) = flushOutgoingBytes rt1
+ if BS.null bytes
+ then pure (Right rt2)
+ else do
+ sendResult <- (try (NSB.sendAll sock bytes) :: IO (Either SomeException ()))
+ pure $ case sendResult of
+ Left ex -> Left (BackendFault ("Wayland send failed: " <> toText (displayException ex)))
+ Right () -> Right rt2
+
+resolveSocketPath :: Maybe FilePath -> IO (Either BackendFault FilePath)
+resolveSocketPath (Just path) = pure (Right path)
+resolveSocketPath Nothing = do
+ display <- lookupEnv "WAYLAND_DISPLAY"
+ runtimeDir <- lookupEnv "XDG_RUNTIME_DIR"
+ pure $ case (display, runtimeDir) of
+ (Just disp, Just dir) -> Right (dir disp)
+ (Nothing, _) -> Left (BackendFault "WAYLAND_DISPLAY is not set")
+ (_, Nothing) -> Left (BackendFault "XDG_RUNTIME_DIR is not set")
diff --git a/src/YMonad/Backend/River/Protocol.hs b/src/YMonad/Backend/River/Protocol.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/Backend/River/Protocol.hs
@@ -0,0 +1,17 @@
+module YMonad.Backend.River.Protocol
+ ( module YMonad.Backend.River.Decode
+ , module YMonad.Backend.River.Encode
+ , module YMonad.Backend.River.Translate
+ , module YMonad.Backend.River.Types
+ , module YMonad.Protocol.Wayland.Types
+ , module YMonad.Protocol.Wayland.Wire
+ , module YMonad.Protocol.Wayland.Xml
+ ) where
+
+import YMonad.Backend.River.Decode
+import YMonad.Backend.River.Encode
+import YMonad.Backend.River.Translate
+import YMonad.Backend.River.Types
+import YMonad.Protocol.Wayland.Types
+import YMonad.Protocol.Wayland.Wire
+import YMonad.Protocol.Wayland.Xml
diff --git a/src/YMonad/Backend/River/Translate.hs b/src/YMonad/Backend/River/Translate.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/Backend/River/Translate.hs
@@ -0,0 +1,166 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module YMonad.Backend.River.Translate (
+ stageRequests,
+ pumpPending,
+) where
+
+import Data.Map.Strict qualified as M
+
+import YMonad.Backend.River.Types
+import YMonad.Core
+import YMonad.Protocol.Wayland.Types
+
+stageRequests :: RiverRuntime -> [BackendReq] -> RiverRuntime
+stageRequests = foldl' stageRequest
+
+stageRequest :: RiverRuntime -> BackendReq -> RiverRuntime
+stageRequest rt req = case req of
+ ReqShowView vid -> enqueueRender rt vid (\handle -> [mkWindowRequest rt handle "show" []])
+ ReqHideView vid -> enqueueRender rt vid (\handle -> [mkWindowRequest rt handle "hide" []])
+ ReqSetViewRect vid rect -> enqueueRender (enqueueManage rt vid manageMessages) vid renderMessages
+ where
+ manageMessages handle = [mkWindowRequest rt handle "propose_dimensions" [ArgIntValue (fromIntegral (rectWidth rect)), ArgIntValue (fromIntegral (rectHeight rect))]]
+ renderMessages handle =
+ [ mkNodeRequest rt handle "set_position" [ArgIntValue (fromIntegral (rectX rect)), ArgIntValue (fromIntegral (rectY rect))]
+ , mkWindowRequest rt handle "show" []
+ ]
+ ReqSetViewStyle vid style -> enqueueRender (enqueueManage rt vid manageMessages) vid renderMessages
+ where
+ manageMessages handle =
+ [ mkWindowRequest rt handle (case viewStyleTitleBarMode style of NoTitleBar -> "use_ssd"; ServerSideTitleBar -> "use_ssd") []
+ ]
+ renderMessages handle = [mkSetBordersRequest rt handle style]
+ ReqFocusView Nothing -> case rrSeat rt of
+ Nothing -> rt
+ Just seat -> rt {rrPendingManage = rrPendingManage rt ++ [mkSeatRequest rt seat "clear_focus" []]}
+ ReqFocusView (Just vid) ->
+ enqueueManage
+ rt
+ vid
+ ( \handle -> case rrSeat rt of
+ Nothing -> []
+ Just seat -> [mkSeatFocusWindow rt seat handle]
+ )
+ ReqCloseView vid -> enqueueManage rt vid (\handle -> [mkWindowRequest rt handle "close" []])
+ ReqExitSession -> case rrManagerObject rt of
+ Nothing -> rt
+ Just managerId -> rt {rrOutgoing = rrOutgoing rt ++ [managerRequest rt managerId "exit_session" []]}
+ ReqCommit -> rt
+
+enqueueManage :: RiverRuntime -> ViewId -> (RiverViewHandle -> [WireMessage]) -> RiverRuntime
+enqueueManage rt vid f = case M.lookup vid (rrViews rt) of
+ Nothing -> rt
+ Just handle -> rt {rrPendingManage = rrPendingManage rt ++ f handle}
+
+enqueueRender :: RiverRuntime -> ViewId -> (RiverViewHandle -> [WireMessage]) -> RiverRuntime
+enqueueRender rt vid f = case M.lookup vid (rrViews rt) of
+ Nothing -> rt
+ Just handle -> rt {rrPendingRender = rrPendingRender rt ++ f handle}
+
+pumpPending :: RiverRuntime -> RiverRuntime
+pumpPending rt = pumpRender (pumpManage rt)
+
+pumpManage :: RiverRuntime -> RiverRuntime
+pumpManage rt = case rrPhase rt of
+ RiverPhaseManage ->
+ let finish = maybe [] (\managerId -> [managerRequest rt managerId "manage_finish" []]) (rrManagerObject rt)
+ in rt
+ { rrOutgoing = rrOutgoing rt ++ rrPendingManage rt ++ finish
+ , rrPendingManage = []
+ , rrManageDirtySent = False
+ , rrPhase = RiverPhaseIdle
+ }
+ _otherPhase
+ | null (rrPendingManage rt) -> requestManageIfNeeded rt
+ | otherwise -> requestManageIfNeeded rt
+
+pumpRender :: RiverRuntime -> RiverRuntime
+pumpRender rt = case rrPhase rt of
+ RiverPhaseRender ->
+ let finish = maybe [] (\managerId -> [managerRequest rt managerId "render_finish" []]) (rrManagerObject rt)
+ in rt
+ { rrOutgoing = rrOutgoing rt ++ rrPendingRender rt ++ finish
+ , rrPendingRender = []
+ , rrPhase = RiverPhaseIdle
+ }
+ _otherPhase -> rt
+
+requestManageIfNeeded :: RiverRuntime -> RiverRuntime
+requestManageIfNeeded rt
+ | null (rrPendingManage rt) = rt
+ | rrManageDirtySent rt = rt
+ | otherwise = case rrManagerObject rt of
+ Nothing -> rt
+ Just managerId ->
+ rt
+ { rrOutgoing = rrOutgoing rt ++ [managerRequest rt managerId "manage_dirty" []]
+ , rrManageDirtySent = True
+ }
+
+managerRequest :: RiverRuntime -> Word32 -> Text -> [ArgValue] -> WireMessage
+managerRequest rt managerId name args =
+ WireMessage
+ { wireObjectId = managerId
+ , wireInterface = "river_window_manager_v1"
+ , wireMessageName = name
+ , wireOpcode = requestOpcode rt "river_window_manager_v1" name
+ , wireArgs = args
+ }
+
+mkWindowRequest :: RiverRuntime -> RiverViewHandle -> Text -> [ArgValue] -> WireMessage
+mkWindowRequest rt handle name args =
+ WireMessage
+ { wireObjectId = riverWindowObjectId handle
+ , wireInterface = "river_window_v1"
+ , wireMessageName = name
+ , wireOpcode = requestOpcode rt "river_window_v1" name
+ , wireArgs = args
+ }
+
+mkNodeRequest :: RiverRuntime -> RiverViewHandle -> Text -> [ArgValue] -> WireMessage
+mkNodeRequest rt handle name args =
+ WireMessage
+ { wireObjectId = fromMaybe 0 (riverNodeObjectId handle)
+ , wireInterface = "river_node_v1"
+ , wireMessageName = name
+ , wireOpcode = requestOpcode rt "river_node_v1" name
+ , wireArgs = args
+ }
+
+mkSeatRequest :: RiverRuntime -> RiverSeatHandle -> Text -> [ArgValue] -> WireMessage
+mkSeatRequest rt seat name args =
+ WireMessage
+ { wireObjectId = riverSeatObjectId seat
+ , wireInterface = "river_seat_v1"
+ , wireMessageName = name
+ , wireOpcode = requestOpcode rt "river_seat_v1" name
+ , wireArgs = args
+ }
+
+mkSeatFocusWindow :: RiverRuntime -> RiverSeatHandle -> RiverViewHandle -> WireMessage
+mkSeatFocusWindow rt seat handle = mkSeatRequest rt seat "focus_window" [ArgObjectValue (Just (riverWindowObjectId handle))]
+
+mkSetBordersRequest :: RiverRuntime -> RiverViewHandle -> ViewStyle -> WireMessage
+mkSetBordersRequest rt handle style =
+ mkWindowRequest
+ rt
+ handle
+ "set_borders"
+ [ ArgUintValue edges
+ , ArgIntValue (fromIntegral width)
+ , ArgUintValue (rgbaRed color)
+ , ArgUintValue (rgbaGreen color)
+ , ArgUintValue (rgbaBlue color)
+ , ArgUintValue (rgbaAlpha color)
+ ]
+ where
+ width = max 0 (unDimension (viewStyleBorderWidth style))
+ edges = if width > 0 then allEdges else 0
+ color = viewStyleBorderColor style
+
+allEdges :: Word32
+allEdges = 1 + 2 + 4 + 8
+
+requestOpcode :: RiverRuntime -> Text -> Text -> Word16
+requestOpcode rt ifaceName name = maybe 0 messageSpecOpcode (lookupRequest (rrProtocol rt) ifaceName name)
diff --git a/src/YMonad/Backend/River/Types.hs b/src/YMonad/Backend/River/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/Backend/River/Types.hs
@@ -0,0 +1,223 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module YMonad.Backend.River.Types (
+ RiverViewHandle (..),
+ RiverOutputHandle (..),
+ RiverSeatHandle (..),
+ RiverPhase (..),
+ RiverCallback (..),
+ RiverConnection (..),
+ RiverRuntime (..),
+ bindingActionForObject,
+ loadRiverRuntime,
+ emptyRiverRuntime,
+ allocateObjectId,
+) where
+
+import Data.ByteString qualified as BS
+import Data.Map.Strict qualified as M
+import Paths_ymonad (getDataFileName)
+
+import YMonad.Config (YAction)
+import YMonad.Core
+import YMonad.Protocol.Wayland.Types
+import YMonad.Protocol.Wayland.Xml
+
+data RiverViewHandle = RiverViewHandle
+ { riverWindowObjectId :: Word32
+ , riverNodeObjectId :: Maybe Word32
+ , riverViewTitle :: Text
+ , riverViewAppId :: Text
+ , riverViewDimensions :: Maybe Size
+ }
+ deriving stock (Eq, Ord, Show)
+
+data RiverOutputHandle = RiverOutputHandle
+ { riverOutputObjectId :: Word32
+ , riverOutputPosition :: Maybe Point
+ , riverOutputSize :: Maybe Size
+ }
+ deriving stock (Eq, Ord, Show)
+
+newtype RiverSeatHandle = RiverSeatHandle
+ { riverSeatObjectId :: Word32
+ }
+ deriving stock (Eq, Ord, Show)
+
+data RiverPhase
+ = RiverPhaseIdle
+ | RiverPhaseManage
+ | RiverPhaseRender
+ deriving stock (Eq, Ord, Show)
+
+data RiverCallback
+ = RiverViewCreated ViewId ViewMeta
+ | RiverViewDestroyed ViewId
+ | RiverOutputDiscovered OutputId OutputInfo
+ | RiverOutputLost OutputId
+ | RiverSeatFocus (Maybe ViewId)
+ | RiverManageStart
+ | RiverRenderStart
+ | RiverUserCommand UserCommand
+ | RiverActionTriggered YAction
+ | RiverProtocolFault Text
+ | RiverTrace Text
+ deriving stock (Eq, Ord, Show)
+
+newtype RiverConnection = RiverConnection
+ { riverSocketPath :: FilePath
+ }
+ deriving stock (Eq, Ord, Show)
+
+data RiverRuntime = RiverRuntime
+ { rrProtocol :: ProtocolSpec
+ , rrDisplayObject :: Word32
+ , rrRegistryObject :: Word32
+ , rrManagerObject :: Maybe Word32
+ , rrXkbBindingsObject :: Maybe Word32
+ , rrStartupSyncObject :: Maybe Word32
+ , rrRegistryReady :: Bool
+ , rrSeat :: Maybe RiverSeatHandle
+ , rrBindingActions :: Map Word32 YAction
+ , rrBindingsInstalled :: Bool
+ , rrViews :: Map ViewId RiverViewHandle
+ , rrViewsByObjectId :: Map Word32 ViewId
+ , rrOutputs :: Map OutputId RiverOutputHandle
+ , rrOutputsByObjectId :: Map Word32 OutputId
+ , rrObjectInterfaces :: Map Word32 Text
+ , rrPendingManage :: [WireMessage]
+ , rrPendingRender :: [WireMessage]
+ , rrOutgoing :: [WireMessage]
+ , rrInboundBuffer :: BS.ByteString
+ , rrNextObjectId :: Word32
+ , rrPhase :: RiverPhase
+ , rrManageDirtySent :: Bool
+ }
+ deriving stock (Eq, Show)
+
+loadRiverRuntime :: IO (Either String RiverRuntime)
+loadRiverRuntime = do
+ windowPath <- getDataFileName "protocol/river/river-window-management-v1.xml"
+ xkbPath <- getDataFileName "protocol/river/river-xkb-bindings-v1.xml"
+ windowSpecResult <- loadProtocolSpec windowPath
+ xkbSpecResult <- loadProtocolSpec xkbPath
+ pure $ do
+ windowSpec <- windowSpecResult
+ emptyRiverRuntime . mergeProtocolSpecs windowSpec <$> xkbSpecResult
+
+emptyRiverRuntime :: ProtocolSpec -> RiverRuntime
+emptyRiverRuntime riverSpec =
+ let base = baseProtocolSpec
+ merged = mergeProtocolSpecs base riverSpec
+ registryMessage = bootstrapGetRegistry
+ in RiverRuntime
+ { rrProtocol = merged
+ , rrDisplayObject = 1
+ , rrRegistryObject = 2
+ , rrManagerObject = Nothing
+ , rrXkbBindingsObject = Nothing
+ , rrStartupSyncObject = Just 3
+ , rrRegistryReady = False
+ , rrSeat = Nothing
+ , rrBindingActions = M.empty
+ , rrBindingsInstalled = False
+ , rrViews = M.empty
+ , rrViewsByObjectId = M.empty
+ , rrOutputs = M.empty
+ , rrOutputsByObjectId = M.empty
+ , rrObjectInterfaces = M.fromList [(1, "wl_display"), (2, "wl_registry"), (3, "wl_callback")]
+ , rrPendingManage = []
+ , rrPendingRender = []
+ , rrOutgoing = [registryMessage, bootstrapSync 3]
+ , rrInboundBuffer = BS.empty
+ , rrNextObjectId = 4
+ , rrPhase = RiverPhaseIdle
+ , rrManageDirtySent = False
+ }
+
+allocateObjectId :: RiverRuntime -> (Word32, RiverRuntime)
+allocateObjectId rt = (rrNextObjectId rt, rt {rrNextObjectId = rrNextObjectId rt + 1})
+
+baseProtocolSpec :: ProtocolSpec
+baseProtocolSpec =
+ ProtocolSpec
+ { protocolName = "wayland-core"
+ , protocolInterfaces =
+ M.fromList
+ [ (interfaceName wlDisplay, wlDisplay)
+ , (interfaceName wlRegistry, wlRegistry)
+ , (interfaceName wlCallback, wlCallback)
+ ]
+ }
+ where
+ wlDisplay =
+ mkInterfaceSpec
+ "wl_display"
+ 1
+ [ MessageSpec "sync" 0 MessageRequest [ArgSpec "callback" (ArgNewId (Just "wl_callback")) False]
+ , MessageSpec "get_registry" 1 MessageRequest [ArgSpec "registry" (ArgNewId (Just "wl_registry")) False]
+ ]
+ [ MessageSpec
+ "error"
+ 0
+ MessageEvent
+ [ ArgSpec "object_id" (ArgObject Nothing) False
+ , ArgSpec "code" ArgUint False
+ , ArgSpec "message" ArgString False
+ ]
+ , MessageSpec "delete_id" 1 MessageEvent [ArgSpec "id" ArgUint False]
+ ]
+ wlRegistry =
+ mkInterfaceSpec
+ "wl_registry"
+ 1
+ [ MessageSpec
+ "bind"
+ 0
+ MessageRequest
+ [ ArgSpec "name" ArgUint False
+ , ArgSpec "interface" ArgString False
+ , ArgSpec "version" ArgUint False
+ , ArgSpec "id" (ArgNewId Nothing) False
+ ]
+ ]
+ [ MessageSpec
+ "global"
+ 0
+ MessageEvent
+ [ ArgSpec "name" ArgUint False
+ , ArgSpec "interface" ArgString False
+ , ArgSpec "version" ArgUint False
+ ]
+ , MessageSpec "global_remove" 1 MessageEvent [ArgSpec "name" ArgUint False]
+ ]
+ wlCallback =
+ mkInterfaceSpec
+ "wl_callback"
+ 1
+ []
+ [ MessageSpec "done" 0 MessageEvent [ArgSpec "callback_data" ArgUint False]
+ ]
+
+bootstrapGetRegistry :: WireMessage
+bootstrapGetRegistry =
+ WireMessage
+ { wireObjectId = 1
+ , wireInterface = "wl_display"
+ , wireMessageName = "get_registry"
+ , wireOpcode = 1
+ , wireArgs = [ArgNewIdValue 2]
+ }
+
+bootstrapSync :: Word32 -> WireMessage
+bootstrapSync callbackId =
+ WireMessage
+ { wireObjectId = 1
+ , wireInterface = "wl_display"
+ , wireMessageName = "sync"
+ , wireOpcode = 0
+ , wireArgs = [ArgNewIdValue callbackId]
+ }
+
+bindingActionForObject :: RiverRuntime -> Word32 -> Maybe YAction
+bindingActionForObject rt objectId = M.lookup objectId (rrBindingActions rt)
diff --git a/src/YMonad/Config.hs b/src/YMonad/Config.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/Config.hs
@@ -0,0 +1,95 @@
+module YMonad.Config (
+ YAction (..),
+ YConfig (..),
+ def,
+ defaultKeys,
+) where
+
+import Data.Bits ((.|.))
+import Data.Map.Strict qualified as M
+
+import YMonad.Core.Common (Dimension (..), TitleBarMode (..))
+import YMonad.Core.Layout (Layout, full, mirror, tall, (|||))
+import YMonad.Keys
+import YMonad.Prompt (YPConfig)
+
+data YAction
+ = Spawn String
+ | ToggleFullscreen
+ | ViewWorkspace String
+ | MoveFocusedTo String
+ | FocusNext
+ | FocusPrev
+ | SwapNext
+ | SwapPrev
+ | KillFocused
+ | CycleLayout
+ | ShrinkMaster
+ | ExpandMaster
+ | IncMasterNBy Int
+ | ExitSession
+ | RecompileRestart
+ | ShellPrompt YPConfig
+ | SafePrompt FilePath YPConfig
+ | UnsafePrompt FilePath YPConfig
+ | SshPrompt YPConfig
+ | ManPrompt YPConfig
+ deriving stock (Eq, Ord, Show)
+
+data YConfig = YConfig
+ { terminal :: String
+ , modMask :: KeyMask
+ , workspaces :: [String]
+ , layoutHook :: Layout
+ , borderWidth :: Dimension
+ , normalBorderColor :: String
+ , focusedBorderColor :: String
+ , titleBarMode :: TitleBarMode
+ , keys :: YConfig -> Map (KeyMask, KeySym) YAction
+ }
+
+def :: YConfig
+def =
+ YConfig
+ { terminal = "foot"
+ , modMask = mod1Mask
+ , workspaces = map show [(1 :: Int) .. 9]
+ , layoutHook = tall ||| mirror tall ||| full
+ , borderWidth = 1
+ , normalBorderColor = "#dddddd"
+ , focusedBorderColor = "#ff0000"
+ , titleBarMode = NoTitleBar
+ , keys = defaultKeys
+ }
+
+defaultKeys :: YConfig -> Map (KeyMask, KeySym) YAction
+defaultKeys conf =
+ M.fromList (baseBindings ++ workspaceBindings)
+ where
+ modm = modMask conf
+ baseBindings =
+ [ ((modm .|. shiftMask, xK_Return), Spawn (terminal conf))
+ , ((modm, xK_Return), ToggleFullscreen)
+ , ((modm, xK_space), CycleLayout)
+ , ((modm, xK_Tab), FocusPrev)
+ , ((modm, xK_j), FocusPrev)
+ , ((modm .|. shiftMask, xK_Tab), FocusNext)
+ , ((modm, xK_ISO_Left_Tab), FocusNext)
+ , ((modm .|. shiftMask, xK_ISO_Left_Tab), FocusNext)
+ , ((modm, xK_k), FocusNext)
+ , ((modm .|. shiftMask, xK_j), SwapPrev)
+ , ((modm .|. shiftMask, xK_k), SwapNext)
+ , ((modm, xK_h), ShrinkMaster)
+ , ((modm, xK_l), ExpandMaster)
+ , ((modm, xK_comma), IncMasterNBy 1)
+ , ((modm, xK_period), IncMasterNBy (-1))
+ , ((modm .|. shiftMask, xK_c), KillFocused)
+ , ((modm, xK_q), ExitSession)
+ , ((modm .|. shiftMask, xK_q), RecompileRestart)
+ ]
+ workspaceBindings = concatMap mkWorkspaceBinding (zip workspaceKeys (workspaces conf))
+ mkWorkspaceBinding (key, workspaceName) =
+ [ ((modm, key), ViewWorkspace workspaceName)
+ , ((modm .|. shiftMask, key), MoveFocusedTo workspaceName)
+ ]
+ workspaceKeys = [xK_1, xK_2, xK_3, xK_4, xK_5, xK_6, xK_7, xK_8, xK_9]
diff --git a/src/YMonad/ControlCommand.hs b/src/YMonad/ControlCommand.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/ControlCommand.hs
@@ -0,0 +1,11 @@
+module YMonad.ControlCommand (
+ ControlCommand (..),
+) where
+
+import YMonad.Core (UserCommand)
+
+data ControlCommand
+ = ControlUserCommand UserCommand
+ | ControlToggleFullscreen
+ | ControlSpawn String
+ deriving stock (Eq, Show, Read)
diff --git a/src/YMonad/Core.hs b/src/YMonad/Core.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/Core.hs
@@ -0,0 +1,13 @@
+module YMonad.Core
+ ( module YMonad.Core.Common
+ , module YMonad.Core.Layout
+ , module YMonad.Core.Reduce
+ , module YMonad.Core.StackSet
+ , module YMonad.Core.Types
+ ) where
+
+import YMonad.Core.Common
+import YMonad.Core.Layout
+import YMonad.Core.Reduce
+import YMonad.Core.StackSet
+import YMonad.Core.Types
diff --git a/src/YMonad/Core/Common.hs b/src/YMonad/Core/Common.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/Core/Common.hs
@@ -0,0 +1,130 @@
+module YMonad.Core.Common (
+ WorkspaceId (..),
+ ScreenId (..),
+ ViewId (..),
+ OutputId (..),
+ Point (..),
+ Size (..),
+ Rect (..),
+ Dimension (..),
+ RgbaColor (..),
+ TitleBarMode (..),
+ opaqueRgb8,
+ parseColorString,
+) where
+
+import Data.Char qualified as Char
+import Data.List qualified as List
+import Data.Map.Strict qualified as M
+import Data.Text qualified as T
+import Numeric (readHex)
+
+newtype WorkspaceId = WorkspaceId {unWorkspaceId :: Text}
+ deriving stock (Eq, Ord, Show, Read)
+
+newtype ScreenId = ScreenId {unScreenId :: Int}
+ deriving stock (Eq, Ord, Show, Read)
+
+newtype ViewId = ViewId {unViewId :: Int}
+ deriving stock (Eq, Ord, Show, Read)
+
+newtype OutputId = OutputId {unOutputId :: Int}
+ deriving stock (Eq, Ord, Show, Read)
+
+newtype Dimension = Dimension {unDimension :: Int}
+ deriving stock (Eq, Ord, Show, Read)
+ deriving newtype (Num)
+
+data Point = Point
+ { pointX :: Int
+ , pointY :: Int
+ }
+ deriving stock (Eq, Ord, Show, Read)
+
+data Size = Size
+ { sizeWidth :: Int
+ , sizeHeight :: Int
+ }
+ deriving stock (Eq, Ord, Show, Read)
+
+data Rect = Rect
+ { rectX :: Int
+ , rectY :: Int
+ , rectWidth :: Int
+ , rectHeight :: Int
+ }
+ deriving stock (Eq, Ord, Show, Read)
+
+data RgbaColor = RgbaColor
+ { rgbaRed :: Word32
+ , rgbaGreen :: Word32
+ , rgbaBlue :: Word32
+ , rgbaAlpha :: Word32
+ }
+ deriving stock (Eq, Ord, Show, Read)
+
+data TitleBarMode
+ = NoTitleBar
+ | ServerSideTitleBar
+ deriving stock (Eq, Ord, Show, Read)
+
+opaqueRgb8 :: Word8 -> Word8 -> Word8 -> RgbaColor
+opaqueRgb8 red green blue = rgbaFrom8Bit red green blue 255
+
+parseColorString :: String -> Maybe RgbaColor
+parseColorString raw =
+ case List.stripPrefix "#" text of
+ Just digits -> parseHexColor digits
+ Nothing -> namedColor text
+ where
+ text = map Char.toLower raw
+
+namedColor :: String -> Maybe RgbaColor
+namedColor name = do
+ (red, green, blue) <- M.lookup (T.pack name) namedPalette
+ pure (opaqueRgb8 red green blue)
+
+namedPalette :: Map Text (Word8, Word8, Word8)
+namedPalette =
+ M.fromList
+ [ ("black", (0, 0, 0))
+ , ("white", (255, 255, 255))
+ , ("red", (255, 0, 0))
+ , ("green", (0, 255, 0))
+ , ("blue", (0, 0, 255))
+ , ("gray", (128, 128, 128))
+ , ("grey", (128, 128, 128))
+ , ("yellow", (255, 255, 0))
+ , ("magenta", (255, 0, 255))
+ , ("cyan", (0, 255, 255))
+ ]
+
+parseHexColor :: String -> Maybe RgbaColor
+parseHexColor digits =
+ case digits of
+ [r, g, b] -> rgbaFrom8Bit <$> dupHex r <*> dupHex g <*> dupHex b <*> pure 255
+ [r, g, b, a] -> rgbaFrom8Bit <$> dupHex r <*> dupHex g <*> dupHex b <*> dupHex a
+ [r1, r2, g1, g2, b1, b2] -> rgbaFrom8Bit <$> byte [r1, r2] <*> byte [g1, g2] <*> byte [b1, b2] <*> pure 255
+ [r1, r2, g1, g2, b1, b2, a1, a2] -> rgbaFrom8Bit <$> byte [r1, r2] <*> byte [g1, g2] <*> byte [b1, b2] <*> byte [a1, a2]
+ _other -> Nothing
+ where
+ dupHex ch = byte [ch, ch]
+ byte chars = case readHex chars of
+ [(value, "")] -> Just (fromIntegral (value :: Int))
+ _ -> Nothing
+
+rgbaFrom8Bit :: Word8 -> Word8 -> Word8 -> Word8 -> RgbaColor
+rgbaFrom8Bit red green blue alpha =
+ RgbaColor
+ { rgbaRed = expand8Bit (premultiply red alpha)
+ , rgbaGreen = expand8Bit (premultiply green alpha)
+ , rgbaBlue = expand8Bit (premultiply blue alpha)
+ , rgbaAlpha = expand8Bit alpha
+ }
+
+expand8Bit :: Word8 -> Word32
+expand8Bit value = fromIntegral value * 0x01010101
+
+premultiply :: Word8 -> Word8 -> Word8
+premultiply channel alpha =
+ fromIntegral (((fromIntegral channel :: Word32) * fromIntegral alpha + 127) `div` 255)
diff --git a/src/YMonad/Core/Layout.hs b/src/YMonad/Core/Layout.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/Core/Layout.hs
@@ -0,0 +1,301 @@
+module YMonad.Core.Layout (
+ Border (..),
+ Layout (..),
+ Resize (..),
+ IncMasterN (..),
+ ChangeLayout (..),
+ CLR (..),
+ LayoutMessage (..),
+ tall,
+ full,
+ mirror,
+ spacingRaw,
+ spacing,
+ spacingWithEdge,
+ smartSpacing,
+ smartSpacingWithEdge,
+ (|||),
+ description,
+ applyLayoutMessage,
+ layoutViews,
+ mirrorRect,
+ splitVertically,
+ splitHorizontally,
+ splitHorizontallyBy,
+ splitVerticallyBy,
+ tile,
+) where
+
+import Data.Ratio ((%))
+
+import YMonad.Core.Common (Rect (..))
+import YMonad.Core.StackSet (Stack (..), integrate)
+
+data Border = Border
+ { borderTop :: Int
+ , borderBottom :: Int
+ , borderRight :: Int
+ , borderLeft :: Int
+ }
+ deriving stock (Eq, Ord, Show, Read)
+
+data Resize = Shrink | Expand
+ deriving stock (Eq, Ord, Show, Read)
+
+newtype IncMasterN = IncMasterN Int
+ deriving stock (Eq, Ord, Show, Read)
+
+data ChangeLayout = FirstLayout | NextLayout
+ deriving stock (Eq, Ord, Show, Read)
+
+data CLR = CL | CR
+ deriving stock (Eq, Ord, Show, Read)
+
+data LayoutMessage
+ = MsgResize Resize
+ | MsgIncMasterN IncMasterN
+ | MsgChangeLayout ChangeLayout
+ | MsgJumpToLayout Text
+ deriving stock (Eq, Ord, Show, Read)
+
+data Layout
+ = Full
+ | Tall
+ { tallNMaster :: Int
+ , tallRatioIncrement :: Rational
+ , tallRatio :: Rational
+ }
+ | Mirror Layout
+ | Choose CLR Layout Layout
+ | Spacing
+ { spacingSmartBorder :: Bool
+ , spacingScreenBorder :: Border
+ , spacingScreenBorderEnabled :: Bool
+ , spacingWindowBorder :: Border
+ , spacingWindowBorderEnabled :: Bool
+ , spacingInnerLayout :: Layout
+ }
+ deriving stock (Eq, Ord, Show, Read)
+
+full :: Layout
+full = Full
+
+tall :: Layout
+tall = Tall 1 (3 % 100) (1 % 2)
+
+mirror :: Layout -> Layout
+mirror = Mirror
+
+spacingRaw :: Bool -> Border -> Bool -> Border -> Bool -> Layout -> Layout
+spacingRaw = Spacing
+
+spacing :: Int -> Layout -> Layout
+spacing px = spacingRaw False zeroBorder False (uniformBorder px) True
+
+spacingWithEdge :: Int -> Layout -> Layout
+spacingWithEdge px = spacingRaw False (uniformBorder px) True (uniformBorder px) True
+
+smartSpacing :: Int -> Layout -> Layout
+smartSpacing px = spacingRaw True zeroBorder False (uniformBorder px) True
+
+smartSpacingWithEdge :: Int -> Layout -> Layout
+smartSpacingWithEdge px = spacingRaw True (uniformBorder px) True (uniformBorder px) True
+
+(|||) :: Layout -> Layout -> Layout
+(|||) = Choose CL
+infixr 5 |||
+
+description :: Layout -> Text
+description layout = case layout of
+ Full -> "Full"
+ Tall {} -> "Tall"
+ Mirror inner -> "Mirror " <> description inner
+ Choose CL left _ -> description left
+ Choose CR _ right -> description right
+ Spacing {spacingInnerLayout = inner} -> description inner
+
+applyLayoutMessage :: LayoutMessage -> Layout -> Layout
+applyLayoutMessage message layout =
+ case message of
+ MsgResize resize -> applyResize resize layout
+ MsgIncMasterN delta -> applyIncMaster delta layout
+ MsgChangeLayout FirstLayout -> firstLayout layout
+ MsgChangeLayout NextLayout -> nextLayout layout
+ MsgJumpToLayout name -> fromMaybe layout (jumpToLayout name layout)
+
+layoutViews :: Layout -> Rect -> Maybe (Stack a) -> [(a, Rect)]
+layoutViews _ _ Nothing = []
+layoutViews layout rect (Just stack) =
+ case layout of
+ Full -> [(stackFocus stack, rect)]
+ Tall nmaster _ frac ->
+ let windows = integrate stack
+ in zip windows (tile frac rect nmaster (length windows))
+ Mirror inner -> map (second mirrorRect) (layoutViews inner (mirrorRect rect) (Just stack))
+ Choose CL left _ -> layoutViews left rect (Just stack)
+ Choose CR _ right -> layoutViews right rect (Just stack)
+ Spacing smart screenBorder screenEnabled windowBorder windowEnabled inner ->
+ let windows = integrate stack
+ applyBorders = not smart || length windows >= 2
+ parentRect =
+ if applyBorders && screenEnabled
+ then insetRect screenBorder rect
+ else rect
+ childViews = layoutViews inner parentRect (Just stack)
+ in if applyBorders && windowEnabled
+ then map (second (insetRect windowBorder)) childViews
+ else childViews
+
+applyResize :: Resize -> Layout -> Layout
+applyResize resize layout = case layout of
+ Tall nmaster delta frac ->
+ Tall nmaster delta (clampRatio (case resize of Shrink -> frac - delta; Expand -> frac + delta))
+ Mirror inner -> Mirror (applyResize resize inner)
+ Choose CL left right -> Choose CL (applyResize resize left) right
+ Choose CR left right -> Choose CR left (applyResize resize right)
+ Spacing smart screenBorder screenEnabled windowBorder windowEnabled inner ->
+ Spacing smart screenBorder screenEnabled windowBorder windowEnabled (applyResize resize inner)
+ Full -> Full
+
+applyIncMaster :: IncMasterN -> Layout -> Layout
+applyIncMaster (IncMasterN delta) layout = case layout of
+ Tall nmaster ratioIncrement frac -> Tall (max 0 (nmaster + delta)) ratioIncrement frac
+ Mirror inner -> Mirror (applyIncMaster (IncMasterN delta) inner)
+ Choose CL left right -> Choose CL (applyIncMaster (IncMasterN delta) left) right
+ Choose CR left right -> Choose CR left (applyIncMaster (IncMasterN delta) right)
+ Spacing smart screenBorder screenEnabled windowBorder windowEnabled inner ->
+ Spacing smart screenBorder screenEnabled windowBorder windowEnabled (applyIncMaster (IncMasterN delta) inner)
+ Full -> Full
+
+firstLayout :: Layout -> Layout
+firstLayout layout = case layout of
+ Choose _ left right -> Choose CL (firstLayout left) (firstLayout right)
+ Mirror inner -> Mirror (firstLayout inner)
+ Spacing smart screenBorder screenEnabled windowBorder windowEnabled inner ->
+ Spacing smart screenBorder screenEnabled windowBorder windowEnabled (firstLayout inner)
+ _ -> layout
+
+nextLayout :: Layout -> Layout
+nextLayout layout = fromMaybe (firstLayout layout) (nextLayoutNoWrap layout)
+
+nextLayoutNoWrap :: Layout -> Maybe Layout
+nextLayoutNoWrap layout = case layout of
+ Full -> Nothing
+ Tall {} -> Nothing
+ Mirror inner -> Mirror <$> nextLayoutNoWrap inner
+ Choose CL left right ->
+ case nextLayoutNoWrap left of
+ Just left' -> Just (Choose CL left' right)
+ Nothing -> Just (Choose CR (firstLayout left) (firstLayout right))
+ Choose CR left right ->
+ Choose CR left <$> nextLayoutNoWrap right
+ Spacing smart screenBorder screenEnabled windowBorder windowEnabled inner ->
+ Spacing smart screenBorder screenEnabled windowBorder windowEnabled <$> nextLayoutNoWrap inner
+
+jumpToLayout :: Text -> Layout -> Maybe Layout
+jumpToLayout name layout
+ | description layout == name = Just layout
+ | otherwise =
+ case layout of
+ Mirror inner -> Mirror <$> jumpToLayout name inner
+ Choose _ left right ->
+ let left' = fromMaybe left (jumpToLayout name left)
+ right' = fromMaybe right (jumpToLayout name right)
+ in if description left' == name
+ then Just (Choose CL left' right')
+ else
+ if description right' == name
+ then Just (Choose CR left' right')
+ else Nothing
+ Spacing smart screenBorder screenEnabled windowBorder windowEnabled inner ->
+ Spacing smart screenBorder screenEnabled windowBorder windowEnabled <$> jumpToLayout name inner
+ _ -> Nothing
+
+clampRatio :: Rational -> Rational
+clampRatio = max 0 . min 1
+
+tile :: Rational -> Rect -> Int -> Int -> [Rect]
+tile frac rect nmaster n
+ | n <= 0 = []
+ | n <= nmaster || nmaster == 0 = splitVertically n rect
+ | otherwise = splitVertically nmaster masterRect ++ splitVertically (n - nmaster) stackRect
+ where
+ (masterRect, stackRect) = splitHorizontallyBy (clampRatio frac) rect
+
+splitVertically :: Int -> Rect -> [Rect]
+splitVertically n rect
+ | n <= 0 = []
+ | n < 2 = [rect]
+ | otherwise = firstRect : splitVertically (n - 1) remainderRect
+ where
+ smallHeight = rectHeight rect `div` n
+ firstRect =
+ Rect
+ { rectX = rectX rect
+ , rectY = rectY rect
+ , rectWidth = rectWidth rect
+ , rectHeight = smallHeight
+ }
+ remainderRect =
+ Rect
+ { rectX = rectX rect
+ , rectY = rectY rect + smallHeight
+ , rectWidth = rectWidth rect
+ , rectHeight = rectHeight rect - smallHeight
+ }
+
+splitHorizontally :: Int -> Rect -> [Rect]
+splitHorizontally n = map mirrorRect . splitVertically n . mirrorRect
+
+splitHorizontallyBy :: Rational -> Rect -> (Rect, Rect)
+splitHorizontallyBy frac rect =
+ ( Rect
+ { rectX = rectX rect
+ , rectY = rectY rect
+ , rectWidth = leftWidth
+ , rectHeight = rectHeight rect
+ }
+ , Rect
+ { rectX = rectX rect + leftWidth
+ , rectY = rectY rect
+ , rectWidth = rectWidth rect - leftWidth
+ , rectHeight = rectHeight rect
+ }
+ )
+ where
+ leftWidth = floor (fromIntegral (rectWidth rect) * frac)
+
+splitVerticallyBy :: Rational -> Rect -> (Rect, Rect)
+splitVerticallyBy frac = both mirrorRect . splitHorizontallyBy frac . mirrorRect
+
+mirrorRect :: Rect -> Rect
+mirrorRect rect =
+ Rect
+ { rectX = rectY rect
+ , rectY = rectX rect
+ , rectWidth = rectHeight rect
+ , rectHeight = rectWidth rect
+ }
+
+both :: (a -> b) -> (a, a) -> (b, b)
+both f (x, y) = (f x, f y)
+
+uniformBorder :: Int -> Border
+uniformBorder px = Border px px px px
+
+zeroBorder :: Border
+zeroBorder = uniformBorder 0
+
+insetRect :: Border -> Rect -> Rect
+insetRect border rect =
+ Rect
+ { rectX = rectX rect + left
+ , rectY = rectY rect + top
+ , rectWidth = max 0 (rectWidth rect - left - right)
+ , rectHeight = max 0 (rectHeight rect - top - bottom)
+ }
+ where
+ top = max 0 (borderTop border)
+ bottom = max 0 (borderBottom border)
+ right = max 0 (borderRight border)
+ left = max 0 (borderLeft border)
diff --git a/src/YMonad/Core/Reduce.hs b/src/YMonad/Core/Reduce.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/Core/Reduce.hs
@@ -0,0 +1,144 @@
+module YMonad.Core.Reduce (
+ reduce,
+ relayoutRequests,
+) where
+
+import Data.List (partition)
+import Data.Map.Strict qualified as M
+
+import YMonad.Core.Layout
+import YMonad.Core.StackSet
+import YMonad.Core.Types
+
+reduce :: RuntimeState -> YEvent -> Transition
+reduce st ev = case ev of
+ EvViewMapped vid meta ->
+ let ws' = insertUp vid (rtWindowSet st)
+ st' = st {rtWindowSet = ws', rtViews = M.insert vid meta (rtViews st)}
+ in Transition st' (relayoutRequests st')
+ EvViewUnmapped vid ->
+ let ws' = delete vid (rtWindowSet st)
+ st' = st {rtWindowSet = ws', rtViews = M.delete vid (rtViews st)}
+ in Transition st' (ReqHideView vid : relayoutRequests st')
+ EvOutputAdded oid info ->
+ let currentScreen = current (rtWindowSet st)
+ ws' =
+ (rtWindowSet st)
+ { current = currentScreen {screenRect = outputRect info}
+ }
+ st' = st {rtWindowSet = ws', rtOutputs = M.insert oid info (rtOutputs st)}
+ in Transition st' (relayoutRequests st')
+ EvOutputRemoved oid ->
+ let st' = st {rtOutputs = M.delete oid (rtOutputs st)}
+ in Transition st' []
+ EvFocusChanged Nothing -> Transition st [ReqFocusView Nothing, ReqCommit]
+ EvFocusChanged (Just vid) ->
+ let ws' = focusWindow vid (rtWindowSet st)
+ st' = st {rtWindowSet = ws'}
+ in Transition st' (relayoutRequests st')
+ EvUserCommand cmd -> reduceCommand st cmd
+ EvBackendFault fault -> Transition (st {rtLastFault = Just fault}) []
+
+reduceCommand :: RuntimeState -> UserCommand -> Transition
+reduceCommand st cmd = case cmd of
+ CmdFocusNext ->
+ let st' = st {rtWindowSet = focusUp (rtWindowSet st)}
+ in Transition st' (relayoutRequests st')
+ CmdFocusPrev ->
+ let st' = st {rtWindowSet = focusDown (rtWindowSet st)}
+ in Transition st' (relayoutRequests st')
+ CmdSwapNext ->
+ let st' = st {rtWindowSet = swapUp (rtWindowSet st)}
+ in Transition st' (relayoutRequests st')
+ CmdSwapPrev ->
+ let st' = st {rtWindowSet = swapDown (rtWindowSet st)}
+ in Transition st' (relayoutRequests st')
+ CmdKillFocused -> case peek (rtWindowSet st) of
+ Nothing -> Transition st []
+ Just vid -> Transition st [ReqCloseView vid, ReqCommit]
+ CmdViewWorkspace wid ->
+ let st' = st {rtWindowSet = view wid (rtWindowSet st)}
+ in Transition st' (relayoutRequests st')
+ CmdMoveFocusedTo wid ->
+ let st' = st {rtWindowSet = shift wid (rtWindowSet st)}
+ in Transition st' (relayoutRequests st')
+ CmdToggleFullscreen -> toggleCurrentWorkspaceFullscreen st
+ CmdCycleLayout -> applyCurrentLayoutMessage (MsgChangeLayout NextLayout) st
+ CmdShrink -> applyCurrentLayoutMessage (MsgResize Shrink) st
+ CmdExpand -> applyCurrentLayoutMessage (MsgResize Expand) st
+ CmdIncMasterN delta -> applyCurrentLayoutMessage (MsgIncMasterN (IncMasterN delta)) st
+ CmdExitSession -> Transition st [ReqExitSession]
+
+applyCurrentLayoutMessage :: LayoutMessage -> RuntimeState -> Transition
+applyCurrentLayoutMessage message st =
+ let ws' =
+ modifyCurrentWorkspace
+ ( \workspace ->
+ let oldLayout = workspaceLayout workspace
+ newLayout = applyLayoutMessage message oldLayout
+ restoreLayout =
+ if description oldLayout == "Full" && description newLayout /= "Full"
+ then Nothing
+ else workspaceRestoreLayout workspace
+ in workspace
+ { workspaceLayout = newLayout
+ , workspaceRestoreLayout = restoreLayout
+ }
+ )
+ (rtWindowSet st)
+ st' = st {rtWindowSet = ws'}
+ in Transition st' (relayoutRequests st')
+
+relayoutRequests :: RuntimeState -> [BackendReq]
+relayoutRequests st = map mkShow placementPairs ++ styleRequests ++ hideRequests ++ focusRequest ++ [ReqCommit]
+ where
+ currentScreen = current (rtWindowSet st)
+ currentWorkspace = screenWorkspace currentScreen
+ placements = layoutViews (workspaceLayout currentWorkspace) (screenRect currentScreen) (workspaceStack currentWorkspace)
+ placementPairs = focusFirst focusedView placements
+ active = map fst placementPairs
+ hideRequests = [ReqHideView vid | vid <- M.keys (rtViews st), vid `notElem` active]
+ focusRequest = case focusedView of
+ Nothing -> [ReqFocusView Nothing]
+ Just vid -> [ReqFocusView (Just vid)]
+ styleRequests = map mkStyle active
+ focusedView = peek (rtWindowSet st)
+ theme = rtTheme st
+
+ mkShow (vid, rect) = ReqSetViewRect vid rect
+ mkStyle vid =
+ ReqSetViewStyle
+ vid
+ ViewStyle
+ { viewStyleTitleBarMode = themeTitleBarMode theme
+ , viewStyleBorderWidth = themeBorderWidth theme
+ , viewStyleBorderColor = if Just vid == focusedView then themeFocusedBorderColor theme else themeNormalBorderColor theme
+ }
+
+toggleCurrentWorkspaceFullscreen :: RuntimeState -> Transition
+toggleCurrentWorkspaceFullscreen st =
+ let ws' =
+ modifyCurrentWorkspace
+ ( \workspace ->
+ let currentLayout = workspaceLayout workspace
+ in if description currentLayout == "Full"
+ then
+ workspace
+ { workspaceLayout = fromMaybe currentLayout (workspaceRestoreLayout workspace)
+ , workspaceRestoreLayout = Nothing
+ }
+ else
+ workspace
+ { workspaceLayout = applyLayoutMessage (MsgJumpToLayout "Full") currentLayout
+ , workspaceRestoreLayout = Just currentLayout
+ }
+ )
+ (rtWindowSet st)
+ st' = st {rtWindowSet = ws'}
+ in Transition st' (relayoutRequests st')
+
+focusFirst :: (Eq a) => Maybe a -> [(a, b)] -> [(a, b)]
+focusFirst Nothing xs = xs
+focusFirst (Just focused) xs = focusedPairs ++ otherPairs
+ where
+ (focusedPairs, otherPairs) = partition ((== focused) . fst) xs
diff --git a/src/YMonad/Core/StackSet.hs b/src/YMonad/Core/StackSet.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/Core/StackSet.hs
@@ -0,0 +1,230 @@
+module YMonad.Core.StackSet (
+ Stack (..),
+ Workspace (..),
+ Screen (..),
+ WindowSet (..),
+ emptyWorkspace,
+ singleton,
+ view,
+ shift,
+ focusWindow,
+ insertUp,
+ delete,
+ focusUp,
+ focusDown,
+ swapUp,
+ swapDown,
+ peek,
+ integrate,
+ allWindows,
+ modifyCurrentWorkspace,
+) where
+
+import Brolude (until)
+import Data.Map.Strict qualified as M
+import YMonad.Core.Common (Rect)
+
+data Stack a = Stack
+ { stackFocus :: a
+ , stackUp :: [a]
+ , stackDown :: [a]
+ }
+ deriving stock (Eq, Ord, Show)
+
+data Workspace i l a = Workspace
+ { workspaceId :: i
+ , workspaceLayout :: l
+ , workspaceStack :: Maybe (Stack a)
+ , workspaceRestoreLayout :: Maybe l
+ }
+ deriving stock (Eq, Ord, Show)
+
+data Screen sid i l a = Screen
+ { screenWorkspace :: Workspace i l a
+ , screenId :: sid
+ , screenRect :: Rect
+ }
+ deriving stock (Eq, Ord, Show)
+
+data WindowSet sid i l a = WindowSet
+ { current :: Screen sid i l a
+ , visible :: [Screen sid i l a]
+ , hidden :: [Workspace i l a]
+ , floating :: M.Map a Rect
+ }
+ deriving stock (Eq, Ord, Show)
+
+emptyWorkspace :: i -> l -> Workspace i l a
+emptyWorkspace wid lay =
+ Workspace
+ { workspaceId = wid
+ , workspaceLayout = lay
+ , workspaceStack = Nothing
+ , workspaceRestoreLayout = Nothing
+ }
+
+singleton :: Screen sid i l a -> [Workspace i l a] -> WindowSet sid i l a
+singleton scr hs =
+ WindowSet
+ { current = scr
+ , visible = []
+ , hidden = hs
+ , floating = M.empty
+ }
+
+modifyCurrentWorkspace :: (Workspace i l a -> Workspace i l a) -> WindowSet sid i l a -> WindowSet sid i l a
+modifyCurrentWorkspace f ws = ws {current = (current ws) {screenWorkspace = f (screenWorkspace (current ws))}}
+
+withCurrentStack :: b -> (Stack a -> b) -> WindowSet sid i l a -> b
+withCurrentStack dflt f = maybe dflt f . workspaceStack . screenWorkspace . current
+
+modifyZ :: Maybe (Stack a) -> (Stack a -> Maybe (Stack a)) -> WindowSet sid i l a -> WindowSet sid i l a
+modifyZ dflt f ws =
+ ws
+ { current =
+ (current ws)
+ { screenWorkspace =
+ (screenWorkspace (current ws))
+ { workspaceStack = withCurrentStack dflt f ws
+ }
+ }
+ }
+
+modifyZ' :: (Stack a -> Stack a) -> WindowSet sid i l a -> WindowSet sid i l a
+modifyZ' f = modifyZ Nothing (Just . f)
+
+peek :: WindowSet sid i l a -> Maybe a
+peek = withCurrentStack Nothing (Just . stackFocus)
+
+integrate :: Stack a -> [a]
+integrate st = reverse (stackUp st) ++ stackFocus st : stackDown st
+
+allWindows :: WindowSet sid i l a -> [a]
+allWindows ws = concatMap workspaceWindows (workspaces ws)
+ where
+ workspaceWindows wk = maybe [] integrate (workspaceStack wk)
+
+workspaces :: WindowSet sid i l a -> [Workspace i l a]
+workspaces ws = screenWorkspace (current ws) : map screenWorkspace (visible ws) ++ hidden ws
+
+member :: (Eq a) => a -> WindowSet sid i l a -> Bool
+member win ws = win `elem` allWindows ws
+
+workspaceMember :: (Eq i) => i -> WindowSet sid i l a -> Bool
+workspaceMember wid ws = wid `elem` map workspaceId (workspaces ws)
+
+findWorkspaceIdOfWindow :: (Eq a) => a -> WindowSet sid i l a -> Maybe i
+findWorkspaceIdOfWindow win ws = workspaceId <$> find containsWindow (workspaces ws)
+ where
+ containsWindow wk = maybe False (elem win . integrate) (workspaceStack wk)
+
+view :: (Eq i) => i -> WindowSet sid i l a -> WindowSet sid i l a
+view wid ws
+ | workspaceId (screenWorkspace (current ws)) == wid = ws
+ | otherwise =
+ case break ((== wid) . workspaceId . screenWorkspace) (visible ws) of
+ (before, target : after) ->
+ ws
+ { current = target
+ , visible = current ws : before ++ after
+ }
+ (_, []) ->
+ case break ((== wid) . workspaceId) (hidden ws) of
+ (before, target : after) ->
+ let oldCurrent = screenWorkspace (current ws)
+ in ws
+ { current = (current ws) {screenWorkspace = target}
+ , hidden = before ++ [oldCurrent] ++ after
+ }
+ (_, []) -> ws
+
+insertUp :: (Eq a) => a -> WindowSet sid i l a -> WindowSet sid i l a
+insertUp win ws
+ | member win ws = ws
+ | otherwise = modifyZ (Just (Stack win [] [])) (\(Stack focus up down) -> Just (Stack win up (focus : down))) ws
+
+focusWindow :: (Eq a, Eq i) => a -> WindowSet sid i l a -> WindowSet sid i l a
+focusWindow win ws
+ | Just win == peek ws = ws
+ | otherwise =
+ fromMaybe ws $ do
+ wid <- findWorkspaceIdOfWindow win ws
+ pure $ until ((Just win ==) . peek) focusUp (view wid ws)
+
+focusUp :: WindowSet sid i l a -> WindowSet sid i l a
+focusUp = modifyZ' focusUpStack
+
+focusDown :: WindowSet sid i l a -> WindowSet sid i l a
+focusDown = modifyZ' focusDownStack
+
+swapUp :: WindowSet sid i l a -> WindowSet sid i l a
+swapUp = modifyZ' swapUpStack
+
+swapDown :: WindowSet sid i l a -> WindowSet sid i l a
+swapDown = modifyZ' swapDownStack
+
+delete :: (Ord a) => a -> WindowSet sid i l a -> WindowSet sid i l a
+delete win = sink win . delete' win
+
+delete' :: (Eq a) => a -> WindowSet sid i l a -> WindowSet sid i l a
+delete' win ws =
+ ws
+ { current = removeFromScreen (current ws)
+ , visible = map removeFromScreen (visible ws)
+ , hidden = map removeFromWorkspace (hidden ws)
+ }
+ where
+ removeFromWorkspace wk = wk {workspaceStack = workspaceStack wk >>= filterStack (/= win)}
+ removeFromScreen scr = scr {screenWorkspace = removeFromWorkspace (screenWorkspace scr)}
+
+sink :: (Ord a) => a -> WindowSet sid i l a -> WindowSet sid i l a
+sink win ws = ws {floating = M.delete win (floating ws)}
+
+filterStack :: (a -> Bool) -> Stack a -> Maybe (Stack a)
+filterStack p (Stack focus up down) =
+ case filter p (focus : down) of
+ focus' : down' -> Just (Stack focus' (filter p up) down')
+ [] ->
+ case filter p up of
+ focus' : up' -> Just (Stack focus' up' [])
+ [] -> Nothing
+
+focusUpStack :: Stack a -> Stack a
+focusUpStack st = case stackUp st of
+ up : ups -> Stack up ups (stackFocus st : stackDown st)
+ [] ->
+ case reverse (stackFocus st : stackDown st) of
+ [] -> st
+ focus : rest -> Stack focus rest []
+
+focusDownStack :: Stack a -> Stack a
+focusDownStack = reverseStack . focusUpStack . reverseStack
+
+swapUpStack :: Stack a -> Stack a
+swapUpStack st = case stackUp st of
+ up : ups -> Stack (stackFocus st) ups (up : stackDown st)
+ [] -> Stack (stackFocus st) (reverse (stackDown st)) []
+
+swapDownStack :: Stack a -> Stack a
+swapDownStack = reverseStack . swapUpStack . reverseStack
+
+reverseStack :: Stack a -> Stack a
+reverseStack st = Stack (stackFocus st) (stackDown st) (stackUp st)
+
+shift :: (Eq a, Eq i) => i -> WindowSet sid i l a -> WindowSet sid i l a
+shift wid ws = case peek ws of
+ Nothing -> ws
+ Just win -> shiftWin wid win ws
+
+shiftWin :: (Eq a, Eq i) => i -> a -> WindowSet sid i l a -> WindowSet sid i l a
+shiftWin wid win ws = case findWorkspaceIdOfWindow win ws of
+ Just from
+ | workspaceMember wid ws && wid /= from -> move from ws
+ _ -> ws
+ where
+ move from = onWorkspace wid (insertUp win) . onWorkspace from (delete' win)
+
+onWorkspace :: (Eq i) => i -> (WindowSet sid i l a -> WindowSet sid i l a) -> WindowSet sid i l a -> WindowSet sid i l a
+onWorkspace wid f ws = view currentWid (f (view wid ws))
+ where
+ currentWid = workspaceId (screenWorkspace (current ws))
diff --git a/src/YMonad/Core/Types.hs b/src/YMonad/Core/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/Core/Types.hs
@@ -0,0 +1,146 @@
+module YMonad.Core.Types (
+ ViewMeta (..),
+ OutputInfo (..),
+ ViewStyle (..),
+ RuntimeTheme (..),
+ UserCommand (..),
+ BackendFault (..),
+ YEvent (..),
+ BackendReq (..),
+ RuntimeState (..),
+ Transition (..),
+ defaultRuntimeState,
+ defaultRuntimeStateWithWorkspaces,
+) where
+
+import Data.Map.Strict qualified as M
+import Data.Text qualified as T
+
+import YMonad.Core.Common
+import YMonad.Core.Layout (Layout, full, mirror, tall, (|||))
+import YMonad.Core.StackSet
+
+data ViewMeta = ViewMeta
+ { viewTitle :: Text
+ , viewAppId :: Text
+ , viewIsFloating :: Bool
+ }
+ deriving stock (Eq, Ord, Show)
+
+data OutputInfo = OutputInfo
+ { outputName :: Text
+ , outputRect :: Rect
+ }
+ deriving stock (Eq, Ord, Show)
+
+data ViewStyle = ViewStyle
+ { viewStyleTitleBarMode :: TitleBarMode
+ , viewStyleBorderWidth :: Dimension
+ , viewStyleBorderColor :: RgbaColor
+ }
+ deriving stock (Eq, Ord, Show)
+
+data RuntimeTheme = RuntimeTheme
+ { themeBorderWidth :: Dimension
+ , themeNormalBorderColor :: RgbaColor
+ , themeFocusedBorderColor :: RgbaColor
+ , themeTitleBarMode :: TitleBarMode
+ }
+ deriving stock (Eq, Ord, Show)
+
+data UserCommand
+ = CmdFocusNext
+ | CmdFocusPrev
+ | CmdSwapNext
+ | CmdSwapPrev
+ | CmdKillFocused
+ | CmdViewWorkspace WorkspaceId
+ | CmdMoveFocusedTo WorkspaceId
+ | CmdToggleFullscreen
+ | CmdCycleLayout
+ | CmdShrink
+ | CmdExpand
+ | CmdIncMasterN Int
+ | CmdExitSession
+ deriving stock (Eq, Ord, Show, Read)
+
+newtype BackendFault = BackendFault
+ { faultMessage :: Text
+ }
+ deriving stock (Eq, Ord, Show)
+
+data YEvent
+ = EvViewMapped ViewId ViewMeta
+ | EvViewUnmapped ViewId
+ | EvOutputAdded OutputId OutputInfo
+ | EvOutputRemoved OutputId
+ | EvFocusChanged (Maybe ViewId)
+ | EvUserCommand UserCommand
+ | EvBackendFault BackendFault
+ deriving stock (Eq, Ord, Show)
+
+data BackendReq
+ = ReqShowView ViewId
+ | ReqHideView ViewId
+ | ReqSetViewRect ViewId Rect
+ | ReqSetViewStyle ViewId ViewStyle
+ | ReqFocusView (Maybe ViewId)
+ | ReqCloseView ViewId
+ | ReqExitSession
+ | ReqCommit
+ deriving stock (Eq, Ord, Show)
+
+data RuntimeState = RuntimeState
+ { rtWindowSet :: WindowSet ScreenId WorkspaceId Layout ViewId
+ , rtViews :: Map ViewId ViewMeta
+ , rtOutputs :: Map OutputId OutputInfo
+ , rtTheme :: RuntimeTheme
+ , rtLastFault :: Maybe BackendFault
+ }
+ deriving stock (Eq, Show)
+
+data Transition = Transition
+ { trState :: RuntimeState
+ , trRequests :: [BackendReq]
+ }
+ deriving stock (Eq, Show)
+
+defaultRuntimeState :: Rect -> RuntimeState
+defaultRuntimeState rect =
+ defaultRuntimeStateWithWorkspaces rect workspaceIds
+ where
+ workspaceIds :: NonEmpty WorkspaceId
+ workspaceIds = WorkspaceId (T.pack "1") :| map (WorkspaceId . show) [(2 :: Int) .. 9]
+
+defaultRuntimeStateWithWorkspaces :: Rect -> NonEmpty WorkspaceId -> RuntimeState
+defaultRuntimeStateWithWorkspaces rect workspaceIds =
+ RuntimeState
+ { rtWindowSet = singleton screen hiddenWorkspaces
+ , rtViews = M.empty
+ , rtOutputs = M.empty
+ , rtTheme = defaultRuntimeTheme
+ , rtLastFault = Nothing
+ }
+ where
+ workspaceFor wid = emptyWorkspace wid (tall ||| mirror tall ||| full)
+
+ currentWorkspace = workspaceFor currentWorkspaceId
+ hiddenWorkspaces = map workspaceFor hiddenWorkspaceIds
+
+ currentWorkspaceId :| hiddenWorkspaceIds = workspaceIds
+
+ screen =
+ Screen
+ { screenWorkspace = currentWorkspace
+ , screenId = ScreenId 0
+ , screenRect = rect
+ }
+
+defaultRuntimeTheme :: RuntimeTheme
+defaultRuntimeTheme =
+ RuntimeTheme
+ { themeBorderWidth = 1
+ , themeNormalBorderColor = opaqueRgb8 0xdd 0xdd 0xdd
+ , themeFocusedBorderColor = opaqueRgb8 0xff 0x00 0x00
+ , themeTitleBarMode = NoTitleBar
+ }
diff --git a/src/YMonad/Keys.hs b/src/YMonad/Keys.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/Keys.hs
@@ -0,0 +1,127 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module YMonad.Keys (
+ KeyMask (..),
+ KeySym (..),
+ noModMask,
+ shiftMask,
+ controlMask,
+ mod1Mask,
+ mod3Mask,
+ mod4Mask,
+ mod5Mask,
+ xK_Return,
+ xK_return,
+ xK_Tab,
+ xK_ISO_Left_Tab,
+ xK_space,
+ xK_j,
+ xK_k,
+ xK_h,
+ xK_l,
+ xK_c,
+ xK_p,
+ xK_s,
+ xK_q,
+ xK_F1,
+ xK_comma,
+ xK_period,
+ xK_1,
+ xK_2,
+ xK_3,
+ xK_4,
+ xK_5,
+ xK_6,
+ xK_7,
+ xK_8,
+ xK_9,
+ renderKeyMask,
+ renderKeySym,
+ keySymToXkb,
+) where
+
+import Data.Bits (Bits, FiniteBits, (.&.))
+import Data.Text qualified as T
+
+newtype KeyMask = KeyMask
+ { unKeyMask :: Word32
+ }
+ deriving stock (Eq, Ord, Show)
+ deriving newtype (Bits, FiniteBits, Num)
+
+newtype KeySym = KeySym
+ { unKeySym :: Text
+ }
+ deriving stock (Eq, Ord, Show)
+
+noModMask, shiftMask, controlMask, mod1Mask, mod3Mask, mod4Mask, mod5Mask :: KeyMask
+noModMask = KeyMask 0
+shiftMask = KeyMask 1
+controlMask = KeyMask 4
+mod1Mask = KeyMask 8
+mod3Mask = KeyMask 32
+mod4Mask = KeyMask 64
+mod5Mask = KeyMask 128
+
+xK_Return, xK_return, xK_Tab, xK_ISO_Left_Tab, xK_space, xK_j, xK_k, xK_h, xK_l, xK_c, xK_p, xK_s, xK_q, xK_comma, xK_period, xK_F1 :: KeySym
+xK_Return = KeySym "Return"
+xK_return = xK_Return
+xK_Tab = KeySym "Tab"
+xK_ISO_Left_Tab = KeySym "ISO_Left_Tab"
+xK_space = KeySym "space"
+xK_j = KeySym "j"
+xK_k = KeySym "k"
+xK_h = KeySym "h"
+xK_l = KeySym "l"
+xK_c = KeySym "c"
+xK_p = KeySym "p"
+xK_s = KeySym "s"
+xK_q = KeySym "q"
+xK_F1 = KeySym "F1"
+xK_comma = KeySym "comma"
+xK_period = KeySym "period"
+
+xK_1, xK_2, xK_3, xK_4, xK_5, xK_6, xK_7, xK_8, xK_9 :: KeySym
+xK_1 = KeySym "1"
+xK_2 = KeySym "2"
+xK_3 = KeySym "3"
+xK_4 = KeySym "4"
+xK_5 = KeySym "5"
+xK_6 = KeySym "6"
+xK_7 = KeySym "7"
+xK_8 = KeySym "8"
+xK_9 = KeySym "9"
+
+renderKeyMask :: KeyMask -> Text
+renderKeyMask mask
+ | unKeyMask mask == 0 = "None"
+ | otherwise = T.intercalate "+" (map snd (filter fst parts))
+ where
+ includes wanted = (unKeyMask mask .&. unKeyMask wanted) /= 0
+ parts =
+ [ (includes shiftMask, "Shift")
+ , (includes controlMask, "Control")
+ , (includes mod1Mask, "Mod1")
+ , (includes mod3Mask, "Mod3")
+ , (includes mod4Mask, "Mod4")
+ , (includes mod5Mask, "Mod5")
+ ]
+
+renderKeySym :: KeySym -> Text
+renderKeySym = unKeySym
+
+keySymToXkb :: KeySym -> Maybe Word32
+keySymToXkb (KeySym sym) =
+ case sym of
+ "Return" -> Just 0xFF0D
+ "Escape" -> Just 0xFF1B
+ "Tab" -> Just 0xFF09
+ "ISO_Left_Tab" -> Just 0xFE20
+ "space" -> Just 0x0020
+ "comma" -> Just 0x002C
+ "period" -> Just 0x002E
+ "F1" -> Just 0xFFBE
+ _ ->
+ case toString sym of
+ [ch] -> Just (fromIntegral (ord ch))
+ _ -> Nothing
diff --git a/src/YMonad/Launcher.hs b/src/YMonad/Launcher.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/Launcher.hs
@@ -0,0 +1,134 @@
+module YMonad.Launcher (
+ launcherMain,
+) where
+
+import Data.Time.Clock (UTCTime)
+import System.Directory
+import System.Environment (getEnvironment, getExecutablePath)
+import System.Exit (ExitCode (..))
+import System.FilePath (takeDirectory, ())
+import System.Process
+
+import YMonad
+
+launcherMain :: IO ()
+launcherMain = do
+ configPath <- getConfigPath
+ configExists <- doesFileExist configPath
+ if not configExists
+ then ymonad def
+ else do
+ cacheDir <- getCacheDirectory
+ createDirectoryIfMissing True cacheDir
+ let buildDir = cacheDir "build"
+ binaryPath = cacheDir "ymonad-config"
+ errorPath = cacheDir "ymonad.errors"
+ forceRebuild <- fmap isJust (lookupEnv "YMONAD_FORCE_REBUILD")
+ shouldBuild <- if forceRebuild then pure True else shouldRebuildConfig configPath binaryPath
+ when shouldBuild $ recompileConfig configPath buildDir binaryPath errorPath
+ launchCompiledConfig binaryPath
+
+getConfigPath :: IO FilePath
+getConfigPath = do
+ explicit <- lookupEnv "YMONAD_CONFIG"
+ case explicit of
+ Just path -> pure path
+ Nothing -> do
+ configHome <- lookupEnv "XDG_CONFIG_HOME"
+ case configHome of
+ Just dir -> pure (dir "ymonad" "ymonad.hs")
+ Nothing -> do
+ homeDir <- getHomeDirectory
+ pure (homeDir ".config" "ymonad" "ymonad.hs")
+
+getCacheDirectory :: IO FilePath
+getCacheDirectory = do
+ cacheHome <- lookupEnv "XDG_CACHE_HOME"
+ case cacheHome of
+ Just dir -> pure (dir "ymonad")
+ Nothing -> do
+ homeDir <- getHomeDirectory
+ pure (homeDir ".cache" "ymonad")
+
+shouldRebuildConfig :: FilePath -> FilePath -> IO Bool
+shouldRebuildConfig configPath binaryPath = do
+ binaryExists <- doesFileExist binaryPath
+ if not binaryExists
+ then pure True
+ else do
+ configTime <- getModificationTime configPath
+ binaryTime <- getModificationTime binaryPath
+ libTime <- newestLibraryTimestamp (takeDirectory configPath "lib")
+ pure (configTime > binaryTime || maybe False (> binaryTime) libTime)
+
+newestLibraryTimestamp :: FilePath -> IO (Maybe UTCTime)
+newestLibraryTimestamp root = do
+ exists <- doesDirectoryExist root
+ if not exists
+ then pure Nothing
+ else do
+ files <- listFilesRecursive root
+ case files of
+ [] -> pure Nothing
+ firstFile : otherFiles -> do
+ firstTime <- getModificationTime firstFile
+ otherTimes <- mapM getModificationTime otherFiles
+ pure (Just (foldl' max firstTime otherTimes))
+
+listFilesRecursive :: FilePath -> IO [FilePath]
+listFilesRecursive root = do
+ names <- listDirectory root
+ fmap concat . forM names $ \name -> do
+ let path = root name
+ isDir <- doesDirectoryExist path
+ if isDir
+ then listFilesRecursive path
+ else pure [path]
+
+recompileConfig :: FilePath -> FilePath -> FilePath -> FilePath -> IO ()
+recompileConfig configPath buildDir binaryPath errorPath = do
+ createDirectoryIfMissing True buildDir
+ ghcPath <- getCompilerPath
+ let configDir = takeDirectory configPath
+ libDir = configDir "lib"
+ ghcArgs =
+ [ "--make"
+ , configPath
+ , "-outputdir"
+ , buildDir
+ , "-o"
+ , binaryPath
+ , "-i" <> configDir
+ , "-i" <> libDir
+ , "-package"
+ , "YMonad"
+ ]
+ (exitCode, stdoutText, stderrText) <- readProcessWithExitCode ghcPath ghcArgs ""
+ let buildLog = stdoutText <> stderrText
+ writeFile errorPath buildLog
+ case exitCode of
+ ExitSuccess -> pass
+ ExitFailure exitCodeValue -> die ("Failed to compile " <> configPath <> " (exit code " <> show exitCodeValue <> "). See " <> errorPath)
+
+getCompilerPath :: IO FilePath
+getCompilerPath = do
+ envPath <- lookupEnv "YMONAD_GHC"
+ case envPath of
+ Just path -> pure path
+ Nothing -> do
+ found <- findExecutable "ghc"
+ case found of
+ Just path -> pure path
+ Nothing -> die "ghc was not found in PATH; set YMONAD_GHC or install ghc"
+
+launchCompiledConfig :: FilePath -> IO ()
+launchCompiledConfig binaryPath = do
+ launcherPath <- getExecutablePath
+ env0 <- getEnvironment
+ let helperPath = takeDirectory launcherPath "ymonadctl"
+ env1 =
+ ("YMONAD_CTL_PATH", helperPath)
+ : ("YMONAD_LAUNCHER_PATH", launcherPath)
+ : filter (\(name, _value) -> name /= "YMONAD_CTL_PATH" && name /= "YMONAD_LAUNCHER_PATH") env0
+ (_, _, _, ph) <- createProcess ((proc binaryPath []) {env = Just env1})
+ waitForProcess ph >>= exitWith
diff --git a/src/YMonad/Layout.hs b/src/YMonad/Layout.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/Layout.hs
@@ -0,0 +1,5 @@
+module YMonad.Layout (
+ module YMonad.Core.Layout,
+) where
+
+import YMonad.Core.Layout
diff --git a/src/YMonad/Prompt.hs b/src/YMonad/Prompt.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/Prompt.hs
@@ -0,0 +1,23 @@
+module YMonad.Prompt (
+ YPConfig (..),
+ defaultYPConfig,
+) where
+
+data YPConfig = YPConfig
+ { promptProgram :: Maybe FilePath
+ , promptProgramArgs :: [String]
+ , promptCaseSensitive :: Bool
+ , promptListLines :: Maybe Int
+ , promptTerminal :: Maybe String
+ }
+ deriving stock (Eq, Ord, Show)
+
+defaultYPConfig :: YPConfig
+defaultYPConfig =
+ YPConfig
+ { promptProgram = Nothing
+ , promptProgramArgs = []
+ , promptCaseSensitive = True
+ , promptListLines = Nothing
+ , promptTerminal = Nothing
+ }
diff --git a/src/YMonad/Prompt/Internal.hs b/src/YMonad/Prompt/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/Prompt/Internal.hs
@@ -0,0 +1,232 @@
+module YMonad.Prompt.Internal (
+ choosePrompt,
+ getCommands,
+ getSshHosts,
+ getMans,
+ getCommandOutput,
+ runInConfiguredTerminal,
+ split,
+) where
+
+import Control.Concurrent (forkIO)
+import Data.Char (isDigit, isSpace)
+import Data.List (dropWhileEnd)
+import Data.String qualified as String
+import System.Directory (doesDirectoryExist, doesFileExist, executable, findExecutable, getDirectoryContents, getHomeDirectory, getPermissions, listDirectory)
+import System.Exit (ExitCode (..))
+import System.FilePath (dropExtensions, takeFileName, ())
+import System.IO qualified as SIO
+import System.IO.Error (catchIOError)
+import System.Process (createProcess, proc, readCreateProcessWithExitCode, shell, waitForProcess)
+
+import YMonad.Config (YConfig (..))
+import YMonad.Prompt (YPConfig (..))
+
+choosePrompt :: YPConfig -> String -> [String] -> IO (Maybe String)
+choosePrompt xpConfig promptLabel rawChoices = do
+ resolved <- resolvePromptProgram xpConfig promptLabel
+ case resolved of
+ Nothing -> pure Nothing
+ Just (programPath, args) -> do
+ let choices = ordNub rawChoices
+ stdinPayload = if null choices then "\n" else String.unlines choices
+ (exitCode, stdoutText, _stderrText) <- readCreateProcessWithExitCode (proc programPath args) stdinPayload
+ case exitCode of
+ ExitSuccess -> pure (nonEmptySelection stdoutText)
+ ExitFailure _ -> pure Nothing
+
+getCommands :: IO [String]
+getCommands = do
+ pathValue <- fromMaybe "" <$> lookupEnv "PATH"
+ let directories = filter (not . null) (split ':' pathValue)
+ (fmap (ordNub . concat) . forM directories) $ \dir -> do
+ exists <- doesDirectoryExist dir
+ if not exists
+ then pure []
+ else do
+ names <- catchIOError (listDirectory dir) (const (pure []))
+ filterM (isExecutableFile . (dir )) names
+
+getSshHosts :: IO [String]
+getSshHosts = do
+ localHosts <- getLocalSshHosts
+ globalHosts <- getGlobalSshHosts
+ pure (ordNub (localHosts ++ globalHosts))
+
+getMans :: IO [String]
+getMans = do
+ pathsText <- do
+ p1 <- getCommandOutput "manpath -g 2>/dev/null"
+ p2 <- getCommandOutput "manpath 2>/dev/null"
+ pure (intercalate ":" (String.lines (p1 ++ p2)))
+ let sections = ["man" <> show n | n <- [(1 :: Int) .. 9]]
+ directories = [baseDir section | baseDir <- split ':' pathsText, not (null baseDir), section <- sections]
+ nested <- forM (ordNub directories) $ \dir -> do
+ exists <- doesDirectoryExist dir
+ if exists
+ then map dropExtensions <$> getDirectoryContents dir
+ else pure []
+ pure (filter validEntry (ordNub (concat nested)))
+
+getCommandOutput :: String -> IO String
+getCommandOutput cmd = do
+ (exitCode, stdoutText, _stderrText) <- readCreateProcessWithExitCode (shell cmd) ""
+ pure $ case exitCode of
+ ExitSuccess -> stdoutText
+ ExitFailure _ -> ""
+
+runInConfiguredTerminal :: YConfig -> YPConfig -> String -> IO ()
+runInConfiguredTerminal yConfig xpConfig commandText = do
+ let terminalCommand = fromMaybe (terminal yConfig) (promptTerminal xpConfig)
+ fullCommand = terminalCommand <> " -e sh -lc " <> shellQuote commandText
+ (_, _, _, processHandle) <- createProcess (shell fullCommand)
+ void (forkIO (void (waitForProcess processHandle)))
+
+resolvePromptProgram :: YPConfig -> String -> IO (Maybe (FilePath, [String]))
+resolvePromptProgram xpConfig promptLabel = do
+ resolvedProgram <- case promptProgram xpConfig of
+ Just explicit -> pure (Just explicit)
+ Nothing -> firstJustM findExecutable ["wmenu", "bemenu", "fuzzel", "tofi", "rofi", "dmenu"]
+ pure $ fmap (\programPath -> (programPath, promptArgs (takeFileName programPath) xpConfig promptLabel)) resolvedProgram
+
+promptArgs :: FilePath -> YPConfig -> String -> [String]
+promptArgs programName xpConfig promptLabel =
+ case programName of
+ "wmenu" -> promptProgramArgs xpConfig ++ ignoreCaseArg ++ listLinesArg ++ ["-p", promptLabel]
+ "bemenu" -> promptProgramArgs xpConfig ++ ignoreCaseArg ++ ["-p", promptLabel]
+ "fuzzel" -> promptProgramArgs xpConfig ++ ["--dmenu", "--prompt", promptLabel]
+ "tofi" -> promptProgramArgs xpConfig ++ ["--prompt-text", promptLabel]
+ "rofi" -> promptProgramArgs xpConfig ++ ["-dmenu", "-p", promptLabel] ++ ignoreCaseArg
+ _ -> promptProgramArgs xpConfig ++ ["-p", promptLabel] ++ ignoreCaseArg
+ where
+ ignoreCaseArg = ["-i" | not (promptCaseSensitive xpConfig) && programName `elem` ["wmenu", "bemenu", "rofi", "dmenu"]]
+ listLinesArg = maybe [] (\lineCount -> ["-l", show lineCount]) (promptListLines xpConfig)
+
+nonEmptySelection :: String -> Maybe String
+nonEmptySelection output =
+ let stripped = strip output
+ in if null stripped then Nothing else Just stripped
+
+{-
+ordNub :: (Ord a) => [a] -> [a]
+ordNub = go S.empty
+ where
+ go _seen [] = []
+ go seen (x : xs)
+ | S.member x seen = go seen xs
+ | otherwise = x : go (S.insert x seen) xs
+-}
+
+split :: (Eq a) => a -> [a] -> [[a]]
+split delimiter = go
+ where
+ go [] = [[]]
+ go (x : xs)
+ | x == delimiter = [] : go xs
+ | otherwise =
+ case go xs of
+ [] -> [[x]]
+ (segment : segments) -> (x : segment) : segments
+
+strip :: String -> String
+strip = dropWhileEnd isSpace . dropWhile isSpace
+
+shellQuote :: String -> String
+shellQuote value = "'" <> concatMap escapeChar value <> "'"
+ where
+ escapeChar '\'' = "'\\''"
+ escapeChar ch = [ch]
+
+validEntry :: String -> Bool
+validEntry entry =
+ not (null entry)
+ && entry /= "."
+ && entry /= ".."
+
+isExecutableFile :: FilePath -> IO Bool
+isExecutableFile path = do
+ exists <- doesFileExist path
+ if not exists
+ then pure False
+ else do
+ permissions <- getPermissions path
+ pure (executable permissions)
+
+getLocalSshHosts :: IO [String]
+getLocalSshHosts = do
+ homeDir <- getHomeDirectory
+ knownHosts <- sshHostsFromKnownHosts (homeDir ".ssh" "known_hosts")
+ configHosts <- sshHostsFromConfig (homeDir ".ssh" "config")
+ pure (knownHosts ++ configHosts)
+
+getGlobalSshHosts :: IO [String]
+getGlobalSshHosts = do
+ envKnownHosts <- lookupEnv "SSH_KNOWN_HOSTS"
+ let candidates = maybeToList envKnownHosts ++ ["/usr/local/etc/ssh/ssh_known_hosts", "/usr/local/etc/ssh_known_hosts", "/etc/ssh/ssh_known_hosts", "/etc/ssh_known_hosts"]
+ existing <- filterM doesFileExist candidates
+ case existing of
+ [] -> pure []
+ firstKnownHosts : _rest -> sshHostsFromKnownHosts firstKnownHosts
+
+sshHostsFromKnownHosts :: FilePath -> IO [String]
+sshHostsFromKnownHosts path = do
+ exists <- doesFileExist path
+ if not exists
+ then pure []
+ else do
+ contents <- catchIOError (SIO.readFile path) (const (pure ""))
+ pure
+ [ getWithPort host
+ | line <- String.lines contents
+ , nonComment line
+ , firstField <- take 1 (String.words line)
+ , host <- split ',' firstField
+ , not (null host)
+ , not ("|" `isPrefixOf` host)
+ ]
+
+sshHostsFromConfig :: FilePath -> IO [String]
+sshHostsFromConfig path = do
+ exists <- doesFileExist path
+ if not exists
+ then pure []
+ else do
+ contents <- catchIOError (SIO.readFile path) (const (pure ""))
+ pure
+ [ candidate
+ | ws <- map String.words (String.lines contents)
+ , isHostDirective ws
+ , candidate <- drop 1 ws
+ , isConcreteHost candidate
+ ]
+
+isHostDirective :: [String] -> Bool
+isHostDirective (directive : _values) = directive == "Host"
+isHostDirective _ = False
+
+isConcreteHost :: String -> Bool
+isConcreteHost value = not (null value) && not (any (`elem` ['*', '?']) value) && value /= "!"
+
+getWithPort :: String -> String
+getWithPort host =
+ case break (== ':') host of
+ (baseHost, []) -> baseHost
+ (baseHost, suffix) ->
+ case suffix of
+ ':' : portDigits | all isDigit portDigits -> baseHost
+ _other -> host
+
+nonComment :: String -> Bool
+nonComment line =
+ case dropWhile isSpace line of
+ [] -> False
+ ('#' : _) -> False
+ _ -> True
+
+firstJustM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m (Maybe b)
+firstJustM _ [] = pure Nothing
+firstJustM f (x : xs) = do
+ result <- f x
+ case result of
+ Just value -> pure (Just value)
+ Nothing -> firstJustM f xs
diff --git a/src/YMonad/Protocol/Wayland/Types.hs b/src/YMonad/Protocol/Wayland/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/Protocol/Wayland/Types.hs
@@ -0,0 +1,117 @@
+module YMonad.Protocol.Wayland.Types (
+ MessageRole (..),
+ ArgType (..),
+ ArgSpec (..),
+ MessageSpec (..),
+ InterfaceSpec (..),
+ ProtocolSpec (..),
+ ArgValue (..),
+ WireMessage (..),
+ RawFrame (..),
+ mkInterfaceSpec,
+ mergeProtocolSpecs,
+ lookupInterface,
+ lookupRequest,
+ lookupEventByOpcode,
+) where
+
+import Data.Map.Strict qualified as M
+
+data MessageRole
+ = MessageRequest
+ | MessageEvent
+ deriving stock (Eq, Ord, Show)
+
+data ArgType
+ = ArgInt
+ | ArgUint
+ | ArgString
+ | ArgObject (Maybe Text)
+ | ArgNewId (Maybe Text)
+ deriving stock (Eq, Ord, Show)
+
+data ArgSpec = ArgSpec
+ { argSpecName :: Text
+ , argSpecType :: ArgType
+ , argSpecAllowNull :: Bool
+ }
+ deriving stock (Eq, Ord, Show)
+
+data MessageSpec = MessageSpec
+ { messageSpecName :: Text
+ , messageSpecOpcode :: Word16
+ , messageSpecRole :: MessageRole
+ , messageSpecArgs :: [ArgSpec]
+ }
+ deriving stock (Eq, Ord, Show)
+
+data InterfaceSpec = InterfaceSpec
+ { interfaceName :: Text
+ , interfaceVersion :: Word32
+ , interfaceRequestsByName :: Map Text MessageSpec
+ , interfaceRequestsByOpcode :: Map Word16 MessageSpec
+ , interfaceEventsByName :: Map Text MessageSpec
+ , interfaceEventsByOpcode :: Map Word16 MessageSpec
+ }
+ deriving stock (Eq, Ord, Show)
+
+data ProtocolSpec = ProtocolSpec
+ { protocolName :: Text
+ , protocolInterfaces :: Map Text InterfaceSpec
+ }
+ deriving stock (Eq, Ord, Show)
+
+data ArgValue
+ = ArgIntValue Int32
+ | ArgUintValue Word32
+ | ArgStringValue (Maybe Text)
+ | ArgObjectValue (Maybe Word32)
+ | ArgNewIdValue Word32
+ deriving stock (Eq, Ord, Show)
+
+data WireMessage = WireMessage
+ { wireObjectId :: Word32
+ , wireInterface :: Text
+ , wireMessageName :: Text
+ , wireOpcode :: Word16
+ , wireArgs :: [ArgValue]
+ }
+ deriving stock (Eq, Ord, Show)
+
+data RawFrame = RawFrame
+ { rawObjectId :: Word32
+ , rawOpcode :: Word16
+ , rawPayload :: !ByteString
+ }
+ deriving stock (Eq, Ord, Show)
+
+mkInterfaceSpec :: Text -> Word32 -> [MessageSpec] -> [MessageSpec] -> InterfaceSpec
+mkInterfaceSpec name version requests events =
+ InterfaceSpec
+ { interfaceName = name
+ , interfaceVersion = version
+ , interfaceRequestsByName = M.fromList [(messageSpecName msg, msg) | msg <- requests]
+ , interfaceRequestsByOpcode = M.fromList [(messageSpecOpcode msg, msg) | msg <- requests]
+ , interfaceEventsByName = M.fromList [(messageSpecName msg, msg) | msg <- events]
+ , interfaceEventsByOpcode = M.fromList [(messageSpecOpcode msg, msg) | msg <- events]
+ }
+
+mergeProtocolSpecs :: ProtocolSpec -> ProtocolSpec -> ProtocolSpec
+mergeProtocolSpecs a b =
+ ProtocolSpec
+ { protocolName = protocolName a
+ , protocolInterfaces = M.union (protocolInterfaces a) (protocolInterfaces b)
+ }
+
+lookupInterface :: ProtocolSpec -> Text -> Maybe InterfaceSpec
+lookupInterface spec name = M.lookup name (protocolInterfaces spec)
+
+lookupRequest :: ProtocolSpec -> Text -> Text -> Maybe MessageSpec
+lookupRequest spec ifaceName msgName = do
+ iface <- lookupInterface spec ifaceName
+ M.lookup msgName (interfaceRequestsByName iface)
+
+lookupEventByOpcode :: ProtocolSpec -> Text -> Word16 -> Maybe MessageSpec
+lookupEventByOpcode spec ifaceName opcode = do
+ iface <- lookupInterface spec ifaceName
+ M.lookup opcode (interfaceEventsByOpcode iface)
diff --git a/src/YMonad/Protocol/Wayland/Wire.hs b/src/YMonad/Protocol/Wayland/Wire.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/Protocol/Wayland/Wire.hs
@@ -0,0 +1,117 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module YMonad.Protocol.Wayland.Wire (
+ encodeWireMessage,
+ encodeWireBatch,
+ decodeRawFrames,
+ decodeMessageArgs,
+) where
+
+import Data.Binary.Get
+import Data.Binary.Put
+import Data.Bits ((.&.))
+import Data.ByteString qualified as BS
+
+import YMonad.Protocol.Wayland.Types
+
+encodeWireMessage :: WireMessage -> BS.ByteString
+encodeWireMessage msg = toStrict $ runPut $ do
+ let payload = toStrict (runPut (mapM_ putArgValue (wireArgs msg)))
+ size = fromIntegral (8 + BS.length payload) :: Word16
+ putWord32le (wireObjectId msg)
+ putWord16le (wireOpcode msg)
+ putWord16le size
+ putByteString payload
+
+encodeWireBatch :: [WireMessage] -> BS.ByteString
+encodeWireBatch = BS.concat . map encodeWireMessage
+
+decodeRawFrames :: BS.ByteString -> Either String ([RawFrame], BS.ByteString)
+decodeRawFrames input = go input id
+ where
+ go bytes acc
+ | BS.length bytes < 8 = Right (acc [], bytes)
+ | otherwise =
+ let header = runGet getHeader (fromStrict (BS.take 8 bytes))
+ payloadLen = fromIntegral (frameSize header) - 8
+ in if frameSize header < 8
+ then Left "Wayland frame shorter than header"
+ else
+ if BS.length bytes < fromIntegral (frameSize header)
+ then Right (acc [], bytes)
+ else
+ let payload = BS.take payloadLen (BS.drop 8 bytes)
+ rest = BS.drop (fromIntegral (frameSize header)) bytes
+ frame = RawFrame (frameObjectId header) (frameOpcode header) payload
+ in go rest (acc . (frame :))
+
+ getHeader = do
+ objectId <- getWord32le
+ opcode <- getWord16le
+ Header objectId opcode <$> getWord16le
+
+decodeMessageArgs :: MessageSpec -> BS.ByteString -> Either String [ArgValue]
+decodeMessageArgs spec payload =
+ case runGetOrFail (mapM getArgValue (messageSpecArgs spec)) (fromStrict payload) of
+ Left (_, _, err) -> Left err
+ Right (_, _, args) -> Right args
+
+putArgValue :: ArgValue -> Put
+putArgValue arg = case arg of
+ ArgIntValue n -> putInt32le n
+ ArgUintValue n -> putWord32le n
+ ArgObjectValue Nothing -> putWord32le 0
+ ArgObjectValue (Just n) -> putWord32le n
+ ArgNewIdValue n -> putWord32le n
+ ArgStringValue Nothing -> putWord32le 0
+ ArgStringValue (Just txt) -> do
+ let bytes = encodeUtf8 txt
+ total = BS.length bytes + 1
+ putWord32le (fromIntegral total)
+ putByteString bytes
+ putWord8 0
+ putPadding total
+
+getArgValue :: ArgSpec -> Get ArgValue
+getArgValue spec = case argSpecType spec of
+ ArgInt -> ArgIntValue <$> getInt32le
+ ArgUint -> ArgUintValue <$> getWord32le
+ ArgObject _ -> do
+ oid <- getWord32le
+ pure $ ArgObjectValue (if oid == 0 then Nothing else Just oid)
+ ArgNewId _ -> ArgNewIdValue <$> getWord32le
+ ArgString -> do
+ len <- getWord32le
+ if len == 0
+ then pure (ArgStringValue Nothing)
+ else do
+ let total = fromIntegral len
+ contentLen = max 0 (total - 1)
+ bytes <- getByteString contentLen
+ _nul <- getWord8
+ skipPadding total
+ case decodeUtf8' bytes of
+ Left err -> fail (show err)
+ Right txt -> pure (ArgStringValue (Just txt))
+
+putPadding :: Int -> Put
+putPadding payloadLen = replicateM_ (padLength payloadLen) (putWord8 0)
+
+skipPadding :: Int -> Get ()
+skipPadding payloadLen = do
+ _ <- getByteString (padLength payloadLen)
+ pass
+
+padLength :: Int -> Int
+padLength n = (4 - (n .&. 3)) .&. 3
+
+data Header = Header !Word32 !Word16 !Word16
+
+frameObjectId :: Header -> Word32
+frameObjectId (Header objectId _ _) = objectId
+
+frameOpcode :: Header -> Word16
+frameOpcode (Header _ opcode _) = opcode
+
+frameSize :: Header -> Word16
+frameSize (Header _ _ size) = size
diff --git a/src/YMonad/Protocol/Wayland/Xml.hs b/src/YMonad/Protocol/Wayland/Xml.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/Protocol/Wayland/Xml.hs
@@ -0,0 +1,93 @@
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module YMonad.Protocol.Wayland.Xml (
+ loadProtocolSpec,
+) where
+
+import Data.Map.Strict qualified as M
+import Text.XML.HXT.Core
+
+import YMonad.Protocol.Wayland.Types
+
+loadProtocolSpec :: FilePath -> IO (Either String ProtocolSpec)
+loadProtocolSpec path = do
+ specs <- runX (readDocument [withValidate no, withRemoveWS yes] path >>> parseProtocol)
+ pure $ case specs of
+ [] -> Left ("No element found in: " <> path)
+ spec : _ -> Right spec
+
+parseProtocol :: IOSArrow XmlTree ProtocolSpec
+parseProtocol =
+ deep (isElem >>> hasName "protocol") >>> proc proto -> do
+ name <- getAttrValue "name" -< proto
+ interfaces <- listA (getChildren >>> isElem >>> hasName "interface" >>> parseInterface) -< proto
+ returnA
+ -<
+ ProtocolSpec
+ { protocolName = toText name
+ , protocolInterfaces = M.fromList [(interfaceName iface, iface) | iface <- interfaces]
+ }
+
+parseInterface :: IOSArrow XmlTree InterfaceSpec
+parseInterface = proc iface -> do
+ name <- getAttrValue "name" -< iface
+ versionTxt <- getAttrValue "version" -< iface
+ requests <- listA (getChildren >>> isElem >>> hasName "request" >>> parseRequest) -< iface
+ events <- listA (getChildren >>> isElem >>> hasName "event" >>> parseEvent) -< iface
+ let version = parseWord32 1 versionTxt
+ returnA -< mkInterfaceSpec (toText name) version (assignOpcodes MessageRequest requests) (assignOpcodes MessageEvent events)
+
+parseRequest :: IOSArrow XmlTree MessageSpec
+parseRequest = parseMessage MessageRequest
+
+parseEvent :: IOSArrow XmlTree MessageSpec
+parseEvent = parseMessage MessageEvent
+
+parseMessage :: MessageRole -> IOSArrow XmlTree MessageSpec
+parseMessage role = proc msg -> do
+ name <- getAttrValue "name" -< msg
+ args <- listA (getChildren >>> isElem >>> hasName "arg" >>> parseArg) -< msg
+ returnA
+ -<
+ MessageSpec
+ { messageSpecName = toText name
+ , messageSpecOpcode = 0
+ , messageSpecRole = role
+ , messageSpecArgs = args
+ }
+
+parseArg :: IOSArrow XmlTree ArgSpec
+parseArg = proc arg -> do
+ name <- getAttrValue "name" -< arg
+ typeName <- getAttrValue "type" -< arg
+ iface <- getAttrValue "interface" -< arg
+ allowNull <- getAttrValue "allow-null" -< arg
+ returnA
+ -<
+ ArgSpec
+ { argSpecName = toText name
+ , argSpecType = parseArgType (toText typeName) (toMaybeText iface)
+ , argSpecAllowNull = allowNull == "true"
+ }
+
+assignOpcodes :: MessageRole -> [MessageSpec] -> [MessageSpec]
+assignOpcodes role = zipWith assign [0 :: Word16 ..]
+ where
+ assign opcode spec = spec {messageSpecOpcode = opcode, messageSpecRole = role}
+
+parseArgType :: Text -> Maybe Text -> ArgType
+parseArgType typeName iface = case typeName of
+ "int" -> ArgInt
+ "uint" -> ArgUint
+ "string" -> ArgString
+ "object" -> ArgObject iface
+ "new_id" -> ArgNewId iface
+ _ -> ArgString
+
+parseWord32 :: Word32 -> String -> Word32
+parseWord32 fallback raw = fromMaybe fallback (readMaybe raw)
+
+toMaybeText :: String -> Maybe Text
+toMaybeText "" = Nothing
+toMaybeText raw = Just (toText raw)
diff --git a/src/YMonad/Run.hs b/src/YMonad/Run.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/Run.hs
@@ -0,0 +1,511 @@
+{-# LANGUAGE BangPatterns #-}
+
+module YMonad.Run (
+ ymonad,
+) where
+
+import Control.Concurrent (forkIO, killThread)
+import Control.Concurrent.STM (TQueue, newTQueueIO, tryReadTQueue, writeTQueue)
+import Control.Exception (AsyncException (ThreadKilled), bracket, try)
+import Control.Monad (foldM)
+import Data.ByteString qualified as BS
+import Data.ByteString.Char8 qualified as B8
+import Data.Map.Strict qualified as M
+import Data.Text qualified as T
+import Data.Text.IO qualified as TIO
+import Network.Socket
+import Network.Socket.ByteString qualified as NSB
+import System.Directory (removePathForcibly)
+import System.Environment (getEnvironment, getExecutablePath)
+import System.FilePath (())
+import System.IO.Error (catchIOError)
+import System.Process (createProcess, env, proc, shell)
+import System.Timeout (timeout)
+
+import YMonad.Backend.River
+import YMonad.Config
+import YMonad.ControlCommand
+import YMonad.Core
+import YMonad.Keys
+import YMonad.Prompt.Internal (choosePrompt, getCommands, getMans, getSshHosts, runInConfiguredTerminal)
+
+ymonad :: YConfig -> IO ()
+ymonad conf = do
+ controlPath <- getControlPath
+ queue <- newTQueueIO
+ withControlServer controlPath queue $ do
+ logTrace ("control socket ready: " <> toText controlPath)
+ runtimeResult <- loadRiverRuntime
+ riverRt0 <- case runtimeResult of
+ Left err -> die ("Failed to load river protocol: " <> err)
+ Right rt -> pure rt
+ socketResult <- connectRiver Nothing
+ sock <- case socketResult of
+ Left fault -> die ("Failed to connect to river: " <> toString (faultMessage fault))
+ Right connected -> pure connected
+ bracket
+ (pure sock)
+ close
+ ( \activeSock -> do
+ startupResult <- acquireRiverManager activeSock riverRt0
+ (runtimeSt0, riverRt1) <- case startupResult of
+ Left fault -> die ("Failed to acquire river window manager: " <> toString (faultMessage fault))
+ Right (startupEvents, riverRt') -> foldM (\(st, rt) event -> applyEvent st rt event) (runtimeStateFromConfig conf, riverRt') startupEvents
+ riverRt2 <- maybeInstallKeyBindings conf riverRt1
+ loop conf activeSock queue runtimeSt0 riverRt2
+ )
+
+runtimeStateFromConfig :: YConfig -> RuntimeState
+runtimeStateFromConfig conf =
+ runtimeSt0
+ { rtWindowSet =
+ windowSet0
+ { current = (current windowSet0) {screenWorkspace = seedLayout (screenWorkspace (current windowSet0))}
+ , hidden = map seedLayout (hidden windowSet0)
+ }
+ , rtTheme =
+ RuntimeTheme
+ { themeBorderWidth = borderWidth conf
+ , themeNormalBorderColor = fromMaybe (opaqueRgb8 0xdd 0xdd 0xdd) (parseColorString (normalBorderColor conf))
+ , themeFocusedBorderColor = fromMaybe (opaqueRgb8 0xff 0x00 0x00) (parseColorString (focusedBorderColor conf))
+ , themeTitleBarMode = titleBarMode conf
+ }
+ }
+ where
+ runtimeSt0 = defaultRuntimeStateWithWorkspaces (Rect 0 0 1920 1080) workspaceIds
+ windowSet0 = rtWindowSet runtimeSt0
+
+ seedLayout workspace = workspace {workspaceLayout = layoutHook conf}
+
+ workspaceIds = case map (WorkspaceId . T.pack) (workspaces conf) of
+ [] -> WorkspaceId "1" :| map (WorkspaceId . show) [(2 :: Int) .. 9]
+ firstWorkspace : remainingWorkspaces -> firstWorkspace :| remainingWorkspaces
+
+data RiverPoll = RiverPoll
+ { riverPollRuntime :: RiverRuntime
+ , riverPollCallbacks :: [RiverCallback]
+ , riverPollSteps :: [RiverPollStep]
+ }
+
+data RiverPollStep
+ = RiverPollAction YAction
+ | RiverPollEvent YEvent
+
+loop :: YConfig -> Socket -> TQueue ControlCommand -> RuntimeState -> RiverRuntime -> IO ()
+loop conf sock queue runtimeSt riverRt = do
+ polled <- pollRiverEvents sock riverRt
+ case polled of
+ Left fault -> stopAfterFault runtimeSt riverRt fault
+ Right poll -> do
+ logCallbacks (riverPollCallbacks poll)
+ (runtimeSt0, riverRt0) <- foldM (applyPollStep conf) (runtimeSt, riverPollRuntime poll) (riverPollSteps poll)
+
+ pendingCommands <- atomically (drainQueue queue)
+ (runtimeSt1, riverRt1) <- foldM applyControlCommand (runtimeSt0, riverRt0) pendingCommands
+ riverRt2 <- maybeInstallKeyBindings conf riverRt1
+
+ flushed <- flushTransportLogged sock riverRt2
+ case flushed of
+ Left fault -> stopAfterFault runtimeSt1 riverRt2 fault
+ Right riverRt3 -> loop conf sock queue runtimeSt1 riverRt3
+ where
+ stopAfterFault runtimeSt' riverRt' fault = do
+ _ <- applyEvent runtimeSt' riverRt' (EvBackendFault fault)
+ logTrace "stopping river event loop after transport failure"
+
+applyPollStep :: YConfig -> (RuntimeState, RiverRuntime) -> RiverPollStep -> IO (RuntimeState, RiverRuntime)
+applyPollStep conf state' step =
+ case step of
+ RiverPollAction action -> applyAction conf state' action
+ RiverPollEvent event -> let (runtimeSt, riverRt) = state' in applyEvent runtimeSt riverRt event
+
+applyEvent :: RuntimeState -> RiverRuntime -> YEvent -> IO (RuntimeState, RiverRuntime)
+applyEvent runtimeSt riverRt event = do
+ case event of
+ EvBackendFault fault -> logBackendFault fault
+ _otherEvent -> pass
+ let transition = reduce runtimeSt event
+ requests = trRequests transition
+ !requestCount = length requests
+ !runtimeSt' = trState transition
+ !riverRt' = pumpPending (stageRequests riverRt requests)
+ requestCount `seq` pass
+ pure (runtimeSt', riverRt')
+
+applyAction :: YConfig -> (RuntimeState, RiverRuntime) -> YAction -> IO (RuntimeState, RiverRuntime)
+applyAction conf (runtimeSt, riverRt) action =
+ case action of
+ Spawn cmd -> do
+ _ <- createProcess (shell cmd)
+ pure (runtimeSt, riverRt)
+ ToggleFullscreen ->
+ applyEvent runtimeSt riverRt (EvUserCommand CmdToggleFullscreen)
+ ViewWorkspace workspaceName ->
+ applyEvent runtimeSt riverRt (EvUserCommand (CmdViewWorkspace (WorkspaceId (T.pack workspaceName))))
+ MoveFocusedTo workspaceName ->
+ applyEvent runtimeSt riverRt (EvUserCommand (CmdMoveFocusedTo (WorkspaceId (T.pack workspaceName))))
+ FocusNext ->
+ applyEvent runtimeSt riverRt (EvUserCommand CmdFocusNext)
+ FocusPrev ->
+ applyEvent runtimeSt riverRt (EvUserCommand CmdFocusPrev)
+ SwapNext ->
+ applyEvent runtimeSt riverRt (EvUserCommand CmdSwapNext)
+ SwapPrev ->
+ applyEvent runtimeSt riverRt (EvUserCommand CmdSwapPrev)
+ KillFocused ->
+ applyEvent runtimeSt riverRt (EvUserCommand CmdKillFocused)
+ CycleLayout ->
+ applyEvent runtimeSt riverRt (EvUserCommand CmdCycleLayout)
+ ShrinkMaster ->
+ applyEvent runtimeSt riverRt (EvUserCommand CmdShrink)
+ ExpandMaster ->
+ applyEvent runtimeSt riverRt (EvUserCommand CmdExpand)
+ IncMasterNBy delta ->
+ applyEvent runtimeSt riverRt (EvUserCommand (CmdIncMasterN delta))
+ ExitSession ->
+ applyEvent runtimeSt riverRt (EvUserCommand CmdExitSession)
+ RecompileRestart -> do
+ restartYMonad
+ pure (runtimeSt, riverRt)
+ ShellPrompt xpConfig -> do
+ commands <- getCommands
+ selection <- choosePrompt xpConfig "Run: " commands
+ case selection of
+ Nothing -> pure (runtimeSt, riverRt)
+ Just commandText -> do
+ _ <- createProcess (shell commandText)
+ pure (runtimeSt, riverRt)
+ SafePrompt commandPath xpConfig -> do
+ selection <- choosePrompt xpConfig "Run: " []
+ case selection of
+ Nothing -> pure (runtimeSt, riverRt)
+ Just argument -> do
+ _ <- createProcess (proc commandPath [argument])
+ pure (runtimeSt, riverRt)
+ UnsafePrompt commandPrefix xpConfig -> do
+ selection <- choosePrompt xpConfig "Run: " []
+ case selection of
+ Nothing -> pure (runtimeSt, riverRt)
+ Just argument -> do
+ _ <- createProcess (shell (commandPrefix <> " " <> argument))
+ pure (runtimeSt, riverRt)
+ SshPrompt xpConfig -> do
+ hosts <- getSshHosts
+ selection <- choosePrompt xpConfig "SSH to: " hosts
+ case selection of
+ Nothing -> pure (runtimeSt, riverRt)
+ Just host -> do
+ runInConfiguredTerminal conf xpConfig ("ssh " <> host)
+ pure (runtimeSt, riverRt)
+ ManPrompt xpConfig -> do
+ pages <- getMans
+ selection <- choosePrompt xpConfig "Manual page: " pages
+ case selection of
+ Nothing -> pure (runtimeSt, riverRt)
+ Just page -> do
+ runInConfiguredTerminal conf xpConfig ("man " <> page)
+ pure (runtimeSt, riverRt)
+
+restartYMonad :: IO ()
+restartYMonad = do
+ launcherPath <- getLauncherPath
+ env0 <- getEnvironment
+ let env1 =
+ ("YMONAD_FORCE_REBUILD", "1")
+ : filter ((/= "YMONAD_FORCE_REBUILD") . fst) env0
+ _ <- createProcess ((proc launcherPath []) {env = Just env1})
+ logTrace ("spawned restart via " <> toText launcherPath)
+ exitSuccess
+
+getLauncherPath :: IO FilePath
+getLauncherPath = do
+ explicit <- lookupEnv "YMONAD_LAUNCHER_PATH"
+ maybe getExecutablePath pure explicit
+
+applyControlCommand :: (RuntimeState, RiverRuntime) -> ControlCommand -> IO (RuntimeState, RiverRuntime)
+applyControlCommand (runtimeSt, riverRt) command =
+ case command of
+ ControlSpawn cmd -> do
+ _ <- createProcess (shell cmd)
+ pure (runtimeSt, riverRt)
+ ControlToggleFullscreen ->
+ applyEvent runtimeSt riverRt (EvUserCommand CmdToggleFullscreen)
+ ControlUserCommand userCmd ->
+ applyEvent runtimeSt riverRt (EvUserCommand userCmd)
+
+pollRiverEvents :: Socket -> RiverRuntime -> IO (Either BackendFault RiverPoll)
+pollRiverEvents sock riverRt = do
+ recvResult <- (try (timeout 10000 (NSB.recv sock 65535)) :: IO (Either SomeException (Maybe BS.ByteString)))
+ case recvResult of
+ Left ex -> pure (Left (BackendFault ("Wayland recv failed: " <> toText (displayException ex))))
+ Right mChunk ->
+ case mChunk of
+ Nothing -> pure (Right (RiverPoll riverRt [] []))
+ Just chunk
+ | BS.null chunk -> pure (Left (BackendFault "Wayland socket closed by compositor"))
+ | otherwise ->
+ pure $ do
+ (riverRt', callbacks) <- ingestBytes riverRt chunk
+ steps <- fmap concat (mapM callbackToSteps callbacks)
+ let !callbackCount = length callbacks
+ !stepCount = length steps
+ callbackCount `seq` stepCount `seq` Right (RiverPoll riverRt' callbacks steps)
+
+pollEventsFromSteps :: [RiverPollStep] -> [YEvent]
+pollEventsFromSteps steps = [event | RiverPollEvent event <- steps]
+
+callbackToSteps :: RiverCallback -> Either BackendFault [RiverPollStep]
+callbackToSteps callback =
+ case callback of
+ RiverActionTriggered action -> Right [RiverPollAction action]
+ _otherCallback -> map RiverPollEvent <$> decodeCallback callback
+
+acquireRiverManager :: Socket -> RiverRuntime -> IO (Either BackendFault ([YEvent], RiverRuntime))
+acquireRiverManager sock riverRt0 = do
+ flushed <- flushTransportLogged sock riverRt0
+ case flushed of
+ Left fault -> pure (Left fault)
+ Right riverRt1 -> waitForRegistryRoundtrip 200 [] riverRt1
+ where
+ waitForRegistryRoundtrip :: Int -> [YEvent] -> RiverRuntime -> IO (Either BackendFault ([YEvent], RiverRuntime))
+ waitForRegistryRoundtrip remaining acc riverRt
+ | startupReady riverRt =
+ case rrManagerObject riverRt of
+ Nothing ->
+ pure
+ ( Left
+ ( BackendFault
+ "Compositor did not advertise river_window_manager_v1 during startup; YMonad requires River's window management protocol"
+ )
+ )
+ Just _managerObject -> do
+ logTrace "river_window_manager_v1 acquired"
+ pure (Right (acc, riverRt))
+ | remaining <= 0 =
+ pure
+ ( Left
+ ( BackendFault
+ "Timed out waiting for wl_registry roundtrip while acquiring river_window_manager_v1"
+ )
+ )
+ | otherwise = do
+ polled <- pollRiverEvents sock riverRt
+ case polled of
+ Left fault -> pure (Left fault)
+ Right poll -> do
+ logCallbacks (riverPollCallbacks poll)
+ let pollEvents = pollEventsFromSteps (riverPollSteps poll)
+ case firstBackendFault pollEvents of
+ Just fault -> pure (Left fault)
+ Nothing -> do
+ flushed' <- flushTransportLogged sock (riverPollRuntime poll)
+ case flushed' of
+ Left fault -> pure (Left fault)
+ Right riverRt' -> waitForRegistryRoundtrip (remaining - 1) (acc ++ pollEvents) riverRt'
+
+ startupReady :: RiverRuntime -> Bool
+ startupReady riverRt =
+ rrRegistryReady riverRt
+ && isJust (rrManagerObject riverRt)
+ && case rrXkbBindingsObject riverRt of
+ Nothing -> True
+ Just _ -> isJust (rrSeat riverRt)
+
+flushTransportLogged :: Socket -> RiverRuntime -> IO (Either BackendFault RiverRuntime)
+flushTransportLogged sock riverRt = do
+ let prepared = pumpPending riverRt
+ logOutgoingMessages (rrOutgoing prepared)
+ flushTransportIO sock riverRt
+
+maybeInstallKeyBindings :: YConfig -> RiverRuntime -> IO RiverRuntime
+maybeInstallKeyBindings conf riverRt
+ | rrBindingsInstalled riverRt = pure riverRt
+ | otherwise =
+ case (rrXkbBindingsObject riverRt, rrSeat riverRt) of
+ (Nothing, _)
+ | rrRegistryReady riverRt -> do
+ logTrace "river_xkb_bindings_v1 was not advertised; key bindings are unavailable"
+ pure (riverRt {rrBindingsInstalled = True})
+ (Just _bindingsObject, Just _seat) -> do
+ let (warnings, riverRt') = stageConfiguredBindings conf riverRt
+ mapM_ logTrace warnings
+ logTrace "installed river xkb key bindings"
+ pure riverRt'
+ _notReadyYet -> pure riverRt
+
+stageConfiguredBindings :: YConfig -> RiverRuntime -> ([Text], RiverRuntime)
+stageConfiguredBindings conf riverRt0 =
+ let (warnings, riverRt1) = foldl' registerBinding ([], riverRt0) (M.toList (keys conf conf))
+ riverRt2 = riverRt1 {rrBindingsInstalled = True}
+ in (warnings, riverRt2)
+ where
+ bindingsObjectId = fromMaybe 0 (rrXkbBindingsObject riverRt0)
+ seatObjectId = maybe 0 riverSeatObjectId (rrSeat riverRt0)
+
+ registerBinding :: ([Text], RiverRuntime) -> ((KeyMask, KeySym), YAction) -> ([Text], RiverRuntime)
+ registerBinding (warnings, riverRt) ((mask, keySym), action) =
+ case keySymToXkb keySym of
+ Nothing ->
+ ( warnings ++ ["skipping unsupported key symbol for river xkb bindings: " <> renderKeySym keySym]
+ , riverRt
+ )
+ Just keysym ->
+ let (bindingObjectId, riverRt1) = allocateObjectId riverRt
+ createBinding =
+ WireMessage
+ { wireObjectId = bindingsObjectId
+ , wireInterface = "river_xkb_bindings_v1"
+ , wireMessageName = "get_xkb_binding"
+ , wireOpcode = requestOpcode riverRt1 "river_xkb_bindings_v1" "get_xkb_binding"
+ , wireArgs =
+ [ ArgObjectValue (Just seatObjectId)
+ , ArgNewIdValue bindingObjectId
+ , ArgUintValue keysym
+ , ArgUintValue (unKeyMask mask)
+ ]
+ }
+ enableBinding =
+ WireMessage
+ { wireObjectId = bindingObjectId
+ , wireInterface = "river_xkb_binding_v1"
+ , wireMessageName = "enable"
+ , wireOpcode = requestOpcode riverRt1 "river_xkb_binding_v1" "enable"
+ , wireArgs = []
+ }
+ riverRt2 =
+ riverRt1
+ { rrBindingActions = M.insert bindingObjectId action (rrBindingActions riverRt1)
+ , rrObjectInterfaces = M.insert bindingObjectId "river_xkb_binding_v1" (rrObjectInterfaces riverRt1)
+ , rrOutgoing = rrOutgoing riverRt1 ++ [createBinding]
+ , rrPendingManage = rrPendingManage riverRt1 ++ [enableBinding]
+ }
+ in (warnings, riverRt2)
+
+requestOpcode :: RiverRuntime -> Text -> Text -> Word16
+requestOpcode riverRt ifaceName name = maybe 0 messageSpecOpcode (lookupRequest (rrProtocol riverRt) ifaceName name)
+
+logCallbacks :: [RiverCallback] -> IO ()
+logCallbacks = mapM_ logCallback
+
+logCallback :: RiverCallback -> IO ()
+logCallback callback = case callback of
+ RiverTrace msg -> logTrace msg
+ RiverProtocolFault _msg -> pass
+ RiverViewCreated vid _meta -> logTrace ("view created: " <> renderText vid)
+ RiverViewDestroyed vid -> logTrace ("view destroyed: " <> renderText vid)
+ RiverOutputDiscovered oid info ->
+ logTrace ("output discovered: " <> renderText oid <> " " <> T.pack (show (outputRect info)))
+ RiverOutputLost oid -> logTrace ("output removed: " <> renderText oid)
+ RiverSeatFocus mVid -> logTrace ("seat focus: " <> maybe "none" renderText mVid)
+ RiverManageStart -> pass
+ RiverRenderStart -> pass
+ RiverUserCommand userCommand -> logTrace ("user command: " <> renderText userCommand)
+ RiverActionTriggered action -> logTrace ("binding pressed: " <> renderText action)
+
+logOutgoingMessages :: [WireMessage] -> IO ()
+logOutgoingMessages = mapM_ (logTrace . ("-> " <>) . renderWireMessage)
+
+renderWireMessage :: WireMessage -> Text
+renderWireMessage msg =
+ wireInterface msg
+ <> "."
+ <> wireMessageName msg
+ <> "(object="
+ <> renderText (wireObjectId msg)
+ <> ", args=["
+ <> T.intercalate ", " (map renderArgValue (wireArgs msg))
+ <> "])"
+
+renderArgValue :: ArgValue -> Text
+renderArgValue arg = case arg of
+ ArgIntValue n -> renderText n
+ ArgUintValue n -> renderText n
+ ArgStringValue Nothing -> "null"
+ ArgStringValue (Just txt) -> txt
+ ArgObjectValue Nothing -> "object:null"
+ ArgObjectValue (Just oid) -> "object:" <> renderText oid
+ ArgNewIdValue oid -> "new_id:" <> renderText oid
+
+renderText :: (Show a) => a -> Text
+renderText = T.pack . show
+
+logBackendFault :: BackendFault -> IO ()
+logBackendFault fault = logTrace ("backend fault: " <> faultMessage fault)
+
+logTrace :: Text -> IO ()
+logTrace msg = TIO.hPutStrLn stderr ("[ymonad] " <> msg)
+
+firstBackendFault :: [YEvent] -> Maybe BackendFault
+firstBackendFault [] = Nothing
+firstBackendFault (event : rest) = case event of
+ EvBackendFault fault -> Just fault
+ _otherEvent -> firstBackendFault rest
+
+getControlPath :: IO FilePath
+getControlPath = do
+ explicit <- lookupEnv "YMONAD_SOCKET"
+ case explicit of
+ Just path -> pure path
+ Nothing -> do
+ runtimeDir <- lookupEnv "XDG_RUNTIME_DIR"
+ case runtimeDir of
+ Just dir -> pure (dir "ymonad.sock")
+ Nothing -> pure "/tmp/ymonad.sock"
+
+withControlServer :: FilePath -> TQueue ControlCommand -> IO a -> IO a
+withControlServer path queue action = bracket acquire releaseResource (const action)
+ where
+ acquire = do
+ removePathForcibly path `catchIOError` const pass
+ server <- socket AF_UNIX Stream defaultProtocol
+ bind server (SockAddrUnix path)
+ listen server 5
+ tid <- forkIO (acceptLoop server)
+ pure (server, tid)
+
+ releaseResource (server, tid) = do
+ killThread tid
+ close server
+ removePathForcibly path `catchIOError` const pass
+
+ acceptLoop server = forever $ do
+ accepted <- (try (accept server) :: IO (Either SomeException (Socket, SockAddr)))
+ case accepted of
+ Left ex
+ | isControlServerShutdown ex -> pass
+ | otherwise -> logTrace ("control socket accept failed: " <> toText (displayException ex))
+ Right (conn, _) -> do
+ commandResult <- (try (recvAll conn) :: IO (Either SomeException BS.ByteString))
+ close conn
+ case commandResult of
+ Left ex -> logTrace ("control socket recv failed: " <> toText (displayException ex))
+ Right commandBytes ->
+ case readMaybe (B8.unpack commandBytes) of
+ Nothing -> logTrace ("ignored malformed control command: " <> decodeUtf8With lenientDecode commandBytes)
+ Just command -> do
+ _ <- evaluateWHNF command
+ atomically (writeTQueue queue command)
+
+isControlServerShutdown :: SomeException -> Bool
+isControlServerShutdown ex =
+ case fromException ex of
+ Just ThreadKilled -> True
+ _ -> "Bad file descriptor" `T.isInfixOf` toText (displayException ex)
+
+recvAll :: Socket -> IO BS.ByteString
+recvAll conn = go id
+ where
+ go chunks = do
+ chunk <- NSB.recv conn 4096
+ if BS.null chunk
+ then pure (BS.concat (chunks []))
+ else go (chunks . (chunk :))
+
+drainQueue :: TQueue a -> STM [a]
+drainQueue queue = go id
+ where
+ go acc = do
+ next <- tryReadTQueue queue
+ case next of
+ Nothing -> pure (acc [])
+ Just value -> go (acc . (value :))
diff --git a/src/YMonad/StackSet.hs b/src/YMonad/StackSet.hs
new file mode 100644
--- /dev/null
+++ b/src/YMonad/StackSet.hs
@@ -0,0 +1,5 @@
+module YMonad.StackSet (
+ module YMonad.Core.StackSet,
+) where
+
+import YMonad.Core.StackSet
diff --git a/ymonad.cabal b/ymonad.cabal
new file mode 100644
--- /dev/null
+++ b/ymonad.cabal
@@ -0,0 +1,122 @@
+cabal-version: 3.4
+name: ymonad
+version: 0.1.0.0
+license: AGPL-3.0-or-later
+license-file: LICENSE
+author: Edward Tjörnhammar
+maintainer: ed@cflags.cc
+build-type: Simple
+synopsis: The Wayland Yutani-Monad
+description:
+ ymonad is a tiling window manager for Wayland that utilizes river for
+ low-level Wayland integration. It is designed to offer an API surface similar
+ to xmonad, ensuring familiarity for existing xmonad users and delivering a
+ composable, keyboard-driven workflow on Wayland.
+
+data-files: protocol/river/*.xml
+homepage: https://ymonad.org
+bug-reports: https://codeberg.org/ymonad/ymonad/issues
+tested-with: GHC ==9.10.3
+category: System
+
+source-repository head
+ type: git
+ location: https://codeberg.org/ymonad/ymonad
+
+flag dev
+ description: Enable strict warnings (-Werror) for development.
+ manual: True
+ default: False
+
+common warnings
+ ghc-options:
+ -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns
+ -Wmissing-deriving-strategies -Wunused-foralls -Wunused-foralls
+ -fprint-explicit-foralls -fprint-explicit-kinds
+
+ if flag(dev)
+ ghc-options: -Werror
+
+common shared
+ mixins:
+ base (Prelude as Brolude),
+ base hiding (Prelude),
+ relude (Relude as Prelude, Relude.Container.One),
+ relude
+
+ hs-source-dirs: src
+ build-depends:
+ , base >=4.14 && <5
+ , binary >=0.8 && <0.9
+ , bytestring >=0.12 && <0.13
+ , containers >=0.7 && <0.8
+ , directory >=1.3 && <1.4
+ , effectful >=2.6 && <2.7
+ , filepath >=1.5 && <1.6
+ , hxt >=9.3 && <9.4
+ , network >=3.2 && <3.3
+ , process >=1.6 && <1.7
+ , relude >=1 && <2
+ , stm >=2.5 && <2.6
+ , text >=2.1 && <2.2
+ , time >=1.12 && <1.13
+
+ default-extensions:
+ DerivingStrategies
+ GeneralizedNewtypeDeriving
+ ImportQualifiedPost
+ OverloadedStrings
+ StrictData
+
+ default-language: Haskell2010
+
+library
+ import: warnings, shared
+ exposed-modules:
+ YMonad
+ YMonad.Config
+ YMonad.Core
+ YMonad.Layout
+ YMonad.StackSet
+
+ other-modules:
+ Paths_ymonad
+ YMonad.Backend.River
+ YMonad.Backend.River.Decode
+ YMonad.Backend.River.Encode
+ YMonad.Backend.River.Interpreter
+ YMonad.Backend.River.Protocol
+ YMonad.Backend.River.Translate
+ YMonad.Backend.River.Types
+ YMonad.ControlCommand
+ YMonad.Core.Common
+ YMonad.Core.Layout
+ YMonad.Core.Reduce
+ YMonad.Core.StackSet
+ YMonad.Core.Types
+ YMonad.Keys
+ YMonad.Prompt
+ YMonad.Prompt.Internal
+ YMonad.Protocol.Wayland.Types
+ YMonad.Protocol.Wayland.Wire
+ YMonad.Protocol.Wayland.Xml
+ YMonad.Run
+
+ autogen-modules: Paths_ymonad
+
+executable ymonad
+ import: warnings, shared
+ main-is: Main.hs
+ other-modules:
+ Paths_ymonad
+ YMonad.Launcher
+
+ autogen-modules: Paths_ymonad
+ build-depends: ymonad
+
+executable ymonadctl
+ import: warnings, shared
+ main-is: ControlMain.hs
+ other-modules: Paths_ymonad
+ autogen-modules: Paths_ymonad
+ build-depends: ymonad