packages feed

dojang (empty) → 0.1.0

raw patch · 64 files changed

+12375/−0 lines, 64 filesdep +Diffdep +basedep +bytestringsetup-changed

Dependencies added: Diff, base, bytestring, case-insensitive, code-page, containers, deepseq, directory, dojang, extra, filepath, filepattern, fortytwo, hashable, hedgehog, hspec, hspec-discover, hspec-expectations-pretty-diff, hspec-hedgehog, hspec-junit-formatter, hspec-megaparsec, megaparsec, monad-logger, mtl, optparse-applicative, parser-combinators, pretty-terminal, process, random, regex-tdfa, semver, temporary, text, text-show, toml-parser, unordered-containers

Files

+ CHANGES.md view
@@ -0,0 +1,7 @@+Dojang changelog+=================++Version 0.1.0+-------------++Initial release.  Released on November 26, 2023.
+ LICENSE view
@@ -0,0 +1,674 @@+                    GNU GENERAL PUBLIC LICENSE+                       Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++                            Preamble++  The GNU General Public License is a free, copyleft license for+software and other kinds of works.++  The licenses for most software and other practical works are designed+to take away your freedom to share and change the works.  By contrast,+the GNU General Public License is intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users.  We, the Free Software Foundation, use the+GNU General Public License for most of our software; it applies also to+any other work released this way by its authors.  You can apply it to+your programs, too.++  When we speak of free software, we are referring to freedom, not+price.  Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++  To protect your rights, we need to prevent others from denying you+these rights or asking you to surrender the rights.  Therefore, you have+certain responsibilities if you distribute copies of the software, or if+you modify it: responsibilities to respect the freedom of others.++  For example, if you distribute copies of such a program, whether+gratis or for a fee, you must pass on to the recipients the same+freedoms that you received.  You must make sure that they, too, receive+or can get the source code.  And you must show them these terms so they+know their rights.++  Developers that use the GNU GPL protect your rights with two steps:+(1) assert copyright on the software, and (2) offer you this License+giving you legal permission to copy, distribute and/or modify it.++  For the developers' and authors' protection, the GPL clearly explains+that there is no warranty for this free software.  For both users' and+authors' sake, the GPL requires that modified versions be marked as+changed, so that their problems will not be attributed erroneously to+authors of previous versions.++  Some devices are designed to deny users access to install or run+modified versions of the software inside them, although the manufacturer+can do so.  This is fundamentally incompatible with the aim of+protecting users' freedom to change the software.  The systematic+pattern of such abuse occurs in the area of products for individuals to+use, which is precisely where it is most unacceptable.  Therefore, we+have designed this version of the GPL to prohibit the practice for those+products.  If such problems arise substantially in other domains, we+stand ready to extend this provision to those domains in future versions+of the GPL, as needed to protect the freedom of users.++  Finally, every program is threatened constantly by software patents.+States should not allow patents to restrict development and use of+software on general-purpose computers, but in those that do, we wish to+avoid the special danger that patents applied to a free program could+make it effectively proprietary.  To prevent this, the GPL assures that+patents cannot be used to render the program non-free.++  The precise terms and conditions for copying, distribution and+modification follow.++                       TERMS AND CONDITIONS++  0. Definitions.++  "This License" refers to version 3 of the GNU General Public License.++  "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++  "The Program" refers to any copyrightable work licensed under this+License.  Each licensee is addressed as "you".  "Licensees" and+"recipients" may be individuals or organizations.++  To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy.  The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++  A "covered work" means either the unmodified Program or a work based+on the Program.++  To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy.  Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++  To "convey" a work means any kind of propagation that enables other+parties to make or receive copies.  Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++  An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License.  If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++  1. Source Code.++  The "source code" for a work means the preferred form of the work+for making modifications to it.  "Object code" means any non-source+form of a work.++  A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++  The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form.  A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++  The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities.  However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work.  For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++  The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++  The Corresponding Source for a work in source code form is that+same work.++  2. Basic Permissions.++  All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met.  This License explicitly affirms your unlimited+permission to run the unmodified Program.  The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work.  This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++  You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force.  You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright.  Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++  Conveying under any other circumstances is permitted solely under+the conditions stated below.  Sublicensing is not allowed; section 10+makes it unnecessary.++  3. Protecting Users' Legal Rights From Anti-Circumvention Law.++  No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++  When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++  4. Conveying Verbatim Copies.++  You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++  You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++  5. Conveying Modified Source Versions.++  You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++    a) The work must carry prominent notices stating that you modified+    it, and giving a relevant date.++    b) The work must carry prominent notices stating that it is+    released under this License and any conditions added under section+    7.  This requirement modifies the requirement in section 4 to+    "keep intact all notices".++    c) You must license the entire work, as a whole, under this+    License to anyone who comes into possession of a copy.  This+    License will therefore apply, along with any applicable section 7+    additional terms, to the whole of the work, and all its parts,+    regardless of how they are packaged.  This License gives no+    permission to license the work in any other way, but it does not+    invalidate such permission if you have separately received it.++    d) If the work has interactive user interfaces, each must display+    Appropriate Legal Notices; however, if the Program has interactive+    interfaces that do not display Appropriate Legal Notices, your+    work need not make them do so.++  A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit.  Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++  6. Conveying Non-Source Forms.++  You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++    a) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by the+    Corresponding Source fixed on a durable physical medium+    customarily used for software interchange.++    b) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by a+    written offer, valid for at least three years and valid for as+    long as you offer spare parts or customer support for that product+    model, to give anyone who possesses the object code either (1) a+    copy of the Corresponding Source for all the software in the+    product that is covered by this License, on a durable physical+    medium customarily used for software interchange, for a price no+    more than your reasonable cost of physically performing this+    conveying of source, or (2) access to copy the+    Corresponding Source from a network server at no charge.++    c) Convey individual copies of the object code with a copy of the+    written offer to provide the Corresponding Source.  This+    alternative is allowed only occasionally and noncommercially, and+    only if you received the object code with such an offer, in accord+    with subsection 6b.++    d) Convey the object code by offering access from a designated+    place (gratis or for a charge), and offer equivalent access to the+    Corresponding Source in the same way through the same place at no+    further charge.  You need not require recipients to copy the+    Corresponding Source along with the object code.  If the place to+    copy the object code is a network server, the Corresponding Source+    may be on a different server (operated by you or a third party)+    that supports equivalent copying facilities, provided you maintain+    clear directions next to the object code saying where to find the+    Corresponding Source.  Regardless of what server hosts the+    Corresponding Source, you remain obligated to ensure that it is+    available for as long as needed to satisfy these requirements.++    e) Convey the object code using peer-to-peer transmission, provided+    you inform other peers where the object code and Corresponding+    Source of the work are being offered to the general public at no+    charge under subsection 6d.++  A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++  A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling.  In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage.  For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product.  A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++  "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source.  The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++  If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information.  But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++  The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed.  Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++  Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++  7. Additional Terms.++  "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law.  If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++  When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it.  (Additional permissions may be written to require their own+removal in certain cases when you modify the work.)  You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++  Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++    a) Disclaiming warranty or limiting liability differently from the+    terms of sections 15 and 16 of this License; or++    b) Requiring preservation of specified reasonable legal notices or+    author attributions in that material or in the Appropriate Legal+    Notices displayed by works containing it; or++    c) Prohibiting misrepresentation of the origin of that material, or+    requiring that modified versions of such material be marked in+    reasonable ways as different from the original version; or++    d) Limiting the use for publicity purposes of names of licensors or+    authors of the material; or++    e) Declining to grant rights under trademark law for use of some+    trade names, trademarks, or service marks; or++    f) Requiring indemnification of licensors and authors of that+    material by anyone who conveys the material (or modified versions of+    it) with contractual assumptions of liability to the recipient, for+    any liability that these contractual assumptions directly impose on+    those licensors and authors.++  All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10.  If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term.  If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++  If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++  Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++  8. Termination.++  You may not propagate or modify a covered work except as expressly+provided under this License.  Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++  However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++  Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++  Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License.  If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++  9. Acceptance Not Required for Having Copies.++  You are not required to accept this License in order to receive or+run a copy of the Program.  Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance.  However,+nothing other than this License grants you permission to propagate or+modify any covered work.  These actions infringe copyright if you do+not accept this License.  Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++  10. Automatic Licensing of Downstream Recipients.++  Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License.  You are not responsible+for enforcing compliance by third parties with this License.++  An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations.  If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++  You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License.  For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++  11. Patents.++  A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based.  The+work thus licensed is called the contributor's "contributor version".++  A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version.  For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++  Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++  In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement).  To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++  If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients.  "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++  If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++  A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License.  You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++  Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++  12. No Surrender of Others' Freedom.++  If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all.  For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++  13. Use with the GNU Affero General Public License.++  Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU Affero General Public License into a single+combined work, and to convey the resulting work.  The terms of this+License will continue to apply to the part which is the covered work,+but the special requirements of the GNU Affero General Public License,+section 13, concerning interaction through a network will apply to the+combination as such.++  14. Revised Versions of this License.++  The Free Software Foundation may publish revised and/or new versions of+the GNU General Public License from time to time.  Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++  Each version is given a distinguishing version number.  If the+Program specifies that a certain numbered version of the GNU General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation.  If the Program does not specify a version number of the+GNU General Public License, you may choose any version ever published+by the Free Software Foundation.++  If the Program specifies that a proxy can decide which future+versions of the GNU General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++  Later license versions may give you additional or different+permissions.  However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++  15. Disclaimer of Warranty.++  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++  16. Limitation of Liability.++  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++  17. Interpretation of Sections 15 and 16.++  If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++                     END OF TERMS AND CONDITIONS++            How to Apply These Terms to Your New Programs++  If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++  To do so, attach the following notices to the program.  It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This program is free software: you can redistribute it and/or modify+    it under the terms of the GNU General Public License as published by+    the Free Software Foundation, either version 3 of the License, or+    (at your option) any later version.++    This program is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+    GNU General Public License for more details.++    You should have received a copy of the GNU General Public License+    along with this program.  If not, see <https://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++  If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++    <program>  Copyright (C) <year>  <name of author>+    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+    This is free software, and you are welcome to redistribute it+    under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License.  Of course, your program's commands+might be different; for a GUI interface, you would use an "about box".++  You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU GPL, see+<https://www.gnu.org/licenses/>.++  The GNU General Public License does not permit incorporating your program+into proprietary programs.  If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications with+the library.  If this is what you want to do, use the GNU Lesser General+Public License instead of this License.  But first, please read+<https://www.gnu.org/licenses/why-not-lgpl.html>.
+ README.md view
@@ -0,0 +1,41 @@+*Available in other languages: [한국어](README.ko.md).*++----++![](cat-pow.svg)+Dojang: A cross-platform dotfiles manager+==========================================++[![GPL 3.0][License badge]](./LICENSE)+[![GitHub Actions][GitHub Actions status badge]][GitHub Actions]+[![Cirrus CI][Cirrus CI status badge]][Cirrus CI]+[![Codecov][Codecov badge]][Codecov]++Dojang is a cross-platform dotfiles manager.  Here are some of the highlights:++ -  Lightweight.  It's built as a native executable, so it's easy to install+    and fast to run.+ -  Cross-platform.  It works on both the POSIX family and Windows.+ -  Flexible.  It keeps in mind that config files can be placed in different+    places or have different contents depending on the environment.+ -  Safe.  Every run can be previewed by simulating it in a sandbox environment+    with the `--dry-run` option.+ -  Friendly.  Error messages are friendly and print helpful hints or warnings.++For further information, see the docs:++ -  [English](https://dojang.dev/)+ -  [한국어](https://dojang.dev/ko/) (Korean)++Distributed under the [GPL 3.0] or later.++[License badge]: https://img.shields.io/github/license/dahlia/dojang+[GitHub Actions status badge]: https://github.com/dahlia/dojang/actions/workflows/build.yaml/badge.svg+[GitHub Actions]: https://github.com/dahlia/dojang/actions/workflows/build.yaml+[Cirrus CI status badge]: https://img.shields.io/cirrus/github/dahlia/dojang+[Cirrus CI]: https://cirrus-ci.com/github/dahlia/dojang+[Codecov badge]: https://codecov.io/gh/dahlia/dojang/graph/badge.svg?token=JrwY5Yt2pD+[Codecov]: https://codecov.io/gh/dahlia/dojang+[GPL 3.0]: https://www.gnu.org/licenses/gpl-3.0.html++<!-- cSpell: ignore codecov -->
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,432 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main (main) where++import Control.Applicative (Alternative ((<|>)), optional, (<**>))+import Control.Monad (void, when)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.Maybe (catMaybes, maybeToList)+import GHC.IO.Encoding (setLocaleEncoding, utf8)+import System.Exit (ExitCode (..), exitWith)+import System.IO (stderr)+import System.IO.CodePage (withCP65001)+import System.IO.Unsafe (unsafePerformIO)+import System.Info (os)++import Control.Monad.Except (MonadError (catchError))+import Options.Applicative+  ( Parser+  , ParserInfo+  , ParserPrefs+  , ParserResult+  , action+  , argument+  , command+  , commandGroup+  , customExecParser+  , defaultPrefs+  , execParserPure+  , flag+  , flag'+  , footer+  , fullDesc+  , handleParseResult+  , header+  , help+  , helper+  , info+  , long+  , many+  , metavar+  , progDesc+  , short+  , showDefault+  , some+  , str+  , subparser+  , switch+  , value+  )+import System.OsPath (OsPath, encodeFS)+import TextShow (TextShow (showt))++import Dojang.App+  ( App+  , AppEnv (..)+  , runAppWithStderrLogging+  , runAppWithoutLogging+  )+import Dojang.Commands (Admonition (Error, Note), codeStyleFor, printStderr')+import Dojang.Commands.Apply qualified (apply)+import Dojang.Commands.Diff (DiffMode (..))+import Dojang.Commands.Diff qualified (diff)+import Dojang.Commands.Env qualified (env)+import Dojang.Commands.Init (InitPreset (..), initPresetName)+import Dojang.Commands.Init qualified (init)+import Dojang.Commands.Reflect qualified (reflect)+import Dojang.Commands.Status (StatusOptions (..))+import Dojang.Commands.Status qualified (status)+import Dojang.ExitCodes (unhandledError)+import Dojang.MonadFileSystem (DryRunIO, MonadFileSystem, dryRunIO')+import Dojang.Version (toString, version)+import Options.Applicative.Path (hyphen, pathArgument, pathOption, period)+++intermediateDirname :: OsPath+intermediateDirname = unsafePerformIO $ encodeFS ".dojang"+{-# NOINLINE intermediateDirname #-}+++manifestFilename :: OsPath+manifestFilename = unsafePerformIO $ encodeFS "dojang.toml"+{-# NOINLINE manifestFilename #-}+++envFilename :: OsPath+envFilename = unsafePerformIO $ encodeFS "dojang-env.toml"+{-# NOINLINE envFilename #-}+++appP :: (MonadFileSystem i, MonadIO i) => Parser (AppEnv, App i ExitCode)+appP = do+  sourceDirectory' <-+    pathOption+      ( long "repository-dir"+          <> short 'r'+          <> metavar "PATH"+          <> value period+          <> showDefault+          <> action "directory"+          <> help "Repository (i.e., source tree) directory"+      )+  intermediateDirectory' <-+    pathOption+      ( long "intermediate-dir"+          <> short 'i'+          <> metavar "PATH"+          <> value intermediateDirname+          <> showDefault+          <> action "directory"+          <> help+            ( "Intermediate directory which is managed by Dojang.  "+                ++ "Relative to source tree directory (-s/--source-dir) "+                ++ "if not absolute"+            )+      )+  manifestFile' <-+    pathOption+      ( long "manifest-file"+          <> short 'm'+          <> metavar "PATH"+          <> value manifestFilename+          <> showDefault+          <> action "file"+          <> help+            ( "Manifest file.  Relative to source tree directory "+                ++ "(-s/--source-dir) if not absolute"+            )+      )+  envFile' <-+    pathOption+      ( long "env-file"+          <> short 'e'+          <> metavar "PATH"+          <> value envFilename+          <> showDefault+          <> action "file"+          <> help+            ( "Environment file.  Relative to source tree directory "+                ++ "(-s/--source-dir) if not absolute.  It will be silently "+                ++ "ignored if the file does not exist"+            )+      )+  dryRun' <-+    switch+      ( long "dry-run"+          <> help+            ( "Do not actually perform actions, but just print them.  "+                ++ "This option probably lets the program run much slower"+            )+      )+  debug' <- switch (long "debug" <> short 'd' <> help "Enable debug logging")+  cmd <- cmdP+  return+    ( AppEnv+        sourceDirectory'+        intermediateDirectory'+        manifestFile'+        envFile'+        dryRun'+        debug'+    , cmd+    )+++initPresetP :: Parser [InitPreset]+initPresetP =+  (\a b c d e f' g -> catMaybes [a, b, c, d, e, f', g])+    <$> f Amd64Linux ("linux-x86_64", "linux-arm64")+    <*> f Arm64Linux ("linux-aarch64", "linux-arm64")+    <*> f AppleSiliconMac ("macos-aarch64", "apple-silicon-mac")+    <*> f IntelMac ("macos-amd64", "intel-mac")+    <*> f Win64 ("windows-amd64", "win64")+    <*> f WinArm64 ("windows-aarch64", "win-arm64")+    <*> f Wsl2 ("linux-wsl2", "wsl2")+ where+  f :: InitPreset -> (String, String) -> Parser (Maybe InitPreset)+  f preset (longOpt, alias) =+    flag+      Nothing+      (Just preset)+      ( long longOpt+          <> long alias+          <> help ("Use " ++ initPresetName preset ++ " preset")+      )+++cmdP :: (MonadFileSystem i, MonadIO i) => Parser (App i ExitCode)+cmdP =+  subparser+    ( commandGroup "Managing commands:"+        <> command+          "init"+          ( info+              ( Dojang.Commands.Init.init+                  <$> initPresetP+                  <*> switch+                    ( long "no-interactive"+                        <> short 'I'+                        <> help "Do not prompt for anything"+                    )+                  <**> helper+              )+              (progDesc "Initialize repository")+          )+        <> command+          "env"+          ( info+              ( Dojang.Commands.Env.env+                  <$> switch+                    ( long "ignore-env-file"+                        <> short 'i'+                        <> help "Ignore environment file"+                    )+                  <*> pathOption+                    ( long "output-file"+                        <> short 'o'+                        <> metavar "PATH"+                        <> value hyphen+                        <> showDefault+                        <> action "file"+                        <> help+                          ( "Output file path.  Use - for stdout, "+                              ++ "and ./- for a file named -"+                          )+                    )+                  <**> helper+              )+              ( progDesc+                  $ "Show environment in TOML format, "+                  ++ "which can be used with -e/--env-file"+              )+          )+        <> command+          "status"+          ( info+              ( Dojang.Commands.Status.status+                  <$> ( StatusOptions+                          <$> switch+                            ( long "no-trailing-slash"+                                <> short 'S'+                                <> help+                                  ( "Do not append trailing slash (or backslash "+                                      ++ "on Windows) to directory paths"+                                  )+                            )+                          <*> switch+                            ( long "only-changes"+                                <> short 'c'+                                <> help "Only show changed files"+                            )+                          <*> switch+                            ( long "show-destination-path"+                                <> short 'd'+                                <> help+                                  ( "Show destination (target) path "+                                      ++ "instead of source path"+                                  )+                            )+                      )+                  <**> helper+              )+              ( progDesc+                  "Show status of repository and target (destination) tree"+              )+          )+        <> command+          "diff"+          ( info+              ( Dojang.Commands.Diff.diff+                  <$> ( flag'+                          Source+                          ( long "source"+                              <> short 's'+                              <> help+                                ( "Two-way diff between source tree and base "+                                    ++ "(intermediate) tree"+                                )+                          )+                          <|> flag'+                            Destination+                            ( long "destination"+                                <> long "target"+                                <> short 'd'+                                <> help+                                  ( "Two-way diff between destination (target) "+                                      ++ "tree and base (intermediate) tree"+                                  )+                            )+                          <|> pure Both+                      )+                  <*> optional+                    ( pathOption+                        ( long "diff-program"+                            <> metavar "PROGRAM"+                            <> action "command"+                            <> help+                              ( "A program to use for two-way diff.  "+                                  ++ "If not specified, fall back to a program "+                                  ++ "specified by the environment variable "+                                  ++ "DOJANG_DIFF"+                              )+                        )+                    )+                  <*> many (pathArgument $ metavar "FILE" <> action "file")+                  <**> helper+              )+              ( progDesc+                  $ "Show changes between source tree and target "+                  ++ "(destination) tree"+              )+          )+        <> command+          "reflect"+          ( info+              ( Dojang.Commands.Reflect.reflect+                  <$> switch+                    ( long "force"+                        <> short 'f'+                        <> help+                          "Enforce reflecting if there are ignorable errors"+                    )+                  <*> some (pathArgument $ metavar "FILE" <> action "file")+              )+              (progDesc "Let the repository reflect the target file")+          )+        <> command+          "apply"+          ( info+              ( Dojang.Commands.Apply.apply+                  <$> switch+                    ( long "force"+                        <> short 'f'+                        <> help+                          ( "Apply changes even if there are undergone "+                              ++ "changes in the target tree too"+                          )+                    )+                  <*> many (pathArgument $ metavar "FILE" <> action "file")+                  <**> helper+              )+              (progDesc "Apply changes to target tree")+          )+    )+    <|> subparser+      ( commandGroup "Meta commands:"+          <> command+            "version"+            ( info+                (pure versionCmd <**> helper)+                (progDesc "Show version")+            )+          <> command "help" (info helpP (progDesc "Show help"))+      )+++helpP :: (MonadFileSystem i, MonadIO i) => Parser (App i ExitCode)+helpP =+  helpCmd+    <$> optional (argument str (metavar "COMMAND"))+    <**> helper+++parser :: (MonadFileSystem i, MonadIO i) => ParserInfo (AppEnv, App i ExitCode)+parser =+  info+    (appP <**> helper)+    ( fullDesc+        <> progDesc "Manage dotfiles"+        <> header "Dojang: A cross-platform dotfiles manager"+        <> footer "Distributed under the GPL 3.0 or later."+    )+++parserPrefs :: ParserPrefs+parserPrefs = defaultPrefs+++versionCmd :: (MonadIO i) => App i ExitCode+versionCmd = do+  liftIO $ putStrLn $ "dojang " <> toString version+  return ExitSuccess+++helpCmd+  :: forall i. (MonadFileSystem i, MonadIO i) => Maybe String -> App i ExitCode+helpCmd cmdString = do+  void $ liftIO $ handleParseResult result+  return ExitSuccess+ where+  args = maybeToList cmdString ++ ["--help"]+  result :: ParserResult (AppEnv, App i ExitCode)+  result = execParserPure parserPrefs parser args+++main :: IO ()+main = withCP65001 $ do+  when (System.Info.os == "mingw32") $ setLocaleEncoding utf8+  (appEnv, _) <-+    liftIO $ customExecParser parserPrefs parser+      :: IO (AppEnv, App DryRunIO ExitCode)+  (exitCode, ops) <-+    if appEnv.dryRun+      then dryRunIO' $ run appEnv+      else do+        exitCode' <- run appEnv+        return (exitCode', -1)+  codeColor <- codeStyleFor stderr+  when (appEnv.dryRun && ops > 0) $ do+    printStderr' Note+      $ "Since "+      <> codeColor "--dry-run"+      <> " was specified, those "+      <> showt ops+      <> " changes were not actually committed to the filesystem."+  exitWith exitCode+ where+  run :: (MonadFileSystem i, MonadIO i) => AppEnv -> i ExitCode+  run appEnv = do+    (_, cmd) <- liftIO $ customExecParser parserPrefs parser+    (if appEnv.debug then runAppWithStderrLogging else runAppWithoutLogging)+      appEnv+      $ cmd+      `catchError` \e -> do+        printStderr' Error+          $ "An unexpected error occurred; you may report this as a bug: "+          <> showt e+        return unhandledError
+ dojang.cabal view
@@ -0,0 +1,199 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.36.0.+--+-- see: https://github.com/sol/hpack++name:           dojang+version:        0.1.0+synopsis:       A cross-platform dotfiles manager+description:    See also the README.md file.+category:       Configuration+homepage:       https://dojang.dev/+author:         Hong Minhee <hong@minhee.org>+maintainer:     Hong Minhee <hong@minhee.org>+copyright:      © 2023 Hong Minhee+license:        GPL-3.0-or-later+license-file:   LICENSE+build-type:     Simple+extra-doc-files:+    README.md+    CHANGES.md+    LICENSE++flag static+  description: Static link+  manual: True+  default: False++library+  exposed-modules:+      Dojang.App+      Dojang.Commands+      Dojang.Commands.Apply+      Dojang.Commands.Diff+      Dojang.Commands.Env+      Dojang.Commands.Init+      Dojang.Commands.Reflect+      Dojang.Commands.Status+      Dojang.ExitCodes+      Dojang.MonadFileSystem+      Dojang.Syntax.Env+      Dojang.Syntax.EnvironmentPredicate+      Dojang.Syntax.EnvironmentPredicate.Parser+      Dojang.Syntax.EnvironmentPredicate.Writer+      Dojang.Syntax.FilePathExpression.Parser+      Dojang.Syntax.Manifest.Internal+      Dojang.Syntax.Manifest.Parser+      Dojang.Syntax.Manifest.Writer+      Dojang.Types.Context+      Dojang.Types.Environment+      Dojang.Types.Environment.Current+      Dojang.Types.EnvironmentPredicate+      Dojang.Types.EnvironmentPredicate.Evaluate+      Dojang.Types.EnvironmentPredicate.Specificity+      Dojang.Types.FilePathExpression+      Dojang.Types.FilePathExpression.Expansion+      Dojang.Types.FileRoute+      Dojang.Types.FileRouteMap+      Dojang.Types.FileRouteMap.Evaluate+      Dojang.Types.Manifest+      Dojang.Types.MonikerMap+      Dojang.Types.MonikerName+      Dojang.Types.Repository+      Dojang.Version+      Options.Applicative.Path+  other-modules:+      Paths_dojang+  autogen-modules:+      Paths_dojang+  hs-source-dirs:+      src+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wmissing-export-lists+  build-depends:+      Diff >=0.4.1 && <0.6+    , base >=4.7 && <5+    , bytestring >=0.11 && <0.13+    , case-insensitive >=1.2.1.0 && <2+    , containers >0+    , deepseq >=1.4 && <2+    , directory >=1.3.8 && <1.4+    , extra >=1.7 && <2+    , filepath >=1.4.100 && <2+    , filepattern >=0.1.3 && <2+    , fortytwo >=2 && <2.1+    , hashable >=1.4.2.0 && <2+    , megaparsec ==9.3.*+    , monad-logger ==0.3.*+    , mtl >=2.3 && <3+    , optparse-applicative >=0.17 && <0.19+    , parser-combinators ==1.*+    , pretty-terminal ==0.1.*+    , process >=1.6 && <2+    , semver ==0.4.*+    , text ==2.*+    , text-show ==3.*+    , toml-parser >=1.3 && <2+    , unordered-containers >=0.2.19.1 && <1+  default-language: Haskell2010++executable dojang+  main-is: Main.hs+  other-modules:+      Paths_dojang+  autogen-modules:+      Paths_dojang+  hs-source-dirs:+      app+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      Diff >=0.4.1 && <0.6+    , base >=4.7 && <5+    , bytestring >=0.11 && <0.13+    , case-insensitive >=1.2.1.0 && <2+    , code-page ==0.2.*+    , containers >0+    , directory >=1.3.8 && <1.4+    , dojang >0+    , filepath >=1.4.100 && <2+    , hashable >=1.4.2.0 && <2+    , megaparsec ==9.3.*+    , monad-logger ==0.3.*+    , mtl >=2.3 && <3+    , optparse-applicative >=0.17 && <0.19+    , pretty-terminal ==0.1.*+    , text ==2.*+    , text-show ==3.*+    , toml-parser >=1.3 && <2+    , unordered-containers >=0.2.19.1 && <1+  default-language: Haskell2010+  if flag(static)+    if os(linux)+      ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wno-incomplete-uni-patterns -optP-Wno-nonportable-include-path -static -optl-static -optl-pthread -optc-Os -fPIC+    else+      ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wno-incomplete-uni-patterns -optP-Wno-nonportable-include-path -static -optc-Os+  else+    ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wno-incomplete-uni-patterns -optP-Wno-nonportable-include-path++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Dojang.Gen+      Dojang.MonadFileSystemSpec+      Dojang.Syntax.EnvironmentPredicate.ParserSpec+      Dojang.Syntax.EnvironmentPredicate.WriterSpec+      Dojang.Syntax.FilePathExpression.ParserSpec+      Dojang.Syntax.Manifest.WriterSpec+      Dojang.TestUtils+      Dojang.Types.ContextSpec+      Dojang.Types.Environment.CurrentSpec+      Dojang.Types.EnvironmentPredicate.EvaluateSpec+      Dojang.Types.EnvironmentPredicate.SpecificitySpec+      Dojang.Types.EnvironmentPredicateSpec+      Dojang.Types.EnvironmentSpec+      Dojang.Types.FilePathExpression.ExpansionSpec+      Dojang.Types.FilePathExpressionSpec+      Dojang.Types.FileRouteMap.EvaluateSpec+      Dojang.Types.FileRouteSpec+      Dojang.Types.Gen+      Dojang.Types.MonikerNameSpec+      Dojang.Types.RepositorySpec+      Spec+      SpecHook+      Paths_dojang+  autogen-modules:+      Paths_dojang+  hs-source-dirs:+      test+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N -Wno-incomplete-uni-patterns -optP-Wno-nonportable-include-path+  build-depends:+      Diff >=0.4.1 && <0.6+    , base >=4.7 && <5+    , bytestring >=0.11 && <0.13+    , case-insensitive >=1.2.1.0 && <2+    , containers >0+    , directory >=1.3.8 && <1.4+    , dojang >0+    , filepath >=1.4.100 && <2+    , hashable >=1.4.2.0 && <2+    , hedgehog >=1.2 && <2+    , hspec >=2.10.10 && <2.11+    , hspec-discover >=2.10.10 && <2.11+    , hspec-expectations-pretty-diff ==0.7.*+    , hspec-hedgehog >=0.0.1.2 && <0.1+    , hspec-junit-formatter >=1.1.0.2 && <1.2+    , hspec-megaparsec ==2.2.*+    , megaparsec ==9.3.*+    , monad-logger ==0.3.*+    , mtl >=2.3 && <3+    , optparse-applicative >=0.17 && <0.19+    , pretty-terminal ==0.1.*+    , random >=1.2 && <2+    , regex-tdfa >=1.3.2 && <1.4+    , temporary ==1.3.*+    , text ==2.*+    , text-show ==3.*+    , toml-parser >=1.3 && <2+    , unordered-containers >=0.2.19.1 && <1+  default-language: Haskell2010
+ src/Dojang/App.hs view
@@ -0,0 +1,320 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- | The application monad for Dojang.+module Dojang.App+  ( App+  , AppEnv (..)+  , Loc+  , LogLevel+  , LogSource+  , LogStr+  , currentEnvironment'+  , doesManifestExist+  , ensureContext+  , ensureRepository+  , loadManifest+  , loadRepository+  , lookupEnv'+  , runAppWithLogging+  , runAppWithStderrLogging+  , runAppWithoutLogging+  , saveManifest+  ) where++import Control.Monad (forM_)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.List.NonEmpty (toList)+import Data.String (IsString (fromString))+import Dojang.Types.FilePathExpression (EnvironmentVariable)+import System.Environment (lookupEnv)+import System.Exit (exitWith)+import System.IO (stderr)+import System.IO.Error (isDoesNotExistError)+import Prelude hiding (readFile, writeFile)++import Control.Monad.Except (MonadError (..), tryError)+import Control.Monad.Logger+  ( Loc+  , LogLevel+  , LogSource+  , LogStr+  , LoggingT (runLoggingT)+  , MonadLogger+  , logDebug+  , logDebugSH+  , logError+  , logInfo+  , logWarn+  , runStderrLoggingT+  )+import Control.Monad.Reader (MonadReader, ReaderT, asks, runReaderT)+import Control.Monad.Trans (MonadTrans (lift))+import Data.Text (concat, pack, unlines, unpack)+import System.OsPath (normalise, (</>))+import System.OsPath.Types (OsPath)+import System.OsString (OsString)+import TextShow (FromStringShow (FromStringShow), TextShow (showt))++import Dojang.Commands+  ( Admonition (..)+  , codeStyleFor+  , die'+  , dieWithErrors+  , printStderr'+  )+import Dojang.ExitCodes+  ( envFileReadError+  , manifestReadError+  , manifestUninitialized+  , noEnvFile+  )+import Dojang.MonadFileSystem (MonadFileSystem (..))+import Dojang.Syntax.Env (readEnvFile)+import Dojang.Syntax.Manifest.Parser (Error, formatErrors, readManifestFile)+import Dojang.Syntax.Manifest.Writer (writeManifestFile)+import Dojang.Types.Context (Context (..))+import Dojang.Types.Environment (Environment (..))+import Dojang.Types.Environment.Current+  ( MonadArchitecture (currentArchitecture)+  , MonadEnvironment (currentEnvironment)+  , MonadOperatingSystem (currentOperatingSystem)+  )+import Dojang.Types.Manifest (Manifest)+import Dojang.Types.Repository (Repository (..))+++-- | The environment for the application monad.+data AppEnv = AppEnv+  { sourceDirectory :: OsPath+  -- ^ The source directory (i.e., repository).+  , intermediateDirectory :: OsPath+  -- ^ The intermediate directory which is managed by Dojang.  It's normally+  -- @.dojang@ in the source directory.+  , manifestFile :: OsPath+  -- ^ The manifest file.+  , envFile :: OsPath+  -- ^ The environment file.+  , dryRun :: Bool+  -- ^ Whether to actually perform actions or just print what would be done.+  , debug :: Bool+  -- ^ Whether debug logging is enabled.+  }+  deriving (Show)+++-- | The application monad for Dojang.+newtype (MonadFileSystem i, MonadError IOError i, MonadIO i) => App i v = App+  { unApp :: ReaderT AppEnv (LoggingT i) v+  }+  deriving+    ( Functor+    , Applicative+    , Monad+    , MonadIO+    , MonadReader AppEnv+    , MonadLogger+    )+++instance+  (MonadFileSystem i, MonadError IOError i, MonadIO i)+  => MonadError IOError (App i)+  where+  throwError = App . throwError+  catchError action handler = App $ catchError (unApp action) (unApp . handler)+++instance (MonadFileSystem i, MonadIO i) => MonadFileSystem (App i) where+  encodePath = App . lift . lift . encodePath+  decodePath = App . lift . lift . decodePath+  exists = App . lift . lift . exists+  isFile = App . lift . lift . isFile+  isDirectory = App . lift . lift . isDirectory+  isSymlink = App . lift . lift . isSymlink+  readFile = App . lift . lift . readFile+  writeFile dst = App . lift . lift . writeFile dst+  readSymlinkTarget = App . lift . lift . readSymlinkTarget+  copyFile src = App . lift . lift . copyFile src+  createDirectory = App . lift . lift . createDirectory+  removeFile = App . lift . lift . removeFile+  removeDirectory = App . lift . lift . removeDirectory+  listDirectory = App . lift . lift . listDirectory+  getFileSize = App . lift . lift . getFileSize+++currentEnvironment' :: (MonadFileSystem i, MonadIO i) => App i Environment+currentEnvironment' = do+  sourceDir <- asks (.sourceDirectory)+  envFile' <- asks (.envFile)+  let filePath = sourceDir </> envFile'+  $(logDebug) $ "Environment file path: " <> showt (FromStringShow filePath)+  result <-+    readEnvFile filePath `catchError` \e -> do+      if isDoesNotExistError e+        then do+          $(logWarn)+            $ "Environment file not found: "+            <> showt (FromStringShow e)+          env <- liftIO currentEnvironment+          return $ Right (env, [])+        else die' noEnvFile $ showt e+  case result of+    Left errors -> do+      let formattedErrors =+            Data.Text.concat+              ["\n  " <> pack e | e <- toList errors]+      die' envFileReadError $ "Syntax errors in environment file:" <> formattedErrors+    Right (env, warnings) -> do+      $(logDebugSH) env+      forM_ warnings $ \w -> $(logWarn) $ fromString w+      return env+++instance (MonadFileSystem i, MonadIO i) => MonadEnvironment (App i) where+  currentEnvironment = currentEnvironment'+++instance (MonadFileSystem i, MonadIO i) => MonadOperatingSystem (App i) where+  currentOperatingSystem = (.operatingSystem) <$> currentEnvironment'+++instance (MonadFileSystem i, MonadIO i) => MonadArchitecture (App i) where+  currentArchitecture = (.architecture) <$> currentEnvironment'+++runAppWithoutLogging+  :: (MonadFileSystem i, MonadIO i) => AppEnv -> App i a -> i a+runAppWithoutLogging env app = runAppWithLogging env app (\_ _ _ _ -> pure ())+++-- | Run the application monad with logging handled by the given function.+runAppWithLogging+  :: (MonadFileSystem i, MonadIO i)+  => AppEnv+  -> App i a+  -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())+  -> i a+runAppWithLogging env app = runLoggingT (runReaderT app.unApp env)+++-- | Run the application monad with logging to stderr.+runAppWithStderrLogging+  :: (MonadFileSystem i, MonadIO i) => AppEnv -> App i a -> i a+runAppWithStderrLogging env = runStderrLoggingT . (`runReaderT` env) . unApp+++manifestPath :: (MonadIO i) => App i OsPath+manifestPath = do+  sourceDir <- asks (.sourceDirectory)+  manifestFile' <- asks (.manifestFile)+  let path = sourceDir </> manifestFile'+  $(logDebug) $ "Manifest path: " <> showt (FromStringShow path)+  return path+++loadManifest+  :: (MonadFileSystem i, MonadIO i) => App i (Either Error (Maybe Manifest))+loadManifest = do+  filename <- manifestPath+  result <- tryError (readManifestFile filename)+  case result of+    Left e+      | isDoesNotExistError e -> do+          $(logInfo) "Manifest file not found"+          return $ Right Nothing+    Left e -> do+      $(logError) $ "Error reading manifest file: " <> showt (FromStringShow e)+      throwError e+    Right (Left err) -> do+      $(logError)+        $ "Error parsing manifest file: "+        <> Data.Text.unlines (formatErrors err)+      return $ Left err+    Right (Right (manifest, warnings)) -> do+      forM_ warnings $ \w -> $(logWarn) w+      $(logDebugSH) manifest+      return $ Right $ Just manifest+++doesManifestExist :: (MonadFileSystem i, MonadIO i) => App i Bool+doesManifestExist = do+  filePath <- manifestPath+  exists' <- exists filePath+  $(logInfo)+    $ "Manifest file "+    <> showt (FromStringShow filePath)+    <> " "+    <> if exists' then "exists" else "does not exist"+  return exists'+++saveManifest :: (MonadFileSystem i, MonadIO i) => Manifest -> App i OsPath+saveManifest manifest = do+  filename <- manifestPath+  $(logDebugSH) manifest+  writeManifestFile manifest filename `catchError` \e -> do+    $(logError) $ "Error writing manifest file: " <> showt (FromStringShow e)+    throwError e+  $(logInfo)+    $ "Manifest file "+    <> showt (FromStringShow filename)+    <> " written"+  return filename+++loadRepository+  :: (MonadFileSystem i, MonadIO i) => App i (Either Error (Maybe Repository))+loadRepository = do+  sourceDir <- asks (normalise . (.sourceDirectory))+  intermediateDir <- asks (normalise . (.intermediateDirectory))+  result <- loadManifest+  case result of+    Left err -> return $ Left err+    Right Nothing -> return $ Right Nothing+    Right (Just manifest) -> do+      return+        $ Right+        $ Just+        $ Repository sourceDir (sourceDir </> intermediateDir) manifest+++ensureRepository :: (MonadFileSystem i, MonadIO i) => App i Repository+ensureRepository = do+  result <- loadRepository+  case result of+    Left e ->+      dieWithErrors manifestReadError $ formatErrors e+    Right Nothing -> do+      printStderr' Error "No manifest found."+      codeStyle <- codeStyleFor stderr+      printStderr'+        Note+        ("Run `" <> codeStyle "dojang init" <> "' to create one.")+      liftIO $ exitWith manifestUninitialized+    Right (Just repo) -> return repo+++ensureContext :: (MonadFileSystem i, MonadIO i) => App i (Context (App i))+ensureContext = do+  repo <- ensureRepository+  currentEnv <- currentEnvironment'+  $(logDebugSH) currentEnv+  return $ Context repo currentEnv lookupEnv'+++lookupEnv'+  :: (MonadFileSystem i, MonadIO i) => EnvironmentVariable -> i (Maybe OsString)+lookupEnv' env = do+  value <- liftIO $ lookupEnv $ unpack env+  case value of+    Just v -> do+      Just <$> encodePath v+    Nothing -> return Nothing
+ src/Dojang/Commands.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Dojang.Commands+  ( Admonition (..)+  , Color (..)+  , codeStyleFor+  , colorFor+  , die'+  , dieWithErrors+  , pathStyleFor+  , pathStyleFor'+  , printStderr+  , printStderr'+  , printTable+  ) where++import Control.Monad (forM_)+import Control.Monad.IO.Class (MonadIO (liftIO))+import System.Environment (lookupEnv)+import System.Exit (ExitCode, exitWith)+import System.IO.Extra (Handle, hIsTerminalDevice, stderr, stdout)+import System.IO.Unsafe (unsafePerformIO)+import Prelude hiding (putStr, replicate)++import Data.List (transpose)+import Data.Text (Text, length, pack, replicate)+import Data.Text.IO (hPutStr, hPutStrLn, putStr)+import System.Console.Pretty+  ( Color (..)+  , Pretty+  , Style (..)+  , bgColor+  , style+  )+import System.Console.Pretty qualified (color)+import System.OsPath (OsPath, decodeFS)+import TextShow (FromStringShow (FromStringShow), TextShow (showt))+++isColorAvailable :: (MonadIO m) => Handle -> m Bool+isColorAvailable handle = liftIO $ do+  term <- lookupEnv "TERM"+  noColor <- lookupEnv "NO_COLOR"+  case (term, noColor) of+    (Just "dumb", _) -> return False+    (_, Just (_ : _)) -> return False+    _ -> hIsTerminalDevice handle+++colorFor+  :: forall a m. (Pretty a, MonadIO m) => Handle -> m (Color -> Color -> a -> a)+colorFor handle = do+  colorAvailable <- isColorAvailable handle+  return $ if colorAvailable then color else dumb+ where+  dumb :: Color -> Color -> a -> a+  dumb _ _ = id+  color :: Color -> Color -> a -> a+  color bg text v = bgColor bg $ System.Console.Pretty.color text v+++codeStyleFor :: forall a m. (Pretty a, MonadIO m) => Handle -> m (a -> a)+codeStyleFor handle = do+  colorAvailable <- isColorAvailable handle+  return+    $ if colorAvailable+      then style Bold+      else id+++pathStyleFor :: forall m. (MonadIO m) => Handle -> m (OsPath -> Text)+pathStyleFor handle = do+  pathStyle <- pathStyleFor' handle+  return $ \path -> pathStyle $ decodeFS' path+ where+  decodeFS' :: OsPath -> Text+  decodeFS' = pack . unsafePerformIO . decodeFS+++pathStyleFor' :: forall a m. (Pretty a, MonadIO m) => Handle -> m (a -> a)+pathStyleFor' handle = do+  colorAvailable <- isColorAvailable handle+  return+    $ if colorAvailable+      then style Italic+      else id+++printStderr :: (MonadIO m) => Text -> m ()+printStderr = liftIO . hPutStrLn stderr+++data Admonition = Hint | Note | Warning | Error+  deriving (Show, Eq, Ord, Enum, Bounded)+++printStderr' :: (MonadIO m) => Admonition -> Text -> m ()+printStderr' admonition message = do+  color <- colorFor stderr+  printStderr $ color Default color' prefix <> message+ where+  color' :: Color+  color' = case admonition of+    Hint -> Cyan+    Note -> Yellow+    Warning -> Yellow+    Error -> Red+  prefix :: Text+  prefix = showt (FromStringShow admonition) <> ": "+++die' :: (MonadIO m) => ExitCode -> Text -> m a+die' exitCode message = do+  printStderr' Error message+  liftIO $ exitWith exitCode+++dieWithErrors :: (MonadIO m) => ExitCode -> [Text] -> m a+dieWithErrors exitCode errors = do+  forM_ errors $ printStderr' Error+  liftIO $ exitWith exitCode+++printTable :: forall m. (MonadIO m) => [Text] -> [[(Color, Text)]] -> m ()+printTable headers rows = do+  -- Headers are printed to stderr, so that they can be piped to another+  -- program without interfering with the table.+  forM_ (zip headers columnWidths) $ \(header, width) -> do+    putCol stderr Cyan header width+    liftIO $ hPutStr stderr " "+  putLnStderr+  forM_ columnWidths $ \width -> do+    putCol stderr Cyan (replicate width "\x2500") width+    liftIO $ hPutStr stderr " "+  putLnStderr+  forM_ rows $ \row -> do+    forM_ (zip3 row columnWidths [1 ..]) $ \((color', value), width, i) -> do+      putCol stdout color' value+        $ if i < Prelude.length row then width else Data.Text.length value+      liftIO $ putStr " "+    putLn+ where+  valueWidths :: [[Int]]+  valueWidths =+    [Data.Text.length c | c <- headers]+      : [[Data.Text.length v | (_, v) <- row] | row <- rows]+  columnWidths :: [Int]+  columnWidths = map maximum $ transpose valueWidths+  putCol :: Handle -> Color -> Text -> Int -> m ()+  putCol h color' value width = do+    color <- colorFor stdout+    liftIO $ hPutStr h $ color Default color' value+    liftIO $ hPutStr h $ replicate (width - Data.Text.length value) " "+  putLn :: m ()+  putLn = liftIO $ putStrLn mempty+  putLnStderr :: m ()+  putLnStderr = liftIO $ hPutStrLn stderr mempty
+ src/Dojang/Commands/Apply.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Dojang.Commands.Apply (apply) where++import Control.Monad (filterM, forM, forM_, unless, void, when)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Reader (asks)+import Data.Function ((&))+import Data.List (nub, sort)+import System.Exit (ExitCode (..), exitWith)+import System.IO (stderr)+import Prelude hiding (readFile)++import Control.Monad.Logger (logDebugSH)+import Data.Map.Strict (fromList, notMember, toList)+import System.Directory.OsPath (makeAbsolute)+import System.OsPath (OsPath, addTrailingPathSeparator, takeDirectory)++import Dojang.App (App, AppEnv (debug, manifestFile), ensureContext, lookupEnv')+import Dojang.Commands+  ( Admonition (..)+  , codeStyleFor+  , die'+  , pathStyleFor+  , printStderr+  , printStderr'+  )+import Dojang.Commands.Status (defaultStatusOptions, printWarnings, status)+import Dojang.ExitCodes+  ( accidentalDeletionWarning+  , conflictError+  , fileNotRoutedError+  )+import Dojang.MonadFileSystem (MonadFileSystem (..), dryRunIO)+import Dojang.Types.Context+  ( Context (..)+  , FileCorrespondence (..)+  , FileDeltaKind (..)+  , FileEntry (..)+  , FileStat (..)+  , RouteState (..)+  , getRouteState+  , makeCorrespond+  )+++apply :: (MonadFileSystem i, MonadIO i) => Bool -> [OsPath] -> App i ExitCode+apply force filePaths = do+  ctx <- ensureContext+  (allFiles, ws) <- makeCorrespond ctx+  fileMap <- fmap fromList $ forM allFiles $ \fc -> do+    srcAbsPath <- liftIO $ makeAbsolute fc.source.path+    return (srcAbsPath, fc)+  pathStyle <- pathStyleFor stderr+  filePaths' <- forM filePaths $ \fp -> do+    fp' <- liftIO $ makeAbsolute fp+    when (fp' `notMember` fileMap) $ do+      die' fileNotRoutedError+        $ "File "+        <> pathStyle fp+        <> " is not tracked by this repository."+    return fp'+  let files =+        if null filePaths'+          then allFiles+          else+            [ f+            | (srcAbsPath, f) <- toList fileMap+            , srcAbsPath `elem` filePaths'+            ]+  $(logDebugSH) files+  -- Check if there are any conflicts:+  conflicts <- filterConflicts files+  codeStyle <- codeStyleFor stderr+  unless (null conflicts) $ do+    forM_ conflicts $ \c -> do+      printStderr' (if force then Warning else Error)+        $ "There is a conflict between "+        <> pathStyle c.source.path+        <> " and "+        <> pathStyle c.destination.path+        <> "."+    printStderr' Hint+      $ "Use `"+      <> codeStyle "dojang diff"+      <> "' to see the actual changes on both sides."+  -- Check if there are any accidental deletions:+  let ops =+        syncSourceToIntermediate+          [ (fc.source, fc.intermediate, fc.sourceDelta)+          | fc <- files+          ]+          & nub+          . sort+  shimOps <- liftIO $ dryRunIO $ do+    forM_ ops doSyncOp+    let ctx' = Context ctx.repository ctx.environment lookupEnv'+    (files', _) <- makeCorrespond ctx'+    syncIntermediateToDestination+      ctx'+      [ (fc.intermediate, fc.destination, fc.destinationDelta)+      | fc <- files'+      ]+  when (any isDeletion shimOps) $ do+    forM_ shimOps $ \case+      RemoveDirs path -> do+        let path' = addTrailingPathSeparator path+        if force+          then+            printStderr' Warning+              $ "Would delete "+              <> pathStyle path'+              <> " (and its children)."+          else+            printStderr' Error+              $ "Cancelled applying because "+              <> pathStyle path'+              <> " (and its children) would be deleted."+      RemoveFile path -> do+        if force+          then printStderr' Warning ("Would delete " <> pathStyle path <> ".")+          else+            printStderr'+              Error+              $ "Cancelled applying because "+              <> pathStyle path+              <> " would be deleted."+      _ -> return ()+    manifestFile' <- asks (.manifestFile)+    printStderr' Hint+      $ "If these deletions are accidental, ignore them in your manifest ("+      <> pathStyle manifestFile'+      <> ")."+  -- Exit if there are any problems (unless forced):+  when (not force && (not (null conflicts) || any isDeletion shimOps)) $ do+    printStderr' Hint+      $ "Use "+      <> codeStyle "-f"+      <> "/"+      <> codeStyle "--force"+      <> " to ignore these warnings and go ahead."+    liftIO+      $ exitWith+      $ if not (null conflicts)+        then conflictError+        else accidentalDeletionWarning+  -- When everything is fine (or excused):+  debug' <- asks (.debug)+  when debug' (void $ status defaultStatusOptions)+  forM_ ops $ \path -> printSyncOp path >> doSyncOp path+  when debug' (void $ status defaultStatusOptions)+  (files', _) <- makeCorrespond ctx+  $(logDebugSH) files'+  ops' <-+    syncIntermediateToDestination+      ctx+      [ (fc.intermediate, fc.destination, fc.destinationDelta)+      | fc <- files'+      ]+  forM_ (nub $ sort ops') $ \path -> printSyncOp path >> doSyncOp path+  printWarnings ws+  return ExitSuccess+ where+  isDeletion :: SyncOp -> Bool+  isDeletion (RemoveDirs _) = True+  isDeletion (RemoveFile _) = True+  isDeletion _ = False+++-- TODO: This should be in another module:+filterConflicts+  :: (MonadFileSystem i, MonadIO i)+  => [FileCorrespondence]+  -> i [FileCorrespondence]+filterConflicts = filterM $ \c -> case (c.sourceDelta, c.destinationDelta) of+  (Unchanged, _) -> return False+  (_, Unchanged) -> return False+  (Removed, Removed) -> return False+  (Added, Added) -> case (c.source.stat, c.destination.stat) of+    (Directory, Directory) -> return False+    (File srcSize, File dstSize) ->+      if srcSize /= dstSize+        then return True+        else do+          src <- readFile c.source.path+          dst <- readFile c.destination.path+          return (src /= dst)+    _ -> return True+  _ -> return True+++data SyncOp+  = RemoveDirs OsPath+  | RemoveFile OsPath+  | CopyFile OsPath OsPath+  | CreateDir OsPath+  | CreateDirs OsPath+  deriving (Eq, Show)+++syncOpOrdKey :: SyncOp -> (OsPath, Int, OsPath)+syncOpOrdKey (RemoveFile path) = (takeDirectory path, 1, path)+syncOpOrdKey (RemoveDirs path) = (path, 2, path)+syncOpOrdKey (CreateDir path) = (path, 3, path)+syncOpOrdKey (CreateDirs path) = (path, 4, path)+syncOpOrdKey (CopyFile _ dst) = (takeDirectory dst, 5, dst)+++instance Ord SyncOp where+  compare a b = compare (syncOpOrdKey a) (syncOpOrdKey b)+++printSyncOp :: (MonadIO i) => SyncOp -> App i ()+printSyncOp (RemoveDirs path) = do+  pathStyle <- pathStyleFor stderr+  let path' = addTrailingPathSeparator path+  printStderr ("Remove " <> pathStyle path' <> " (and its children)...")+printSyncOp (RemoveFile path) = do+  pathStyle <- pathStyleFor stderr+  printStderr ("Remove " <> pathStyle path <> "...")+printSyncOp (CopyFile src dst) = do+  pathStyle <- pathStyleFor stderr+  printStderr+    ("Copy " <> pathStyle src <> " to " <> pathStyle dst <> "...")+printSyncOp (CreateDir path) = do+  pathStyle <- pathStyleFor stderr+  let path' = addTrailingPathSeparator path+  printStderr ("Create " <> pathStyle path' <> "...")+printSyncOp (CreateDirs path) = do+  pathStyle <- pathStyleFor stderr+  let path' = addTrailingPathSeparator path+  printStderr ("Create " <> pathStyle path' <> " (and its ancestors)...")+++doSyncOp :: (MonadFileSystem i) => SyncOp -> i ()+doSyncOp (RemoveDirs path) = removeDirectoryRecursively path+doSyncOp (RemoveFile path) = removeFile path+doSyncOp (CopyFile src dst) = copyFile src dst+doSyncOp (CreateDir path) = createDirectory path+doSyncOp (CreateDirs path) = createDirectories path+++syncSourceToIntermediate+  :: [(FileEntry, FileEntry, FileDeltaKind)]+  -> [SyncOp]+syncSourceToIntermediate files =+  concat+    [ case delta of+      Unchanged -> []+      Removed ->+        if to.stat == Directory+          then [RemoveDirs to.path]+          else [RemoveFile to.path]+      Modified ->+        case (from.stat, to.stat) of+          (Directory, _) -> [RemoveFile to.path, CreateDir to.path]+          (_, Directory) -> [RemoveDirs to.path, CopyFile from.path to.path]+          _ -> [CopyFile from.path to.path]+      Added ->+        if from.stat == Directory+          then [CreateDirs to.path]+          else [CreateDirs $ takeDirectory to.path, CopyFile from.path to.path]+    | (from, to, delta) <- files+    ]+++syncIntermediateToDestination+  :: (MonadFileSystem i, MonadIO i)+  => Context i+  -> [(FileEntry, FileEntry, FileDeltaKind)]+  -> i [SyncOp]+syncIntermediateToDestination ctx files =+  (fmap concat . sequence)+    [ case delta of+      Unchanged -> return []+      Removed ->+        if from.stat == Directory+          then return [CreateDirs to.path]+          else return [CreateDirs $ takeDirectory to.path, CopyFile from.path to.path]+      Modified ->+        case (from.stat, to.stat) of+          (Directory, _) -> return [RemoveFile to.path, CreateDir to.path]+          (_, Directory) -> return [RemoveDirs to.path, CopyFile from.path to.path]+          _ -> return [CopyFile from.path to.path]+      Added -> do+        (state, _) <- getRouteState ctx to.path+        case state of+          Ignored _ _ -> return []+          _ ->+            if to.stat == Directory+              then return [RemoveDirs to.path]+              else return [RemoveFile to.path]+    | (from, to, delta) <- files+    ]
+ src/Dojang/Commands/Diff.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Dojang.Commands.Diff (DiffMode (..), diff) where++import Control.Monad (filterM, forM, forM_, unless, when)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.List (find, nub)+import Data.Maybe (maybeToList)+import System.Environment (lookupEnv)+import System.Exit (ExitCode (ExitFailure, ExitSuccess), exitWith)+import System.IO (stderr, stdout)+import System.Info (os)+import Prelude hiding (lines, putStrLn, readFile)+import Prelude qualified (putStrLn)++import Data.Algorithm.Diff (getGroupedDiff)+import Data.Algorithm.DiffOutput+  ( DiffOperation (..)+  , LineRange (..)+  , diffToLineRanges+  )+import Data.Text (Text, cons, lines, pack, unpack)+import Data.Text.Encoding (decodeUtf8)+import Data.Text.IO (putStrLn)+import System.Directory.OsPath (makeAbsolute)+import System.OsPath (OsPath)+import System.Process (spawnProcess, waitForProcess)+import TextShow (TextShow (showt))++import Dojang.App (App, ensureContext)+import Dojang.Commands+  ( Admonition (..)+  , Color (..)+  , colorFor+  , die'+  , pathStyleFor+  , pathStyleFor'+  , printStderr'+  )+import Dojang.Commands.Status (printWarnings)+import Dojang.ExitCodes (externalProgramNonZeroExit, fileNotRoutedError)+import Dojang.MonadFileSystem (MonadFileSystem (..))+import Dojang.Types.Context+  ( FileCorrespondence (..)+  , FileDeltaKind (..)+  , FileEntry (..)+  , FileStat (..)+  , makeCorrespond+  )+++data DiffMode = Both | Source | Destination deriving (Show)+++diff+  :: (MonadFileSystem i, MonadIO i)+  => DiffMode+  -> Maybe OsPath+  -> [OsPath]+  -> App i ExitCode+diff mode diffProgram files = do+  ctx <- ensureContext+  (corresponds, ws) <- makeCorrespond ctx+  routedFiles <- forM corresponds $ \c -> do+    sourcePath <- liftIO $ makeAbsolute c.source.path+    destinationPath <- liftIO $ makeAbsolute c.destination.path+    return (sourcePath, destinationPath)+  pathStyle <- pathStyleFor stderr+  nonExistents <- (`filterM` files) $ \file -> do+    file' <- liftIO $ makeAbsolute file+    if any (\(src, dst) -> file' == src || file' == dst) routedFiles+      then return False+      else do+        printWarnings ws+        printStderr' Error $ pathStyle file <> " is not a routed file."+        return True+  unless (null nonExistents) $ do+    printWarnings ws+    liftIO $ exitWith fileNotRoutedError+  files' <-+    nub <$> case files of+      [] -> return corresponds+      _ -> do+        fs <- forM files $ \file -> do+          file' <- liftIO $ makeAbsolute file+          let found =+                find (\((src, dst), _) -> file' == src || file' == dst)+                  $ zip routedFiles corresponds+          return $ maybeToList $ fmap snd found+        return $ concat fs+  case mode of+    Source -> twoWay diffProgram (.source) (.intermediate) files'+    Destination -> twoWay diffProgram (.destination) (.intermediate) files'+    Both -> twoWay diffProgram (.source) (.destination) files'+  printWarnings ws+  return ExitSuccess+++nullPath :: FilePath+nullPath = if os == "mingw32" then "NUL" else "/dev/null"+++getPath :: (MonadFileSystem m) => FileEntry -> m FilePath+getPath entry = case entry.stat of+  Missing -> return nullPath+  Directory -> return nullPath+  _ -> decodePath entry.path+++twoWay+  :: (MonadFileSystem i, MonadIO i)+  => Maybe OsPath+  -> (FileCorrespondence -> FileEntry)+  -> (FileCorrespondence -> FileEntry)+  -> [FileCorrespondence]+  -> App i ()+twoWay program' srcSelector dstSelector files = do+  program <- case program' of+    Just p -> Just <$> decodePath p+    Nothing -> liftIO $ lookupEnv "DOJANG_DIFF"+  forM_ files $ \file -> when (hasChange file) $ do+    let src = srcSelector file+    let dst = dstSelector file+    case program of+      Nothing -> do+        builtinDiff src dst+      Just prog -> do+        srcPath <- getPath src+        dstPath <- getPath dst+        handle <- liftIO $ spawnProcess prog [srcPath, dstPath]+        exitCode <- liftIO $ waitForProcess handle+        when (exitCode /= ExitSuccess && exitCode /= ExitFailure 1) $ do+          cmdStyle <- pathStyleFor' stderr+          die' externalProgramNonZeroExit+            $ cmdStyle (pack prog)+            <> " terminated with exit code "+            <> showt exitCode+            <> "."+++hasChange :: FileCorrespondence -> Bool+hasChange c = case (c.sourceDelta, c.destinationDelta) of+  (Unchanged, Unchanged) -> False+  _ -> True+++builtinDiff+  :: forall i. (MonadFileSystem i, MonadIO i) => FileEntry -> FileEntry -> App i ()+builtinDiff a b = do+  color <- colorFor stdout+  color' <- colorFor stdout+  pathStyle <- pathStyleFor stdout+  liftIO $ putStrLn $ color Default Red "--- " <> pathStyle a.path <> case a.stat of+    Missing -> " (missing)"+    Directory -> " (directory)"+    _ -> ""+  liftIO $ putStrLn $ color Default Green "+++ " <> pathStyle b.path <> case b.stat of+    Missing -> " (missing)"+    Directory -> " (directory)"+    _ -> ""+  textA <- readFileEntry a+  textB <- readFileEntry b+  let linesA = lines textA+  let linesB = lines textB+  let diffOps =+        diffToLineRanges+          $ getGroupedDiff (unpack <$> linesA) (unpack <$> linesB)+  forM_ diffOps $ \op -> liftIO $ do+    case op of+      Deletion aRange bOffset -> do+        let ( addRange+              , delRange+              , (headOffset, headLines)+              , (tailOffset, tailLines)+              ) = calcRange linesB (bOffset + 1, bOffset) linesA aRange.lrNumbers+        printRange delRange addRange+        forM_ (take headLines (drop headOffset linesB)) $ \line ->+          putStrLn $ ' ' `cons` line+        forM_ aRange.lrContents $ \line ->+          Prelude.putStrLn $ color' Default Red ('-' : line)+        forM_ (take tailLines (drop tailOffset linesB)) $ \line ->+          putStrLn $ ' ' `cons` line+      Addition bRange aOffset -> do+        let ( addRange+              , delRange+              , (headOffset, headLines)+              , (tailOffset, tailLines)+              ) = calcRange linesB bRange.lrNumbers linesA (aOffset + 1, aOffset)+        printRange delRange addRange+        forM_ (take headLines (drop headOffset linesB)) $ \line ->+          putStrLn $ ' ' `cons` line+        forM_ bRange.lrContents $ \line ->+          Prelude.putStrLn $ color' Default Green ('+' : line)+        forM_ (take tailLines (drop tailOffset linesB)) $ \line ->+          putStrLn $ ' ' `cons` line+      Change aRange bRange -> do+        let ( addRange+              , delRange+              , (headOffset, headLines)+              , (tailOffset, tailLines)+              ) = calcRange linesB bRange.lrNumbers linesA aRange.lrNumbers+        printRange delRange addRange+        forM_ (take headLines (drop headOffset linesB)) $ \line ->+          putStrLn $ ' ' `cons` line+        forM_ aRange.lrContents $ \line ->+          Prelude.putStrLn $ color' Default Red ('-' : line)+        forM_ bRange.lrContents $ \line ->+          Prelude.putStrLn $ color' Default Green ('+' : line)+        forM_ (take tailLines (drop tailOffset linesB)) $ \line ->+          putStrLn $ ' ' `cons` line+ where+  context :: Int+  context = 3+  calcRange+    :: [Text]+    -> (Int, Int)+    -> [Text]+    -> (Int, Int)+    -> ((Int, Int), (Int, Int), (Int, Int), (Int, Int))+  calcRange addContentLines (addBegin, addEnd) delContentLines (delBegin, delEnd) =+    let headOffset = max 0 (addBegin - 1 - context)+        headLines = min context (addBegin - 1 - headOffset)+        tailOffset = addEnd+        tailLines = min context (length addContentLines - tailOffset)+        addOffset =+          min (length addContentLines) (1 + max 0 (addBegin - 1 - context))+        addLines =+          min+            (length addContentLines)+            (addEnd - (addBegin - 1) + headLines + tailLines)+        delOffset =+          min (length delContentLines) (1 + max 0 (delBegin - 1 - context))+        delLines =+          min+            (length delContentLines)+            (delEnd - (delBegin - 1) + headLines + tailLines)+    in ( (addOffset, addLines)+       , (delOffset, delLines)+       , (headOffset, headLines)+       , (tailOffset, tailLines)+       )+  printRange :: (Int, Int) -> (Int, Int) -> IO ()+  printRange (delOffset, delLines) (addOffset, addLines) = do+    color <- colorFor stdout+    putStrLn+      $ color Default Cyan+      $ "@@ -"+      <> showt delOffset+      <> ","+      <> showt delLines+      <> " +"+      <> showt addOffset+      <> ","+      <> showt addLines+      <> " @@"+  readFileEntry :: FileEntry -> App i Text+  readFileEntry entry = case entry.stat of+    Missing -> return ""+    Directory -> return ""+    _ ->+      -- FIXME: It is assuming that the file is encoded in UTF-8, but it is not+      --        always the case:+      decodeUtf8 <$> readFile entry.path
+ src/Dojang/Commands/Env.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoFieldSelectors #-}++module Dojang.Commands.Env (env) where++import Control.Monad.IO.Class (MonadIO (liftIO))+import System.Exit (ExitCode (..))+import Prelude hiding (putStr)++import Control.Monad.Except (MonadError (..))+import Control.Monad.Logger (logDebugSH, logError)+import Data.Text.IO (putStr)+import Options.Applicative.Path (hyphen)+import System.OsPath (OsPath)+import TextShow (TextShow (showt))++import Dojang.App (App, currentEnvironment')+import Dojang.ExitCodes (fileWriteError)+import Dojang.MonadFileSystem (MonadFileSystem)+import Dojang.Syntax.Env (writeEnvFile, writeEnvironment)+import Dojang.Types.Environment.Current (MonadEnvironment (..))+++env :: (MonadFileSystem i, MonadIO i) => Bool -> OsPath -> App i ExitCode+env ignoreEnvFile outputPath = do+  currentEnv <-+    if ignoreEnvFile then liftIO currentEnvironment else currentEnvironment'+  $(logDebugSH) currentEnv+  if outputPath == hyphen+    then do+      liftIO $ putStr $ writeEnvironment currentEnv+      return ExitSuccess+    else+      ( do+          () <- writeEnvFile currentEnv outputPath+          return ExitSuccess+      )+        `catchError` \err -> do+          $(logError) $ showt err+          return fileWriteError
+ src/Dojang/Commands/Init.hs view
@@ -0,0 +1,407 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoFieldSelectors #-}++module Dojang.Commands.Init+  ( InitPreset (..)+  , init+  , initPresetName+  ) where++import Control.Monad (forM_, when)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.Function ((&))+import Data.List (maximumBy, sortOn)+import Data.List.NonEmpty as NonEmpty (NonEmpty ((:|)), toList)+import Data.Ord (comparing)+import Data.String (IsString)+import System.Exit (ExitCode (..), exitWith)+import System.IO (stderr)+import System.IO.Unsafe (unsafePerformIO)+import System.Info qualified (os)+import Prelude hiding (init)++import Control.Monad.Logger (logDebugSH, logInfo)+import Control.Monad.Reader (asks)+import Data.HashMap.Strict qualified as HashMap+  ( filterWithKey+  , lookup+  , member+  , toList+  )+import Data.Map.Strict+  ( Map+  , findWithDefault+  , fromList+  , fromListWith+  , keys+  , toAscList+  , (!)+  )+import Data.Map.Strict qualified as Map (toList)+import Data.Set (Set)+import Data.Set qualified as Set (member, null, toAscList)+import Data.Text (Text, lines, unlines)+import FortyTwo.Prompts.Multiselect (multiselect)+import System.FilePattern (FilePattern)+import System.OsPath (OsPath, encodeFS, (</>))++import Dojang.App+  ( App+  , AppEnv (debug, dryRun, sourceDirectory)+  , doesManifestExist+  , saveManifest+  )+import Dojang.Commands+  ( Admonition (..)+  , codeStyleFor+  , die'+  , pathStyleFor+  , printStderr+  , printStderr'+  )+import Dojang.ExitCodes (manifestAlreadyExists, unsupportedOnEnvError)+import Dojang.MonadFileSystem (FileType (..), MonadFileSystem (..))+import Dojang.Syntax.Manifest.Writer (writeManifest)+import Dojang.Types.Environment+  ( Architecture (..)+  , Environment (..)+  , Kernel (..)+  , OperatingSystem (..)+  )+import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (..))+import Dojang.Types.EnvironmentPredicate.Evaluate (evaluate)+import Dojang.Types.EnvironmentPredicate.Specificity (specificity)+import Dojang.Types.FilePathExpression (FilePathExpression (..), (+/+))+import Dojang.Types.FileRoute (FileRoute (fileType), fileRoute)+import Dojang.Types.FileRouteMap (FileRouteMap)+import Dojang.Types.Manifest (Manifest (..))+import Dojang.Types.MonikerMap (MonikerMap)+import Dojang.Types.MonikerName (MonikerName, parseMonikerName)+++data InitPreset+  = Amd64Linux+  | Arm64Linux+  | AppleSiliconMac+  | IntelMac+  | Win64+  | WinArm64+  | Wsl2+  deriving (Show, Eq, Ord, Enum, Bounded)+++initPresetName :: (IsString a) => InitPreset -> a+initPresetName = \case+  Amd64Linux -> "Linux (AMD64)"+  Arm64Linux -> "Linux (ARM64)"+  AppleSiliconMac -> "Apple silicon Mac (M series)"+  IntelMac -> "Intel Mac"+  Win64 -> "Windows (64-bit)"+  WinArm64 -> "Windows (ARM64)"+  Wsl2 -> "Linux (WSL2)"+++toEnvironment :: InitPreset -> Environment+toEnvironment = \case+  Amd64Linux -> Environment Linux X86_64 (Kernel "Linux" "0.0.0.0")+  Arm64Linux -> Environment Linux AArch64 (Kernel "Linux" "0.0.0.0")+  AppleSiliconMac -> Environment MacOS AArch64 (Kernel "Darwin" "0.0.0")+  IntelMac -> Environment MacOS X86_64 (Kernel "Darwin" "0.0.0")+  Win64 -> Environment Windows X86_64 (Kernel "Windows" "0.0.0.0")+  WinArm64 -> Environment Windows AArch64 (Kernel "Windows" "0.0.0.0")+  Wsl2 ->+    Environment+      Linux+      X86_64+      (Kernel "Linux" "0.0.0.0-microsoft-standard-WSL2")+++monikers :: MonikerMap+monikers =+  [ (moniker "linux", OperatingSystem Linux)+  , (moniker "macos", OperatingSystem MacOS)+  , (moniker "windows", OperatingSystem Windows)+  , (moniker "posix", Or [OperatingSystem Linux, OperatingSystem MacOS])+  , (moniker "linux-amd64", And [OperatingSystem Linux, Architecture X86_64])+  , (moniker "linux-arm64", And [OperatingSystem Linux, Architecture AArch64])+  , (moniker "macos-intel", And [OperatingSystem MacOS, Architecture X86_64])+  ,+    ( moniker "macos-apple-silicon"+    , And [OperatingSystem MacOS, Architecture AArch64]+    )+  ,+    ( moniker "windows-amd64"+    , And [OperatingSystem Windows, Architecture X86_64]+    )+  ,+    ( moniker "windows-arm64"+    , And [OperatingSystem Windows, Architecture AArch64]+    )+  ,+    ( moniker "linux-wsl"+    , And+        [ OperatingSystem Linux+        , KernelReleaseSuffix "-microsoft-standard-WSL2"+        ]+    )+  ]+++moniker :: Text -> MonikerName+moniker name = case parseMonikerName name of+  Right n -> n+  Left _ -> error $ "Invalid moniker name: " <> show name+++selectMonikers :: Environment -> [MonikerName]+selectMonikers env =+  [ (name, predicate)+  | (name, predicate) <- HashMap.toList monikers+  , fst $ evaluate env monikers predicate+  ]+    & sortOn (specificity (`HashMap.lookup` monikers) . snd)+    & map fst+++listNeededMonikers :: [InitPreset] -> [(InitPreset, NonEmpty MonikerName)]+listNeededMonikers presets =+  [ (preset, head ms' :| tail ms')+  | (preset, ms) <- selectedMonikers+  , let (havingDups, notHavingDups) = span (hasDuplicateMonikers preset) ms+  , let ms' = havingDups ++ take 1 notHavingDups+  , not $ null ms'+  ]+ where+  selectedMonikers :: [(InitPreset, [MonikerName])]+  selectedMonikers =+    [(preset, selectMonikers $ toEnvironment preset) | preset <- presets]+  hasDuplicateMonikers :: InitPreset -> MonikerName -> Bool+  hasDuplicateMonikers preset moniker' =+    (not . null)+      [ True+      | (p, ms) <- selectedMonikers+      , p /= preset+      , m <- ms+      , m == moniker'+      ]+++path :: String -> OsPath+path = unsafePerformIO . encodeFS+++routes+  :: Map OsPath ([(Set MonikerName, FilePathExpression)], Set OperatingSystem)+routes =+  [+    ( path "HOME"+    ,+      (+        [ ([moniker "posix", moniker "linux", moniker "macos"], posixHome)+        , ([moniker "windows"], windowsUserProfile)+        ]+      , [Linux, MacOS, Linux]+      )+    )+  ,+    ( path "XDG_CONFIG_HOME"+    ,+      (+        [+          ( [moniker "posix", moniker "linux", moniker "macos"]+          , posixXdgConfigHome+          )+        , ([moniker "windows"], windowsXdgConfigHome)+        ]+      , [Linux, MacOS]+      )+    )+  ,+    ( path "Application Support"+    ,+      (+        [ ([moniker "macos"], macosApplicationSupport)+        , ([moniker "linux"], posixXdgConfigHome)+        , ([moniker "windows"], windowsAppData)+        ]+      , [MacOS]+      )+    )+  ,+    ( path "AppData"+    ,+      (+        [ ([moniker "windows"], windowsAppData)+        ,+          ( [moniker "posix", moniker "linux", moniker "macos"]+          , posixXdgConfigHome+          )+        ]+      , [Windows]+      )+    )+  ]+++ignorePatterns' :: Map OsPath [FilePattern]+ignorePatterns' =+  [ (path "HOME", ["*"])+  , (path "Application Support", ["*"])+  , (path "AppData", ["*"])+  ]+++makeRouteMap+  :: [(InitPreset, NonEmpty MonikerName)] -> MonikerMap -> FileRouteMap+makeRouteMap neededMonikers monikers' =+  fromList+    [ (path', fileRoute monikers' (makePairs route) Directory)+    | (path', (route, requiredOses)) <- Map.toList routes+    , any+        ((`Set.member` requiredOses) . (.operatingSystem) . toEnvironment . fst)+        neededMonikers+    ]+ where+  monikerScoreTable :: Map MonikerName Int+  monikerScoreTable =+    fromListWith (+)+      $ zip (concatMap (NonEmpty.toList . snd) neededMonikers) [1, 1 ..]+  makePairs+    :: [(Set MonikerName, FilePathExpression)]+    -> [(MonikerName, Maybe FilePathExpression)]+  makePairs route =+    [ ( maximumBy+          ( comparing $ \k ->+              ( findWithDefault 0 k monikerScoreTable+              , specificity (`HashMap.lookup` monikers') $ Moniker k+              )+          )+          (Set.toAscList names)+      , Just expr+      )+    | (names, expr) <- route+    , not $ Set.null names+    , any (`HashMap.member` monikers') $ Set.toAscList names+    ]+++makeManifest :: [InitPreset] -> Manifest+makeManifest presets =+  Manifest monikers' routeMap+    $ fromList+      [ (p, ignores)+      | p <- keys routeMap+      , let ignores = findWithDefault [] p ignorePatterns'+      , not $ null ignores+      ]+ where+  neededMonikers :: [(InitPreset, NonEmpty MonikerName)]+  neededMonikers = listNeededMonikers presets+  monikers' :: MonikerMap+  monikers' =+    monikers+      & HashMap.filterWithKey+        ( \k _ ->+            k `elem` [m | (_, ms) <- neededMonikers, m <- NonEmpty.toList ms]+        )+  routeMap :: FileRouteMap+  routeMap = makeRouteMap neededMonikers monikers'+++init :: (MonadFileSystem i, MonadIO i) => [InitPreset] -> Bool -> App i ExitCode+init presets noInteractive = do+  manifestExists <- doesManifestExist+  when manifestExists $ do+    die' manifestAlreadyExists "Manifest already exists."+  $(logInfo) "No manifest found."+  when (System.Info.os == "mingw32" && not noInteractive) $ do+    codeStyle <- codeStyleFor stderr+    printStderr' Error+      $ "We are sorry, but interactive mode is currently not supported on "+      <> "Windows.  See the relevant issue:\n"+      <> "\n  https://github.com/dahlia/dojang/issues/4\n"+    printStderr' Hint+      $ ("Please use the " <> codeStyle "--linux-*" <> "/")+      <> (codeStyle "--macos-*" <> "/" <> codeStyle "--windows-*")+      <> " options with the "+      <> (codeStyle "-I" <> "/" <> codeStyle "--no-interactive")+      <> " flag.  See also "+      <> (codeStyle "-h" <> "/" <> codeStyle "--help")+      <> " for command-line options."+    liftIO $ exitWith unsupportedOnEnvError+  presets' <-+    if null presets && not noInteractive+      then askPresets+      else pure presets+  $(logDebugSH) presets'+  let manifest = makeManifest presets'+  repoDir <- asks (.sourceDirectory)+  pathStyle <- pathStyleFor stderr+  forM_ (Data.Map.Strict.toAscList manifest.fileRoutes) $ \(path', route') -> do+    when (route'.fileType == Directory) $ do+      let dirPath = repoDir </> path'+      createDirectories dirPath+      printStderr $ "Directory created: " <> pathStyle dirPath <> "."+  filename <- saveManifest manifest+  printStderr $ "Manifest created: " <> pathStyle filename <> "."+  debug' <- asks (.debug)+  dryRun' <- asks (.dryRun)+  when (debug' || dryRun') $ do+    let manifestText = indent $ writeManifest manifest+    printStderr' Note+      $ "The manifest file looks like below:\n\n"+      <> manifestText+      <> "\n"+  return ExitSuccess+++posixHome :: FilePathExpression+posixHome = Substitution "HOME"+++windowsUserProfile :: FilePathExpression+windowsUserProfile = Substitution "UserProfile"+++posixXdgConfigHome :: FilePathExpression+posixXdgConfigHome =+  SubstitutionWithDefault "XDG_CONFIG_HOME" $ posixHome +/+ ".config"+++windowsXdgConfigHome :: FilePathExpression+windowsXdgConfigHome =+  SubstitutionWithDefault "XDG_CONFIG_HOME" $ windowsUserProfile +/+ ".config"+++macosApplicationSupport :: FilePathExpression+macosApplicationSupport =+  Substitution "HOME" +/+ "Library" +/+ "Application Support"+++windowsAppData :: FilePathExpression+windowsAppData = Substitution "AppData"+++askPresets :: (MonadIO i) => App i [InitPreset]+askPresets = do+  -- FIXME: It doesn't seem to work on Windows...+  -- https://github.com/GianlucaGuarini/fortytwo/issues/7+  presets <-+    multiselect+      "What operating systems and architectures do you use?"+      (map initPresetName [minBound .. maxBound])+  return [namesToPresets ! name | name <- presets]+ where+  namesToPresets :: Map String InitPreset+  namesToPresets =+    fromList+      [(initPresetName preset, preset) | preset <- [minBound .. maxBound]]+++indent :: Text -> Text+indent = Data.Text.unlines . map ("  " <>) . Data.Text.lines
+ src/Dojang/Commands/Reflect.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Dojang.Commands.Reflect (reflect) where++import Control.Monad (filterM, forM, forM_, unless)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.List (isPrefixOf, nub)+import System.Exit (ExitCode (..), exitWith)+import System.IO (stderr)++import Control.Monad.Logger (logDebug, logDebugSH)+import Control.Monad.Reader (asks)+import Data.Text (pack)+import System.Directory.OsPath (makeAbsolute)+import System.OsPath (OsPath, splitDirectories, takeDirectory)++import Dojang.App (App, AppEnv (manifestFile), ensureContext)+import Dojang.Commands+  ( Admonition (..)+  , codeStyleFor+  , die'+  , dieWithErrors+  , pathStyleFor+  , printStderr+  , printStderr'+  )+import Dojang.Commands.Status (printWarnings)+import Dojang.ExitCodes+  ( fileNotFoundError+  , fileNotRoutedError+  , ignoredFileError+  , sourceCannotBeTargetError+  )+import Dojang.MonadFileSystem (MonadFileSystem (..))+import Dojang.Types.Context+  ( Context (..)+  , FileCorrespondence (..)+  , FileDeltaKind (..)+  , FileEntry (..)+  , FileStat (..)+  , RouteState (..)+  , getRouteState+  , makeCorrespondWithDestination+  )+import Dojang.Types.Repository (Repository (..))+++reflect+  :: (MonadFileSystem i, MonadIO i) => Bool -> [OsPath] -> App i ExitCode+reflect force paths = do+  ctx <- ensureContext+  nonExistents <- filterM (fmap not . exists) paths+  pathStyle <- pathStyleFor stderr+  unless (null nonExistents) $ do+    dieWithErrors+      fileNotFoundError+      ["No such file: " <> pathStyle p <> "." | p <- nonExistents]+  absPaths <- liftIO $ mapM makeAbsolute paths+  $(logDebugSH) (absPaths :: [OsPath])+  sourcePath' <- liftIO $ makeAbsolute ctx.repository.sourcePath+  let sourcePathPrefix = splitDirectories sourcePath'+  $(logDebugSH) sourcePathPrefix+  let overlappedPaths =+        [ p+        | p <- absPaths+        , sourcePathPrefix `isPrefixOf` splitDirectories p+        ]+  $(logDebugSH) overlappedPaths+  unless (null overlappedPaths) $ do+    dieWithErrors+      sourceCannotBeTargetError+      [ "Cannot reflect "+        <> pathStyle p+        <> " because it is a file inside the repository."+      | p <- overlappedPaths+      ]+  codeStyle <- codeStyleFor stderr+  warningLists <- forM absPaths $ \absPath -> do+    (state, ws) <- getRouteState ctx absPath+    case state of+      NotRouted -> do+        manifestFile' <- asks (.manifestFile)+        printWarnings ws+        printStderr'+          Error+          ("File " <> pathStyle absPath <> " is not routed.")+        printStderr'+          Hint+          ("Add a route for it in " <> pathStyle manifestFile' <> ".")+        liftIO $ exitWith fileNotRoutedError+      Routed _ -> do+        return ws+      Ignored name pattern -> do+        routeName' <- decodePath name+        if force+          then do+            printStderr' Note+              $ "File "+              <> pathStyle absPath+              <> " is ignored due to pattern "+              <> codeStyle (pack $ show pattern)+              <> " (route name: "+              <> codeStyle (pack routeName')+              <> "), but reflect it anyway as you enforced it using "+              <> codeStyle "-f"+              <> "/"+              <> codeStyle "--force"+              <> " option."+            return ws+          else do+            printWarnings ws+            printStderr' Error+              $ "File "+              <> pathStyle absPath+              <> " is ignored due to pattern "+              <> codeStyle (pack $ show pattern)+              <> " (route name: "+              <> codeStyle (pack routeName')+              <> ")."+            printStderr'+              Hint+              $ "You can reflect it anyway by enforcing it using "+              <> codeStyle "-f"+              <> "/"+              <> codeStyle "--force"+              <> " option."+            liftIO $ exitWith ignoredFileError+  files <- forM absPaths $ \p -> do+    (f, ws) <- makeCorrespondWithDestination ctx p+    printWarnings $ nub ws+    case f of+      Nothing ->+        die' fileNotRoutedError ("File " <> pathStyle p <> " is not routed.")+      Just c -> return c+  let conflicts = filterConflicts files+  $(logDebugSH) conflicts+  unless (force || null conflicts) $ do+    printWarnings $ nub $ concat warningLists+    dieWithErrors+      sourceCannotBeTargetError+      [ "Cannot reflect "+        <> pathStyle c.destination.path+        <> ", since "+        <> pathStyle c.source.path+        <> " is also changed."+      | c <- conflicts+      ]+  forM_ files $ \c -> do+    if c.sourceDelta == Unchanged && c.destinationDelta == Unchanged+      then+        printStderr'+          Note+          ( "File "+              <> pathStyle c.destination.path+              <> " is skipped, since it is the same as file "+              <> pathStyle c.source.path+              <> "."+          )+      else do+        printStderr+          $ "Reflect "+          <> pathStyle c.destination.path+          <> " to "+          <> pathStyle c.source.path+          <> "..."+        cleanup c.intermediate+        copy c.destination c.intermediate+        cleanup c.source+        copy c.intermediate c.source+  printWarnings $ nub $ concat warningLists+  return ExitSuccess+++cleanup :: (MonadFileSystem i, MonadIO i) => FileEntry -> App i ()+cleanup fileEntry = do+  path <- decodePath fileEntry.path+  case fileEntry.stat of+    Missing -> return ()+    Directory -> do+      $(logDebug) $ "Remove directory recursively: " <> pack path+      removeDirectoryRecursively fileEntry.path+    _ -> do+      $(logDebug) $ "Remove file: " <> pack path+      removeFile fileEntry.path+++copy :: (MonadFileSystem i, MonadIO i) => FileEntry -> FileEntry -> App i ()+copy from to = do+  from' <- decodePath from.path+  to' <- decodePath to.path+  case from.stat of+    Directory -> do+      $(logDebug) $ "Create directory recursively: " <> pack to'+      createDirectories to.path+    _ -> do+      let parent = takeDirectory to.path+      parent' <- decodePath parent+      $(logDebug) $ "Create directory recursively: " <> pack parent'+      createDirectories parent+      $(logDebug) $ "Copy file: " <> pack from' <> " -> " <> pack to'+      copyFile from.path to.path+++filterConflicts+  :: [FileCorrespondence]+  -> [FileCorrespondence]+filterConflicts corresponds = [c | c <- corresponds, c.sourceDelta /= Unchanged]
+ src/Dojang/Commands/Status.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++module Dojang.Commands.Status+  ( StatusOptions (..)+  , defaultStatusOptions+  , formatWarning+  , printWarnings+  , status+  ) where++import Control.Monad (forM, forM_)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.List.NonEmpty (NonEmpty ((:|)), toList)+import System.Exit (ExitCode (..))+import System.IO (Handle, stderr)++import Data.CaseInsensitive (original)+import Data.Text (Text, intercalate, pack)+import System.Console.Pretty (Color (..))+import System.Directory.OsPath (makeAbsolute)+import System.OsPath (addTrailingPathSeparator, makeRelative)+import TextShow (FromStringShow (FromStringShow), TextShow (showt))++import Dojang.App (App, ensureContext)+import Dojang.Commands+  ( Admonition (..)+  , codeStyleFor+  , pathStyleFor+  , printStderr'+  , printTable+  )+import Dojang.MonadFileSystem (MonadFileSystem (..))+import Dojang.Types.Context+  ( Context (..)+  , FileCorrespondence (..)+  , FileDeltaKind (..)+  , FileEntry (..)+  , FileStat (..)+  , makeCorrespond+  )+import Dojang.Types.EnvironmentPredicate.Evaluate (EvaluationWarning (..))+import Dojang.Types.FilePathExpression.Expansion (ExpansionWarning (..))+import Dojang.Types.MonikerName ()+import Dojang.Types.Repository (Repository (..), RouteMapWarning (..))+++data StatusOptions = StatusOptions+  { noTrailingSlash :: Bool+  , onlyChanges :: Bool+  , showDestinationPath :: Bool+  }+  deriving (Show)+++defaultStatusOptions :: StatusOptions+defaultStatusOptions =+  StatusOptions+    { noTrailingSlash = False+    , onlyChanges = False+    , showDestinationPath = False+    }+++status :: (MonadFileSystem i, MonadIO i) => StatusOptions -> App i ExitCode+status options = do+  ctx <- ensureContext+  (files, ws) <- makeCorrespond ctx+  let files' = if options.onlyChanges then filter isChanged files else files+  sourcePath <- liftIO $ makeAbsolute ctx.repository.sourcePath+  rows <- forM files' $ \file -> do+    displayPath <-+      if options.showDestinationPath+        then liftIO $ makeAbsolute file.destination.path+        else do+          path <- liftIO $ makeAbsolute file.source.path+          return $ makeRelative sourcePath path+    let displayPathS =+          if not options.noTrailingSlash+            && ( (file.source.stat == Directory)+                  || (file.source.stat == Missing)+                  && (file.destination.stat == Directory)+               )+            then addTrailingPathSeparator displayPath+            else displayPath+    displayPathFP <- decodePath displayPathS+    return+      [ renderDeltaKind file.sourceDelta+      , renderFileStat file.source.stat+      , renderDeltaKind file.destinationDelta+      , renderFileStat file.destination.stat+      , (Default, pack displayPathFP)+      ]+  printTable+    [ "Source"+    , "ST"+    , "Destination"+    , "DT"+    , if options.showDestinationPath then "Destination File" else "Source File"+    ]+    rows+  printWarnings ws+  return ExitSuccess+++isChanged :: FileCorrespondence -> Bool+isChanged file =+  file.sourceDelta /= Unchanged || file.destinationDelta /= Unchanged+++renderDeltaKind :: FileDeltaKind -> (Color, Text)+renderDeltaKind Unchanged = (Default, "unchanged")+renderDeltaKind Added = (Green, "added")+renderDeltaKind Removed = (Red, "removed")+renderDeltaKind Modified = (Yellow, "modified")+++renderFileStat :: FileStat -> (Color, Text)+renderFileStat Missing = (Red, "-")+renderFileStat Directory = (Default, "D")+renderFileStat (File _) = (Default, "F")+renderFileStat (Symlink _) = (Default, "L")+++-- TODO: This should be in a separate module:+formatWarning :: (MonadIO i) => Handle -> RouteMapWarning -> i Text+formatWarning handle (EnvironmentPredicateWarning w) = do+  codeStyle <- codeStyleFor handle+  case w of+    (UndefinedMoniker moniker) ->+      return+        $ "Reference to an undefined moniker: "+        <> codeStyle (original moniker.name)+        <> "."+    (UnrecognizedOperatingSystem os) ->+      return+        $ "Unrecognized operating system: "+        <> codeStyle (showt $ FromStringShow os)+        <> "."+    (UnrecognizedArchitecture arch) ->+      return+        $ "Unrecognized architecture: "+        <> codeStyle (showt $ FromStringShow arch)+        <> "."+formatWarning handle (FilePathExpressionWarning (UndefinedEnvironmentVariable envVar)) = do+  codeStyle <- codeStyleFor handle+  return+    $ "Reference to an undefined environment variable: "+    <> codeStyle envVar+    <> "."+formatWarning handle (OverlapDestinationPathsWarning name dst paths) = do+  pathStyle <- pathStyleFor handle+  pairStrings <- forM paths $ \(from, to) -> do+    return $ pathStyle from <> " -> " <> pathStyle to+  case pairStrings of+    pairString :| [] ->+      return+        $ pathStyle name+        <> " -> "+        <> pathStyle dst+        <> " overlaps with: "+        <> pairString+        <> "."+    _ ->+      return+        $ pathStyle name+        <> " -> "+        <> pathStyle dst+        <> " overlaps with:\n  "+        <> intercalate "\n  " (toList pairStrings)+++-- TODO: This should be in a separate module:+printWarnings :: (MonadIO i) => [RouteMapWarning] -> App i ()+printWarnings ws =+  forM_ ws $ \w -> do+    formatted <- formatWarning stderr w+    printStderr' Warning formatted
+ src/Dojang/ExitCodes.hs view
@@ -0,0 +1,69 @@+{-# OPTIONS_GHC -Wno-missing-export-lists #-}++module Dojang.ExitCodes where++import System.Exit (ExitCode (..))+++unhandledError :: ExitCode+unhandledError = ExitFailure $ -1+++cliError :: ExitCode+cliError = ExitFailure 1+++fileWriteError :: ExitCode+fileWriteError = ExitFailure 2+++fileNotFoundError :: ExitCode+fileNotFoundError = ExitFailure 3+++externalProgramNonZeroExit :: ExitCode+externalProgramNonZeroExit = ExitFailure 4+++unsupportedOnEnvError :: ExitCode+unsupportedOnEnvError = ExitFailure 9+++manifestUninitialized :: ExitCode+manifestUninitialized = ExitFailure 10+++manifestReadError :: ExitCode+manifestReadError = ExitFailure 11+++manifestAlreadyExists :: ExitCode+manifestAlreadyExists = ExitFailure 12+++noEnvFile :: ExitCode+noEnvFile = ExitFailure 20+++envFileReadError :: ExitCode+envFileReadError = ExitFailure 21+++conflictError :: ExitCode+conflictError = ExitFailure 30+++sourceCannotBeTargetError :: ExitCode+sourceCannotBeTargetError = ExitFailure 31+++fileNotRoutedError :: ExitCode+fileNotRoutedError = ExitFailure 32+++ignoredFileError :: ExitCode+ignoredFileError = ExitFailure 33+++accidentalDeletionWarning :: ExitCode+accidentalDeletionWarning = ExitFailure 34
+ src/Dojang/MonadFileSystem.hs view
@@ -0,0 +1,839 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE InstanceSigs #-}++module Dojang.MonadFileSystem+  ( DryRunIO+  , FileType (..)+  , MonadFileSystem (..)+  , dryRunIO+  , dryRunIO'+  , tryDryRunIO+  ) where++import Control.Concurrent (threadDelay)+import Control.Monad (forM, forM_, unless, when)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.List (inits, isPrefixOf, sort, sortOn)+import Data.List.NonEmpty (NonEmpty ((:|)), filter, singleton, toList)+import Data.Ord (Down (Down))+import GHC.IO.Exception (IOErrorType (InappropriateType))+import GHC.Stack (HasCallStack)+import System.IO.Error+  ( alreadyExistsErrorType+  , doesNotExistErrorType+  , ioeGetLocation+  , ioeSetErrorString+  , ioeSetLocation+  , isDoesNotExistError+  , isPermissionError+  , mkIOError+  )+import System.Info (os)+import Prelude hiding (filter, readFile, writeFile)++import Control.Monad.Except (MonadError (..), tryError)+import Control.Monad.Extra (partitionM)+import Control.Monad.State.Strict+  ( MonadState+  , StateT+  , gets+  , modify'+  , runStateT+  )+import Data.ByteString (ByteString)+import Data.ByteString qualified (length, readFile, writeFile)+import Data.Map.Strict (Map, alter, fromList, keys, toAscList, (!?))+import System.Directory.OsPath+  ( doesDirectoryExist+  , doesFileExist+  , doesPathExist+  , getSymbolicLinkTarget+  , pathIsSymbolicLink+  , removeDirectoryRecursive+  )+import System.Directory.OsPath qualified+  ( copyFile+  , createDirectory+  , getFileSize+  , listDirectory+  , removeDirectory+  , removeFile+  )+import System.FilePattern (FilePattern, Step (stepApply, stepDone), step_)+import System.OsPath+  ( OsPath+  , decodeFS+  , encodeFS+  , joinPath+  , normalise+  , splitDirectories+  , takeDirectory+  , takeFileName+  , (</>)+  )+++-- | A type that represents a file or directory.+data FileType+  = -- | A directory.+    Directory+  | -- | A file.+    File+  | -- | A symbolic link.+    Symlink+  deriving (Eq, Ord, Show)+++-- | A monad that can perform filesystem operations.  It's also based on+-- 'OsPath' instead of 'FilePath'.+class (MonadError IOError m) => MonadFileSystem m where+  -- | Encodes a 'FilePath' into an 'OsPath'.+  encodePath :: (HasCallStack) => FilePath -> m OsPath+++  -- | Decodes a 'OsPath' into a 'FilePath'.+  decodePath :: (HasCallStack) => OsPath -> m FilePath+++  -- | Checks if a file (or directory) exists.  If a path is a symbolic link,+  -- then it tells whether the target of the symbolic link exists.+  exists :: (HasCallStack) => OsPath -> m Bool+++  -- | Checks if a path exists and is a file.  If a path is a symbolic link,+  -- then it tells whether the target of the symbolic link is a file.+  isFile :: (HasCallStack) => OsPath -> m Bool+++  -- | Checks if a path exists and is a directory.  If a path is a symbolic+  -- link, then it tells whether the target of the symbolic link is a directory.+  isDirectory :: (HasCallStack) => OsPath -> m Bool+++  -- | Checks if a path exists and is a symbolic link.+  isSymlink :: (HasCallStack) => OsPath -> m Bool+++  -- | Reads contents from a file.+  readFile :: (HasCallStack) => OsPath -> m ByteString+++  -- | Writes contents into a file.+  writeFile :: (HasCallStack) => OsPath -> ByteString -> m ()+++  -- | Tells the target path of a symbolic link.  If the path is not a symbolic+  -- link, then it throws an 'IOError'.  The target path is relative to the+  -- symbolic link (i.e., resolved from the directory that contains the+  -- symbolic link).+  readSymlinkTarget :: OsPath -> m OsPath+++  -- | Copies a file from one path to another.+  copyFile+    :: (HasCallStack)+    => OsPath+    -- ^ Source path.+    -> OsPath+    -- ^ Destination path.+    -> m ()+++  -- | Creates a directory at the given path.+  createDirectory :: (HasCallStack) => OsPath -> m ()+++  -- | Creates a directory at the given path, including all parent directories.+  createDirectories :: (HasCallStack) => OsPath -> m ()+  createDirectories path =+    ( do+        forM_ ancestors $ \ancestor -> do+          isSymlink' <- isSymlink ancestor+          when isSymlink' $ do+            ancestor' <- decodePath ancestor+            throwError $ fileError ancestor'+          isDir <- isDirectory ancestor+          unless isDir $ do+            exists' <- isFile ancestor+            if exists'+              then do+                ancestor' <- decodePath ancestor+                throwError $ fileError ancestor'+              else createDirectory ancestor+    )+      `mapError` (`ioePrependLocation` "createDirectories")+   where+    split :: [OsPath]+    split = splitDirectories path+    ancestors :: [OsPath]+    ancestors = map joinPath $ tail (inits split)+    fileError :: FilePath -> IOError+    fileError path' =+      mkIOError InappropriateType "createDirectories" Nothing (Just path')+        `ioeSetErrorString` "one of its ancestors is a non-directory file"+++  -- | Removes a regular file.+  removeFile :: (HasCallStack) => OsPath -> m ()+++  -- | Removes a directory.  It must be empty.+  removeDirectory :: (HasCallStack) => OsPath -> m ()+++  -- | Removes a directory entirely, including all its contents.+  removeDirectoryRecursively :: (HasCallStack) => OsPath -> m ()+  removeDirectoryRecursively path =+    ( do+        entries <- listDirectoryRecursively path []+        forM_ (sortOn (Down . snd) entries) $ \(fileType, entry) ->+          case fileType of+            Directory -> removeDirectoryRecursively $ path </> entry+            File -> removeFile $ path </> entry+            Symlink -> removeFile $ path </> entry+        removeDirectory path+    )+      `mapError` (`ioePrependLocation` "removeDirectoryRecursively")+++  -- | Lists all files and directories in a directory except for @.@ and @..@,+  -- without recursing into subdirectories.+  listDirectory :: (HasCallStack) => OsPath -> m [OsPath]+++  -- | Lists all files and directories in a directory recursively.  It doesn't+  -- include @.@ and @..@.  Paths are relative to the given directory,+  -- and directories always go before their contents.+  --+  -- Note that it doesn't follow symbolic links.  Instead, it returns the+  -- symbolic links themselves with the 'Symlink' file type.+  listDirectoryRecursively+    :: (HasCallStack)+    => OsPath+    -- ^ The directory to list recursively.+    -> [FilePattern]+    -- ^ The file patterns to ignore.  If a directory matches one of these+    -- patterns, then its contents will not be listed recursively either.+    -> m [(FileType, OsPath)]+    -- ^ The list of pairs of file types and paths.  The paths are relative+    -- to the given directory.+  listDirectoryRecursively path ignorePatterns =+    listDirectoryRecursively' path (step_ ignorePatterns)+      `mapError` (`ioePrependLocation` "listDirectoryRecursively")+++  -- | Gets the size of a file in bytes.  If the file doesn't exist or is+  -- a directory, then it throws an 'IOError'.+  getFileSize :: (HasCallStack) => OsPath -> m Integer+++listDirectoryRecursively'+  :: (HasCallStack, MonadFileSystem m)+  => OsPath+  -> Step ()+  -> m [(FileType, OsPath)]+listDirectoryRecursively' path ptnStep = do+  unfilteredEntries <- listDirectory path+  entriesWithSteps <- forM unfilteredEntries $ \entry -> do+    decoded <- decodePath entry+    let nextStep = stepApply ptnStep decoded+    return (entry, nextStep)+  let filteredEntries =+        [ (entry, step)+        | (entry, step) <- entriesWithSteps+        , null $ stepDone step+        ]+  (symlinks, entries') <-+    partitionM (isSymlink . (path </>) . fst) filteredEntries+  (dirs, files) <- partitionM (isDirectory . (path </>) . fst) entries'+  symlinks' <- forM symlinks $ \(symlink, _) -> return (Symlink, symlink)+  files' <- forM files $ \(file, _) -> return (File, file)+  dirs' <- forM dirs $ \(dir, step) -> do+    subentries <- listDirectoryRecursively' (path </> dir) step+    return $ (Directory, dir) : (fmap (dir </>) <$> subentries)+  return $ files' ++ symlinks' ++ concat dirs'+++instance MonadFileSystem IO where+  encodePath = encodeFS+++  decodePath = decodeFS+++  exists = doesPathExist+++  isFile = doesFileExist+++  isDirectory = doesDirectoryExist+++  isSymlink path =+    pathIsSymbolicLink path `catchError` \e ->+      if isDoesNotExistError e then return False else throwError e+++  readFile src = decodePath src >>= Data.ByteString.readFile+++  writeFile dst contents = do+    dst' <- decodePath dst+    Data.ByteString.writeFile dst' contents+++  readSymlinkTarget = getSymbolicLinkTarget+++  createDirectory = System.Directory.OsPath.createDirectory+++  removeFile = System.Directory.OsPath.removeFile+++  removeDirectory = System.Directory.OsPath.removeDirectory+++  removeDirectoryRecursively =+    retryOnPermissionErrorsOnWindows 10 . removeDirectoryRecursive+   where+    -- See also: https://github.com/jaspervdj/hakyll/pull/783+    retryOnPermissionErrorsOnWindows :: Int -> IO () -> IO ()+    retryOnPermissionErrorsOnWindows retry action+      | os /= "mingw32" = action+      | retry < 1 = action+      | otherwise =+          action `catchError` \e ->+            if isPermissionError e+              then do+                threadDelay 100+                retryOnPermissionErrorsOnWindows (retry - 1) action+              else throwError e+++  listDirectory = System.Directory.OsPath.listDirectory+++  getFileSize path = do+    isDir <- isDirectory path+    when isDir $ do+      path' <- decodePath path+      throwError+        $ mkIOError InappropriateType "getFileSize" Nothing (Just path')+        `ioeSetErrorString` "it is a directory"+    System.Directory.OsPath.getFileSize path+++  copyFile = System.Directory.OsPath.copyFile+++type SeqNo = Int+++-- | The result of a filesystem operation.+data OverlaidFile+  = -- | A file with the given contents.+    Contents ByteString+  | -- | A directory.+    Directory'+  | -- | A file that doesn't exist (i.e., it was deleted).+    Gone+  | -- | A file that was copied from the given path.+    Copied OsPath+  deriving (Eq, Show)+++-- | Internal state of 'DryRun'.+data DryRunState = DryRunState+  { overlaidFiles :: Map OsPath (NonEmpty (SeqNo, OverlaidFile))+  -- ^ The overlaid files and their list of changes.  Each change is a pair+  -- of the global sequence number and the new event that occurred.  The latest+  -- change comes first and the oldest change comes last.+  , nextSequenceNumber :: SeqNo+  }+++currentSequenceNumber :: DryRunState -> SeqNo+currentSequenceNumber state = nextSequenceNumber state - 1+++-- | A monad that can perform filesystem operations, but only in a sandbox.+-- Note that, however, it can bypass the sandboxing of the 'MonadFileSystem'+-- class by using 'liftIO'.+newtype DryRunIO a = DryRunIO {unDryRunIO :: StateT DryRunState IO a}+  deriving+    ( Functor+    , Applicative+    , Monad+    , MonadFail+    , MonadError IOError+    , MonadIO+    , MonadState DryRunState+    )+++addChangeToFile :: OsPath -> OverlaidFile -> DryRunIO ()+addChangeToFile path change = modify' $ \state ->+  let oFiles = overlaidFiles state+      nextSeqNo = nextSequenceNumber state+      newOFiles = alter (appendChange nextSeqNo) (normalise path) oFiles+  in state{overlaidFiles = newOFiles, nextSequenceNumber = nextSeqNo + 1}+ where+  appendChange+    :: SeqNo+    -> Maybe (NonEmpty (SeqNo, OverlaidFile))+    -> Maybe (NonEmpty (SeqNo, OverlaidFile))+  appendChange seqNo (Just changes) = Just $ (seqNo, change) :| toList changes+  appendChange seqNo Nothing = Just $ singleton (seqNo, change)+++readFileFromDryRunIO :: SeqNo -> OsPath -> DryRunIO ByteString+readFileFromDryRunIO seqOffset src = do+  oFiles <- gets overlaidFiles+  case oFiles !? normalise src of+    Nothing -> fallback+    Just changes ->+      let filteredChanges = filter (\(no, _) -> no <= seqOffset) changes+      in case filteredChanges of+          [] -> fallback+          (_, Contents contents) : _ -> return contents+          (seqNo, Copied src') : _ ->+            readFileFromDryRunIO seqNo src'+          (_, Gone) : _ -> do+            src' <- decodePath src+            throwError+              $ mkIOError doesNotExistErrorType "readFile" Nothing (Just src')+              `ioeSetErrorString` "no such file"+          (_, Directory') : _ -> do+            src' <- decodePath src+            throwError $ nonDirError src'+ where+  fallback :: DryRunIO ByteString+  fallback = liftIO $ do+    isDir <- doesDirectoryExist src+    src' <- decodeFS src+    when isDir $ throwError (nonDirError src')+    Data.ByteString.readFile src'+  nonDirError :: FilePath -> IOError+  nonDirError src' =+    mkIOError InappropriateType "readFile" Nothing (Just src')+      `ioeSetErrorString` "is a directory"+++instance MonadFileSystem DryRunIO where+  encodePath = liftIO . encodeFS+++  decodePath = liftIO . decodeFS+++  exists path = do+    oFiles <- gets overlaidFiles+    case oFiles !? normalise path of+      Just ((_, Gone) :| _) -> return False+      Just (_ :| _) -> return True+      Nothing -> liftIO $ doesPathExist path+++  isFile path = do+    oFiles <- gets overlaidFiles+    case oFiles !? normalise path of+      Just ((_, Contents _) :| _) -> return True+      Just ((_, Copied _) :| _) -> return True+      Just (_ :| _) -> return False+      Nothing -> liftIO $ doesFileExist path+++  isDirectory path = do+    oFiles <- gets overlaidFiles+    case oFiles !? normalise path of+      Just ((_, Directory') :| _) -> return True+      Just (_ :| _) -> return False+      Nothing -> liftIO $ doesDirectoryExist path+++  isSymlink path = do+    oFiles <- gets overlaidFiles+    case oFiles !? normalise path of+      Just _ -> return False+      Nothing ->+        liftIO (pathIsSymbolicLink path)+          `catchError` \e ->+            if isDoesNotExistError e then return False else throwError e+++  readFile src = do+    seqNo <- gets currentSequenceNumber+    readFileFromDryRunIO seqNo src+++  writeFile dst contents = do+    oFiles <- gets overlaidFiles+    let dstDir = normalise $ takeDirectory dst+    dstParentExists <- liftIO $ doesPathExist dstDir+    dstDirExists <- liftIO $ doesDirectoryExist dstDir+    dst' <- decodePath dst+    dstIsDir <- liftIO $ doesDirectoryExist dst+    case (oFiles !? dstDir, oFiles !? normalise dst) of+      (Just ((_, Gone) :| _), _) -> throwError $ noParentDirError dst'+      (Nothing, _) | not dstParentExists -> throwError $ noParentDirError dst'+      (Just ((_, Contents _) :| _), _) -> throwError $ notInsideDirError dst'+      (Just ((_, Copied _) :| _), _) -> throwError $ notInsideDirError dst'+      (Nothing, _) | not dstDirExists -> throwError $ notInsideDirError dst'+      (_, Just ((_, Directory') :| _)) -> throwError $ dirError dst'+      (_, Nothing) | dstIsDir -> throwError $ dirError dst'+      _ -> do+        addChangeToFile dst $ Contents contents+        return ()+   where+    dirError :: FilePath -> IOError+    dirError dst' =+      mkIOError InappropriateType "writeFile" Nothing (Just dst')+        `ioeSetErrorString` "is a directory"+    noParentDirError :: FilePath -> IOError+    noParentDirError dst' =+      mkIOError doesNotExistErrorType "writeFile" Nothing (Just dst')+        `ioeSetErrorString` "no parent directory"+    notInsideDirError :: FilePath -> IOError+    notInsideDirError dst' =+      mkIOError InappropriateType "writeFile" Nothing (Just dst')+        `ioeSetErrorString` "not inside a directory"+++  readSymlinkTarget path = do+    oFiles <- gets overlaidFiles+    case oFiles !? normalise path of+      Just ((_, Gone) :| _) -> do+        path' <- decodePath path+        throwError+          $ mkIOError+            doesNotExistErrorType+            "readSymlinkTarget"+            Nothing+            (Just path')+          `ioeSetErrorString` "no such file"+      Just _ -> do+        path' <- decodePath path+        throwError+          $ mkIOError InappropriateType "readSymlinkTarget" Nothing (Just path')+          `ioeSetErrorString` "not a symbolic link"+      Nothing ->+        liftIO+          $ getSymbolicLinkTarget path+          `mapError` (`ioePrependLocation` "readSymlinkTarget")+++  copyFile src dst = do+    oFiles <- gets overlaidFiles+    src' <- decodePath src+    srcExists <- liftIO $ doesPathExist src+    srcIsDir <- liftIO $ doesDirectoryExist src+    let dstDir = normalise $ takeDirectory dst+    dstDirExists <- liftIO $ doesPathExist dstDir+    dstDirIsDir <- liftIO $ doesDirectoryExist dstDir+    dst' <- decodePath dst+    dstIsDir <- liftIO $ doesDirectoryExist dst+    case oFiles !? normalise src of+      Just ((_, Gone) :| _) -> throwError $ noSrcFileError src'+      Nothing | not srcExists -> throwError $ noSrcFileError src'+      Just ((_, Directory') :| _) -> throwError $ srcIsDirError src'+      Nothing | srcIsDir -> throwError $ srcIsDirError src'+      _ -> case (oFiles !? dstDir, oFiles !? normalise dst) of+        (Just ((_, Gone) :| _), _) -> throwError $ noParentDirError dst'+        (Nothing, _) | not dstDirExists -> throwError $ noParentDirError dst'+        (Just ((_, Contents _) :| _), _) -> throwError $ notInsideDirError dst'+        (Just ((_, Copied _) :| _), _) -> throwError $ notInsideDirError dst'+        (Nothing, _) | not dstDirIsDir -> throwError $ notInsideDirError dst'+        (_, Just ((_, Directory') :| _)) -> throwError $ dstIsDirError dst'+        (_, Nothing) | dstIsDir -> throwError $ dstIsDirError dst'+        _ -> do+          addChangeToFile dst $ Copied src+          return ()+   where+    noSrcFileError :: FilePath -> IOError+    noSrcFileError src' =+      mkIOError doesNotExistErrorType "copyFile" Nothing (Just src')+        `ioeSetErrorString` "source does not exist"+    srcIsDirError :: FilePath -> IOError+    srcIsDirError src' =+      mkIOError InappropriateType "copyFile" Nothing (Just src')+        `ioeSetErrorString` "source is a directory"+    noParentDirError :: FilePath -> IOError+    noParentDirError dst' =+      mkIOError doesNotExistErrorType "copyFile" Nothing (Just dst')+        `ioeSetErrorString` "no parent directory"+    notInsideDirError :: FilePath -> IOError+    notInsideDirError dst' =+      mkIOError InappropriateType "copyFile" Nothing (Just dst')+        `ioeSetErrorString` "not inside a directory"+    dstIsDirError :: FilePath -> IOError+    dstIsDirError dst' =+      mkIOError InappropriateType "copyFile" Nothing (Just dst')+        `ioeSetErrorString` "destination is a directory"+++  createDirectory dst = do+    oFiles <- gets overlaidFiles+    dst' <- decodePath dst+    isFile' <- liftIO $ doesFileExist dst+    isDir <- liftIO $ doesDirectoryExist dst+    isSymlink' <-+      liftIO $ pathIsSymbolicLink dst `catchError` \e ->+        if isDoesNotExistError e+          then return False+          else throwError $ e `ioePrependLocation` "createDirectory"+    parentExists <- liftIO $ doesPathExist parent+    parentIsDir <- liftIO $ doesDirectoryExist parent+    case (oFiles !? parent, oFiles !? normalise dst) of+      (Just ((_, Gone) :| _), _) -> throwError $ noParentDirError dst'+      (Nothing, _) | not parentExists -> throwError $ noParentDirError dst'+      (Just ((_, Contents _) :| _), _) -> throwError $ notInsideDirError dst'+      (Just ((_, Copied _) :| _), _) -> throwError $ notInsideDirError dst'+      (Nothing, _) | not parentIsDir -> throwError $ notInsideDirError dst'+      (_, Just ((_, Contents _) :| _)) -> throwError $ dstIsFileError dst'+      (_, Just ((_, Copied _) :| _)) -> throwError $ dstIsFileError dst'+      (Nothing, _) | isFile' -> throwError $ dstIsFileError dst'+      (_, Just ((_, Directory') :| _)) -> throwError $ dstIsDirError dst'+      _ | isDir && not isSymlink' -> throwError $ dstIsDirError dst'+      _ -> do+        addChangeToFile dst Directory'+        return ()+   where+    parent :: OsPath+    parent = normalise $ takeDirectory dst+    noParentDirError :: FilePath -> IOError+    noParentDirError dst' =+      mkIOError doesNotExistErrorType "createDirectory" Nothing (Just dst')+        `ioeSetErrorString` "no parent directory"+    notInsideDirError :: FilePath -> IOError+    notInsideDirError dst' =+      mkIOError InappropriateType "createDirectory" Nothing (Just dst')+        `ioeSetErrorString` "not inside a directory"+    dstIsFileError :: FilePath -> IOError+    dstIsFileError dst' =+      mkIOError alreadyExistsErrorType "createDirectory" Nothing (Just dst')+        `ioeSetErrorString` "destination is already a file"+    dstIsDirError :: FilePath -> IOError+    dstIsDirError dst' =+      mkIOError alreadyExistsErrorType "createDirectory" Nothing (Just dst')+        `ioeSetErrorString` "destination is already a directory"+++  removeFile path = do+    oFiles <- gets overlaidFiles+    path' <- decodePath path+    exists' <- liftIO $ doesPathExist path+    isSymlink' <-+      liftIO+        $ pathIsSymbolicLink path+        `catchError` \e ->+          if isDoesNotExistError e+            then return False+            else throwError $ e `ioePrependLocation` "removeFile"+    isDir <- liftIO $ doesDirectoryExist path+    case oFiles !? normalise path of+      Just ((_, Gone) :| _) -> throwError $ noFileError path'+      Nothing | not exists' -> throwError $ noFileError path'+      Just ((_, Directory') :| _) -> throwError $ dirError path'+      Nothing | isDir && not isSymlink' -> throwError $ dirError path'+      _ -> do+        addChangeToFile path Gone+        return ()+   where+    noFileError :: FilePath -> IOError+    noFileError path' =+      mkIOError doesNotExistErrorType "removeFile" Nothing (Just path')+        `ioeSetErrorString` "no such file"+    dirError :: FilePath -> IOError+    dirError path' =+      mkIOError InappropriateType "removeFile" Nothing (Just path')+        `ioeSetErrorString` "is a directory"+++  removeDirectory path = do+    oFiles <- gets overlaidFiles+    path' <- decodePath path+    exists' <- liftIO $ doesPathExist path+    isDir <- liftIO $ doesDirectoryExist path+    case oFiles !? normalise path of+      Just ((_, Gone) :| _) ->+        throwError $ noDirError path'+      Nothing+        | not exists' ->+            throwError $ noDirError path'+      Just ((_, Contents _) :| _) ->+        throwError $ nonDirError path'+      Just ((_, Copied _) :| _) ->+        throwError $ nonDirError path'+      Nothing+        | not isDir ->+            throwError $ nonDirError path'+      _ -> do+        addChangeToFile path Gone+        return ()+   where+    noDirError :: FilePath -> IOError+    noDirError path' =+      mkIOError+        doesNotExistErrorType+        "removeDirectory"+        Nothing+        (Just path')+        `ioeSetErrorString` "no such directory"+    nonDirError :: FilePath -> IOError+    nonDirError path' =+      mkIOError+        InappropriateType+        "removeDirectory"+        Nothing+        (Just path')+        `ioeSetErrorString` "not a directory"+++  listDirectory path = do+    oFiles <- gets overlaidFiles+    pathFP <- decodePath path+    case oFiles !? path' of+      Just ((_, Gone) :| _) ->+        throwError $ noDirError pathFP+      Just ((_, Contents _) :| _) ->+        throwError $ nonDirError pathFP+      Just ((_, Copied _) :| _) ->+        throwError $ nonDirError pathFP+      Just ((_, Directory') :| _) ->+        return $ map takeFileName $ keys $ directOChildren oFiles+      Nothing -> do+        isSymlink' <-+          liftIO+            $ pathIsSymbolicLink path+            `catchError` \e ->+              if isDoesNotExistError e+                then return False+                else throwError $ e `ioePrependLocation` "listDirectory"+        isFile' <- liftIO $ doesFileExist path+        when (isSymlink' || isFile') $ throwError (nonDirError pathFP)+        files <-+          liftIO+            $ System.Directory.OsPath.listDirectory path+            `mapError` (`ioePrependLocation` "listDirectory")+        let directOChildren' = directOChildren oFiles+        let result =+              [f | f <- files, directOChildren' !? (path' </> f) /= Just Gone]+                ++ [ filename+                   | (filePath, f) <- toAscList directOChildren'+                   , f /= Gone+                   , let split = splitDirectories filePath+                   , pathDirs `isPrefixOf` split+                   , length pathDirs < length split+                   , let filename = split !! length pathDirs+                   , filename `notElem` files+                   ]+        return $ sort result+   where+    path' :: OsPath+    path' = normalise path+    pathDirs :: [OsPath]+    pathDirs = splitDirectories path'+    directOChildren+      :: Map OsPath (NonEmpty (SeqNo, OverlaidFile)) -> Map OsPath OverlaidFile+    directOChildren oFiles =+      fromList+        [ (filePath, f)+        | (filePath, (_, f) :| []) <- toAscList oFiles+        , let split = splitDirectories filePath+        , pathDirs `isPrefixOf` split+        , length pathDirs + 1 == length split+        ]+    noDirError :: FilePath -> IOError+    noDirError pathFP =+      mkIOError+        doesNotExistErrorType+        "listDirectory"+        Nothing+        (Just pathFP)+        `ioeSetErrorString` "no such directory"+    nonDirError :: FilePath -> IOError+    nonDirError pathFP =+      mkIOError+        InappropriateType+        "listDirectory"+        Nothing+        (Just pathFP)+        `ioeSetErrorString` "not a directory"+++  getFileSize path = do+    oFiles <- gets overlaidFiles+    path' <- decodePath path+    case oFiles !? normalise path of+      Just ((_, Gone) :| _) ->+        throwError $ noFileError path'+      Just ((_, Directory') :| _) ->+        throwError $ nonFileError path'+      Just _ -> do+        contents <- readFile path+        return+          $ fromIntegral+          $ Data.ByteString.length contents+      Nothing -> do+        isDir <- isDirectory path+        if isDir+          then throwError $ nonFileError path'+          else+            liftIO (System.Directory.OsPath.getFileSize path)+              `mapError` (`ioeSetLocation` "getFileSize")+   where+    noFileError :: FilePath -> IOError+    noFileError pathFP =+      mkIOError+        doesNotExistErrorType+        "getFileSize"+        Nothing+        (Just pathFP)+        `ioeSetErrorString` "no such file"+    nonFileError :: FilePath -> IOError+    nonFileError pathFP =+      mkIOError+        InappropriateType+        "getFileSize"+        Nothing+        (Just pathFP)+        `ioeSetErrorString` "not a regular file, but a directory"+++-- | Performs 'DryRunIO' action in the sandbox and returns the result.+dryRunIO :: DryRunIO a -> IO a+dryRunIO = fmap fst . dryRunIO'+++-- | Performs 'DryRunIO' action in the sandbox and returns the result and+-- the total number of filesystem operations that were performed.+dryRunIO' :: DryRunIO a -> IO (a, Int)+dryRunIO' action = do+  (value, state) <- runStateT (unDryRunIO action) initialState+  return (value, nextSequenceNumber state)+ where+  initialState = DryRunState{overlaidFiles = mempty, nextSequenceNumber = 0}+++-- | Performs 'DryRunIO' action in the sandbox and returns either the result+-- or an 'IOError' that occurred.+tryDryRunIO :: DryRunIO a -> IO (Either IOError a)+tryDryRunIO action = dryRunIO $ tryError action+++ioePrependLocation :: IOError -> String -> IOError+ioePrependLocation e location =+  ioeSetLocation e $ case loc of+    "" -> location+    _ -> location ++ ':' : loc+ where+  loc :: String+  loc = ioeGetLocation e+++mapError :: (MonadError e m) => m a -> (e -> e) -> m a+mapError action transform = catchError action (throwError . transform)
+ src/Dojang/Syntax/Env.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Dojang.Syntax.Env+  ( TomlError+  , TomlWarning+  , readEnvFile+  , readEnvironment+  , writeEnvFile+  , writeEnvironment+  ) where++import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.String (IsString (fromString))+import Prelude hiding (readFile, writeFile)++import Control.DeepSeq (force)+import Data.CaseInsensitive (CI (original))+import Data.Text (Text, unpack)+import Data.Text.Encoding (decodeUtf8Lenient, encodeUtf8)+import System.OsPath (OsPath)+import TextShow (FromStringShow (FromStringShow), TextShow (showt))+import Toml (decode, encode)+import Toml.FromValue+  ( FromValue (fromValue)+  , Result (Failure, Success)+  , parseTableFromValue+  , reqKey+  )+import Toml.ToValue+  ( ToTable (toTable)+  , ToValue (toValue)+  , defaultTableToValue+  , table+  , (.=)+  )++import Dojang.MonadFileSystem (MonadFileSystem (..))+import Dojang.Types.Environment+  ( Architecture+  , Environment (..)+  , Kernel (..)+  , OperatingSystem+  )+++instance FromValue OperatingSystem where+  fromValue os = fromString <$> fromValue os+++instance ToValue OperatingSystem where+  toValue = toValue . original . (.identifier)+++instance FromValue Architecture where+  fromValue arch = fromString <$> fromValue arch+++instance ToValue Architecture where+  toValue = toValue . original . (.identifier)+++instance FromValue Kernel where+  fromValue =+    parseTableFromValue+      $ Kernel+      <$> (fromString <$> reqKey "name")+      <*> (fromString <$> reqKey "version")+++instance ToValue Kernel where+  toValue = defaultTableToValue+++instance ToTable Kernel where+  toTable kernel =+    table+      [ "name" .= original kernel.name+      , "release" .= original kernel.release+      ]+++instance FromValue Environment where+  fromValue =+    parseTableFromValue+      $ Environment+      <$> reqKey "os"+      <*> reqKey "arch"+      <*> reqKey "kernel"+++instance ToValue Environment where+  toValue = defaultTableToValue+++instance ToTable Environment where+  toTable env =+    table+      [ "os" .= env.operatingSystem+      , "arch" .= env.architecture+      , "kernel" .= env.kernel+      ]+++-- | An error made during parsing.+type TomlError = String+++-- | A warning message made during parsing.+type TomlWarning = String+++-- | Decodes a TOML-encoded 'Environment'.+readEnvironment+  :: Text+  -- ^ A TOML document text to parse.+  -> Either (NonEmpty TomlError) (Environment, [TomlWarning])+  -- ^ A decoded 'Environment' with warnings, or a list of errors.+readEnvironment toml = case decode $ unpack toml of+  Success warnings env -> Right (env, warnings)+  Failure (e : es) -> Left $ e :| es+  Failure [] -> Left $ "unknown error" :| []+++-- | Reads a TOML-encoded 'Environment' from the given file path.  It assumes+-- that the file is encoded in UTF-8.  Throws an 'IOError' if the file cannot+-- be read.+readEnvFile+  :: (MonadFileSystem m)+  => OsPath+  -- ^ A path to the env file.+  -> m (Either (NonEmpty TomlError) (Environment, [TomlWarning]))+  -- ^ A decoded 'Environment' with warnings, or error(s).+readEnvFile filePath = do+  content <- readFile filePath+  let decoded = decodeUtf8Lenient content+  return $ readEnvironment $ force decoded+++-- | Encodes an 'Environment' into a TOML document.+writeEnvironment :: Environment -> Text+writeEnvironment = showt . FromStringShow . encode+++-- | Writes an 'Environment' file to the given path.  Throws an 'IOError' if+-- any occurs while writing the file.+writeEnvFile+  :: (MonadFileSystem m)+  => Environment+  -- ^ The 'Environment' to write.+  -> OsPath+  -- ^ The path to write the 'Environment' to.+  -> m ()+writeEnvFile env filePath =+  writeFile filePath $ encodeUtf8 $ writeEnvironment env
+ src/Dojang/Syntax/EnvironmentPredicate.hs view
@@ -0,0 +1,15 @@+-- | A human-friendly syntax for describing+-- 'Dojang.Types.EnvironmentPredicate.EnvironmentPredicate's.  It is mainly+-- used for @when@ statements in /dojang.toml/ files.+module Dojang.Syntax.EnvironmentPredicate+  ( errorBundlePretty+  , parseEnvironmentPredicate+  , writeEnvironmentPredicate+  ) where++import Dojang.Syntax.EnvironmentPredicate.Parser+  ( errorBundlePretty+  , parseEnvironmentPredicate+  )+import Dojang.Syntax.EnvironmentPredicate.Writer (writeEnvironmentPredicate)+
+ src/Dojang/Syntax/EnvironmentPredicate/Parser.hs view
@@ -0,0 +1,347 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}++module Dojang.Syntax.EnvironmentPredicate.Parser+  ( Field (..)+  , FieldOp (..)+  , ParseErrorBundle+  , andExpression+  , bareStringLiteral+  , charactersInStringLiteral+  , doubleQuoteStringLiteral+  , equalOp+  , errorBundlePretty+  , expression+  , field+  , fieldOp+  , inOp+  , notEqualOp+  , notInOp+  , parse+  , parseEnvironmentPredicate+  , prefixOp+  , simpleExpression+  , singleQuoteStringLiteral+  , stringLiteral+  , strings+  , suffixOp+  ) where++import Control.Applicative (optional, (<|>))+import Control.Applicative.Combinators (choice, sepBy1, sepEndBy)+import Control.Monad (void)+import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (..))+import Dojang.Types.MonikerName (parseMonikerName)++import Data.CaseInsensitive (mk)+import Data.Char (isAlpha, isAlphaNum, isDigit)+import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.String (IsString (fromString))+import Data.Text (Text, concat, cons, pack, singleton, unpack)+import Data.Void (Void)+import Text.Megaparsec+  ( MonadParsec (eof, takeWhile1P, takeWhileP, try)+  , Parsec+  , label+  , many+  , parse+  , satisfy+  )+import Text.Megaparsec.Char (char, hexDigitChar, space, space1, string)+import Text.Megaparsec.Error (ParseErrorBundle)+import Text.Megaparsec.Error qualified (errorBundlePretty)+import Prelude hiding (concat)+++type Parser = Parsec Void Text+++-- | Parse a 'EnvironmentPredicate' from a 'Text'.+parseEnvironmentPredicate+  :: FilePath+  -- ^ The name of source file.+  -> Text+  -- ^ The input text.+  -> Either (ParseErrorBundle Text Void) EnvironmentPredicate+  -- ^ The result of parsing.+parseEnvironmentPredicate = parse $ expression <* eof+++-- | A parser for 'EnvironmentPredicate'.+expression :: Parser EnvironmentPredicate+expression = label "expression" $ do+  space+  subExprs <- andExpression `sepBy1` (space >> string "||" >> space)+  space+  return $ case subExprs of+    x : xs | not (null xs) -> Or $ x :| xs+    _ -> head subExprs+++andExpression :: Parser EnvironmentPredicate+andExpression = do+  space+  subExprs <- simpleExpression `sepBy1` (space >> string "&&" >> space)+  space+  return $ case subExprs of+    x : xs | not (null xs) -> And $ x :| xs+    _ -> head subExprs+++simpleExpression :: Parser EnvironmentPredicate+simpleExpression = do+  space+  expr <-+    choice+      [ char '(' >> space >> expression <* space <* char ')'+      , string "always" >> return Always+      , string "never" >> return (Not Always)+      , do+          void $ char '!'+          space+          void $ char '('+          space+          expr' <- expression+          space+          void $ char ')'+          return $ Not expr'+      , fieldOp+      ]+  space+  return expr+++data FieldOp+  = EqualOp Text+  | NotEqualOp Text+  | PrefixOp Text+  | SuffixOp Text+  | InOp [Text]+  | NotInOp [Text]+++fieldOp :: Parser EnvironmentPredicate+fieldOp = do+  space+  field' <- field+  op <-+    choice+      [ try equalOp+      , try notEqualOp+      , try inOp+      , try notInOp+      , if field' == KernelRelease' then try prefixOp else fail ""+      , if field' == KernelRelease' then try suffixOp else fail ""+      ]+  space+  return $ case op of+    EqualOp value -> makePredicate field' value+    NotEqualOp value -> Not $ makePredicate field' value+    PrefixOp prefix -> KernelReleasePrefix $ mk prefix+    SuffixOp suffix -> KernelReleaseSuffix $ mk suffix+    InOp [] -> Not Always+    InOp (x : xs) -> Or $ makePredicate field' <$> (x :| xs)+    NotInOp [] -> Always+    NotInOp (x : xs) -> And $ Not . makePredicate field' <$> (x :| xs)+ where+  makePredicate :: Field -> Text -> EnvironmentPredicate+  makePredicate OS = OperatingSystem . fromString . unpack+  makePredicate Arch = Architecture . fromString . unpack+  makePredicate Kernel = KernelName . fromString . unpack+  makePredicate KernelRelease' = KernelRelease . fromString . unpack+  makePredicate Moniker' =+    either (const $ Not Always) Moniker . parseMonikerName+++equalOp :: Parser FieldOp+equalOp = do+  space+  void $ char '='+  void $ optional (char '=')+  space+  EqualOp <$> stringLiteral+++notEqualOp :: Parser FieldOp+notEqualOp = do+  space+  void $ string "!="+  space+  NotEqualOp <$> stringLiteral+++prefixOp :: Parser FieldOp+prefixOp = do+  space+  void $ string "^="+  space+  PrefixOp <$> stringLiteral+++suffixOp :: Parser FieldOp+suffixOp = do+  space+  void $ string "$="+  space+  SuffixOp <$> stringLiteral+++inOp :: Parser FieldOp+inOp = do+  space1+  void $ string "in"+  space+  InOp <$> strings+++notInOp :: Parser FieldOp+notInOp = do+  space1+  void $ string "not"+  space1+  void $ string "in"+  space+  NotInOp <$> strings+++strings :: Parser [Text]+strings = do+  space+  void $ char '('+  space+  members <- stringLiteral `sepEndBy` (space >> char ',' >> space)+  space+  void $ char ')'+  space+  return members+++data Field = OS | Arch | Kernel | KernelRelease' | Moniker' deriving (Eq)+++field :: Parser Field+field =+  choice+    [ OS <$ string "os"+    , Arch <$ string "arch"+    , KernelRelease' <$ string "kernel-release"+    , Kernel <$ string "kernel"+    , Moniker' <$ string "moniker"+    ]+++stringLiteral :: Parser Text+stringLiteral = label "string literal" $ do+  space+  string' <-+    choice+      [ doubleQuoteStringLiteral+      , singleQuoteStringLiteral+      , bareStringLiteral+      ]+  space+  return string'+++bareStringLiteral :: Parser Text+bareStringLiteral = label "bare string literal" $ do+  first <- satisfy isAlpha+  str <- takeWhileP Nothing isAlphaNum+  return $ first `cons` str+++doubleQuoteStringLiteral :: Parser Text+doubleQuoteStringLiteral = label "double quote string literal" $ do+  void $ char '"'+  str <- charactersInStringLiteral '"'+  void $ char '"'+  return str+++singleQuoteStringLiteral :: Parser Text+singleQuoteStringLiteral = label "single quote string literal" $ do+  void $ char '\''+  str <- charactersInStringLiteral '\''+  void $ char '\''+  return str+++charactersInStringLiteral :: Char -> Parser Text+charactersInStringLiteral terminal = do+  chunks <-+    many+      $ takeWhile1P (Just "string character") (\c -> c /= '\\' && c /= terminal)+      <|> singleton+      <$> charEscape+  return $ concat chunks+ where+  charEscape :: Parser Char+  charEscape = do+    void $ char '\\'+    choice+      [ char '\\' >> return '\\'+      , char '\'' >> return '\''+      , char '"' >> return '"'+      , char 'b' >> return '\b'+      , char 'f' >> return '\f'+      , char 'n' >> return '\n'+      , char 'r' >> return '\r'+      , char 't' >> return '\t'+      , char 'v' >> return '\v'+      , char '0' >> return '\0'+      , do+          void $ char 'x'+          d1 <- hex+          d2 <- hex+          return $ toEnum $ d1 * 0x10 + d2+      , do+          void $ char 'u'+          d1 <- hex+          d2 <- hex+          d3 <- hex+          d4 <- hex+          return $ toEnum $ d1 * 0x1000 + d2 * 0x100 + d3 * 0x10 + d4+      , do+          void $ char 'U'+          d1 <- hex+          d2 <- hex+          d3 <- hex+          d4 <- hex+          d5 <- hex+          d6 <- hex+          d7 <- hex+          d8 <- hex+          return+            $ toEnum+            $ d1+            * 0x10000000+            + d2+            * 0x1000000+            + d3+            * 0x100000+            + d4+            * 0x10000+            + d5+            * 0x1000+            + d6+            * 0x100+            + d7+            * 0x10+            + d8+      ]+  hex :: Parser Int+  hex = do+    c <- hexDigitChar+    return+      $ if isDigit c+        then fromEnum c - 0x30+        else+          if 'A' <= c && c <= 'F'+            then fromEnum c - 0x37+            else fromEnum c - 0x57+++-- | Basically the same as 'Text.Megaparsec.Error.errorBundlePretty' but+-- returns a 'Text' instead of a 'String'.+errorBundlePretty :: ParseErrorBundle Text Void -> Text+errorBundlePretty = pack . Text.Megaparsec.Error.errorBundlePretty
+ src/Dojang/Syntax/EnvironmentPredicate/Writer.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++module Dojang.Syntax.EnvironmentPredicate.Writer+  ( writeEnvironmentPredicate+  )+where++import Dojang.Types.Environment (Architecture, OperatingSystem)+import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (..))+import Dojang.Types.MonikerName (MonikerName)++import Data.CaseInsensitive (CI (original))+import Data.Char (isAlpha, isAlphaNum, isControl)+import Data.List.NonEmpty (toList)+import Data.Text+  ( Text+  , all+  , concatMap+  , elem+  , intercalate+  , justifyRight+  , pack+  , singleton+  , uncons+  )+import Numeric (showHex)+import Prelude hiding (all, concatMap, elem, reverse)+++-- | Turns an 'EnvironmentPredicate' into a string that can be used in a+-- @dojang.toml@ file.  The string can be parsed back into an+-- 'EnvironmentPredicate' using+-- 'Dojang.Syntax.EnvironmentPredicate.Parser.parseEnvironmentPredicate'.+writeEnvironmentPredicate :: EnvironmentPredicate -> Text+writeEnvironmentPredicate = fst . write+++write+  :: EnvironmentPredicate+  -> (Text, Bool)+-- \^ @(when, can be split by &&)@+write Always = ("always", False)+write (OperatingSystem os) =+  ("os = " <> stringLiteral (original os.identifier), False)+write (Architecture arch) =+  ("arch = " <> stringLiteral (original arch.identifier), False)+write (KernelName kernel) =+  ("kernel = " <> stringLiteral (original kernel), False)+write (KernelRelease rel) =+  ("kernel-release = " <> stringLiteral (original rel), False)+write (KernelReleasePrefix prefix) =+  ("kernel-release ^= " <> stringLiteral (original prefix), False)+write (KernelReleaseSuffix suffix) =+  ("kernel-release $= " <> stringLiteral (original suffix), False)+write (Moniker moniker) =+  ("moniker = " <> stringLiteral (original moniker.name), False)+write (And predicates) =+  case (excludeOses, excludeArchitectures, excludeMonikers) of+    (_ : _, [], [])+      | length excludeOses == length predicates ->+          ( "os not in "+              <> strings [original os.identifier | os <- excludeOses]+          , False+          )+    ([], _ : _, [])+      | length excludeArchitectures == length predicates ->+          ( "arch not in "+              <> strings+                [ original arch.identifier+                | arch <- excludeArchitectures+                ]+          , False+          )+    ([], [], _ : _)+      | length excludeMonikers == length predicates ->+          ( "moniker not in "+              <> strings [original moniker.name | moniker <- excludeMonikers]+          , False+          )+    _ ->+      ( intercalate+          " && "+          [ let (when', needParentheses) = write p+            in if needParentheses then "(" <> when' <> ")" else when'+          | p <- toList predicates+          ]+      , False+      )+ where+  excludeOses :: [OperatingSystem]+  excludeOses = [os | Not (OperatingSystem os) <- toList predicates]+  excludeArchitectures :: [Architecture]+  excludeArchitectures = [arch | Not (Architecture arch) <- toList predicates]+  excludeMonikers :: [MonikerName]+  excludeMonikers = [moniker | Not (Moniker moniker) <- toList predicates]+write (Or predicates) =+  case (oses, architectures, monikers) of+    (_ : _, [], [])+      | length oses == length predicates ->+          ("os in " <> strings [original os.identifier | os <- oses], False)+    ([], _ : _, [])+      | length architectures == length predicates ->+          ( "arch in "+              <> strings [original arch.identifier | arch <- architectures]+          , False+          )+    ([], [], _ : _)+      | length monikers == length predicates ->+          ( "moniker in "+              <> strings [original moniker.name | moniker <- monikers]+          , False+          )+    _ -> (intercalate " || " (fst . write <$> toList predicates), True)+ where+  oses :: [OperatingSystem]+  oses = [os | OperatingSystem os <- toList predicates]+  architectures :: [Architecture]+  architectures = [arch | Architecture arch <- toList predicates]+  monikers :: [MonikerName]+  monikers = [moniker | Moniker moniker <- toList predicates]+write (Not Always) = ("never", False)+write (Not (OperatingSystem os)) =+  ("os != " <> stringLiteral (original os.identifier), False)+write (Not (Architecture arch)) =+  ("arch != " <> stringLiteral (original arch.identifier), False)+write (Not (Moniker moniker)) =+  ("moniker != " <> stringLiteral (original moniker.name), False)+write (Not p) = ("!(" <> fst (write p) <> ")", False)+++stringLiteral :: Text -> Text+stringLiteral v = case uncons v of+  Nothing -> "\"\""+  Just (c, cs) | isAlpha c && all isAlphaNum cs -> v+  _ | '"' `elem` v && not ('\'' `elem` v) -> "'" <> escapeText False v <> "'"+  _ -> "\"" <> escapeText True v <> "\""+ where+  escapeText :: Bool -> Text -> Text+  escapeText doubleQuote = concatMap (escape doubleQuote)+  escape :: Bool -> Char -> Text+  escape True '"' = "\\\""+  escape False '\'' = "\\'"+  escape _ '\\' = "\\\\"+  escape _ '\b' = "\\b"+  escape _ '\f' = "\\f"+  escape _ '\n' = "\\n"+  escape _ '\r' = "\\r"+  escape _ '\t' = "\\t"+  escape _ '\v' = "\\v"+  escape _ '\0' = "\\0"+  escape _ c+    | not (isControl c) && c < '\x80' = singleton c+    | c <= '\xff' = "\\x" <> justifyRight 2 '0' (hex c)+    | c <= '\xffff' = "\\u" <> justifyRight 4 '0' (hex c) -- cSpell: disable-line+    | otherwise = "\\U" <> justifyRight 8 '0' (hex c)+   where+    hex :: Char -> Text+    hex = pack . (`showHex` "") . fromEnum+++strings :: [Text] -> Text+strings = ("(" <>) . (<> ")") . intercalate ", " . fmap stringLiteral
+ src/Dojang/Syntax/FilePathExpression/Parser.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}++module Dojang.Syntax.FilePathExpression.Parser+  ( ParseErrorBundle+  , bareComponent+  , environmentVariable+  , errorBundlePretty+  , filePathExpression+  , filePathExpression'+  , parseFilePathExpression+  , parse+  , root+  , substitution+  , substitutionConditional+  , substitutionDefault+  , substitutionInBraces+  , substitutionModifierAfterColon+  ) where++import Dojang.Types.FilePathExpression+  ( EnvironmentVariable+  , FilePathExpression (..)+  )++import Control.Applicative (Alternative ((<|>)), optional)+import Control.Monad (void)+import Data.Char (isAlpha, isAlphaNum, isAscii, isControl)+import Data.Text (Text, cons, pack)+import Data.Void (Void)+import Text.Megaparsec+  ( MonadParsec (eof, takeWhile1P, takeWhileP)+  , Parsec+  , label+  , many+  , oneOf+  , parse+  , satisfy+  , some+  , try+  , (<?>)+  )+import Text.Megaparsec.Char (char, string)+import Text.Megaparsec.Error (ParseErrorBundle)+import Text.Megaparsec.Error qualified (errorBundlePretty)+++type Parser = Parsec Void Text+++-- | Parse a 'FilePathExpression' from a 'Text'.+parseFilePathExpression+  :: FilePath+  -- ^ The name of source file.+  -> Text+  -- ^ The input text.+  -> Either (ParseErrorBundle Text Void) FilePathExpression+  -- ^ The result of parsing.+parseFilePathExpression = parse $ filePathExpression <* eof+++-- | A parser for 'FilePathExpression'.+filePathExpression :: Parser FilePathExpression+filePathExpression = filePathExpression' True []+{-# INLINE filePathExpression #-}+++filePathExpression' :: Bool -> [Char] -> Parser FilePathExpression+filePathExpression' begin disallowedBareChars = do+  root' <- if begin then optional $ try root else return Nothing+  head' <- case root' of+    Nothing -> do+      firstComponent <- component begin disallowedBareChars+      components <- many $ component False disallowedBareChars+      return $ foldl Concatenation firstComponent components+    Just r -> do+      components <- many $ component False disallowedBareChars+      return $ case components of+        [] -> r+        c : cs -> PathSeparator r $ foldl Concatenation c cs+  betweenSeparators <- many $ try $ do+    void $ oneOf ['/', '\\']+    components' <- some $ component False disallowedBareChars+    return $ foldl1 Concatenation components'+  let topExpr = foldl PathSeparator head' betweenSeparators+  void $ optional $ oneOf ['/', '\\']+  return topExpr+{-# INLINE filePathExpression' #-}+++component :: Bool -> [Char] -> Parser FilePathExpression+component begin disallowedBareChars =+  bareComponent disallowedBareChars+    <|> substitutionInBraces begin+    <|> substitution+{-# INLINE component #-}+++bareComponent :: [Char] -> Parser FilePathExpression+bareComponent disallowedChars = do+  component' <- takeWhile1P (Just "component") isValidChar+  return $ BareComponent component'+ where+  isValidChar :: Char -> Bool+  isValidChar = not . isInvalidChar+  isInvalidChar :: Char -> Bool+  isInvalidChar c =+    isControl c+      || c+      == '/'+      || c+      == '\\'+      || c+      == '$'+      || c+      == '\r'+      || c+      == '\n'+      || c+      `elem` disallowedChars+{-# INLINE bareComponent #-}+++root :: Parser FilePathExpression+root =+  driveLetter <|> rootSlash+ where+  driveLetter :: Parser FilePathExpression+  driveLetter = do+    letter <- satisfy (`elem` ['A' .. 'Z']) <?> "drive letter"+    void $ char ':'+    void $ satisfy (`elem` ['/', '\\'])+    return $ Root $ Just letter+  rootSlash :: Parser FilePathExpression+  rootSlash = char '/' >> return (Root Nothing)+++environmentVariable :: Parser EnvironmentVariable+environmentVariable = label "environment variable" $ do+  first <- satisfy (\c -> isAscii c && isAlpha c || c == '_')+  rest <- takeWhileP Nothing (\c -> isAscii c && isAlphaNum c || c == '_')+  return $ cons first rest+{-# INLINE environmentVariable #-}+++substitution :: Parser FilePathExpression+substitution =+  char '$' >> Substitution <$> environmentVariable+{-# INLINE substitution #-}+++substitutionInBraces :: Bool -> Parser FilePathExpression+substitutionInBraces begin = do+  void $ string "${"+  envVar <- environmentVariable+  colon <- optional $ char ':'+  expr <- case colon of+    Nothing -> return $ Substitution envVar+    Just _ -> substitutionModifierAfterColon begin envVar+  void $ char '}'+  return expr+{-# INLINE substitutionInBraces #-}+++substitutionModifierAfterColon+  :: Bool+  -> EnvironmentVariable+  -> Parser FilePathExpression+substitutionModifierAfterColon begin envVar =+  substitutionDefault begin envVar <|> substitutionConditional begin envVar+{-# INLINE substitutionModifierAfterColon #-}+++substitutionDefault :: Bool -> EnvironmentVariable -> Parser FilePathExpression+substitutionDefault begin envVar = do+  void $ char '-'+  SubstitutionWithDefault envVar <$> filePathExpression' begin "}"+{-# INLINE substitutionDefault #-}+++substitutionConditional+  :: Bool -> EnvironmentVariable -> Parser FilePathExpression+substitutionConditional begin envVar = do+  void $ char '+'+  ConditionalSubstitution envVar <$> filePathExpression' begin "}"+{-# INLINE substitutionConditional #-}+++-- | Basically the same as 'Text.Megaparsec.Error.errorBundlePretty' but+-- returns a 'Text' instead of a 'String'.+errorBundlePretty :: ParseErrorBundle Text Void -> Text+errorBundlePretty = pack . Text.Megaparsec.Error.errorBundlePretty
+ src/Dojang/Syntax/Manifest/Internal.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Dojang.Syntax.Manifest.Internal+  ( FileRoute'+  , FileRouteMap'+  , EnvironmentPredicate' (..)+  , FlatOrNonEmptyStrings (..)+  , IgnoreMap'+  , Manifest' (..)+  , MonikerMap'+  , always+  ) where++import Data.List.NonEmpty (NonEmpty)+import GHC.Generics (Generic)+import Prelude hiding (all, any)++import Data.CaseInsensitive (CI (original))+import Data.Map.Strict (Map)+import Data.Text (Text, pack, unpack)+import Dojang.Types.MonikerName (MonikerName, parseMonikerName)+import System.FilePattern (FilePattern)+import Toml (Value (..))+import Toml.FromValue+  ( FromKey (..)+  , FromValue (..)+  , optKey+  , parseTableFromValue+  )+import Toml.FromValue.Generic (genericParseTable)+import Toml.FromValue.Matcher (Matcher)+import Toml.ToValue+  ( ToKey (..)+  , ToTable (toTable)+  , ToValue (toValue)+  , defaultTableToValue+  , table+  )+import Toml.ToValue.Generic (genericToTable)+++data FlatOrNonEmptyStrings+  = Flat String+  | NonEmpty (NonEmpty String)+  deriving (Eq, Show)+++typeError :: Value -> String -> Matcher a+typeError actual wanted =+  fail $ "type error. wanted: " ++ wanted ++ " got: " ++ case actual of+    Integer{} -> "integer"+    Float{} -> "float"+    String{} -> "string"+    Table{} -> "table"+    Array{} -> "array"+    Bool{} -> "boolean"+    TimeOfDay{} -> "local time"+    LocalTime{} -> "local date-time"+    Day{} -> "locate date"+    ZonedTime{} -> "offset date-time"+++instance FromValue FlatOrNonEmptyStrings where+  fromValue v@Array{} = NonEmpty <$> fromValue v+  fromValue v@String{} = Flat <$> fromValue v+  fromValue v = typeError v "string or array of strings"+++instance ToValue FlatOrNonEmptyStrings where+  toValue (Flat a) = toValue a+  toValue (NonEmpty as) = toValue as+++instance FromKey MonikerName where+  fromKey key = case parseMonikerName $ pack key of+    Right monikerName -> return monikerName+    Left _ -> fail $ "invalid moniker name: " ++ show key+++instance FromValue MonikerName where+  fromValue v@String{} = do+    result <- fromValue v+    case parseMonikerName result of+      Right monikerName -> return monikerName+      Left _ -> fail $ "invalid moniker name: " ++ show v+  fromValue v = typeError v "string"+++instance ToKey MonikerName where+  toKey = unpack . original . (.name)+++instance ToValue MonikerName where+  toValue monikerName = toValue $ original monikerName.name+++data EnvironmentPredicate' = EnvironmentPredicate'+  { os :: Maybe FlatOrNonEmptyStrings+  , arch :: Maybe FlatOrNonEmptyStrings+  , kernel :: Maybe FlatOrNonEmptyStrings+  , kernelRelease :: Maybe FlatOrNonEmptyStrings+  , all :: Maybe (NonEmpty MonikerName)+  , any :: Maybe (NonEmpty MonikerName)+  , when :: Maybe Text+  }+  deriving (Eq, Show)+++always :: EnvironmentPredicate'+always =+  EnvironmentPredicate'+    { os = Nothing+    , arch = Nothing+    , kernel = Nothing+    , kernelRelease = Nothing+    , all = Nothing+    , any = Nothing+    , when = Nothing+    }+++instance FromValue EnvironmentPredicate' where+  fromValue =+    parseTableFromValue+      $ EnvironmentPredicate'+      <$> optKey "os"+      <*> optKey "arch"+      <*> optKey "kernel"+      <*> optKey "kernel-release"+      <*> optKey "all"+      <*> optKey "any"+      <*> optKey "when"+++instance ToValue EnvironmentPredicate' where+  toValue = defaultTableToValue+++instance ToTable EnvironmentPredicate' where+  toTable pred' =+    table+      $ fieldsToValue fields+      ++ fieldsToValue fields'+      ++ fieldsToValue+        [("when", pred'.when)]+   where+    fields :: [(String, Maybe FlatOrNonEmptyStrings)]+    fields =+      [ ("os", pred'.os)+      , ("arch", pred'.arch)+      , ("kernel", pred'.kernel)+      , ("kernel-release", pred'.kernelRelease)+      ]+    fields' :: [(String, Maybe (NonEmpty MonikerName))]+    fields' =+      [ ("all", pred'.all)+      , ("any", pred'.any)+      ]+    fieldsToValue :: (ToValue a) => [(String, Maybe a)] -> [(String, Value)]+    fieldsToValue fs = [(key, toValue value) | (key, Just value) <- fs]+++type MonikerMap' = Map MonikerName EnvironmentPredicate'+++type FileRoute' = Map MonikerName Text+++type FileRouteMap' = Map FilePath FileRoute'+++type IgnoreMap' = Map FilePath [FilePattern]+++data Manifest' = Manifest'+  { monikers :: MonikerMap'+  , dirs :: FileRouteMap'+  , files :: FileRouteMap'+  , ignores :: IgnoreMap'+  }+  deriving (Eq, Show, Generic)+++instance FromValue Manifest' where+  fromValue = parseTableFromValue genericParseTable+++instance ToValue Manifest' where+  toValue = defaultTableToValue+++instance ToTable Manifest' where+  toTable = genericToTable
+ src/Dojang/Syntax/Manifest/Parser.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoFieldSelectors #-}++module Dojang.Syntax.Manifest.Parser+  ( Error (..)+  , formatErrors+  , readManifest+  , readManifestFile+  ) where++import Data.Bifunctor (Bifunctor (first))+import Data.Either (lefts)+import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Data.List.NonEmpty (toList)+import Data.String (IsString (fromString))+import Data.Void (Void)+import System.IO.Unsafe (unsafePerformIO)+import Prelude hiding (readFile)++import Data.HashMap.Strict as HashMap (fromList)+import Data.Map.Strict as Map (Map, fromList, toList)+import Data.Text (Text, pack, unpack)+import Data.Text.Encoding (decodeUtf8Lenient)+import System.FilePattern (FilePattern)+import System.OsPath (OsPath, encodeFS)+import Toml (Result (..), decode)++import Dojang.MonadFileSystem (FileType (..), MonadFileSystem (readFile))+import Dojang.Syntax.EnvironmentPredicate.Parser+  ( ParseErrorBundle+  , errorBundlePretty+  , parseEnvironmentPredicate+  )+import Dojang.Syntax.FilePathExpression.Parser+  ( errorBundlePretty+  , parseFilePathExpression+  )+import Dojang.Syntax.Manifest.Internal+  ( EnvironmentPredicate' (..)+  , FileRoute'+  , FileRouteMap'+  , FlatOrNonEmptyStrings (..)+  , Manifest' (..)+  , MonikerMap'+  )+import Dojang.Types.EnvironmentPredicate+  ( EnvironmentPredicate (..)+  , normalizePredicate+  )+import Dojang.Types.FilePathExpression (FilePathExpression)+import Dojang.Types.FileRoute (FileRoute, fileRoute)+import Dojang.Types.FileRouteMap (FileRouteMap)+import Dojang.Types.Manifest (Manifest (Manifest))+import Dojang.Types.MonikerMap (MonikerMap)+import Dojang.Types.MonikerName (MonikerName)+++-- | An error made during parsing.+data Error+  = -- | TOML parsing errors.+    TomlErrors (NonEmpty String)+  | -- | An error made during parsing an 'EnvironmentPredicate'.+    EnvironmentPredicateError (ParseErrorBundle Text Void)+  | -- | An error made during parsing a 'FilePathExpression'.+    FilePathExpressionError (ParseErrorBundle Text Void)+++-- | A warning message made during parsing.+type TomlWarning = Text+++-- | Decodes a 'Manifest' from a 'Text'.+readManifest+  :: Text+  -- ^ A TOML document text to parse.+  -> Either Error (Manifest, [TomlWarning])+  -- ^ A decoded 'Manifest' with warnings, or a list of errors.+readManifest toml = case decode $ unpack toml of+  Success warnings manifest' ->+    case mapManifest manifest' of+      Left e -> Left e+      Right m -> Right (m, pack <$> warnings)+  Failure (e : es) -> Left $ TomlErrors $ e :| es+  Failure [] -> Left $ TomlErrors $ "unknown error" :| []+++-- | Reads a 'Manifest' file from the given path.  It assumes that the file+-- is encoded in UTF-8.  Throws an 'IOError' if the file cannot be read.+readManifestFile+  :: (MonadFileSystem m)+  => OsPath+  -- ^ A path to the manifest file.+  -> m (Either Error (Manifest, [TomlWarning]))+  -- ^ A decoded manifest with warnings, or a list of errors.+readManifestFile filePath = do+  content <- readFile filePath+  return $ readManifest $ decodeUtf8Lenient content+++-- | Format error messages.+formatErrors :: Error -> [Text]+formatErrors (TomlErrors es) = Data.List.NonEmpty.toList $ fmap pack es+formatErrors (EnvironmentPredicateError e) =+  [Dojang.Syntax.EnvironmentPredicate.Parser.errorBundlePretty e]+formatErrors (FilePathExpressionError e) =+  [Dojang.Syntax.FilePathExpression.Parser.errorBundlePretty e]+++mapManifest :: Manifest' -> Either Error Manifest+mapManifest manifest' =+  case monikersResult of+    Left e -> Left e+    Right monikers' ->+      case mapFileRouteMap monikers' manifest'.dirs manifest'.files of+        Left e -> Left e+        Right fileRoutes' -> Right $ Manifest monikers' fileRoutes' ignores'+ where+  monikersResult :: Either Error MonikerMap+  monikersResult = mapMonikerMap manifest'.monikers+  ignores' :: Map OsPath [FilePattern]+  ignores' =+    Map.fromList+      [ (encodePath path, pattern)+      | (path, pattern) <- Map.toList manifest'.ignores+      ]+++mapMonikerMap :: MonikerMap' -> Either Error MonikerMap+mapMonikerMap m =+  case errors of+    e : _ -> Left e+    _ ->+      Right+        $ HashMap.fromList+          [(name, pred') | (name, Right pred') <- results]+ where+  results :: [(MonikerName, Either Error EnvironmentPredicate)]+  results =+    [ (name, mapEnvironmentPredicate' pred')+    | (name, pred') <- toList m+    ]+  errors :: [Error]+  errors = lefts [r | (_, r) <- results]+++mapEnvironmentPredicate'+  :: EnvironmentPredicate'+  -> Either Error EnvironmentPredicate+mapEnvironmentPredicate' envPred' =+  case when of+    Right pred' ->+      Right+        $ normalizePredicate+        $ And [os, arch, kernel, kernelRelease, all', any', pred']+    Left err -> Left err+ where+  os :: EnvironmentPredicate+  os =+    maybe+      Always+      (Or . fmap OperatingSystem . mapFlatOrNonEmptyStrings)+      envPred'.os+  arch :: EnvironmentPredicate+  arch =+    maybe+      Always+      (Or . fmap Architecture . mapFlatOrNonEmptyStrings)+      envPred'.arch+  kernel :: EnvironmentPredicate+  kernel =+    maybe+      Always+      (Or . fmap KernelName . mapFlatOrNonEmptyStrings)+      envPred'.kernel+  kernelRelease :: EnvironmentPredicate+  kernelRelease =+    maybe+      Always+      (Or . fmap KernelRelease . mapFlatOrNonEmptyStrings)+      envPred'.kernelRelease+  all' :: EnvironmentPredicate+  all' = maybe Always (And . fmap Moniker) envPred'.all+  any' :: EnvironmentPredicate+  any' = maybe Always (Or . fmap Moniker) envPred'.any+  when :: Either Error EnvironmentPredicate+  when =+    maybe+      (Right Always)+      (first EnvironmentPredicateError . parseEnvironmentPredicate "")+      envPred'.when+++mapFlatOrNonEmptyStrings :: (IsString a) => FlatOrNonEmptyStrings -> NonEmpty a+mapFlatOrNonEmptyStrings (Flat a) = [fromString a]+mapFlatOrNonEmptyStrings (NonEmpty as) = fromString <$> as+++mapFileRouteMap+  :: MonikerMap -> FileRouteMap' -> FileRouteMap' -> Either Error FileRouteMap+mapFileRouteMap monikerMap dirs files =+  case errors of+    e : _ -> Left e+    _ -> Right $ Map.fromList [(name, route) | (name, Right route) <- results]+ where+  results :: [(OsPath, Either Error FileRoute)]+  results =+    [ (encodePath name, mapFileRoute monikerMap route Directory)+    | (name, route) <- toList dirs+    ]+      ++ [ (encodePath name, mapFileRoute monikerMap route File)+         | (name, route) <- toList files+         ]+  errors :: [Error]+  errors = lefts [r | (_, r) <- results]+++encodePath :: String -> OsPath+encodePath = unsafePerformIO . encodeFS+++mapFileRoute+  :: MonikerMap+  -> FileRoute'+  -> FileType+  -> Either Error FileRoute+mapFileRoute monikerMap fileRoute' fileType =+  case errors of+    e : _ -> Left $ FilePathExpressionError e+    _ ->+      Right+        $ fileRoute+          monikerMap+          ( [(name, Just expr') | (name, Just (Right expr')) <- results]+              ++ [(name, Nothing) | (name, Nothing) <- results]+          )+          fileType+ where+  results+    :: [ ( MonikerName+         , Maybe (Either (ParseErrorBundle Text Void) FilePathExpression)+         )+       ]+  results =+    [ ( name+      , if expr == "" then Nothing else Just $ parseFilePathExpression "" expr+      )+    | (name, expr) <- toList fileRoute'+    ]+  errors :: [ParseErrorBundle Text Void]+  errors = lefts [r | (_, Just r) <- results]
+ src/Dojang/Syntax/Manifest/Writer.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoFieldSelectors #-}++module Dojang.Syntax.Manifest.Writer+  ( writeManifest+  , writeManifestFile+  ) where++import Data.Bifunctor (Bifunctor (bimap, second))+import Data.List (partition)+import Data.List.NonEmpty (NonEmpty ((:|)), length, toList)+import Data.Maybe (catMaybes, fromMaybe, listToMaybe)+import GHC.IsList (IsList (fromList))+import System.IO.Unsafe (unsafePerformIO)+import Prelude hiding (all, any, writeFile)++import Data.CaseInsensitive (CI (original))+import Data.HashMap.Strict (toList)+import Data.Map.Strict (toList)+import Data.Text (Text, unpack)+import Data.Text.Encoding (encodeUtf8)+import System.OsPath (OsPath, decodeFS)+import TextShow (FromStringShow (FromStringShow), TextShow (showt))+import Toml.Pretty (prettyTomlOrdered)+import Toml.ToValue (ToTable (toTable))+import Toml.Value (Table)++import Dojang.MonadFileSystem+  ( FileType (Directory)+  , MonadFileSystem (writeFile)+  )+import Dojang.Syntax.EnvironmentPredicate.Writer (writeEnvironmentPredicate)+import Dojang.Syntax.Manifest.Internal+  ( EnvironmentPredicate' (..)+  , FileRoute'+  , FileRouteMap'+  , FlatOrNonEmptyStrings (..)+  , IgnoreMap'+  , Manifest' (Manifest')+  , MonikerMap'+  , always+  )+import Dojang.Types.EnvironmentPredicate+  ( EnvironmentPredicate (..)+  , normalizePredicate+  )+import Dojang.Types.FilePathExpression (toPathText)+import Dojang.Types.FileRoute (FileRoute (..))+import Dojang.Types.FileRouteMap (FileRouteMap)+import Dojang.Types.Manifest (Manifest (..))+import Dojang.Types.MonikerMap (MonikerMap)+import Dojang.Types.MonikerName (MonikerName)+++schema :: Text+schema = "https://schema.dojang.dev/2023-11/manifest.schema.json"+++-- | Encodes a 'Manifest' into a TOML document.+writeManifest :: Manifest -> Text+writeManifest manifest =+  "#:schema "+    <> schema+    <> "\n\n"+    <> (showt $ FromStringShow $ prettyTomlOrdered order tbl)+ where+  manifest' :: Manifest'+  manifest' = mapManifest' manifest+  tbl :: Table+  tbl = toTable manifest'+  order :: [String] -> String -> Either Int String+  order [] field = case field of+    "dirs" -> Left 1+    "files" -> Left 2+    "ignores" -> Left 3+    "monikers" -> Left 4+    _ -> Right field+  order _ field = Right field+++-- | Writes a 'Manifest' file to the given path.  Throw an 'IOError' if the+-- an occurs while writing the file.+writeManifestFile+  :: (MonadFileSystem m)+  => Manifest+  -- ^ The 'Manifest' to write.+  -> OsPath+  -- ^ The path to write the 'Manifest' to.+  -> m ()+writeManifestFile manifest filePath =+  writeFile filePath $ encodeUtf8 $ writeManifest manifest+++mapManifest' :: Manifest -> Manifest'+mapManifest' manifest =+  Manifest' monikers' dirs files ignores+ where+  dirs :: FileRouteMap'+  files :: FileRouteMap'+  (dirs, files) = mapFiles manifest.fileRoutes manifest.monikers+  monikers' :: MonikerMap'+  monikers' = mapMonikers' manifest.monikers+  ignores :: IgnoreMap'+  ignores =+    fromList+      [ (decodePath path, pattern)+      | (path, pattern) <- Data.Map.Strict.toList manifest.ignorePatterns+      ]+++mapFiles :: FileRouteMap -> MonikerMap -> (FileRouteMap', FileRouteMap')+mapFiles fileRouteMap monikers =+  ( fromList (bimap decodePath (`mapFileRoute'` monikers) <$> dirs)+  , fromList (bimap decodePath (`mapFileRoute'` monikers) <$> files)+  )+ where+  dirs :: [(OsPath, FileRoute)]+  files :: [(OsPath, FileRoute)]+  (dirs, files) =+    partition+      ((== Directory) . fileType . snd)+      $ Data.Map.Strict.toList fileRouteMap+++decodePath :: OsPath -> FilePath+decodePath = unsafePerformIO . decodeFS+++mapFileRoute' :: FileRoute -> MonikerMap -> FileRoute'+mapFileRoute' fileRoute monikers =+  (fromList . catMaybes)+    [ case (normalizePredicate pred', maybe "" toPathText filePath) of+      (Moniker n, path) -> Just (n, path)+      (pred'', path) -> case lookBack monikers pred'' of+        Just n -> Just (n, path)+        Nothing -> Nothing+    | (pred', filePath) <- fileRoute.predicates+    ]+++lookBack :: MonikerMap -> EnvironmentPredicate -> Maybe MonikerName+lookBack monikers predicate =+  listToMaybe+    [ n+    | (n, p) <- Data.HashMap.Strict.toList monikers+    , normalizePredicate p == normalizedPred+    ]+ where+  normalizedPred :: EnvironmentPredicate+  normalizedPred = normalizePredicate predicate+++mapMonikers' :: MonikerMap -> MonikerMap'+mapMonikers' monikers =+  fromList+    $ second (mapEnvironmentPredicate' . normalizePredicate)+    <$> Data.HashMap.Strict.toList monikers+++mapEnvironmentPredicate' :: EnvironmentPredicate -> EnvironmentPredicate'+mapEnvironmentPredicate' Always = always+mapEnvironmentPredicate' (Moniker n) = always{all = Just $ fromList [n]}+mapEnvironmentPredicate' (OperatingSystem os) =+  always{os = Just $ Flat $ unpack $ original os.identifier}+mapEnvironmentPredicate' (Architecture arch) =+  always{arch = Just $ Flat $ unpack $ original arch.identifier}+mapEnvironmentPredicate' (KernelName kernel) =+  always{kernel = Just $ Flat $ unpack $ original kernel}+mapEnvironmentPredicate' (KernelRelease kernelRelease) =+  always{kernelRelease = Just $ Flat $ unpack $ original kernelRelease}+mapEnvironmentPredicate' (And predicates') =+  fromMaybe+    always{when = Just $ writeEnvironmentPredicate $ And predicates'}+    (xor' $ mapEnvironmentPredicate' <$> predicates')+ where+  xor' :: NonEmpty EnvironmentPredicate' -> Maybe EnvironmentPredicate'+  xor' (predicate :| []) = Just predicate+  xor' (a :| predicates'') =+    let r : est = predicates''+    in case xor' (r :| est) of+        Nothing -> Nothing+        Just b -> do+          os' <- xorMaybe a.os b.os+          arch' <- xorMaybe a.arch b.arch+          kernel' <- xorMaybe a.kernel b.kernel+          kernelRelease' <- xorMaybe a.kernelRelease b.kernelRelease+          all' <- xorMaybe a.all b.all+          any' <- xorMaybe a.any b.any+          when' <- xorMaybe a.when b.when+          return+            EnvironmentPredicate'+              { os = os'+              , arch = arch'+              , kernel = kernel'+              , kernelRelease = kernelRelease'+              , all = all'+              , any = any'+              , when = when'+              }+  xorMaybe :: Maybe a -> Maybe a -> Maybe (Maybe a)+  xorMaybe (Just _) (Just _) = Nothing+  xorMaybe (Just a) Nothing = Just $ Just a+  xorMaybe Nothing (Just b) = Just $ Just b+  xorMaybe Nothing Nothing = Just Nothing+mapEnvironmentPredicate' (Or predicates')+  | Prelude.length oses == length' =+      always{os = Just $ NonEmpty $ toNonEmpty oses}+  | Prelude.length arches == length' =+      always{arch = Just $ NonEmpty $ toNonEmpty arches}+  | Prelude.length kernels == length' =+      always{kernel = Just $ NonEmpty $ toNonEmpty kernels}+  | Prelude.length kernelReleases == length' =+      always{kernelRelease = Just $ NonEmpty $ toNonEmpty kernelReleases}+  | Prelude.length monikers' == length' =+      always{any = Just $ toNonEmpty monikers'}+  | otherwise =+      always{when = Just $ writeEnvironmentPredicate $ Or predicates'}+ where+  length' :: Int+  length' = Data.List.NonEmpty.length predicates'+  oses :: [String]+  oses =+    [ unpack $ original os'.identifier+    | OperatingSystem os' <- Data.List.NonEmpty.toList predicates'+    ]+  arches :: [String]+  arches =+    [ unpack $ original arch'.identifier+    | Architecture arch' <- Data.List.NonEmpty.toList predicates'+    ]+  kernels :: [String]+  kernels =+    [ unpack $ original kernel'+    | KernelName kernel' <- Data.List.NonEmpty.toList predicates'+    ]+  kernelReleases :: [String]+  kernelReleases =+    [ unpack $ original kernelRelease'+    | KernelRelease kernelRelease' <- Data.List.NonEmpty.toList predicates'+    ]+  monikers' :: [MonikerName]+  monikers' = [n | Moniker n <- Data.List.NonEmpty.toList predicates']+  toNonEmpty :: [a] -> NonEmpty a+  toNonEmpty l = head l :| tail l+mapEnvironmentPredicate' pred' =+  always{when = Just $ writeEnvironmentPredicate pred'}
+ src/Dojang/Types/Context.hs view
@@ -0,0 +1,532 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoFieldSelectors #-}++module Dojang.Types.Context+  ( Context (..)+  , FileCorrespondence (..)+  , FileDeltaKind (..)+  , FileEntry (..)+  , FileStat (..)+  , RouteState (..)+  , getRouteState+  , listFiles+  , makeCorrespond+  , makeCorrespondBetweenThreeDirs+  , makeCorrespondBetweenThreeFiles+  , makeCorrespondBetweenTwoDirs+  , makeCorrespondWithDestination+  , routePaths+  ) where++import Control.Monad (forM, when)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.List (find, isPrefixOf, sortOn)+import Data.Ord (Down (Down))+import GHC.IO.Exception (IOErrorType (InappropriateType))+import GHC.Stack (HasCallStack)+import System.IO.Error+  ( ioeSetErrorString+  , ioeSetFileName+  , isPermissionError+  , mkIOError+  )+import Prelude hiding (readFile)++import Control.Monad.Except (MonadError (..))+import Data.Map.Strict+  ( Map+  , filter+  , findWithDefault+  , fromList+  , keysSet+  , unionWith+  , (!?)+  )+import System.Directory.OsPath (makeAbsolute)+import System.FilePattern (FilePattern, matchMany)+import System.OsPath+  ( OsPath+  , joinPath+  , makeRelative+  , normalise+  , splitDirectories+  , (</>)+  )+import System.OsString (OsString)++import Data.Set (toList, union)+import Dojang.MonadFileSystem (MonadFileSystem (..))+import Dojang.MonadFileSystem qualified (FileType (..))+import Dojang.Types.Environment (Environment)+import Dojang.Types.FilePathExpression (EnvironmentVariable)+import Dojang.Types.Manifest (Manifest (..))+import Dojang.Types.Repository+  ( Repository (..)+  , RouteMapWarning+  , RouteResult (..)+  )+import Dojang.Types.Repository qualified (routePaths)+++-- | The context in which repository operations are performed.+data (MonadFileSystem m) => Context m = Context+  { repository :: Repository+  -- ^ The repository.+  , environment :: Environment+  -- ^ The environment.+  , environmentVariableGetter :: EnvironmentVariable -> m (Maybe OsString)+  -- ^ A function to look up an environment variable.+  }+++-- | Route the paths in the repository.  This will return a list of expanded+-- paths, along with any warnings that were generated.  Null routes will be+-- ignored.+routePaths+  :: (MonadFileSystem m)+  => Context m+  -- ^ The context in which to perform path routing.+  -> m ([RouteResult], [RouteMapWarning])+  -- ^ The expanded paths, along with any warnings that were generated.+routePaths ctx =+  Dojang.Types.Repository.routePaths+    ctx.repository+    ctx.environment+    ctx.environmentVariableGetter+++-- | The small stat of a file.+data FileStat+  = -- | The file is missing.+    Missing+  | -- | The file is a directory.+    Directory+  | -- | The file is a regular file, and this is its size in bytes.+    File Integer+  | -- | The file is a symlink, and this is the path to the symlink target.+    Symlink OsPath+  deriving (Eq, Ord, Show)+++-- | A file/directory in the repository or the destination directory.+data FileEntry = FileEntry+  { path :: OsPath+  -- ^ The path to the file.+  , stat :: FileStat+  -- ^ Whether the file is a file, a directory, or missing.+  }+  deriving (Eq, Ord, Show)+++-- | The kind of change that was made to a file.+data FileDeltaKind = Unchanged | Added | Removed | Modified+  deriving (Eq, Ord, Show)+++-- | A correspondence between a source file, an intermediate file, and+-- a destination file.+data FileCorrespondence = FileCorrespondence+  { source :: FileEntry+  -- ^ The source file.+  , sourceDelta :: FileDeltaKind+  -- ^ The kind of change that was made to the source file.+  , intermediate :: FileEntry+  -- ^ The intermediate file.+  , destination :: FileEntry+  -- ^ The destination file.+  , destinationDelta :: FileDeltaKind+  -- ^ The kind of change that was made to the destination file.+  }+  deriving (Eq, Ord, Show)+++-- | Creates a 'FileCorrespondence' from a single destination file.+makeCorrespondWithDestination+  :: forall m+   . (MonadFileSystem m)+  => Context m+  -- ^ The context in which to perform file correspondence.+  -> OsPath+  -- ^ The path to the destination file.+  -> m (Maybe FileCorrespondence, [RouteMapWarning])+  -- ^ The file correspondence, along with a list of warnings that occurred+  -- during path routing (if any).  The file paths in the returned+  -- 'FileCorrespondence' value are absolute, or relative to the current+  -- working directory at least.+makeCorrespondWithDestination ctx dstPath = do+  (paths, warnings) <- routePaths ctx+  let paths' = sortOn (Down . (.destinationPath)) paths+  let dstPath' = splitDirectories $ normalise dstPath+  case find (`startsWith` dstPath') paths' of+    Nothing -> return (Nothing, warnings)+    Just route -> do+      let normalized = normalise route.destinationPath+      let relPath = makeRelative normalized dstPath+      period <- encodePath "."+      let (interPath, srcPath) =+            if normalized == dstPath || relPath == period+              then+                let interPath' =+                      normalise+                        (ctx.repository.intermediatePath </> route.routeName)+                    srcPath' = normalise route.sourcePath+                in (interPath', srcPath')+              else+                let interPath' =+                      normalise+                        $ ctx.repository.intermediatePath+                        </> route.routeName+                        </> relPath+                    srcPath' = normalise $ route.sourcePath </> relPath+                in (interPath', srcPath')+      correspond <- makeCorrespondBetweenThreeFiles interPath srcPath dstPath+      return (Just correspond, warnings)+ where+  startsWith :: RouteResult -> [OsPath] -> Bool+  startsWith p prefix =+    splitDirectories (normalise p.destinationPath) `isPrefixOf` prefix+++-- | Creates a list of file correspondences between the source files, the+-- intermediate files, and the destination files.  Throws an 'IOError' if any of+-- the files cannot be read.+makeCorrespond+  :: (HasCallStack, MonadFileSystem m)+  => Context m+  -- ^ The context in which to perform file correspondence.+  -> m ([FileCorrespondence], [RouteMapWarning])+  -- ^ The file correspondences, along with a list of warnings that occurred+  -- during path routing (if any).  The file paths in the returned+  -- 'FileCorrespondence' values are absolute, or relative to the current+  -- working directory at least.+makeCorrespond ctx = do+  (paths, warnings) <- routePaths ctx+  files <- forM paths $ \expanded -> do+    let interAbsPath = repo.intermediatePath </> expanded.routeName+    case expanded.fileType of+      Dojang.MonadFileSystem.Directory -> do+        fs <-+          makeCorrespondBetweenThreeDirs+            interAbsPath+            expanded.sourcePath+            expanded.destinationPath+            (findWithDefault [] (normalise expanded.routeName) ignorePatterns)+        return+          [ correspond+            { source =+                correspond.source{path = expanded.sourcePath </> correspond.source.path}+            , intermediate =+                correspond.intermediate+                  { path = interAbsPath </> correspond.intermediate.path+                  }+            , destination =+                correspond.destination+                  { path =+                      expanded.destinationPath </> correspond.destination.path+                  }+            }+          | correspond <- fs+          ]+      _ -> do+        f <-+          makeCorrespondBetweenThreeFiles+            interAbsPath+            expanded.sourcePath+            expanded.destinationPath+        return [f]+  return (concat files, warnings)+ where+  repo :: Repository+  repo = ctx.repository+  ignorePatterns :: Map OsPath [FilePattern]+  ignorePatterns = repo.manifest.ignorePatterns+++makeCorrespondBetweenThreeFiles+  :: forall m+   . (HasCallStack, MonadFileSystem m)+  => OsPath+  -> OsPath+  -> OsPath+  -> m FileCorrespondence+makeCorrespondBetweenThreeFiles intermediatePath srcPath dstPath = do+  interStat <- getFileStat intermediatePath+  let interEntry = FileEntry intermediatePath interStat+  srcStat <- getFileStat srcPath+  let srcEntry = FileEntry srcPath srcStat+  srcDelta <- getDelta interEntry srcEntry+  dstStat <- getFileStat dstPath+  let dstEntry = FileEntry dstPath dstStat+  dstDelta <- getDelta interEntry dstEntry+  return+    FileCorrespondence+      { source = srcEntry+      , sourceDelta = srcDelta+      , intermediate = interEntry+      , destination = dstEntry+      , destinationDelta = dstDelta+      }+ where+  getFileStat :: OsPath -> m FileStat+  getFileStat path = do+    isDir <- isDirectory path+    when isDir $ do+      path' <- decodePath path+      throwError+        $ userError+          ( "makeCorrespondBetweenThreeFiles: "+              ++ "expected a file, but got a directory"+          )+        `ioeSetFileName` path'+    exists' <- exists path+    if exists'+      then do+        size <- getFileSize path+        return $ File size+      else return Missing+  getDelta :: FileEntry -> FileEntry -> m FileDeltaKind+  getDelta (FileEntry _ Missing) (FileEntry _ Missing) = return Unchanged+  getDelta (FileEntry _ Missing) (FileEntry _ _) = return Added+  getDelta (FileEntry _ File{}) (FileEntry _ Missing) = return Removed+  getDelta (FileEntry _ Symlink{}) (FileEntry _ Missing) = return Removed+  getDelta (FileEntry _ (Symlink path)) (FileEntry _ (Symlink path')) =+    if path == path'+      then return Unchanged+      else return Modified+  getDelta interEntry targetEntry =+    if interEntry.stat /= targetEntry.stat+      then return Modified+      else do+        interData <- readFile interEntry.path+        targetData <- readFile targetEntry.path+        return $ if interData == targetData then Unchanged else Modified+++makeCorrespondBetweenThreeDirs+  :: forall m+   . (HasCallStack, MonadFileSystem m)+  => OsPath+  -> OsPath+  -> OsPath+  -> [FilePattern]+  -> m [FileCorrespondence]+makeCorrespondBetweenThreeDirs intermediatePath srcPath dstPath ignores = do+  srcEntries <- makeCorrespondBetweenTwoDirs intermediatePath srcPath []+  dstEntries <-+    makeCorrespondBetweenTwoDirs intermediatePath dstPath ignores+  let paths = keysSet srcEntries `union` keysSet dstEntries+  forM (Data.Set.toList paths) $ \path -> do+    let missing = FileEntry path Missing+    (interEntry, srcEntry, srcDelta) <- case srcEntries !? path of+      Nothing -> return (missing, missing, Unchanged)+      Just (interEntry', srcEntry') -> do+        delta <-+          getDelta path srcPath interEntry'.stat srcEntry'.stat+        return (interEntry', srcEntry', delta)+    (interEntry2, dstEntry, dstDelta) <- case dstEntries !? path of+      Nothing -> return (missing, missing, Unchanged)+      Just (interEntry', dstEntry') -> do+        delta <- getDelta path dstPath interEntry'.stat dstEntry'.stat+        return (interEntry', dstEntry', delta)+    (dstEntry', dstDelta') <-+      if null ignores || dstEntry.stat /= Missing+        then return (dstEntry, dstDelta)+        else do+          actualDstStat <- getFileStat (dstPath </> path)+          actualDelta <- getDelta path dstPath interEntry2.stat actualDstStat+          return (dstEntry{stat = actualDstStat}, actualDelta)+    return+      $ FileCorrespondence+        { source = srcEntry+        , sourceDelta = srcDelta+        , intermediate =+            if interEntry.stat == Missing+              then interEntry2+              else interEntry+        , destination = dstEntry'+        , destinationDelta = dstDelta'+        }+ where+  getDelta+    :: OsPath+    -- \^ The relative path to the file.+    -> OsPath+    -- \^ The path to the target directory.+    -> FileStat+    -- \^ An intermediate file stat.+    -> FileStat+    -- \^ A target (source or destination) file stat.+    -> m FileDeltaKind+  getDelta _ _ Directory Directory = return Unchanged+  getDelta _ _ Directory Missing = return Removed+  getDelta _ _ Directory _ = return Modified+  getDelta path targetPath (File size) (File size') =+    if size /= size'+      then return Modified+      else do+        interData <- readFile (intermediatePath </> path)+        targetData <- readFile (targetPath </> path)+        return $ if interData == targetData then Unchanged else Modified+  getDelta _ _ (File _) Missing = return Removed+  getDelta _ _ (File _) _ = return Modified+  getDelta _ _ (Symlink path) (Symlink path') =+    if path == path'+      then return Unchanged+      else return Modified+  getDelta _ _ (Symlink _) Missing = return Added+  getDelta _ _ (Symlink _) _ = return Modified+  getDelta _ _ Missing Missing = return Unchanged+  getDelta _ _ Missing _ = return Added+  getFileStat :: OsPath -> m FileStat+  getFileStat path' = do+    isSym <- isSymlink path'+    if isSym+      then do+        target <- readSymlinkTarget path'+        return $ Symlink target+      else do+        isDir <- isDirectory path'+        if isDir+          then return Directory+          else do+            isFle <- isFile path'+            if isFle+              then do+                size <- getFileSize path'+                return $ File size+              else return Missing+++makeCorrespondBetweenTwoDirs+  :: forall m+   . (HasCallStack, MonadFileSystem m)+  => OsPath+  -> OsPath+  -> [FilePattern]+  -> m (Map OsPath (FileEntry, FileEntry))+makeCorrespondBetweenTwoDirs intermediatePath targetPath ignorePatterns = do+  intermediateDirExists <- exists intermediatePath+  intermediateFiles <-+    if intermediateDirExists+      then listFiles intermediatePath []+      else return []+  targetFiles <- listFiles targetPath ignorePatterns+  let intermediateEntries =+        fromList+          [(p, (e, e{stat = Missing})) | e@(FileEntry p _) <- intermediateFiles]+      targetEntries =+        fromList+          [(p, (e{stat = Missing}, e)) | e@(FileEntry p _) <- targetFiles]+      allEntries = unionWith combinePairs intermediateEntries targetEntries+  return $ Data.Map.Strict.filter eitherExists allEntries+ where+  combinePairs+    :: (FileEntry, FileEntry)+    -> (FileEntry, FileEntry)+    -> (FileEntry, FileEntry)+  combinePairs (a1, b1) (a2, b2)+    | isNotMissing a1 && isNotMissing b2 = (a1, b2)+    | isNotMissing a2 && isNotMissing b1 = (a2, b1)+    | isMissing a1 && isNotMissing b2 = (a2, b2)+    | otherwise = (a1, b1)+   where+    isMissing :: FileEntry -> Bool+    isMissing (FileEntry _ Missing) = True+    isMissing _ = False+    isNotMissing :: FileEntry -> Bool+    isNotMissing = not . isMissing+  eitherExists :: (FileEntry, FileEntry) -> Bool+  eitherExists (FileEntry _ Missing, FileEntry _ Missing) = False+  eitherExists _ = True+++-- | Lists all 'FilEntry' values in the given directory.  Throws an 'IOError' if+-- the directory cannot be read.+listFiles+  :: (MonadFileSystem m)+  => OsPath+  -- ^ The path to the directory to list entries in.+  -> [FilePattern]+  -- ^ The file patterns to ignore.  If a directory matches one of these+  -- patterns, then its contents will not be listed either.+  -> m [FileEntry]+  -- ^ The list of 'FileEntry' values in the directory.+listFiles path ignorePatterns = do+  isSymlink' <- isSymlink path+  isFile' <- isFile path+  when (isSymlink' || isFile') $ do+    path' <- decodePath path+    throwError+      $ mkIOError InappropriateType "listFiles" Nothing (Just path')+      `ioeSetErrorString` "not a directory"+  exists' <- exists path+  if exists'+    then do+      entries <-+        listDirectoryRecursively path ignorePatterns `catchError` \e ->+          if isPermissionError e+            then return []+            else throwError e+      forM entries $ \case+        (Dojang.MonadFileSystem.Directory, d) ->+          return $ FileEntry d Directory+        (Dojang.MonadFileSystem.File, f) -> do+          size <- getFileSize $ path </> f+          return $ FileEntry f $ File size+        (Dojang.MonadFileSystem.Symlink, s) -> do+          target <- readSymlinkTarget $ path </> s+          return $ FileEntry s $ Symlink target+    else return []+++-- | Represents the route state of a (potential) destination file+-- in the repository.+data RouteState+  = -- | The file is routed.  The 'OsPath' is the name of the relevant route+    -- name.+    Routed OsPath+  | -- | The file is routed but ignored.  The 'OsPath' is the name of+    -- the relevant route name, and the 'FilePattern' is the ignore pattern+    -- that matched the file.+    Ignored OsPath FilePattern+  | -- | The file is not routed at all.+    NotRouted+  deriving (Eq, Ord, Show)+++-- | Gets the route state of the given path (which is a potential destination).+getRouteState+  :: (HasCallStack, MonadFileSystem m, MonadIO m)+  => Context m+  -- ^ The context in which to perform path routing.+  -> OsPath+  -- ^ The path (which is a potential destination) to get the route state of.+  -> m (RouteState, [RouteMapWarning])+  -- ^ The route state of the path, along with any warnings that were generated.+getRouteState ctx path = do+  absPath <- liftIO $ makeAbsolute path+  let dirs = splitDirectories absPath+  (routes, ws) <- routePaths ctx+  states <- forM routes $ \route -> do+    dstPath <- liftIO $ makeAbsolute route.destinationPath+    let prefix = splitDirectories dstPath+    if prefix `isPrefixOf` dirs+      then do+        let ignores =+              findWithDefault+                []+                (normalise route.routeName)+                ignorePatterns+        relPath <- decodePath $ joinPath $ drop (length prefix) dirs+        case matchMany [(i, i) | i <- ignores] [((), relPath)] of+          (pattern, _, _) : _ -> return $ Ignored route.routeName pattern+          _ -> return $ Routed route.routeName+      else return NotRouted+  return (if null states then NotRouted else minimum states, ws)+ where+  ignorePatterns :: Map OsPath [FilePattern]+  ignorePatterns = ctx.repository.manifest.ignorePatterns
+ src/Dojang/Types/Environment.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoFieldSelectors #-}++module Dojang.Types.Environment+  ( Architecture (..)+  , Environment (..)+  , Kernel (..)+  , OperatingSystem (..)+  ) where++import Data.Maybe (fromMaybe)+import Data.String (IsString (fromString))+import GHC.Records (HasField (getField))++import Data.CaseInsensitive (CI, mk)+import Data.HashMap.Strict (HashMap, fromList, toList, (!), (!?))+import Data.Hashable (Hashable (hashWithSalt))+import Data.Text (Text, pack)+++-- $setup+-- >>> :seti -XOverloadedStrings+-- >>> :seti -XOverloadedRecordDot+++-- | An operating system identifier.+data OperatingSystem+  = Android+  | FreeBSD+  | Linux+  | MacOS+  | NetBSD+  | OpenBSD+  | Windows+  | -- | An operating system that is not one of the above.+    OtherOS (CI Text)+  deriving (Eq, Ord, Read, Show)+++operatingSystems :: HashMap OperatingSystem (CI Text)+operatingSystems =+  [ (Android, "android")+  , (FreeBSD, "freebsd")+  , (Linux, "linux")+  , (MacOS, "macos")+  , (NetBSD, "netbsd")+  , (OpenBSD, "openbsd")+  , (Windows, "windows")+  ]+++operatingSystemIdentifiers :: HashMap (CI Text) OperatingSystem+operatingSystemIdentifiers =+  fromList $! [(ident, os') | (os', ident) <- toList operatingSystems]+++-- | Gets an 'OperatingSystem' from an identifier.+--+-- >>> fromString "linux" :: OperatingSystem+-- Linux+-- >>> fromString "windows" :: OperatingSystem+-- Windows+-- >>> fromString "amigaos" :: OperatingSystem+-- OtherOS "amigaos"+instance IsString OperatingSystem where+  fromString s =+    fromMaybe (OtherOS ident) (operatingSystemIdentifiers !? ident)+   where+    ident :: CI Text+    ident = mk $ pack s+++-- | Gets the identifier for an 'OperatingSystem'.+--+-- >>> (Linux).identifier+-- "linux"+-- >>> (Windows).identifier+-- "windows"+--+-- If the 'OperatingSystem' is 'OtherOS', then the identifier is returned+-- unchanged.+--+-- >>> (OtherOS "amigaos").identifier+-- "amigaos"+instance HasField "identifier" OperatingSystem (CI Text) where+  getField (OtherOS os') = os'+  getField os' = operatingSystems ! os'+++instance Hashable OperatingSystem where+  hashWithSalt salt = hashWithSalt salt . show+++-- | An architecture identifier.+data Architecture+  = -- | ARM64+    AArch64+  | -- | x86 (i.e., i386)+    X86+  | -- | x86-64 (i.e., amd64)+    X86_64+  | -- | An architecture that is not one of the above.+    Etc (CI Text)+  deriving (Eq, Ord, Read, Show)+++architectures :: HashMap Architecture (CI Text)+architectures =+  [ (AArch64, "aarch64")+  , (X86, "x86")+  , (X86_64, "x86_64")+  ]+++architectureIdentifiers :: HashMap (CI Text) Architecture+architectureIdentifiers =+  fromList $! [(ident, arch') | (arch', ident) <- toList architectures]+++-- | Gets an 'Architecture' from an identifier.+--+-- >>> fromString "x86_64" :: Architecture+-- X86_64+-- >>> fromString "aarch64" :: Architecture+-- AArch64+-- >>> fromString "alpha" :: Architecture+-- Etc "alpha"+instance IsString Architecture where+  fromString s =+    fromMaybe (Etc ident) (architectureIdentifiers !? ident)+   where+    ident :: CI Text+    ident = mk $ pack s+++-- | Gets the identifier for an 'Architecture'.+--+-- >>> (X86_64).identifier+-- "x86_64"+-- >>> (AArch64).identifier+-- "aarch64"+--+-- If the 'Architecture' is 'Etc', then the identifier is returned unchanged.+--+-- >>> (Etc "alpha").identifier+-- "alpha"+instance HasField "identifier" Architecture (CI Text) where+  getField (Etc arch') = arch'+  getField arch' = architectures ! arch'+++instance Hashable Architecture where+  hashWithSalt salt = hashWithSalt salt . show+++-- | A kernel information.  Equivalent to @uname -sr@.+data Kernel = Kernel+  { name :: CI Text+  -- ^ The kernel name.  Equivalent to @uname -s@.+  , release :: CI Text+  -- ^ The kernel release.  Equivalent to @uname -r@.+  }+  deriving (Eq, Ord, Read, Show)+++instance Hashable Kernel where+  hashWithSalt salt (Kernel name' release') =+    salt `hashWithSalt` name' `hashWithSalt` release'+++-- | An environment.+data Environment = Environment+  { operatingSystem :: OperatingSystem+  -- ^ The operating system (e.g. 'Linux', 'MacOS').+  , architecture :: Architecture+  -- ^ The architecture (e.g. 'X86_64', 'AArch64').+  , kernel :: Kernel+  -- ^ The kernel information.  Equivalent to @uname -sr@.+  }+  deriving (Eq, Ord, Read, Show)+++instance Hashable Environment where+  hashWithSalt salt (Environment os' arch' kernel) =+    salt `hashWithSalt` os' `hashWithSalt` arch' `hashWithSalt` kernel
+ src/Dojang/Types/Environment/Current.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Dojang.Types.Environment.Current+  ( MonadArchitecture (..)+  , MonadEnvironment (..)+  , MonadOperatingSystem (..)+  , MonadKernel (..)+  , parseArchitecture+  , parseOperatingSystem+  ) where++import Data.Char (isDigit)+import Data.String (IsString (fromString))+import System.Info (arch, os)+import Prelude hiding (break)++import Data.CaseInsensitive (mk)+import Data.Text (break, dropAround, pack, strip, stripEnd)+import System.Process (readCreateProcess, readProcess, shell)++import Dojang.Types.Environment+  ( Architecture (..)+  , Environment (..)+  , Kernel (..)+  , OperatingSystem (..)+  )+++-- | Turns a string returned by 'System.Info.os' into an 'OperatingSystem'.+parseOperatingSystem :: String -> OperatingSystem+parseOperatingSystem = \case+  "linux-android" -> Android+  "darwin" -> MacOS+  "freebsd" -> FreeBSD+  "linux" -> Linux+  "netbsd" -> NetBSD+  "openbsd" -> OpenBSD+  "mingw32" -> Windows+  os' -> OtherOS $ fromString os'+++-- | Turns a string returned by 'System.Info.arch' into an 'Architecture'.+parseArchitecture :: String -> Architecture+parseArchitecture = \case+  "aarch64" -> AArch64+  "i386" -> X86+  "x86_64" -> X86_64+  arch' -> Etc $ fromString arch'+++-- | A monad that can get the current 'Environment'.+class (Monad m) => MonadOperatingSystem m where+  -- | Gets the current 'OperatingSystem'.+  currentOperatingSystem :: m OperatingSystem+++instance MonadOperatingSystem IO where+  currentOperatingSystem = return $ parseOperatingSystem os+++-- | A monad that can get the current 'Architecture'.+class (Monad m) => MonadArchitecture m where+  -- | Gets the current 'Architecture'.+  currentArchitecture :: m Architecture+++instance MonadArchitecture IO where+  currentArchitecture = return $ parseArchitecture arch+++-- | A monad that can get the current 'Kernel' information.+class (Monad m) => MonadKernel m where+  -- | Gets the current 'Kernel' information.+  currentKernel :: m Kernel+++instance MonadKernel IO where+  currentKernel+    | os == "mingw32" = do+        ver <- strip . pack <$> readCreateProcess (shell "cmd /c ver") ""+        let (name, rest) = break (== '[') ver+        let (_, release) = break (isDigit) $ dropAround (`elem` "[]") rest+        return $ Kernel (mk $ stripEnd name) (mk $ strip release)+    | otherwise = do+        name <- strip . pack <$> readProcess "uname" ["-s"] ""+        release <- strip . pack <$> readProcess "uname" ["-r"] ""+        return $ Kernel (mk name) (mk release)+++-- | A monad that can get the current 'Environment'.+class (Monad m) => MonadEnvironment m where+  -- | Gets the current 'Environment'.+  currentEnvironment :: m Environment+++instance+  (Monad m, MonadOperatingSystem m, MonadArchitecture m, MonadKernel m)+  => MonadEnvironment m+  where+  currentEnvironment = do+    os' <- currentOperatingSystem+    arch' <- currentArchitecture+    kernel' <- currentKernel+    return+      Environment+        { operatingSystem = os'+        , architecture = arch'+        , kernel = kernel'+        }
+ src/Dojang/Types/EnvironmentPredicate.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedRecordUpdate #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoFieldSelectors #-}++-- | A predicate expression that can be used to match an environment, e.g.,+-- @And [OperatingSystem "linux", Architecture "x86_64"]@.+module Dojang.Types.EnvironmentPredicate+  ( EnvironmentPredicate (..)+  , normalizePredicate+  ) where++import Data.List.NonEmpty (NonEmpty, filter, nonEmpty, nub, sortWith, toList)+import Prelude hiding (filter)++import Data.CaseInsensitive (CI)+import Data.Hashable (Hashable (hashWithSalt))+import Data.Text (Text)++import Data.Ord (Down (..))+import Dojang.Types.Environment (Architecture, OperatingSystem)+import Dojang.Types.MonikerName (MonikerName)+++-- | A predicate that can be used to match an environment.+data EnvironmentPredicate+  = -- | A predicate that always matches.+    Always+  | -- | A predicate that matches if the given predicate does not match.+    Not EnvironmentPredicate+  | -- | A predicate that matches if all of the given predicates match.+    And (NonEmpty EnvironmentPredicate)+  | -- | A predicate that matches if any of the given predicates match.+    Or (NonEmpty EnvironmentPredicate)+  | -- | A predicate that matches to another moniker.  Mostly used to eliminate+    -- duplication.+    Moniker MonikerName+  | -- | A predicate that matches to the given operating system (e.g. @linux@).+    -- For a list of possible values, see the 'System.Info.os' field.+    OperatingSystem OperatingSystem+  | -- | A predicate that matches to the given architecture (e.g. @x86_64@).+    -- For a list of possible values, see the 'System.Info.arch' field.+    Architecture Architecture+  | -- | A predicate that matches to the given kernel name (e.g. @Darwin@).+    KernelName (CI Text)+  | -- | A predicate that exactly matches to the given kernel release+    -- (e.g. @23.1.0@).+    KernelRelease (CI Text)+  | -- | A predicate that matches to the given kernel release prefix+    -- (e.g. @23.1@ for @23.1.0@).+    KernelReleasePrefix (CI Text)+  | -- | A predicate that matches to the given kernel release suffix+    -- (e.g. @amd64@ for @4.19.0-16-amd64@).+    KernelReleaseSuffix (CI Text)+  deriving (Show)+++instance Eq EnvironmentPredicate where+  Always == Always = True+  Always == _ = False+  Not p == Not p' = p == p'+  Not _ == _ = False+  And ps == And ps' = normalizePredicateList ps == normalizePredicateList ps'+  And _ == _ = False+  Or ps == Or ps' = normalizePredicateList ps == normalizePredicateList ps'+  Or _ == _ = False+  Moniker monikerName == Moniker monikerName' = monikerName == monikerName'+  Moniker _ == _ = False+  OperatingSystem os == OperatingSystem os' = os == os'+  OperatingSystem _ == _ = False+  Architecture arch == Architecture arch' = arch == arch'+  Architecture _ == _ = False+  KernelName kernel == KernelName kernel' = kernel == kernel'+  KernelName _ == _ = False+  KernelRelease ver == KernelRelease ver' = ver == ver'+  KernelRelease _ == _ = False+  KernelReleasePrefix prefix == KernelReleasePrefix prefix' = prefix == prefix'+  KernelReleasePrefix _ == _ = False+  KernelReleaseSuffix suffix == KernelReleaseSuffix suffix' = suffix == suffix'+  KernelReleaseSuffix _ == _ = False+++instance Hashable EnvironmentPredicate where+  hashWithSalt salt Always =+    salt `hashWithSalt` ("Always" :: Text)+  hashWithSalt salt (Not predicate) =+    salt `hashWithSalt` ("Not" :: Text) `hashWithSalt` predicate+  hashWithSalt salt (And predicates) =+    salt+      `hashWithSalt` ("And" :: Text)+      `hashWithSalt` normalizePredicateList predicates+  hashWithSalt salt (Or predicates) =+    salt+      `hashWithSalt` ("Or" :: Text)+      `hashWithSalt` normalizePredicateList predicates+  hashWithSalt salt (Moniker monikerName) =+    salt `hashWithSalt` ("Moniker" :: Text) `hashWithSalt` monikerName+  hashWithSalt salt (OperatingSystem os') =+    salt `hashWithSalt` ("OperatingSystem" :: Text) `hashWithSalt` os'+  hashWithSalt salt (Architecture arch') =+    salt `hashWithSalt` ("Architecture" :: Text) `hashWithSalt` arch'+  hashWithSalt salt (KernelName kernel) =+    salt `hashWithSalt` ("KernelName" :: Text) `hashWithSalt` kernel+  hashWithSalt salt (KernelRelease ver) =+    salt `hashWithSalt` ("KernelRelease" :: Text) `hashWithSalt` ver+  hashWithSalt salt (KernelReleasePrefix prefix) =+    salt `hashWithSalt` ("KernelReleasePrefix" :: Text) `hashWithSalt` prefix+  hashWithSalt salt (KernelReleaseSuffix suffix) =+    salt `hashWithSalt` ("KernelReleaseSuffix" :: Text) `hashWithSalt` suffix+++normalizePredicateList+  :: NonEmpty EnvironmentPredicate -> NonEmpty EnvironmentPredicate+normalizePredicateList = nub . sortWith (Down . hashWithSalt 1)+++-- | Normalize an environment predicate by removing redundant predicates.+--+-- >>> normalizePredicate $ And [Not Always, Always]+-- Not Always+-- >>> normalizePredicate $ Or [Not Always, Always]+-- Always+-- >>> import Dojang.Types.MonikerName (parseMonikerName)+-- >>> let Right foo = parseMonikerName "foo"+-- >>> normalizePredicate $ And [Moniker foo, Not $ Moniker foo]+-- Not Always+-- >>> normalizePredicate $ Or [Moniker foo, Not $ Moniker foo]+-- Always+-- >>> let Right a = parseMonikerName "a"+-- >>> let Right b = parseMonikerName "b"+-- >>> let Right c = parseMonikerName "c"+-- >>> normalizePredicate $ And [Moniker a, And [Moniker b, Moniker c]]+-- And (Moniker (MonikerName "a") :| [Moniker (MonikerName "b"),Moniker (MonikerName "c")])+normalizePredicate :: EnvironmentPredicate -> EnvironmentPredicate+normalizePredicate pred'+  | normalized == normalized2 = normalized+  | otherwise = normalizePredicate normalized2+ where+  normalized :: EnvironmentPredicate+  normalized = normalizePredicate' pred'+  normalized2 :: EnvironmentPredicate+  normalized2 = normalizePredicate' normalized+++normalizePredicate' :: EnvironmentPredicate -> EnvironmentPredicate+normalizePredicate' (And [p]) = normalizePredicate' p+normalizePredicate' (And ps) =+  if Not Always `elem` ps'+    then Not Always+    else+      let filtered = filter (/= Always) ps'+      in if (`any` filtered) $ \case Not p' -> p' `elem` filtered; _ -> False+          then Not Always+          else+            let reduced =+                  maybe Always And+                    $ nonEmpty+                      [ p'+                      | p <- filtered+                      , p' <- case p of+                          And ps'' -> normalizePredicate' <$> toList ps''+                          p'' -> [p'']+                      ]+            in case reduced of+                And [p'] -> p'+                _ -> reduced+ where+  ps' :: NonEmpty EnvironmentPredicate+  ps' = normalizePredicate' <$> ps+normalizePredicate' (Or [p]) = normalizePredicate' p+normalizePredicate' (Or ps) =+  if Always `elem` ps'+    then Always+    else+      let filtered = filter (/= Not Always) ps'+      in if (`any` filtered) $ \case Not p' -> p' `elem` filtered; _ -> False+          then Always+          else+            let reduced =+                  maybe (Not Always) Or+                    $ nonEmpty+                      [ p'+                      | p <- filtered+                      , p' <- case p of+                          Or ps'' -> normalizePredicate' <$> toList ps''+                          p'' -> [p'']+                      ]+            in case reduced of+                Or [p'] -> p'+                _ -> reduced+ where+  ps' :: NonEmpty EnvironmentPredicate+  ps' = normalizePredicate' <$> ps+normalizePredicate' (Not (Not p)) = normalizePredicate' p+normalizePredicate' (Not p) = Not $ normalizePredicate' p+normalizePredicate' p = p
+ src/Dojang/Types/EnvironmentPredicate/Evaluate.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE OverloadedRecordDot #-}++module Dojang.Types.EnvironmentPredicate.Evaluate+  ( EvaluationWarning (..)+  , evaluate+  , evaluate'+  ) where++import Prelude hiding (length, lookup, take)++import Data.CaseInsensitive (mk, original)+import Data.HashMap.Strict (lookup)+import Data.Text (Text, length, take, takeEnd)++import Dojang.Types.Environment+  ( Architecture (Etc)+  , Environment (..)+  , Kernel (..)+  , OperatingSystem (OtherOS)+  )+import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (..))+import Dojang.Types.MonikerMap (MonikerMap, MonikerResolver)+import Dojang.Types.MonikerName (MonikerName)+++-- $setup+-- >>> :seti -XOverloadedStrings+-- >>> :seti -XOverloadedLists+++-- | A warning that occurred during evaluation.+data EvaluationWarning+  = -- | A moniker was referenced that was not defined.+    UndefinedMoniker MonikerName+  | -- | The operating system was not recognized.+    UnrecognizedOperatingSystem OperatingSystem+  | -- | The architecture was not recognized.+    UnrecognizedArchitecture Architecture+  deriving (Eq, Show)+++-- | Evaluates the given predicate against the given environment.+--+-- >>> import Dojang.Types.Environment (Environment (..))+-- >>> import Dojang.Types.MonikerMap (MonikerMap)+-- >>> import Dojang.Types.MonikerName (MonikerName, parseMonikerName)+-- >>> let (Right linuxAmd64) = parseMonikerName "linux-amd64"+-- >>> :{+-- let monikerMap =+--       [ (linuxAmd64, And [OperatingSystem "linux", Architecture "x86_64"])+--       ] :: MonikerMap+-- :}+--+-- >>> let environment = Environment "linux" "x86_64"+-- >>> evaluate environment monikerMap (OperatingSystem "linux")+-- (True,[])+-- >>> evaluate environment monikerMap (Architecture "aarch64")+-- (False,[])+--+-- The 'snd' of the result is a list of warnings that occurred during+-- evaluation:+--+-- >>> let (Right nonExistentMoniker) = parseMonikerName "non-existent"+-- >>> evaluate environment monikerMap (Moniker nonExistentMoniker)+-- (False,[UndefinedMoniker (MonikerName "non-existent")])+evaluate+  :: Environment+  -- ^ The 'Environment' to evaluate against.+  -> MonikerMap+  -- ^ The 'MonikerMap' to resolve 'MonikerName's against.+  -> EnvironmentPredicate+  -- ^ The 'EnvironmentPredicate' to evaluate.+  -> (Bool, [EvaluationWarning])+  -- ^ The result of the evaluation. The 'snd' of the result is a list of+  -- warnings that occurred during evaluation.  Note that warnings can be+  -- present even if the result is 'True'.+evaluate environment monikerMap =+  evaluate' environment (`lookup` monikerMap)+++-- | Same as 'evaluate', but takes a resolver function instead of a+-- 'MonikerMap'.+evaluate'+  :: Environment+  -- ^ The 'Environment' to evaluate against.+  -> MonikerResolver+  -- ^ A function that resolves 'MonikerName's to 'EnvironmentPredicate's.+  -> EnvironmentPredicate+  -- ^ The 'EnvironmentPredicate' to evaluate.+  -> (Bool, [EvaluationWarning])+  -- ^ The result of the evaluation. The 'snd' of the result is a list of+  -- warnings that occurred during evaluation.  Note that warnings can be+  -- present even if the result is 'True'.+evaluate' _ _ Always =+  (True, [])+evaluate' environment resolver (Not predicate) =+  let (result, warnings) = evaluate' environment resolver predicate+  in (not result, warnings)+evaluate' environment resolver (And predicates) =+  let results = fmap (evaluate' environment resolver) predicates+  in (all fst results, concatMap snd results)+evaluate' environment resolver (Or predicates) =+  let results = fmap (evaluate' environment resolver) predicates+  in (any fst results, concatMap snd results)+evaluate' environment resolver (Moniker monikerName) =+  case resolver monikerName of+    Nothing -> (False, [UndefinedMoniker monikerName])+    Just predicate -> evaluate' environment resolver predicate+evaluate' environment _ (OperatingSystem os) =+  ( os == environment.operatingSystem+  , case os of+      OtherOS _ -> [UnrecognizedOperatingSystem os]+      _ -> []+  )+evaluate' environment _ (Architecture arch) =+  ( arch == environment.architecture+  , case arch of+      Etc _ -> [UnrecognizedArchitecture arch]+      _ -> []+  )+evaluate' environment _ (KernelName kernel) =+  (kernel == environment.kernel.name, [])+evaluate' environment _ (KernelRelease ver) =+  (ver == environment.kernel.release, [])+evaluate' environment _ (KernelReleasePrefix prefix) =+  (length rel >= prefixLen && mk (take prefixLen rel) == prefix, [])+ where+  rel :: Text+  rel = original environment.kernel.release+  prefixLen :: Int+  prefixLen = length $ original prefix+evaluate' environment _ (KernelReleaseSuffix suffix) =+  (length rel >= suffixLen && mk (takeEnd suffixLen rel) == suffix, [])+ where+  rel :: Text+  rel = original environment.kernel.release+  suffixLen :: Int+  suffixLen = length $ original suffix
+ src/Dojang/Types/EnvironmentPredicate/Specificity.hs view
@@ -0,0 +1,81 @@+-- | This module contains the 'Specificity' type and the 'specificity' function,+-- which are used to determine how specific an 'EnvironmentPredicate' is, i.e.,+-- when there are multiple predicates that could match, which one should be+-- chosen.+module Dojang.Types.EnvironmentPredicate.Specificity+  ( Specificity (..)+  , specificity+  ) where++import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (..))+import Dojang.Types.MonikerName (MonikerName)+++-- $setup+-- >>> :seti -XOverloadedStrings+-- >>> :seti -XOverloadedLists+++-- | The specificity of an 'EnvironmentPredicate'.  It guarantees that+-- the more specific predicate will always be greater than the less specific+-- predicate (e.g. @And [OperatingSystem "linux", Architecture "x86_64"]@ is+-- more specific than @OperatingSystem "linux"@).+data Specificity = Specificity+  { maxPredicates :: Int+  -- ^ The number of predicates that must be evaluated at a maximum.+  , totalPredicates :: Int+  -- ^ The total number of predicates regardless of whether they would be+  -- evaluated or not (e.g. if the first predicate in an 'Or' matches,+  -- then the second predicate would not be evaluated, but it would still be+  -- counted).+  }+  deriving (Eq, Show, Read)+++instance Ord Specificity where+  compare (Specificity maxA totalA) (Specificity maxB totalB) =+    case compare maxA maxB of+      EQ -> compare totalB totalA+      x -> x+++-- | Calculates the 'Specificity' of an 'EnvironmentPredicate'.  For details+-- on how the 'Specificity' is calculated, see the documentation for+-- 'Specificity'.+--+-- >>> import Data.List (sortOn)+-- >>> import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (..))+-- >>> :{+-- let predicates =+--       [ OperatingSystem "linux"+--       , Architecture "x86_64"+--       , And [OperatingSystem "linux", Architecture "x86_64"]+--       , Or [OperatingSystem "linux", Architecture "x86_64"]+--       ] :: [EnvironmentPredicate]+-- :}+--+-- >>> sortOn (specificity (const Nothing)) predicates+-- [Or (...),OperatingSystem Linux,Architecture X86_64,And (...)]+specificity+  :: (MonikerName -> Maybe EnvironmentPredicate)+  -> EnvironmentPredicate+  -> Specificity+specificity _ Always = Specificity 0 0+specificity monikerResolver (Not predicate) =+  specificity monikerResolver predicate+specificity monikerResolver (And predicates) =+  let qs = specificity monikerResolver <$> predicates+  in Specificity (sum $ maxPredicates <$> qs) (sum $ totalPredicates <$> qs)+specificity monikerResolver (Or predicates) =+  let qs = specificity monikerResolver <$> predicates+  in Specificity (maximum $ maxPredicates <$> qs) (sum $ totalPredicates <$> qs)+specificity monikerResolver (Moniker monikerName) =+  case monikerResolver monikerName of+    Nothing -> Specificity 0 0+    Just predicate -> specificity monikerResolver predicate+specificity _ (OperatingSystem _) = Specificity 1 1+specificity _ (Architecture _) = Specificity 1 1+specificity _ (KernelName _) = Specificity 1 1+specificity _ (KernelRelease _) = Specificity 1 1+specificity _ (KernelReleasePrefix _) = Specificity 1 1+specificity _ (KernelReleaseSuffix _) = Specificity 1 1
+ src/Dojang/Types/FilePathExpression.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE OverloadedStrings #-}++module Dojang.Types.FilePathExpression+  ( EnvironmentVariable+  , FilePathExpression (..)+  , toPathText+  , (++)+  , (+/+)+  ) where++import Data.Char (isAlphaNum, isAscii)+import Data.String (IsString (..))+import Prelude hiding (head, null, (++))++import Data.Hashable (Hashable (hashWithSalt))+import Data.Text (Text, head, null, pack)+++-- | An environment variable.+type EnvironmentVariable = Text+++-- | An expression that can be used to build a file path.+data FilePathExpression+  = -- | A bare component of a file path.  E.g., @foo@ and @bar@ in @/foo/bar@.+    BareComponent Text+  | -- | The root of a file path.  E.g., @/@ on POSIX systems or @C:\@ on+    -- Windows.  The 'Maybe' 'Char' is the drive letter on Windows, if present.+    -- On POSIX systems, this is always 'Nothing'.+    Root (Maybe Char)+  | -- | A concatenation of two 'FilePathExpression's.  E.g., @${FOO}bar@ is+    -- a concatenation of @${FOO}@ and @bar@.+    Concatenation FilePathExpression FilePathExpression+  | -- | A path separator which combines two 'FilePathExpression's.  E.g.,+    -- @/@ on POSIX systems or @\@ on Windows.+    PathSeparator FilePathExpression FilePathExpression+  | -- | A simple substitution of an environment variable.  E.g., @$FOO@ or+    -- @${BAR}@.+    Substitution EnvironmentVariable+  | -- | A substitution of an environment variable with a default value for when+    -- the environment variable is not set.  E.g., @${FOO:-this value is used if+    -- FOO is not set or is empty}@.+    SubstitutionWithDefault EnvironmentVariable FilePathExpression+  | -- | A conditional substitution of an environment variable with an expression+    -- to be expanded if the environment variable is set.  E.g., @${FOO:+this+    -- value is used if FOO is set and non-empty}@.+    ConditionalSubstitution EnvironmentVariable FilePathExpression+  -- TODO: Add support for SubstringSubstitution (e.g., ${FOO:0:3})+  -- See also https://www.gnu.org/software/bash/manual/html_node/Shell-Parameter-Expansion.html+  deriving (Eq, Show)+++instance Hashable FilePathExpression where+  hashWithSalt salt (BareComponent component) =+    salt `hashWithSalt` (0 :: Int) `hashWithSalt` component+  hashWithSalt salt (Root driveLetter) =+    salt `hashWithSalt` (1 :: Int) `hashWithSalt` driveLetter+  hashWithSalt salt (Concatenation expr1 expr2) =+    salt `hashWithSalt` (2 :: Int) `hashWithSalt` expr1 `hashWithSalt` expr2+  hashWithSalt salt (PathSeparator expr1 expr2) =+    salt `hashWithSalt` (3 :: Int) `hashWithSalt` expr1 `hashWithSalt` expr2+  hashWithSalt salt (Substitution envVar) =+    salt `hashWithSalt` (4 :: Int) `hashWithSalt` envVar+  hashWithSalt salt (SubstitutionWithDefault envVar expr) =+    salt `hashWithSalt` (5 :: Int) `hashWithSalt` envVar `hashWithSalt` expr+  hashWithSalt salt (ConditionalSubstitution envVar expr) =+    salt `hashWithSalt` (6 :: Int) `hashWithSalt` envVar `hashWithSalt` expr+++infixl 5 ++, +/++++-- | Concatenates two 'FilePathExpression's.  A synonym for 'Concatenation'.+(++) :: FilePathExpression -> FilePathExpression -> FilePathExpression+(++) = Concatenation+{-# INLINE (++) #-}+++-- | Combines two 'FilePathExpression's with a path separator.  A synonym for+-- 'PathSeparator'.+(+/+) :: FilePathExpression -> FilePathExpression -> FilePathExpression+(+/+) = PathSeparator+{-# INLINE (+/+) #-}+++-- | Converts a 'FilePathExpression' to a textual representation.+toPathText :: FilePathExpression -> Text+toPathText (Root (Just driveLetter)) = pack [driveLetter, ':', '/']+toPathText expr = toPathText' False expr+++-- | Internal implementation of 'toPathText'.+toPathText'+  :: Bool+  -- ^ Whether it is followed by a 'BareComponent'.+  -> FilePathExpression+  -- ^ The 'FilePathExpression' to render.+  -> Text+  -- ^ The rendered 'FilePathExpression'.+toPathText' _ (BareComponent component) = component+toPathText' _ (Root Nothing) = "/"+toPathText' _ (Root (Just driveLetter)) = pack [driveLetter, ':']+toPathText' followedByBare (Concatenation a b) =+  toPathText' doesBStartWithBare a <> renderedB+ where+  renderedB :: Text+  renderedB = toPathText' followedByBare b+  doesBStartWithBare :: Bool+  doesBStartWithBare =+    not (null renderedB)+      && let c = head renderedB in isAscii c && isAlphaNum c || c == '_'+toPathText' followedByBare (PathSeparator a@(Root Nothing) b) =+  toPathText' False a <> toPathText' followedByBare b+toPathText' followedByBare (PathSeparator a b) =+  toPathText' False a <> "/" <> toPathText' followedByBare b+toPathText' False (Substitution envVar) = "$" <> envVar+toPathText' True (Substitution envVar) = "${" <> envVar <> "}"+toPathText' _ (SubstitutionWithDefault envVar expr) =+  "${" <> envVar <> ":-" <> toPathText' False expr <> "}"+toPathText' _ (ConditionalSubstitution envVar expr) =+  "${" <> envVar <> ":+" <> toPathText' False expr <> "}"+++instance IsString FilePathExpression where+  fromString = BareComponent . pack
+ src/Dojang/Types/FilePathExpression/Expansion.hs view
@@ -0,0 +1,71 @@+module Dojang.Types.FilePathExpression.Expansion+  ( ExpansionWarning (..)+  , expandFilePath+  ) where++import Dojang.Types.FilePathExpression+  ( EnvironmentVariable+  , FilePathExpression (..)+  )++import Data.Text (Text)+import System.OsPath (OsPath, pack, pathSeparator, unsafeFromChar, (</>))+import System.OsString (OsString)+++-- | A set of warnings that can occur during expansion.+newtype ExpansionWarning+  = -- | The case where an environment variable that is referenced in a+    -- 'Substitution' is not defined.+    UndefinedEnvironmentVariable EnvironmentVariable+  deriving (Eq, Show)+++-- | Expands a 'FilePathExpression' into an 'OsPath'.+expandFilePath+  :: (Monad m)+  => FilePathExpression+  -- ^ The 'FilePathExpression' to expand.+  -> (EnvironmentVariable -> m (Maybe OsString))+  -- ^ A function that can look up an environment variable.+  -> (Text -> m OsString)+  -- ^ A function that encodes a 'Text' into an 'OsString'.+  -> m (OsPath, [ExpansionWarning])+  -- ^ The expanded 'OsPath', along with a list of warnings that occurred during+  -- expansion (if any).+expandFilePath (BareComponent component) _ encode = do+  f <- encode component+  return (f, [])+expandFilePath (Root Nothing) _ _ = return (pack [pathSeparator], [])+expandFilePath (Root (Just driveLetter)) _ _ =+  return+    ( pack+        [ unsafeFromChar driveLetter+        , unsafeFromChar ':'+        , pathSeparator+        ]+    , []+    )+expandFilePath (Concatenation expr1 expr2) lookupEnv encode = do+  (expanded1, ws1) <- expandFilePath expr1 lookupEnv encode+  (expanded2, ws2) <- expandFilePath expr2 lookupEnv encode+  return (expanded1 <> expanded2, ws1 ++ ws2)+expandFilePath (PathSeparator expr1 expr2) lookupEnv encode = do+  (expanded1, ws1) <- expandFilePath expr1 lookupEnv encode+  (expanded2, ws2) <- expandFilePath expr2 lookupEnv encode+  return (expanded1 </> expanded2, ws1 ++ ws2)+expandFilePath (Substitution envVar) lookupEnv _ = do+  v <- lookupEnv envVar+  case v of+    Just v' -> return (v', [])+    Nothing -> return (mempty, [UndefinedEnvironmentVariable envVar])+expandFilePath (SubstitutionWithDefault envVar expr) lookupEnv encode = do+  env <- lookupEnv envVar+  case env of+    Just env' | env' /= mempty -> return (env', [])+    _ -> expandFilePath expr lookupEnv encode+expandFilePath (ConditionalSubstitution envVar expr) lookupEnv encode = do+  env <- lookupEnv envVar+  case env of+    Just env' | env' /= mempty -> expandFilePath expr lookupEnv encode+    _ -> return (mempty, [])
+ src/Dojang/Types/FileRoute.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++module Dojang.Types.FileRoute+  ( FileRoute (..)+  , RouteWarning (..)+  , fileRoute+  , fileRoute'+  , dispatch+  , routePath+  ) where++import Data.List (sortOn)+import Data.Ord (Down (Down))+import Prelude hiding (lookup)++import Data.HashMap.Strict (lookup)+import Data.HashSet (HashSet, singleton, union, unions)+import Data.Text (unpack)+import System.OsPath (OsPath)+import System.OsString (OsString)++import Dojang.MonadFileSystem (FileType, MonadFileSystem (..))+import Dojang.Types.Environment (Environment)+import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (..))+import Dojang.Types.EnvironmentPredicate.Evaluate (EvaluationWarning, evaluate')+import Dojang.Types.EnvironmentPredicate.Specificity (Specificity, specificity)+import Dojang.Types.FilePathExpression (EnvironmentVariable, FilePathExpression)+import Dojang.Types.FilePathExpression.Expansion+  ( ExpansionWarning+  , expandFilePath+  )+import Dojang.Types.MonikerMap (MonikerMap, MonikerResolver)+import Dojang.Types.MonikerName (MonikerName)+++-- | A route that maps 'EnvironmentPredicate's to 'FilePathExpression's.+--+-- Each 'EnvironmentPredicate' represents a condition that must be met for the+-- 'FilePathExpression' to be dispatched.  The 'FilePathExpression' is+-- the path to the directory that should be dispatched to.  If it is 'Nothing',+-- then it is considered a "null route" and will be ignored.+--+-- Note that a null route will still be considered a match, and will be+-- dispatched as 'Nothing'.+data FileRoute = FileRoute+  { monikerResolver :: MonikerResolver+  -- ^ The 'MonikerResolver' used to resolve 'MonikerName's.+  , predicates :: [(EnvironmentPredicate, Maybe FilePathExpression)]+  -- ^ The pairs of 'EnvironmentPredicate's and 'FilePathExpression's that make+  -- up the 'FileRoute'.  If the file path expression is 'Nothing', then it is+  -- considered a "null route" and will be ignored.+  , fileType :: FileType+  -- ^ Whether the 'FileRoute' represents a file or a directory.+  }+++instance Eq FileRoute where+  a == b =+    (a.fileType == b.fileType)+      && (a.predicates == b.predicates)+      && all (\m -> a.monikerResolver m == b.monikerResolver m) allMonikerRefs+   where+    monikerRefs :: EnvironmentPredicate -> HashSet MonikerName+    monikerRefs predicates' =+      case predicates' of+        Moniker monikerName -> singleton monikerName+        Or ps -> foldMap monikerRefs ps+        And ps -> foldMap monikerRefs ps+        Not p -> monikerRefs p+        OperatingSystem _ -> mempty+        Architecture _ -> mempty+        Always -> mempty+        KernelName _ -> mempty+        KernelRelease _ -> mempty+        KernelReleasePrefix _ -> mempty+        KernelReleaseSuffix _ -> mempty+    allMonikerRefs :: HashSet MonikerName+    allMonikerRefs =+      unions (monikerRefs . fst <$> a.predicates)+        `union` unions (monikerRefs . fst <$> b.predicates)+++-- | Creates a 'FileRoute' from a 'MonikerMap' and pairs of+-- 'MonikerName's and 'FilePathExpression's.+fileRoute+  :: MonikerMap+  -- ^ The 'MonikerMap' to resolve 'MonikerName's against.+  -> [(MonikerName, Maybe FilePathExpression)]+  -- ^ The pairs of 'MonikerName's and 'FilePathExpression's that make up the+  -- 'FileRoute'.  If the file path expression is 'Nothing', then it is+  -- considered a "null route" and will be ignored.+  -> FileType+  -- ^ Whether the 'FileRoute' represents a file or a directory.+  -> FileRoute+  -- ^ The resulting 'FileRoute'.+fileRoute monikerMap predicates' =+  fileRoute'+    (`lookup` monikerMap)+    [(Moniker name, pathExpr) | (name, pathExpr) <- predicates']+++-- | Similar to 'FileRoute', but it takes more raw arguments: a 'MonikerResolver'+-- (instead of a 'MonikerMap'), and a pairs of 'EnvironmentPredicate' (instead+-- of 'MonikerName') and 'FilePathExpression'.+fileRoute'+  :: MonikerResolver+  -- ^ A function that resolves a 'MonikerName' to an 'EnvironmentPredicate'.+  -> [(EnvironmentPredicate, Maybe FilePathExpression)]+  -- ^ The pairs of 'EnvironmentPredicate's and 'FilePathExpression's that make+  -- up the 'FileRoute'.  If the file path expression is 'Nothing', then it is+  -- considered a "null route" and will be ignored.+  -> FileType+  -- ^ Whether the 'FileRoute' represents a file or a directory.+  -> FileRoute+  -- ^ The resulting 'FileRoute'.+fileRoute' resolver predicates' =+  FileRoute resolver $ sortOn sortKey predicates'+ where+  sortKey+    :: (EnvironmentPredicate, Maybe FilePathExpression)+    -> Down (Specificity, String)+  sortKey (pred', _) = Down (specificity resolver pred', show pred')+++-- | Dispatches the given 'FileRoute' against the given 'Environment'.+dispatch+  :: Environment+  -- ^ The 'Environment' to dispatch against.+  -> FileRoute+  -- ^ The 'FileRoute' to dispatch.+  -> ([Maybe FilePathExpression], [EvaluationWarning])+  -- ^ The list of 'Maybe' 'FilePathExpression's that matched+  -- the given 'Environment' and 'MonikerMap'.  Even if matches are made,+  -- their values may be 'Nothing' if the 'FilePathExpression' was+  -- a "null route".+  -- The 'snd' of the result is a list of warnings that occurred+  -- during evaluation  whether or not any 'FilePathExpression' matched.+dispatch environment (FileRoute resolver route _) =+  (matched, warnings)+ where+  eval :: EnvironmentPredicate -> (Bool, [EvaluationWarning])+  eval = evaluate' environment resolver+  evaluated :: [((Bool, [EvaluationWarning]), Maybe FilePathExpression)]+  evaluated = [(eval predicate, expr) | (predicate, expr) <- route]+  warnings :: [EvaluationWarning]+  warnings = concatMap (snd . fst) evaluated+  matched :: [Maybe FilePathExpression]+  matched = [expr | ((True, _), expr) <- evaluated]+++-- | A warning that can occur during path routing.+data RouteWarning+  = -- | A warning that can occur during environment predicate evaluation.+    EnvironmentPredicateWarning EvaluationWarning+  | -- | A warning that can occur during file path expression expansion.+    FilePathExpressionWarning ExpansionWarning+  deriving (Eq, Show)+++-- | Routes the given 'FileRoute' against the given 'Environment', and expands+-- the resulting 'FilePathExpression' into an 'OsPath', if any.  For null+-- routes, returns 'Nothing'.+routePath+  :: (MonadFileSystem m)+  => FileRoute+  -- ^ The 'FileRoute' to route and expand.+  -> Environment+  -- ^ The environment to use when evaluating environment predicates.+  -> (EnvironmentVariable -> m (Maybe OsString))+  -- ^ A function that can look up an environment variable.+  -> m (Maybe OsPath, [RouteWarning])+  -- ^ The resulting 'OsPath', if any, and a list of warnings that occurred+  -- during evaluation and expansion.  For null routes, returns 'Nothing',+  -- but still returns any warnings that occurred (if any).+routePath route env lookupEnvVar = do+  let (matched, warnings) = dispatch env route+  let predWarnings = map EnvironmentPredicateWarning warnings+  case matched of+    [] -> return (Nothing, predWarnings)+    (Nothing : _) -> return (Nothing, predWarnings)+    (Just pathExpr : _) -> do+      (path, exprWarnings) <-+        expandFilePath pathExpr lookupEnvVar (encodePath . unpack)+      return (Just path, predWarnings ++ map FilePathExpressionWarning exprWarnings)+++instance Show FileRoute where+  show (FileRoute _ route fileType') =+    "FileRoute " ++ show route ++ " " ++ show fileType'
+ src/Dojang/Types/FileRouteMap.hs view
@@ -0,0 +1,10 @@+module Dojang.Types.FileRouteMap (FileRouteMap) where++import Data.Map.Strict (Map)+import System.OsPath (OsPath)++import Dojang.Types.FileRoute (FileRoute)+++-- | A map of directories and their routes.+type FileRouteMap = Map OsPath FileRoute
+ src/Dojang/Types/FileRouteMap/Evaluate.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE NamedFieldPuns #-}++module Dojang.Types.FileRouteMap.Evaluate+  ( evaluateRoutes+  , evaluateRoutesWithFileTypes+  ) where++import Data.Map.Strict (Map, fromList, mapWithKey, toList, (!?))+import System.OsPath (OsPath)++import Dojang.MonadFileSystem (FileType (..))+import Dojang.Types.Environment (Environment)+import Dojang.Types.EnvironmentPredicate.Evaluate (EvaluationWarning)+import Dojang.Types.FilePathExpression (FilePathExpression)+import Dojang.Types.FileRoute (FileRoute (..), dispatch)+import Dojang.Types.FileRouteMap (FileRouteMap)+++-- | Evaluates the 'FileRouteMap' against an 'Environment'.+evaluateRoutes+  :: FileRouteMap+  -- ^ The 'FileRouteMap' to evaluate.+  -> Environment+  -- ^ The 'Environment' to evaluate against.+  -> (Map OsPath FilePathExpression, [EvaluationWarning])+  -- ^ The evaluated routes and the warnings that occurred during evaluation.+  -- Unmatched routes or null routes will not be included in the result.+evaluateRoutes fileRoutes env =+  (evaluated, warnings)+ where+  results :: [(OsPath, FilePathExpression, [EvaluationWarning])]+  results =+    [ (filePath, match, warnings')+    | (filePath, route) <- toList fileRoutes+    , let (matches, warnings') = dispatch env route+    , Just match : _ <- [matches]+    ]+  warnings :: [EvaluationWarning]+  warnings = concatMap (\(_, _, w) -> w) results+  evaluated :: Map OsPath FilePathExpression+  evaluated = fromList [(filePath, match) | (filePath, match, _) <- results]+++-- | Similar to 'evaluateRoutes', but also includes the 'FileType' of each+-- evaluated route.+evaluateRoutesWithFileTypes+  :: FileRouteMap+  -- ^ The 'FileRouteMap' to evaluate.+  -> Environment+  -- ^ The 'Environment' to evaluate against.+  -> (Map OsPath (FilePathExpression, FileType), [EvaluationWarning])+  -- ^ The evaluated routes and the warnings that occurred during evaluation.+  -- Unmatched routes or null routes will not be included in the result.+evaluateRoutesWithFileTypes fileRoutes env =+  (evaluatedRoutesWithFileTypes, warnings)+ where+  evaluatedRoutes :: Map OsPath FilePathExpression+  warnings :: [EvaluationWarning]+  (evaluatedRoutes, warnings) = evaluateRoutes fileRoutes env+  evaluatedRoutesWithFileTypes :: Map OsPath (FilePathExpression, FileType)+  evaluatedRoutesWithFileTypes = mapWithKey addFileType evaluatedRoutes+  addFileType :: OsPath -> FilePathExpression -> (FilePathExpression, FileType)+  addFileType path expr =+    ( expr+    , maybe File (\FileRoute{fileType} -> fileType) (fileRoutes !? path)+    )
+ src/Dojang/Types/Manifest.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedRecordUpdate #-}+{-# LANGUAGE NoFieldSelectors #-}++module Dojang.Types.Manifest (IgnoreMap, Manifest (..), manifest) where++import Data.Map.Strict (Map, fromList, toAscList, toList)+import System.FilePattern (FilePattern)+import System.OsPath (OsPath, normalise)++import Dojang.MonadFileSystem (FileType (..))+import Dojang.Types.FilePathExpression (FilePathExpression)+import Dojang.Types.FileRoute (FileRoute, fileRoute)+import Dojang.Types.FileRouteMap (FileRouteMap)+import Dojang.Types.MonikerMap (MonikerMap)+import Dojang.Types.MonikerName (MonikerName)+++-- | A map of directory routes to file patterns that should be ignored.+type IgnoreMap = Map OsPath [FilePattern]+++-- | A manifest of the directory routes and the definitions of monikers that+-- are used to resolve them.+data Manifest = Manifest+  { monikers :: MonikerMap+  -- ^ The definitions of monikers that are used to resolve the directory routes.+  , fileRoutes :: FileRouteMap+  -- ^ The directory routes that are resolved by the monikers.+  , ignorePatterns :: IgnoreMap+  -- ^ The file patterns that should be ignored for each directory route.+  }+  deriving (Eq, Show)+++-- | Makes a 'Manifest' from definitions of monikers and directory routes.+manifest+  :: MonikerMap+  -- ^ The monikers that are used to resolve the directory routes.+  -> Map OsPath [(MonikerName, Maybe FilePathExpression)]+  -- ^ The file routes that are resolved by the monikers.  The keys are+  -- the file names, and the values are the pairs of 'MonikerName's and+  -- 'FilePathExpression's that make up each 'FileRoute'.+  -- If the same 'MonikerName' is used more than once, then the latest one+  -- will be used.  If the same file name appears in the directory routes+  -- (the next parameter), then the directory route will take precedence.+  -> Map OsPath [(MonikerName, Maybe FilePathExpression)]+  -- ^ The directory routes that are resolved by the monikers.  The keys are+  -- the names of the directories, and the values are the pairs of+  -- 'MonikerName's and 'FilePathExpression's that make up each 'FileRoute'.+  -- If the same 'MonikerName' is used more than once, then the latest one+  -- will be used.  If the same file name appears in the file routes+  -- (the previous parameter), then the directory route will take precedence.+  -> IgnoreMap+  -- ^ The file patterns that should be ignored for each directory route.+  -> Manifest+  -- ^ The made 'Manifest'.+manifest monikers' fileRoutes' dirRoutes' ignorePatterns' =+  Manifest+    { monikers = monikers'+    , fileRoutes = fromList $ files ++ dirs+    , ignorePatterns = ignores+    }+ where+  files :: [(OsPath, FileRoute)]+  files = do+    (filename, monikerPairs) <- toList fileRoutes'+    pure (normalise filename, fileRoute monikers' monikerPairs File)+  dirs :: [(OsPath, FileRoute)]+  dirs = do+    (dirName, monikerPairs) <- toList dirRoutes'+    pure (normalise dirName, fileRoute monikers' monikerPairs Directory)+  ignores :: IgnoreMap+  ignores =+    fromList+      [ (normalise p, pattern)+      | (p, pattern) <- toAscList ignorePatterns'+      ]
+ src/Dojang/Types/MonikerMap.hs view
@@ -0,0 +1,14 @@+module Dojang.Types.MonikerMap (MonikerMap, MonikerResolver) where++import Data.HashMap.Strict (HashMap)++import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate)+import Dojang.Types.MonikerName (MonikerName)+++-- | A map that defines the monikers and what conditions they match.+type MonikerMap = HashMap MonikerName EnvironmentPredicate+++-- | A function that resolves a 'MonikerName' to an 'EnvironmentPredicate'.+type MonikerResolver = MonikerName -> Maybe EnvironmentPredicate
+ src/Dojang/Types/MonikerName.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedRecordUpdate #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Use guards" #-}++module Dojang.Types.MonikerName+  ( MonikerName+  , MonikerNameError (..)+  , parseMonikerName+  ) where++import Data.CaseInsensitive (CI, mk)+import Data.Char (isAlpha, isAlphaNum)+import Data.Hashable (Hashable)+import Data.Text (Text, findIndex, head, null)+import GHC.Records (HasField (getField))++import Prelude hiding (head, null)+++-- $setup+-- >>> :seti -XOverloadedStrings -XOverloadedRecordDot+++-- | A moniker name.  The name must start with a letter and contain only+-- letters, digits, hyphens, and underscores (no spaces, no special characters).+-- Non-Latin letters and digits are allowed too.  The name must not be empty.+--+-- >>> parseMonikerName "foo-bar"+-- Right (MonikerName "foo-bar")+-- >>> parseMonikerName "甲乙_丙丁"+-- Right (MonikerName "甲乙_丙丁")+--+-- Case insensitive, but the original case is preserved:+--+-- >>> parseMonikerName "FOO-BAR" == parseMonikerName "foo-bar"+-- True+-- >>> parseMonikerName "GIÁP_ẤT" == parseMonikerName "giáp_ất" -- cSpell:disable-line+-- True+newtype MonikerName = MonikerName (CI Text) deriving (Eq, Ord, Hashable, Show)+++-- | A record field named @name@ for 'MonikerName':+--+-- >>> let (Right monikerName) = parseMonikerName "foo-bar"+-- >>> monikerName.name+-- "foo-bar"+instance HasField "name" MonikerName (CI Text) where+  getField (MonikerName name) = name+++-- | Errors that can occur when parsing a moniker name.+data MonikerNameError+  = -- | The moniker name is empty.+    Empty+  | -- | The moniker name starts with a non-letter character.+    StartingWithNonLetter+  | -- | The moniker name contains an invalid character at the given index.+    HavingInvalidCharacter Int+  deriving (Eq, Show, Read)+++-- | Parse a moniker name.+--+-- >>> parseMonikerName "foo-bar"+-- Right (MonikerName "foo-bar")+-- >>> parseMonikerName "1"+-- Left StartingWithNonLetter+-- >>> parseMonikerName "foo bar"+-- Left (HavingInvalidCharacter 3)+-- >>> parseMonikerName "甲乙_丙丁"+-- Right (MonikerName "甲乙_丙丁")+-- >>> parseMonikerName ""+-- Left Empty+parseMonikerName :: Text -> Either MonikerNameError MonikerName+parseMonikerName name =+  if null name+    then Left Empty+    else+      if isAlpha $ head name+        then case findIndex isInvalidChar name of+          Nothing -> Right $ MonikerName $ mk name+          Just i -> Left $ HavingInvalidCharacter i+        else Left StartingWithNonLetter+ where+  isInvalidChar :: Char -> Bool+  isInvalidChar c = not $ isAlphaNum c || c == '-' || c == '_'
+ src/Dojang/Types/Repository.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoFieldSelectors #-}++module Dojang.Types.Repository+  ( Repository (..)+  , RouteMapWarning (..)+  , RouteResult (..)+  , findOverlappingRouteResults+  , overlaps+  , routePaths+  ) where++import Control.Monad (forM)+import Data.Function ((&))+import Data.List (isPrefixOf, nub)+import Data.List.NonEmpty+  ( NonEmpty ((:|))+  , append+  , nub+  , singleton+  , sort+  , toList+  )++import Data.Map.Strict (Map, findWithDefault, fromListWith, toList)+import System.FilePattern (FilePattern, matchMany)+import System.OsPath (OsPath, makeRelative, normalise, splitDirectories, (</>))+import System.OsString (OsString)++import Dojang.MonadFileSystem (FileType, MonadFileSystem (..))+import Dojang.Types.Environment (Environment)+import Dojang.Types.EnvironmentPredicate.Evaluate (EvaluationWarning)+import Dojang.Types.FilePathExpression (EnvironmentVariable)+import Dojang.Types.FilePathExpression.Expansion (ExpansionWarning)+import Dojang.Types.FileRoute (FileRoute (..), RouteWarning, routePath)+import Dojang.Types.FileRoute qualified as FileRoute (RouteWarning (..))+import Dojang.Types.Manifest (Manifest (..))+++-- | A repository, which is a directory containing a manifest file and dotfiles.+data Repository = Repository+  { sourcePath :: OsPath+  -- ^ The path to the repository.+  , intermediatePath :: OsPath+  -- ^ The path to the intermediate directory, which is managed by Dojang and+  -- contains the post-processed files.+  , manifest :: Manifest+  -- ^ The manifest of the repository.+  }+++-- | The expanded dispatch paths of a 'FileRoute'.+data RouteResult = RouteResult+  { sourcePath :: OsPath+  -- ^ The source path.  It is either absolute or relative to the current+  -- working directory.+  , routeName :: OsPath+  -- ^ The source path relative from the repository root, i.e., the route name.+  , destinationPath :: OsPath+  -- ^ The destination path.   It is either absolute or relative to+  -- the current working directory.+  , fileType :: FileType+  }+  deriving (Eq, Show)+++-- | A warning that can occur during routing paths.+data RouteMapWarning+  = -- | A warning that can occur during environment predicate evaluation.+    EnvironmentPredicateWarning EvaluationWarning+  | -- | A warning that can occur during file path expression expansion.+    FilePathExpressionWarning ExpansionWarning+  | -- | A warning that two or more routes overlap in their destination paths+    -- (e.g., @/foo/bar@ and @/foo/bar/baz@).+    OverlapDestinationPathsWarning+      OsPath+      -- ^ The source path of the route that have overlapping destination paths.+      OsPath+      -- ^ The destination path that overlaps.+      (NonEmpty (OsPath, OsPath))+      -- ^ The pairs of corresponding source and destination paths that overlap.+  deriving (Eq, Show)+++-- | Route the paths in the repository.  This will return a list of expanded+-- paths, along with any warnings that were generated.  Null routes will be+-- ignored.+routePaths+  :: forall m+   . (MonadFileSystem m)+  => Repository+  -- ^ The repository.+  -> Environment+  -- ^ The environment to use when evaluating the environment predicates.+  -> (EnvironmentVariable -> m (Maybe OsString))+  -- ^ The function to look up environment variables.+  -> m ([RouteResult], [RouteMapWarning])+  -- ^ The expanded paths, along with any warnings that were generated.+routePaths repo env lookupEnvVar = do+  paths <- forM fileRoutes $ \(src, route) -> do+    (dstPath, warnings) <- routePath route env lookupEnvVar+    return (src, dstPath, route.fileType, warnings)+  let paths' =+        [ RouteResult (repo.sourcePath </> src) src dst' ft+        | (src, Just dst', ft, _) <- paths+        ]+  overlappingRoutes <-+    forM (Data.Map.Strict.toList $ findOverlappingRouteResults paths')+      $ \((name, dst), overlaps') -> do+        let ignorePatterns =+              findWithDefault [] name repo.manifest.ignorePatterns+        filtered <- filterIgnoredPathsFromOverlaps dst ignorePatterns overlaps'+        return ((name, dst), filtered)+  let warnings =+        [translateWarning w | (_, _, _, ws) <- paths, w <- ws]+          ++ [ OverlapDestinationPathsWarning name dst (o :| overlaps')+             | ((name, dst), o : overlaps') <- overlappingRoutes+             ]+  return (paths', Data.List.nub warnings)+ where+  fileRoutes :: [(OsPath, FileRoute)]+  fileRoutes = Data.Map.Strict.toList repo.manifest.fileRoutes+  filterIgnoredPathsFromOverlaps+    :: OsPath+    -> [FilePattern]+    -> NonEmpty (OsPath, OsPath)+    -> m [(OsPath, OsPath)]+  filterIgnoredPathsFromOverlaps base patterns paths = do+    paths' <- forM pathList $ \pair@(_, dst') -> do+      dstFP <- decodePath $ makeRelative base' $ normalise dst'+      return (pair, dstFP)+    let ignored = [pair | (_, pair, _) <- matchMany patterns' paths']+    return [pair | pair <- pathList, pair `notElem` ignored]+   where+    base' :: OsPath+    base' = normalise base+    pathList :: [(OsPath, OsPath)]+    pathList = Data.List.NonEmpty.toList paths+    patterns' :: [((), FilePattern)]+    patterns' =+      [((), pattern) | pattern <- patterns]+        ++ [((), pattern ++ "/**/*") | pattern <- patterns]+++translateWarning :: RouteWarning -> RouteMapWarning+translateWarning (FileRoute.EnvironmentPredicateWarning w) =+  EnvironmentPredicateWarning w+translateWarning (FileRoute.FilePathExpressionWarning w) =+  FilePathExpressionWarning w+++findOverlappingRouteResults+  :: [RouteResult] -> Map (OsPath, OsPath) (NonEmpty (OsPath, OsPath))+findOverlappingRouteResults routes =+  fromListWith append found & fmap (Data.List.NonEmpty.nub . sort)+ where+  pairs :: [(OsPath, OsPath)]+  pairs =+    [ (name, dst)+    | RouteResult{routeName = name, destinationPath = dst} <- routes+    ]+  found :: [((OsPath, OsPath), NonEmpty (OsPath, OsPath))]+  found =+    [ ((name, dst), singleton (name', dst'))+    | (name, dst) <- pairs+    , (name', dst') <- pairs+    , name /= name'+    , dst `overlaps` dst'+    ]+++-- | Returns whether the two paths overlap.  The former path is assumed to be+-- shorter than or equal to the latter path.+overlaps :: OsPath -> OsPath -> Bool+overlaps a b =+  (a' == b') || aDirs `isPrefixOf` bDirs+ where+  a' :: OsPath+  a' = normalise a+  b' :: OsPath+  b' = normalise b+  aDirs :: [OsPath]+  aDirs = splitDirectories a'+  bDirs :: [OsPath]+  bDirs = splitDirectories b'
+ src/Dojang/Version.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Dojang.Version (toString, toText, version) where+++#if defined(DOJANG_DEV_BUILD)+import Data.Maybe (fromJust)+#endif++import Data.Version qualified++import Data.SemVer hiding (version)+import Data.SemVer qualified (version)++import Paths_dojang qualified+++version :: Version+version =+  let (Data.Version.Version [major', minor', patch'] _) = Paths_dojang.version+  in Data.SemVer.version+      major'+      minor'+      patch'+#if defined(DOJANG_DEV_BUILD)+      [fromJust $ textual "dev", numeric (DOJANG_DEV_BUILD)]+#else+      []+#endif+      []
+ src/Options/Applicative/Path.hs view
@@ -0,0 +1,42 @@+module Options.Applicative.Path+  ( hyphen+  , path+  , pathOption+  , pathArgument+  , period+  ) where++import System.IO.Unsafe (unsafePerformIO)++import Options.Applicative+  ( ArgumentFields+  , Mod+  , OptionFields+  , Parser+  , argument+  , option+  )+import Options.Applicative.Types (ReadM, readerAsk)+import System.OsPath (OsPath, encodeFS)+++hyphen :: OsPath+hyphen = unsafePerformIO $ encodeFS "-"+{-# NOINLINE hyphen #-}+++period :: OsPath+period = unsafePerformIO $ encodeFS "."+{-# NOINLINE period #-}+++path :: ReadM OsPath+path = unsafePerformIO . encodeFS <$> readerAsk+++pathOption :: Mod OptionFields OsPath -> Parser OsPath+pathOption = option path+++pathArgument :: Mod ArgumentFields OsPath -> Parser OsPath+pathArgument = argument path
+ test/Dojang/Gen.hs view
@@ -0,0 +1,12 @@+module Dojang.Gen (evaluationWarning) where++import Test.Hspec.Hedgehog (MonadGen)++import Dojang.Types.EnvironmentPredicate.Evaluate+  ( EvaluationWarning (UndefinedMoniker)+  )+import Dojang.Types.Gen (monikerName)+++evaluationWarning :: (MonadGen m) => m EvaluationWarning+evaluationWarning = UndefinedMoniker <$> monikerName
+ test/Dojang/MonadFileSystemSpec.hs view
@@ -0,0 +1,1000 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}++module Dojang.MonadFileSystemSpec (spec) where++import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.List (sort, sortOn)+import GHC.IO.Exception (IOErrorType (InappropriateType))+import System.IO.Error+  ( alreadyExistsErrorType+  , doesNotExistErrorType+  , ioeGetErrorType+  , ioeGetFileName+  , ioeGetLocation+  , isDoesNotExistError+  )+import Prelude hiding (readFile, writeFile)+import Prelude qualified (readFile, writeFile)++import Control.Monad.Except (MonadError (catchError), tryError)+import Data.ByteString qualified (readFile, writeFile)+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range (constantFrom)+import System.Directory.OsPath+  ( createDirectoryLink+  , createFileLink+  , doesDirectoryExist+  , doesFileExist+  , doesPathExist+  )+import System.Directory.OsPath qualified (createDirectory)+import System.FilePath (combine)+import System.OsPath (dropFileName, encodeFS, (</>))+import Test.Hspec (Spec, describe, it, runIO, specify, xit, xspecify)+import Test.Hspec.Expectations.Pretty+  ( shouldBe+  , shouldContain+  , shouldReturn+  , shouldSatisfy+  , shouldStartWith+  , shouldThrow+  )+import Test.Hspec.Hedgehog (forAll, hedgehog, (===))++import Dojang.MonadFileSystem+  ( FileType (..)+  , MonadFileSystem (..)+  , dryRunIO+  , tryDryRunIO+  )+import Dojang.TestUtils (withTempDir)+++packageYamlFP :: FilePath+packageYamlFP = "package.yaml"+++testFP :: FilePath+testFP = "test"+++nonExistentFP :: FilePath+nonExistentFP = "---non-existent---"+++nonExistentFP' :: FilePath+nonExistentFP' = "---non-existent-2---"+++spec :: Spec+spec = do+  packageYamlP <- runIO $ encodeFS packageYamlFP+  testP <- runIO $ encodeFS testFP+  nonExistentP <- runIO $ encodeFS nonExistentFP+  nonExistentP' <- runIO $ encodeFS nonExistentFP'++  -- cSpell:ignore quux corge+  foo <- runIO $ encodeFS "foo"+  bar <- runIO $ encodeFS "bar"+  baz <- runIO $ encodeFS "baz"+  qux <- runIO $ encodeFS "qux"+  quux <- runIO $ encodeFS "quux"+  corge <- runIO $ encodeFS "corge"++  symlinkAvailable <- runIO $ withTempDir $ \tmpDir tmpDir' ->+    ( do+        Prelude.writeFile (tmpDir' `combine` "foo") ""+        createFileLink foo (tmpDir </> bar)+        return True+    )+      `catchError` const (return False)+  let symIt = if symlinkAvailable then it else xit+  let symSpecify = if symlinkAvailable then specify else xspecify++  let withFixture action = withTempDir $ \tmpDir tmpDir' -> do+        () <- Prelude.writeFile (tmpDir' `combine` "foo") ""+        () <- System.Directory.OsPath.createDirectory $ tmpDir </> bar+        () <- System.Directory.OsPath.createDirectory $ tmpDir </> baz+        () <-+          System.Directory.OsPath.createDirectory+            (tmpDir </> baz </> qux)+        action tmpDir tmpDir'++  describe "MonadFileSystem IO" $ do+    specify "encodePath" $ hedgehog $ do+      filePath <- forAll $ Gen.string (constantFrom 0 0 256) Gen.unicode+      filePath' <- liftIO $ encodePath filePath >>= decodePath+      filePath' === filePath++    specify "exists" $ do+      exists packageYamlP `shouldReturn` True+      exists testP `shouldReturn` True+      exists nonExistentP `shouldReturn` False++    specify "isFile" $ do+      isFile packageYamlP `shouldReturn` True+      isFile testP `shouldReturn` False+      isFile nonExistentP `shouldReturn` False++    specify "isDirectory" $ do+      isDirectory packageYamlP `shouldReturn` False+      isDirectory testP `shouldReturn` True+      isDirectory nonExistentP `shouldReturn` False++    symSpecify "isSymlink" $ do+      isSymlink packageYamlP `shouldReturn` False+      isSymlink testP `shouldReturn` False+      isSymlink nonExistentP `shouldReturn` False+      withTempDir $ \tmpDir tmpDir' -> do+        Prelude.writeFile (tmpDir' `combine` "foo") ""+        createFileLink foo (tmpDir </> bar)+        isSymlink (tmpDir </> bar) `shouldReturn` True++    specify "readFile" $ withTempDir $ \tmpDir tmpDir' -> do+      () <- Prelude.writeFile (tmpDir' `combine` "foo") "Foo contents"+      contents <- readFile $ tmpDir </> foo+      contents `shouldBe` "Foo contents"+      Left error' <- tryError $ readFile nonExistentP+      ioeGetErrorType error' `shouldBe` doesNotExistErrorType+      ioeGetFileName error' `shouldBe` Just nonExistentFP++    specify "writeFile" $ withTempDir $ \tmpDirP tmpDirFP -> do+      () <- writeFile (tmpDirP </> nonExistentP) "foo"+      Data.ByteString.readFile (tmpDirFP `combine` nonExistentFP)+        `shouldReturn` "foo"++    describe "readSymlinkTarget" $ do+      symIt "tells the target path of a symbolic link" $ withTempDir $ \tmpDir tmpDir' -> do+        () <- Prelude.writeFile (tmpDir' `combine` "foo") ""+        createFileLink foo (tmpDir </> bar)+        readSymlinkTarget (tmpDir </> bar) `shouldReturn` foo++      it "fails with IOError if the path does not exist" $ do+        readSymlinkTarget nonExistentP `shouldThrow` \e -> do+          isDoesNotExistError e && ioeGetFileName e == Just nonExistentFP++    specify "copyFile" $ withTempDir $ \tmpDirP tmpDirFP -> do+      () <- copyFile packageYamlP (tmpDirP </> nonExistentP)+      contents <- Data.ByteString.readFile (tmpDirFP `combine` nonExistentFP)+      original <- Data.ByteString.readFile packageYamlFP+      contents `shouldBe` original++    specify "createDirectory" $ withTempDir $ \tmpDirP _ -> do+      () <- createDirectory (tmpDirP </> nonExistentP)+      doesDirectoryExist (tmpDirP </> nonExistentP)+        `shouldReturn` True++    specify "removeFile" $ withTempDir $ \tmpDirP tmpDirFP -> do+      Data.ByteString.writeFile (tmpDirFP `combine` nonExistentFP) ""+      doesFileExist (tmpDirP </> nonExistentP) `shouldReturn` True+      () <- removeFile (tmpDirP </> nonExistentP)+      doesFileExist (tmpDirP </> nonExistentP) `shouldReturn` False++    specify "removeDirectory" $ withTempDir $ \tmpDirP tmpDirFP -> do+      () <- createDirectory (tmpDirP </> nonExistentP)+      () <- removeDirectory (tmpDirP </> nonExistentP)+      doesDirectoryExist (tmpDirP </> nonExistentP)+        `shouldReturn` False+      removeDirectory (tmpDirP </> nonExistentP) `shouldThrow` \e ->+        isDoesNotExistError e+          && (ioeGetFileName e == Just (tmpDirFP `combine` nonExistentFP))++    specify "removeDirectoryRecursively" $ withFixture $ \tmpDirP tmpDirFP -> do+      removeDirectoryRecursively tmpDirP+      doesPathExist tmpDirP `shouldReturn` False+      removeDirectoryRecursively tmpDirP `shouldThrow` \e ->+        isDoesNotExistError e && ioeGetFileName e == Just tmpDirFP++    specify "listDirectory" $ withFixture $ \tmpDir _ -> do+      result <- listDirectory tmpDir+      sort result `shouldBe` [bar, baz, foo]++    describe "listDirectoryRecursively" $ do+      specify "basic behavior" $ withFixture $ \tmpDir tmpDir' -> do+        () <- Prelude.writeFile (tmpDir' `combine` "bar" `combine` "quux") ""+        () <- Prelude.writeFile (tmpDir' `combine` "baz" `combine` "corge") ""+        result <- listDirectoryRecursively tmpDir []+        sortOn snd result+          `shouldBe` [ (Directory, bar)+                     , (File, bar </> quux)+                     , (Directory, baz)+                     , (File, baz </> corge)+                     , (Directory, baz </> qux)+                     , (File, foo)+                     ]++      it "filters out files by ignorePatterns" $ withFixture $ \tmpDir tmpDir' -> do+        () <- Prelude.writeFile (tmpDir' `combine` "bar" `combine` "quux") ""+        () <- Prelude.writeFile (tmpDir' `combine` "baz" `combine` "corge") ""+        result <- listDirectoryRecursively tmpDir ["bar/q*", "baz"]+        sortOn snd result `shouldBe` [(Directory, bar), (File, foo)]++      symIt "distinguishes symlinks from regular files and directories"+        $ withFixture+        $ \tmpDir tmpDir' -> do+          () <- Prelude.writeFile (tmpDir' `combine` "bar" `combine` "quux") ""+          () <- createFileLink quux (tmpDir </> baz </> corge)+          () <- createDirectoryLink baz (tmpDir </> corge)+          result <- listDirectoryRecursively tmpDir []+          sortOn snd result+            `shouldBe` [ (Directory, bar)+                       , (File, bar </> quux)+                       , (Directory, baz)+                       , (Symlink, baz </> corge)+                       , (Directory, baz </> qux)+                       , (Symlink, corge)+                       , (File, foo)+                       ]++    specify "getFileSize" $ withFixture $ \tmpDir tmpDirFP -> do+      Data.ByteString.writeFile (tmpDirFP `combine` "foo") "asdf"+      getFileSize (tmpDir </> foo) `shouldReturn` 4+      Left e <- tryError $ getFileSize (tmpDir </> nonExistentP)+      ioeGetErrorType e `shouldBe` doesNotExistErrorType+      ioeGetFileName e `shouldBe` Just (tmpDirFP `combine` nonExistentFP)+      Left e' <- tryError $ getFileSize tmpDir+      ioeGetErrorType e' `shouldBe` InappropriateType+      ioeGetLocation e' `shouldBe` "getFileSize"+      ioeGetFileName e' `shouldBe` Just tmpDirFP+      show e' `shouldContain` "it is a directory"++  describe "DryRunIO" $ do+    specify "encodePath" $ hedgehog $ do+      filePath <- forAll $ Gen.string (constantFrom 0 0 256) Gen.unicode+      filePath' <- liftIO $ dryRunIO (encodePath filePath >>= decodePath)+      filePath' === filePath++    describe "isFile" $ do+      it "checks an actual file that exists on the real file system" $ do+        packageYamlIsFile <- dryRunIO $ isFile packageYamlP+        packageYamlIsFile `shouldBe` True++      it "checks an actual directory that exists on the real file system" $ do+        testIsFile <- dryRunIO $ isFile testP+        testIsFile `shouldBe` False++      it "checks a non-existent file" $ do+        nonExistentIsFile <- dryRunIO $ isFile nonExistentP+        nonExistentIsFile `shouldBe` False++      it "checks a virtual file (Contents) that exists in memory" $ do+        nonExistentIsFile <- dryRunIO $ do+          () <- writeFile nonExistentP ""+          isFile nonExistentP+        nonExistentIsFile `shouldBe` True++      it "checks a virtual file (Copied) that exists in memory" $ do+        nonExistentIsFile <- dryRunIO $ do+          () <- copyFile packageYamlP nonExistentP+          isFile nonExistentP+        nonExistentIsFile `shouldBe` True++      it "checks a virtual directory that exists in memory" $ do+        nonExistentIsFile <- dryRunIO $ do+          () <- createDirectory nonExistentP+          isFile nonExistentP+        nonExistentIsFile `shouldBe` False++      it "checks a virtual non-existent file" $ do+        packageYamlIsFile <- dryRunIO $ do+          () <- removeFile packageYamlP+          isFile packageYamlP+        packageYamlIsFile `shouldBe` False++    describe "isDirectory" $ do+      it "check an actual file that exists on the real file system" $ do+        packageYamlIsDir <- dryRunIO $ isDirectory packageYamlP+        packageYamlIsDir `shouldBe` False++      it "checks an actual directory that exists on the real file system" $ do+        testIsDir <- dryRunIO $ isDirectory testP+        testIsDir `shouldBe` True++      it "checks a non-existent directory" $ do+        nonExistentIsDir <- dryRunIO $ isDirectory nonExistentP+        nonExistentIsDir `shouldBe` False++      it "checks a virtual directory that exists in memory" $ do+        nonExistentIsDir' <- dryRunIO $ do+          () <- createDirectory nonExistentP+          isDirectory nonExistentP+        nonExistentIsDir' `shouldBe` True++      it "checks a virtual file (Copied) that exists in memory" $ do+        nonExistentIsDir'' <- dryRunIO $ do+          () <- copyFile packageYamlP nonExistentP+          isDirectory nonExistentP+        nonExistentIsDir'' `shouldBe` False++      it "checks a virtual file (Contents) that exists in memory" $ do+        nonExistentIsDir''' <- dryRunIO $ do+          () <- writeFile nonExistentP ""+          isDirectory nonExistentP+        nonExistentIsDir''' `shouldBe` False++      it "checks a virtual non-existent directory" $ do+        packageYamlIsFile <- dryRunIO $ do+          () <- removeFile packageYamlP+          isDirectory packageYamlP+        packageYamlIsFile `shouldBe` False++    describe "isSymlink" $ do+      symIt "checks an actual symlink that exists on the real file system"+        $ withTempDir+        $ \tmpDir tmpDir' -> do+          () <- Prelude.writeFile (tmpDir' `combine` "foo") ""+          createFileLink foo (tmpDir </> bar)+          dryRunIO (isSymlink $ tmpDir </> bar) `shouldReturn` True++      it "return False if a path does not exist" $ do+        dryRunIO (isSymlink nonExistentP) `shouldReturn` False++      it "checks a virtual file that exists in memory" $ do+        nonExistentExists' <- dryRunIO $ do+          () <- writeFile nonExistentP ""+          isSymlink nonExistentP+        nonExistentExists' `shouldBe` False++    describe "exists" $ do+      it "checks an actual file that exists on the real file system" $ do+        packageYamlExists <- dryRunIO $ exists packageYamlP+        packageYamlExists `shouldBe` True++      it "checks an actual directory that exists on the real file system" $ do+        testExists <- dryRunIO $ exists testP+        testExists `shouldBe` True++      it "checks a non-existent file" $ do+        nonExistentExists <- dryRunIO $ exists nonExistentP+        nonExistentExists `shouldBe` False++      it "checks a virtual file (Contents) that exists in memory" $ do+        nonExistentExists' <- dryRunIO $ do+          () <- writeFile nonExistentP ""+          exists nonExistentP+        nonExistentExists' `shouldBe` True++      it "checks a virtual file (Copied) that exists in memory" $ do+        nonExistentExists'' <- dryRunIO $ do+          () <- copyFile packageYamlP nonExistentP+          exists nonExistentP+        nonExistentExists'' `shouldBe` True++      it "checks a virtual directory that exists in memory" $ do+        nonExistentExists''' <- dryRunIO $ do+          () <- createDirectory nonExistentP+          exists nonExistentP+        nonExistentExists''' `shouldBe` True++      it "checks a virtual non-existent file" $ do+        packageYamlIsFile <- dryRunIO $ do+          () <- removeFile packageYamlP+          exists packageYamlP+        packageYamlIsFile `shouldBe` False++    describe "readFile" $ do+      it "can read an actual file that exists on the real file system"+        $ withTempDir+        $ \tmpDir tmpDir' -> do+          () <- Prelude.writeFile (tmpDir' `combine` "foo") "Foo contents"+          packageYamlData <- dryRunIO $ readFile $ tmpDir </> foo+          packageYamlData `shouldBe` "Foo contents"++      it "can't read a directory that exists on the real file system" $ do+        Left failToReadTest <- tryDryRunIO $ readFile testP+        ioeGetErrorType failToReadTest `shouldBe` InappropriateType+        ioeGetFileName failToReadTest `shouldBe` Just testFP++      it "can't read a non-existent file" $ do+        Left failToReadNonExistent <- tryDryRunIO $ readFile nonExistentP+        ioeGetErrorType failToReadNonExistent `shouldBe` doesNotExistErrorType+        ioeGetFileName failToReadNonExistent+          `shouldBe` Just nonExistentFP++      it "can read a virtual file (Contents) that exists in memory" $ do+        nonExistentData <- dryRunIO $ do+          () <- writeFile nonExistentP "foo"+          readFile nonExistentP+        nonExistentData `shouldBe` "foo"++      it "can read a virtual file (Copied) that exists in memory"+        $ withTempDir+        $ \tmpDir tmpDir' -> do+          Prelude.writeFile (tmpDir' `combine` "foo") "Foo contents"+          nonExistentData <- dryRunIO $ do+            () <- copyFile (tmpDir </> foo) nonExistentP+            () <- writeFile packageYamlP "foo" -- must not affect the result+            () <- copyFile nonExistentP nonExistentP'+            () <- writeFile nonExistentP "bar" -- must not affect the result+            readFile nonExistentP'+          nonExistentData `shouldBe` "Foo contents"++      it "can't read a virtual directory that exists in memory" $ do+        Left failToReadNonExistent <- tryDryRunIO $ do+          () <- createDirectory nonExistentP+          readFile nonExistentP+        ioeGetErrorType failToReadNonExistent `shouldBe` InappropriateType+        ioeGetFileName failToReadNonExistent+          `shouldBe` Just nonExistentFP+        ioeGetLocation failToReadNonExistent `shouldBe` "readFile"+        show failToReadNonExistent `shouldContain` "is a directory"++      it "can't read a virtual non-existent file" $ do+        Left failToReadNonExistent <- tryDryRunIO $ do+          () <- removeFile packageYamlP+          readFile packageYamlP+        ioeGetErrorType failToReadNonExistent `shouldBe` doesNotExistErrorType+        ioeGetFileName failToReadNonExistent `shouldBe` Just packageYamlFP+        ioeGetLocation failToReadNonExistent `shouldBe` "readFile"+        show failToReadNonExistent `shouldContain` "no such file"++    describe "writeFile" $ do+      it "can write data to an non-existent file" $ do+        data' <- dryRunIO $ do+          () <- writeFile nonExistentP "foo"+          readFile nonExistentP+        data' `shouldBe` "foo"+        withTempDir $ \tmpDir tmpDir' -> do+          () <- Prelude.writeFile (tmpDir' `combine` "foo") "Foo contents"+          data'' <- dryRunIO $ do+            () <- removeFile $ tmpDir </> foo+            () <- writeFile (tmpDir </> foo) "bar"+            readFile $ tmpDir </> foo+          data'' `shouldBe` "bar"+          Prelude.readFile (tmpDir' `combine` "foo")+            `shouldReturn` "Foo contents"++      it "can write data to an existing file"+        $ withTempDir+        $ \tmpDir tmpDir' -> do+          () <- Prelude.writeFile (tmpDir' `combine` "foo") "Foo contents"+          data' <- dryRunIO $ do+            () <- writeFile (tmpDir </> foo) "modified"+            readFile (tmpDir </> foo)+          data' `shouldBe` "modified"+          Prelude.readFile (tmpDir' `combine` "foo")+            `shouldReturn` "Foo contents"+          data'' <- dryRunIO $ do+            () <- writeFile nonExistentP "bar"+            () <- writeFile nonExistentP "baz"+            readFile nonExistentP+          data'' `shouldBe` "baz"+          doesFileExist nonExistentP `shouldReturn` False++      it "can't write data to a directory" $ do+        Left failToWriteToTest <- tryDryRunIO $ writeFile testP "foo"+        ioeGetErrorType failToWriteToTest `shouldBe` InappropriateType+        ioeGetFileName failToWriteToTest `shouldBe` Just testFP+        ioeGetLocation failToWriteToTest `shouldBe` "writeFile"+        show failToWriteToTest `shouldContain` "is a directory"+        Left failToWriteToTest' <- tryDryRunIO $ do+          () <- createDirectory nonExistentP+          writeFile nonExistentP "foo"+        ioeGetErrorType failToWriteToTest' `shouldBe` InappropriateType+        ioeGetFileName failToWriteToTest' `shouldBe` Just nonExistentFP+        ioeGetLocation failToWriteToTest' `shouldBe` "writeFile"+        show failToWriteToTest' `shouldContain` "is a directory"++      it "can't write data to a file path in a non-existent directory" $ do+        Left failToWrite <- tryDryRunIO $ do+          writeFile (nonExistentP </> nonExistentP) "foo"+        ioeGetErrorType failToWrite `shouldBe` doesNotExistErrorType+        ioeGetFileName failToWrite+          `shouldBe` Just (nonExistentFP `combine` nonExistentFP)+        ioeGetLocation failToWrite `shouldBe` "writeFile"+        show failToWrite `shouldContain` "no parent directory"+        Left failToWrite' <- tryDryRunIO $ do+          () <- removeFile packageYamlP+          writeFile (packageYamlP </> nonExistentP) "foo"+        ioeGetErrorType failToWrite' `shouldBe` doesNotExistErrorType+        ioeGetFileName failToWrite'+          `shouldBe` Just (packageYamlFP `combine` nonExistentFP)+        ioeGetLocation failToWrite' `shouldBe` "writeFile"+        show failToWrite' `shouldContain` "no parent directory"++      it "can't write data to a file path inside a non-directory file" $ do+        Left failToWrite <- tryDryRunIO $ do+          writeFile (packageYamlP </> nonExistentP) "bar"+        ioeGetErrorType failToWrite `shouldBe` InappropriateType+        ioeGetFileName failToWrite+          `shouldBe` Just (packageYamlFP `combine` nonExistentFP)+        ioeGetLocation failToWrite `shouldBe` "writeFile"+        show failToWrite `shouldContain` "not inside a directory"+        Left failToWrite' <- tryDryRunIO $ do+          () <- writeFile nonExistentP ""+          writeFile (nonExistentP </> nonExistentP) "bar"+        ioeGetErrorType failToWrite' `shouldBe` InappropriateType+        ioeGetFileName failToWrite'+          `shouldBe` Just (nonExistentFP `combine` nonExistentFP)+        ioeGetLocation failToWrite' `shouldBe` "writeFile"+        show failToWrite' `shouldContain` "not inside a directory"+        Left failToWrite'' <- tryDryRunIO $ do+          () <- copyFile packageYamlP nonExistentP+          writeFile (nonExistentP </> nonExistentP) "bar"+        ioeGetErrorType failToWrite'' `shouldBe` InappropriateType+        ioeGetFileName failToWrite''+          `shouldBe` Just (nonExistentFP `combine` nonExistentFP)+        ioeGetLocation failToWrite'' `shouldBe` "writeFile"+        show failToWrite'' `shouldContain` "not inside a directory"++    describe "readSymlinkTarget" $ do+      symIt "returns the target path of a symbolic link"+        $ withTempDir+        $ \tmpDir tmpDir' -> do+          () <- Prelude.writeFile (tmpDir' `combine` "foo") ""+          createFileLink foo (tmpDir </> bar)+          dryRunIO (readSymlinkTarget $ tmpDir </> bar) `shouldReturn` foo++      it "fails with non-existent file" $ do+        dryRunIO (readSymlinkTarget nonExistentP) `shouldThrow` \e ->+          isDoesNotExistError e && ioeGetFileName e == Just nonExistentFP++      it "just fails with any virtual files as they can't be a symlink" $ do+        Left failToReadSymlink <- tryDryRunIO $ do+          () <- writeFile nonExistentP ""+          readSymlinkTarget nonExistentP+        ioeGetErrorType failToReadSymlink `shouldBe` InappropriateType+        ioeGetFileName failToReadSymlink `shouldBe` Just nonExistentFP+        ioeGetLocation failToReadSymlink `shouldBe` "readSymlinkTarget"+        show failToReadSymlink `shouldContain` "not a symbolic link"++      it "fails with an overlaid removal tag" $ do+        Left failToReadSymlink <- tryDryRunIO $ do+          () <- writeFile nonExistentP ""+          () <- removeFile nonExistentP+          readSymlinkTarget nonExistentP+        ioeGetErrorType failToReadSymlink `shouldBe` doesNotExistErrorType+        ioeGetFileName failToReadSymlink `shouldBe` Just nonExistentFP+        ioeGetLocation failToReadSymlink `shouldBe` "readSymlinkTarget"+        show failToReadSymlink `shouldContain` "no such file"++    describe "copyFile" $ do+      it "copies a source file to a destination path" $ do+        data' <- dryRunIO $ do+          () <- copyFile packageYamlP nonExistentP+          readFile nonExistentP+        packageYamlData <- Data.ByteString.readFile packageYamlFP+        data' `shouldBe` packageYamlData+        doesFileExist nonExistentP `shouldReturn` False+        data'' <- dryRunIO $ do+          () <- writeFile nonExistentP "foo"+          () <- copyFile nonExistentP nonExistentP'+          readFile nonExistentP'+        data'' `shouldBe` "foo"+        doesFileExist nonExistentP' `shouldReturn` False+        data''' <- dryRunIO $ do+          () <- copyFile packageYamlP nonExistentP+          () <- copyFile nonExistentP nonExistentP'+          readFile nonExistentP'+        data''' `shouldBe` packageYamlData+        doesFileExist nonExistentP' `shouldReturn` False++      it "can copy a source file to an existing file by overwriting it" $ do+        data' <- dryRunIO $ do+          () <- writeFile nonExistentP "foo"+          () <- copyFile packageYamlP nonExistentP+          readFile nonExistentP+        packageYamlData <- Data.ByteString.readFile packageYamlFP+        data' `shouldBe` packageYamlData+        doesPathExist nonExistentP `shouldReturn` False++      it "can't copy a non-existent file" $ do+        Left failToCopy <- tryDryRunIO $ copyFile nonExistentP nonExistentP'+        ioeGetErrorType failToCopy `shouldBe` doesNotExistErrorType+        ioeGetFileName failToCopy `shouldBe` Just nonExistentFP+        ioeGetLocation failToCopy `shouldBe` "copyFile"+        show failToCopy `shouldContain` "source does not exist"+        Left failToCopy' <- tryDryRunIO $ do+          () <- removeFile packageYamlP+          copyFile packageYamlP nonExistentP+        ioeGetErrorType failToCopy' `shouldBe` doesNotExistErrorType+        ioeGetFileName failToCopy' `shouldBe` Just packageYamlFP+        ioeGetLocation failToCopy' `shouldBe` "copyFile"+        show failToCopy' `shouldContain` "source does not exist"++      it "can't copy a directory" $ do+        Left failToCopy <- tryDryRunIO $ copyFile testP nonExistentP+        ioeGetErrorType failToCopy `shouldBe` InappropriateType+        ioeGetFileName failToCopy `shouldBe` Just testFP+        ioeGetLocation failToCopy `shouldBe` "copyFile"+        show failToCopy `shouldContain` "source is a directory"+        doesPathExist nonExistentP `shouldReturn` False+        Left failToCopy' <- tryDryRunIO $ do+          () <- createDirectory nonExistentP+          copyFile nonExistentP nonExistentP'+        ioeGetErrorType failToCopy' `shouldBe` InappropriateType+        ioeGetFileName failToCopy' `shouldBe` Just nonExistentFP+        ioeGetLocation failToCopy' `shouldBe` "copyFile"+        show failToCopy' `shouldContain` "source is a directory"+        doesPathExist nonExistentP' `shouldReturn` False++      it "can't copy a file to a file path that has no parent directory" $ do+        Left failToCopy <- tryDryRunIO $ do+          copyFile packageYamlP (nonExistentP </> nonExistentP)+        failToCopy `shouldSatisfy` isDoesNotExistError+        ioeGetFileName failToCopy+          `shouldBe` Just (nonExistentFP `combine` nonExistentFP)+        ioeGetLocation failToCopy `shouldBe` "copyFile"+        show failToCopy `shouldContain` "no parent directory"+        Left failToCopy' <- tryDryRunIO $ do+          () <- writeFile nonExistentP ""+          () <- removeFile nonExistentP+          copyFile packageYamlP (nonExistentP </> nonExistentP)+        failToCopy' `shouldSatisfy` isDoesNotExistError+        ioeGetFileName failToCopy'+          `shouldBe` Just (nonExistentFP `combine` nonExistentFP)+        ioeGetLocation failToCopy' `shouldBe` "copyFile"+        show failToCopy' `shouldContain` "no parent directory"++      it "can't copy a file to a file path inside a non-directory path" $ do+        Left failToCopy <- tryDryRunIO $ do+          copyFile packageYamlP (packageYamlP </> nonExistentP)+        ioeGetErrorType failToCopy `shouldBe` InappropriateType+        ioeGetFileName failToCopy+          `shouldBe` Just (packageYamlFP `combine` nonExistentFP)+        ioeGetLocation failToCopy `shouldBe` "copyFile"+        show failToCopy `shouldContain` "not inside a directory"+        Left failToCopy' <- tryDryRunIO $ do+          () <- writeFile nonExistentP ""+          copyFile packageYamlP (nonExistentP </> nonExistentP)+        ioeGetErrorType failToCopy `shouldBe` InappropriateType+        ioeGetFileName failToCopy'+          `shouldBe` Just (nonExistentFP `combine` nonExistentFP)+        ioeGetLocation failToCopy' `shouldBe` "copyFile"+        show failToCopy' `shouldContain` "not inside a directory"+        Left failToCopy'' <- tryDryRunIO $ do+          () <- copyFile packageYamlP nonExistentP+          copyFile nonExistentP (nonExistentP </> nonExistentP)+        ioeGetErrorType failToCopy `shouldBe` InappropriateType+        ioeGetFileName failToCopy''+          `shouldBe` Just (nonExistentFP `combine` nonExistentFP)+        ioeGetLocation failToCopy'' `shouldBe` "copyFile"+        show failToCopy'' `shouldContain` "not inside a directory"++      it "can't copy a file to a directory path" $ do+        Left failToCopy <- tryDryRunIO $ copyFile packageYamlP testP+        ioeGetErrorType failToCopy `shouldBe` InappropriateType+        ioeGetFileName failToCopy `shouldBe` Just testFP+        ioeGetLocation failToCopy `shouldBe` "copyFile"+        show failToCopy `shouldContain` "destination is a directory"+        doesDirectoryExist testP `shouldReturn` True+        Left failToCopy' <- tryDryRunIO $ do+          () <- createDirectory nonExistentP+          copyFile packageYamlP nonExistentP+        ioeGetErrorType failToCopy' `shouldBe` InappropriateType+        ioeGetFileName failToCopy' `shouldBe` Just nonExistentFP+        ioeGetLocation failToCopy' `shouldBe` "copyFile"+        show failToCopy' `shouldContain` "destination is a directory"++    describe "createDirectory" $ do+      it "creates an empty directory" $ do+        dryRunIO (createDirectory nonExistentP >> isDirectory nonExistentP)+          `shouldReturn` True++      it "can't create a directory inside a non-existent path" $ do+        Left failToCreate <- tryDryRunIO $ do+          createDirectory (nonExistentP </> nonExistentP)+        ioeGetErrorType failToCreate `shouldBe` doesNotExistErrorType+        ioeGetFileName failToCreate+          `shouldBe` Just (nonExistentFP `combine` nonExistentFP)+        ioeGetLocation failToCreate `shouldBe` "createDirectory"+        show failToCreate `shouldContain` "no parent directory"+        Left failToCreate' <- tryDryRunIO $ do+          () <- writeFile nonExistentP ""+          () <- removeFile nonExistentP+          createDirectory (nonExistentP </> nonExistentP)+        ioeGetErrorType failToCreate' `shouldBe` doesNotExistErrorType+        ioeGetFileName failToCreate'+          `shouldBe` Just (nonExistentFP `combine` nonExistentFP)+        ioeGetLocation failToCreate' `shouldBe` "createDirectory"+        show failToCreate' `shouldContain` "no parent directory"++      it "can't create a directory inside a non-directory path" $ do+        Left failToCreate <- tryDryRunIO $ do+          createDirectory (packageYamlP </> nonExistentP)+        ioeGetErrorType failToCreate `shouldBe` InappropriateType+        ioeGetFileName failToCreate+          `shouldBe` Just (packageYamlFP `combine` nonExistentFP)+        ioeGetLocation failToCreate `shouldStartWith` "createDirectory"+        doesFileExist packageYamlP `shouldReturn` True+        Left failToCreate' <- tryDryRunIO $ do+          () <- writeFile nonExistentP ""+          createDirectory (nonExistentP </> nonExistentP)+        ioeGetErrorType failToCreate' `shouldBe` InappropriateType+        ioeGetFileName failToCreate'+          `shouldBe` Just (nonExistentFP `combine` nonExistentFP)+        ioeGetLocation failToCreate' `shouldStartWith` "createDirectory"+        show failToCreate' `shouldContain` "not inside a directory"+        Left failToCreate'' <- tryDryRunIO $ do+          () <- copyFile packageYamlP nonExistentP+          createDirectory (nonExistentP </> nonExistentP)+        ioeGetErrorType failToCreate'' `shouldBe` InappropriateType+        ioeGetFileName failToCreate''+          `shouldBe` Just (nonExistentFP `combine` nonExistentFP)+        ioeGetLocation failToCreate'' `shouldStartWith` "createDirectory"+        show failToCreate'' `shouldContain` "not inside a directory"++      it "can't create a directory by overwriting an existing file" $ do+        Left failToCreate <- tryDryRunIO $ do+          createDirectory packageYamlP+        ioeGetErrorType failToCreate `shouldBe` alreadyExistsErrorType+        ioeGetFileName failToCreate `shouldBe` Just packageYamlFP+        ioeGetLocation failToCreate `shouldBe` "createDirectory"+        show failToCreate `shouldContain` "destination is already a file"+        doesFileExist packageYamlP `shouldReturn` True+        Left failToCreate' <- tryDryRunIO $ do+          () <- writeFile nonExistentP ""+          createDirectory nonExistentP+        ioeGetErrorType failToCreate' `shouldBe` alreadyExistsErrorType+        ioeGetFileName failToCreate' `shouldBe` Just nonExistentFP+        ioeGetLocation failToCreate' `shouldBe` "createDirectory"+        show failToCreate' `shouldContain` "destination is already a file"+        Left failToCreate'' <- tryDryRunIO $ do+          () <- copyFile packageYamlP nonExistentP+          createDirectory nonExistentP+        ioeGetErrorType failToCreate'' `shouldBe` alreadyExistsErrorType+        ioeGetFileName failToCreate'' `shouldBe` Just nonExistentFP+        ioeGetLocation failToCreate'' `shouldBe` "createDirectory"+        show failToCreate'' `shouldContain` "destination is already a file"++      it "can't create a directory if it's already a directory" $ do+        Left failToCreate <- tryDryRunIO $ do+          createDirectory testP+        ioeGetErrorType failToCreate `shouldBe` alreadyExistsErrorType+        ioeGetFileName failToCreate `shouldBe` Just testFP+        ioeGetLocation failToCreate `shouldBe` "createDirectory"+        show failToCreate `shouldContain` "destination is already a directory"+        doesDirectoryExist testP `shouldReturn` True+        Left failToCreate' <- tryDryRunIO $ do+          () <- createDirectory nonExistentP+          createDirectory nonExistentP+        ioeGetErrorType failToCreate' `shouldBe` alreadyExistsErrorType+        ioeGetFileName failToCreate' `shouldBe` Just nonExistentFP+        ioeGetLocation failToCreate' `shouldBe` "createDirectory"+        show failToCreate' `shouldContain` "destination is already a directory"++    describe "removeFile" $ do+      it "removes an existing file" $ do+        dryRunIO (removeFile packageYamlP >> exists packageYamlP)+          `shouldReturn` False+        doesFileExist packageYamlP `shouldReturn` True+        fileExists <- dryRunIO $ do+          () <- writeFile nonExistentP ""+          () <- removeFile nonExistentP+          exists nonExistentP+        fileExists `shouldBe` False+        fileExists' <- dryRunIO $ do+          () <- copyFile packageYamlP nonExistentP+          () <- removeFile nonExistentP+          exists nonExistentP+        fileExists' `shouldBe` False++      it "can't remove a non-existent file" $ do+        Left failToRemove <- tryDryRunIO $ removeFile nonExistentP+        ioeGetErrorType failToRemove `shouldBe` doesNotExistErrorType+        ioeGetFileName failToRemove `shouldBe` Just nonExistentFP+        ioeGetLocation failToRemove `shouldBe` "removeFile"+        show failToRemove `shouldContain` "no such file"+        Left failToRemove' <- tryDryRunIO $ do+          () <- removeFile packageYamlP+          removeFile packageYamlP+        ioeGetErrorType failToRemove' `shouldBe` doesNotExistErrorType+        ioeGetFileName failToRemove' `shouldBe` Just packageYamlFP+        ioeGetLocation failToRemove' `shouldBe` "removeFile"+        show failToRemove' `shouldContain` "no such file"++      it "can't remove a directory" $ do+        Left failToRemove <- tryDryRunIO $ removeFile testP+        ioeGetErrorType failToRemove `shouldBe` InappropriateType+        ioeGetFileName failToRemove `shouldBe` Just testFP+        ioeGetLocation failToRemove `shouldBe` "removeFile"+        show failToRemove `shouldContain` "is a directory"+        doesDirectoryExist testP `shouldReturn` True+        Left failToRemove' <- tryDryRunIO $ do+          () <- createDirectory nonExistentP+          removeFile nonExistentP+        ioeGetErrorType failToRemove' `shouldBe` InappropriateType+        ioeGetFileName failToRemove' `shouldBe` Just nonExistentFP+        ioeGetLocation failToRemove' `shouldBe` "removeFile"+        show failToRemove' `shouldContain` "is a directory"++    describe "removeDirectory" $ do+      it "removes an existing directory" $ do+        result <- dryRunIO $ do+          createDirectory nonExistentP+          removeDirectory nonExistentP+          exists nonExistentP+        result `shouldBe` False++      it "can't remove a non-existent directory" $ do+        Left failToRemove <- tryDryRunIO $ removeDirectory nonExistentP+        failToRemove `shouldSatisfy` isDoesNotExistError+        ioeGetFileName failToRemove `shouldBe` Just nonExistentFP+        Left failToRemove' <- tryDryRunIO $ do+          () <- removeFile packageYamlP+          removeDirectory packageYamlP+        failToRemove' `shouldSatisfy` isDoesNotExistError+        ioeGetFileName failToRemove' `shouldBe` Just packageYamlFP++      it "can't remove a non-directory" $ do+        Left failToRemove <- tryDryRunIO $ removeDirectory packageYamlP+        ioeGetErrorType failToRemove `shouldBe` InappropriateType+        ioeGetFileName failToRemove `shouldBe` Just packageYamlFP+        doesFileExist packageYamlP `shouldReturn` True+        Left failToRemove' <- tryDryRunIO $ do+          () <- writeFile nonExistentP ""+          removeDirectory nonExistentP+        ioeGetErrorType failToRemove' `shouldBe` InappropriateType+        ioeGetFileName failToRemove' `shouldBe` Just nonExistentFP+        Left failToRemove'' <- tryDryRunIO $ do+          () <- copyFile packageYamlP nonExistentP+          removeDirectory nonExistentP+        ioeGetErrorType failToRemove'' `shouldBe` InappropriateType+        ioeGetFileName failToRemove'' `shouldBe` Just nonExistentFP++    describe "removeDirectoryRecursively" $ do+      it "removes an existing directory recursively" $ do+        result <- dryRunIO $ do+          createDirectory nonExistentP+          writeFile (nonExistentP </> foo) ""+          createDirectory (nonExistentP </> bar)+          writeFile (nonExistentP </> bar </> baz) ""+          removeDirectoryRecursively nonExistentP+          exists nonExistentP+        result `shouldBe` False++      it "can't remove a non-existent directory" $ do+        Left failToRemove <- tryDryRunIO $ do+          removeDirectoryRecursively nonExistentP+        failToRemove `shouldSatisfy` isDoesNotExistError+        ioeGetFileName failToRemove `shouldBe` Just nonExistentFP+        Left failToRemove' <- tryDryRunIO $ do+          () <- removeFile packageYamlP+          removeDirectoryRecursively packageYamlP+        failToRemove' `shouldSatisfy` isDoesNotExistError+        ioeGetFileName failToRemove' `shouldBe` Just packageYamlFP++      it "can't remove a non-directory" $ do+        Left failToRemove <- tryDryRunIO $ removeDirectoryRecursively packageYamlP+        ioeGetErrorType failToRemove `shouldBe` InappropriateType+        ioeGetLocation failToRemove+          `shouldStartWith` "removeDirectoryRecursively"+        ioeGetFileName failToRemove `shouldBe` Just packageYamlFP+        doesFileExist packageYamlP `shouldReturn` True+        Left failToRemove' <- tryDryRunIO $ do+          () <- writeFile nonExistentP ""+          removeDirectoryRecursively nonExistentP+        ioeGetErrorType failToRemove' `shouldBe` InappropriateType+        ioeGetLocation failToRemove'+          `shouldStartWith` "removeDirectoryRecursively"+        ioeGetFileName failToRemove' `shouldBe` Just nonExistentFP+        Left failToRemove'' <- tryDryRunIO $ do+          () <- copyFile packageYamlP nonExistentP+          removeDirectoryRecursively nonExistentP+        ioeGetErrorType failToRemove'' `shouldBe` InappropriateType+        ioeGetLocation failToRemove''+          `shouldStartWith` "removeDirectoryRecursively"+        ioeGetFileName failToRemove'' `shouldBe` Just nonExistentFP++    describe "createDirectories" $ do+      it "creates a directory and its ancestors if needed" $ do+        result <- dryRunIO $ do+          () <- createDirectories (nonExistentP </> nonExistentP)+          isDirectory (nonExistentP </> nonExistentP)+        result `shouldBe` True+        doesDirectoryExist nonExistentP `shouldReturn` False++      it "can't create a directory if any of its ancestors is a file" $ do+        Left failToCreate <- tryDryRunIO $ do+          createDirectories (packageYamlP </> nonExistentP </> nonExistentP)+        ioeGetErrorType failToCreate `shouldBe` InappropriateType+        ioeGetFileName failToCreate `shouldBe` Just packageYamlFP+        ioeGetLocation failToCreate `shouldStartWith` "createDirectories"+        show failToCreate+          `shouldContain` "one of its ancestors is a non-directory file"++    describe "listDirectory" $ do+      it "lists direct children in a directory" $ do+        withFixture $ \tmpDir tmpDir' -> do+          result <- dryRunIO $ listDirectory tmpDir+          result `shouldBe` [bar, baz, foo]+          () <- Prelude.writeFile (tmpDir' `combine` "corge") ""+          result' <- dryRunIO $ do+            () <- writeFile (tmpDir </> qux) ""+            () <- createDirectory (tmpDir </> quux)+            () <- writeFile (tmpDir </> corge) ""+            () <- writeFile (dropFileName tmpDir </> foo) ""+            listDirectory tmpDir+          result' `shouldBe` [bar, baz, corge, foo, quux, qux]++      it "lists direct children in a virtual directory" $ do+        result <- dryRunIO $ do+          () <- createDirectory nonExistentP+          () <- writeFile (nonExistentP </> foo) ""+          () <- createDirectory (nonExistentP </> bar)+          () <- createDirectory (nonExistentP </> baz)+          () <- createDirectory (nonExistentP </> baz </> qux)+          listDirectory nonExistentP+        result `shouldBe` [bar, baz, foo]++      it "hides removed files in the sandbox" $ withFixture $ \tmpDir _ -> do+        result <- dryRunIO $ do+          () <- removeFile (tmpDir </> foo)+          listDirectory tmpDir+        result `shouldBe` [bar, baz]++      it "fails if a specified path does not exist" $ do+        Left e <- tryDryRunIO $ listDirectory nonExistentP+        e `shouldSatisfy` isDoesNotExistError+        ioeGetFileName e `shouldBe` Just nonExistentFP+        ioeGetErrorType e `shouldBe` doesNotExistErrorType+        ioeGetLocation e `shouldStartWith` "listDirectory"+        Left e' <- tryDryRunIO $ do+          () <- removeFile packageYamlP+          listDirectory packageYamlP+        e' `shouldSatisfy` isDoesNotExistError+        ioeGetFileName e' `shouldBe` Just packageYamlFP+        ioeGetLocation e' `shouldStartWith` "listDirectory"+        show e' `shouldContain` "no such directory"++      it "fails if a specified path is a regular file" $ do+        Left e <- tryDryRunIO $ listDirectory packageYamlP+        ioeGetErrorType e `shouldBe` InappropriateType+        ioeGetFileName e `shouldBe` Just packageYamlFP+        ioeGetLocation e `shouldBe` "listDirectory"+        Left e' <- tryDryRunIO $ do+          () <- writeFile nonExistentP ""+          listDirectory nonExistentP+        ioeGetErrorType e' `shouldBe` InappropriateType+        ioeGetFileName e' `shouldBe` Just nonExistentFP+        ioeGetLocation e' `shouldBe` "listDirectory"+        show e' `shouldContain` "not a directory"+        Left e'' <- tryDryRunIO $ do+          () <- copyFile packageYamlP nonExistentP+          listDirectory nonExistentP+        ioeGetErrorType e'' `shouldBe` InappropriateType+        ioeGetFileName e'' `shouldBe` Just nonExistentFP+        ioeGetLocation e'' `shouldBe` "listDirectory"+        show e'' `shouldContain` "not a directory"++    describe "getFileSize" $ do+      it "returns the size of a file" $ withTempDir $ \tmpDir tmpDirFP -> do+        Data.ByteString.writeFile (tmpDirFP `combine` "foo") "asdf"+        dryRunIO (getFileSize $ tmpDir </> foo) `shouldReturn` 4+        size <- dryRunIO $ do+          () <- writeFile (tmpDir </> bar) "asdf asdf"+          getFileSize $ tmpDir </> bar+        size `shouldBe` 9+        size' <- dryRunIO $ do+          () <- writeFile (tmpDir </> bar) "asdf"+          () <- copyFile (tmpDir </> bar) (tmpDir </> baz)+          getFileSize $ tmpDir </> baz+        size' `shouldBe` 4++      it "fails if path doesn't exist" $ withTempDir $ \tmpDir tmpDirFP -> do+        Left e <- tryDryRunIO $ getFileSize $ tmpDir </> nonExistentP+        ioeGetErrorType e `shouldBe` doesNotExistErrorType+        ioeGetFileName e `shouldBe` Just (tmpDirFP `combine` nonExistentFP)+        ioeGetLocation e `shouldBe` "getFileSize"+        Left e' <- tryDryRunIO $ do+          () <- removeFile packageYamlP+          getFileSize packageYamlP+        ioeGetErrorType e' `shouldBe` doesNotExistErrorType+        ioeGetFileName e' `shouldBe` Just packageYamlFP+        ioeGetLocation e' `shouldBe` "getFileSize"+        show e' `shouldContain` "does not exist"++      it "fails if path is a directory" $ withTempDir $ \tmpDir tmpDirFP -> do+        Left e <- tryDryRunIO $ getFileSize tmpDir+        ioeGetErrorType e `shouldBe` InappropriateType+        ioeGetFileName e `shouldBe` Just tmpDirFP+        ioeGetLocation e `shouldBe` "getFileSize"+        show e `shouldContain` "not a regular file, but a directory"+        Left e' <- tryDryRunIO $ do+          () <- createDirectory nonExistentP+          getFileSize nonExistentP+        ioeGetErrorType e' `shouldBe` InappropriateType+        ioeGetFileName e' `shouldBe` Just nonExistentFP+        ioeGetLocation e' `shouldBe` "getFileSize"+        show e' `shouldContain` "not a regular file, but a directory"
+ test/Dojang/Syntax/EnvironmentPredicate/ParserSpec.hs view
@@ -0,0 +1,361 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Dojang.Syntax.EnvironmentPredicate.ParserSpec (spec) where++import Dojang.Syntax.EnvironmentPredicate.Parser+  ( Field (..)+  , FieldOp (..)+  , andExpression+  , bareStringLiteral+  , charactersInStringLiteral+  , doubleQuoteStringLiteral+  , equalOp+  , errorBundlePretty+  , expression+  , field+  , fieldOp+  , inOp+  , notEqualOp+  , notInOp+  , parseEnvironmentPredicate+  , prefixOp+  , simpleExpression+  , singleQuoteStringLiteral+  , stringLiteral+  , strings+  , suffixOp+  )+import Dojang.Types.Environment (Architecture (..), OperatingSystem (..))+import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (..))+import Dojang.Types.MonikerName (parseMonikerName)++import Control.Monad (forM_)+import Data.Text (singleton)+import Test.Hspec (Spec, specify)+import Test.Hspec.Expectations.Pretty (shouldBe)+import Test.Hspec.Megaparsec+  ( eeof+  , elabel+  , err+  , etok+  , etoks+  , shouldFailWith+  , shouldParse+  , ueof+  , utok+  , utoks+  )+import Text.Megaparsec (eof, parse)+++deriving instance Show Field+deriving instance Eq FieldOp+deriving instance Show FieldOp+++spec :: Spec+spec = do+  specify "expression" $ do+    let p = expression <* eof+    parse p "" "os=linux" `shouldParse` OperatingSystem Linux+    parse p "" "os=windows || arch=aarch64"+      `shouldParse` Or [OperatingSystem Windows, Architecture AArch64]+    parse p "" " os=linux && arch=x86 || os=macos && arch=aarch64 "+      `shouldParse` Or+        [ And [OperatingSystem Linux, Architecture X86]+        , And [OperatingSystem MacOS, Architecture AArch64]+        ]+    parse p "" "os=linux && ( arch=x86 || os=macos ) && arch=aarch64"+      `shouldParse` And+        [ OperatingSystem Linux+        , Or [Architecture X86, OperatingSystem MacOS]+        , Architecture AArch64+        ]++  specify "andExpression" $ do+    let p = andExpression <* eof+    parse p "" "os=linux&&arch=aarch64"+      `shouldParse` And [OperatingSystem Linux, Architecture AArch64]+    parse p "" " ( always ) && ( always )" `shouldParse` And [Always, Always]++  specify "simpleExpression" $ do+    let p = simpleExpression <* eof+    parse p "" "os=linux" `shouldParse` OperatingSystem Linux+    parse p "" "(os = windows)" `shouldParse` OperatingSystem Windows+    parse p "" " ( os == macos ) " `shouldParse` OperatingSystem MacOS+    parse p "" "always" `shouldParse` Always+    parse p "" "never" `shouldParse` Not Always+    parse p "" "!(arch = x86)" `shouldParse` Not (Architecture X86)+    parse p "" "!(arch == 'x86_64')"+      `shouldParse` Not (Architecture X86_64)+    parse p "" "! ( arch != aarch64 )"+      `shouldParse` Not (Not (Architecture AArch64))++  specify "fieldOp" $ do+    let p = fieldOp <* eof+    parse p "" "os=linux" `shouldParse` OperatingSystem Linux+    parse p "" " arch = 'x86_64' " `shouldParse` Architecture X86_64+    parse p "" "kernel = Darwin" `shouldParse` KernelName "Darwin"+    parse p "" "kernel-release=\"1.2.3\"" `shouldParse` KernelRelease "1.2.3"+    let Right fooBar = parseMonikerName "foo-bar"+    parse p "" " moniker == \"foo-bar\" " `shouldParse` Moniker fooBar+    parse p "" " moniker = 'invalid moniker' " `shouldParse` Not Always+    parse p "" " os != \"windows\" " `shouldParse` Not (OperatingSystem Windows)+    parse p "" "arch!=aarch64" `shouldParse` Not (Architecture AArch64)+    parse p "" "kernel != Linux" `shouldParse` Not (KernelName "Linux")+    parse p "" "kernel-release!='4.5.6'"+      `shouldParse` Not (KernelRelease "4.5.6")+    parse p "" "moniker!='foo-bar'" `shouldParse` Not (Moniker fooBar)+    parse p "" "kernel-release ^= '1.2'" `shouldParse` KernelReleasePrefix "1.2"+    parse p "" "kernel-release$='2.3'" `shouldParse` KernelReleaseSuffix "2.3"+    parse p "" "os in ()" `shouldParse` Not Always+    parse p "" " arch  in  ( x86, \"x86_64\", ) "+      `shouldParse` Or [Architecture X86, Architecture X86_64]+    let Right baz = parseMonikerName "baz"+    parse p "" "moniker in (\"foo-bar\", baz)"+      `shouldParse` Or [Moniker fooBar, Moniker baz]+    parse p "" "os not in (linux, macos,)"+      `shouldParse` And+        [ Not $ OperatingSystem Linux+        , Not $ OperatingSystem MacOS+        ]+    parse p "" " arch not in () " `shouldParse` Always+    parse p "" "moniker not in ('foo-bar', baz,)"+      `shouldParse` And [Not $ Moniker fooBar, Not $ Moniker baz]+    parse p "" "os ^= lin"+      `shouldFailWith` err+        3+        ( utoks "^= "+            <> etoks "!="+            <> etoks "in"+            <> etoks "not"+            <> etoks "="+            <> elabel "white space"+        )++  specify "equalOp" $ do+    let p = equalOp <* eof+    parse p "" "=foo" `shouldParse` EqualOp "foo"+    parse p "" "==bar" `shouldParse` EqualOp "bar"+    parse p "" " = foo" `shouldParse` EqualOp "foo"+    parse p "" " == bar" `shouldParse` EqualOp "bar"+    parse p "" "='foo bar'" `shouldParse` EqualOp "foo bar"+    parse p "" " = \"foo bar\"" `shouldParse` EqualOp "foo bar"+    parse p "" "="+      `shouldFailWith` err+        1+        (ueof <> etok '=' <> elabel "white space" <> elabel "string literal")+    parse p "" "= "+      `shouldFailWith` err+        2+        (ueof <> elabel "white space" <> elabel "string literal")+    parse p "" "= = foo"+      `shouldFailWith` err+        2+        (utok '=' <> elabel "white space" <> elabel "string literal")++  specify "notEqualOp" $ do+    let p = notEqualOp <* eof+    parse p "" "!=foo" `shouldParse` NotEqualOp "foo"+    parse p "" " != foo" `shouldParse` NotEqualOp "foo"+    parse p "" "!='foo bar'" `shouldParse` NotEqualOp "foo bar"+    parse p "" " != \"foo bar\"" `shouldParse` NotEqualOp "foo bar"+    parse p "" "!="+      `shouldFailWith` err+        2+        (ueof <> elabel "white space" <> elabel "string literal")+    parse p "" "!= "+      `shouldFailWith` err+        3+        (ueof <> elabel "white space" <> elabel "string literal")+    parse p "" "! = foo"+      `shouldFailWith` err+        0+        (utoks "! " <> elabel "white space" <> etoks "!=")++  specify "prefixOp" $ do+    let p = prefixOp <* eof+    parse p "" "^=foo" `shouldParse` PrefixOp "foo"+    parse p "" " ^= foo" `shouldParse` PrefixOp "foo"+    parse p "" "^='foo bar'" `shouldParse` PrefixOp "foo bar"+    parse p "" " ^= \"foo bar\"" `shouldParse` PrefixOp "foo bar"+    parse p "" "^="+      `shouldFailWith` err+        2+        (ueof <> elabel "white space" <> elabel "string literal")+    parse p "" "^= "+      `shouldFailWith` err+        3+        (ueof <> elabel "white space" <> elabel "string literal")+    parse p "" "^ = foo"+      `shouldFailWith` err+        0+        (utoks "^ " <> elabel "white space" <> etoks "^=")++  specify "suffixOp" $ do+    let p = suffixOp <* eof+    parse p "" "$=foo" `shouldParse` SuffixOp "foo"+    parse p "" " $= foo" `shouldParse` SuffixOp "foo"+    parse p "" "$='foo bar'" `shouldParse` SuffixOp "foo bar"+    parse p "" " $= \"foo bar\"" `shouldParse` SuffixOp "foo bar"+    parse p "" "$="+      `shouldFailWith` err+        2+        (ueof <> elabel "white space" <> elabel "string literal")+    parse p "" "$= "+      `shouldFailWith` err+        3+        (ueof <> elabel "white space" <> elabel "string literal")+    parse p "" "$ = foo"+      `shouldFailWith` err+        0+        (utoks "$ " <> elabel "white space" <> etoks "$=")++  specify "inOp" $ do+    let p = inOp <* eof+    parse p "" " in ()" `shouldParse` InOp []+    parse p "" " in (foo)" `shouldParse` InOp ["foo"]+    parse p "" " in (foo, bar,) " `shouldParse` InOp ["foo", "bar"]+    parse p "" "in ()" `shouldFailWith` err 0 (utok 'i' <> elabel "white space")+    parse p "" " in"+      `shouldFailWith` err 3 (ueof <> etok '(' <> elabel "white space")+    parse p "" " in "+      `shouldFailWith` err 4 (ueof <> etok '(' <> elabel "white space")+    parse p "" " in ("+      `shouldFailWith` err+        5+        (ueof <> etok ')' <> elabel "string literal" <> elabel "white space")++  specify "notInOp" $ do+    let p = notInOp <* eof+    parse p "" " not in ()" `shouldParse` NotInOp []+    parse p "" " not in (foo)" `shouldParse` NotInOp ["foo"]+    parse p "" " not in (foo, bar,) " `shouldParse` NotInOp ["foo", "bar"]+    parse p "" "not in ()"+      `shouldFailWith` err 0 (utok 'n' <> elabel "white space")+    parse p "" " not" `shouldFailWith` err 4 (ueof <> elabel "white space")+    parse p "" " not "+      `shouldFailWith` err 5 (ueof <> etoks "in" <> elabel "white space")+    parse p "" " not in"+      `shouldFailWith` err 7 (ueof <> etok '(' <> elabel "white space")+    parse p "" " not in "+      `shouldFailWith` err 8 (ueof <> etok '(' <> elabel "white space")+    parse p "" " not in ("+      `shouldFailWith` err+        9+        (ueof <> etok ')' <> elabel "string literal" <> elabel "white space")++  specify "strings" $ do+    let p = strings <* eof+    parse p "" "(foo, 'bar', \"baz\")" `shouldParse` ["foo", "bar", "baz"]+    parse p "" "('foo bar', \"baz qux\",)" `shouldParse` ["foo bar", "baz qux"]+    parse p "" "( 'foo bar' , )" `shouldParse` ["foo bar"]+    parse p "" ""+      `shouldFailWith` err 0 (ueof <> etok '(' <> elabel "white space")+    parse p "" "(foo"+      `shouldFailWith` err+        4+        (ueof <> etok ')' <> etok ',' <> elabel "white space")+    parse p "" "(foo, "+      `shouldFailWith` err+        6+        (ueof <> etok ')' <> elabel "string literal" <> elabel "white space")++  specify "field" $ do+    let p = field <* eof+    parse p "" "os" `shouldParse` OS+    parse p "" "arch" `shouldParse` Arch+    parse p "" "kernel" `shouldParse` Kernel+    parse p "" "kernel-release" `shouldParse` KernelRelease'+    parse p "" "moniker" `shouldParse` Moniker'+    parse p "" "foo"+      `shouldFailWith` err+        0+        ( utoks "foo"+            <> etoks "arch"+            <> etoks "kernel"+            <> etoks "kernel-release"+            <> etoks "moniker"+            <> etoks "os"+        )++  specify "stringLiteral" $ do+    let p = stringLiteral <* eof+    parse p "" "foo" `shouldParse` "foo"+    parse p "" "'foo'" `shouldParse` "foo"+    parse p "" "\"foo\"" `shouldParse` "foo"+    parse p "" "foo bar"+      `shouldFailWith` err 4 (utok 'b' <> eeof <> elabel "white space")+    parse p "" "'foo bar'" `shouldParse` "foo bar"+    parse p "" "\"foo bar\"" `shouldParse` "foo bar"++  specify "bareStringLiteral" $ do+    let p = bareStringLiteral <* eof+    parse p "" "foo" `shouldParse` "foo"+    parse p "" "foo123" `shouldParse` "foo123"+    parse p "" "" `shouldFailWith` err 0 (ueof <> elabel "bare string literal")+    parse p "" "123foo"+      `shouldFailWith` err 0 (utok '1' <> elabel "bare string literal")+    parse p "" "foo bar" `shouldFailWith` err 3 (utok ' ' <> eeof)+    parse p "" "foo-bar" `shouldFailWith` err 3 (utok '-' <> eeof)+    parse p "" "foo_bar" `shouldFailWith` err 3 (utok '_' <> eeof)+    parse p "" "foo.bar" `shouldFailWith` err 3 (utok '.' <> eeof)++  specify "doubleQuoteStringLiteral" $ do+    let p = doubleQuoteStringLiteral <* eof+    parse p "" "\"foo\"" `shouldParse` "foo"+    parse p "" "\"foo bar\"" `shouldParse` "foo bar"+    parse p "" "\"\\\"Hello\\'\\n\\\\\"" `shouldParse` "\"Hello'\n\\"+    parse p "" "foo"+      `shouldFailWith` err 0 (utok 'f' <> elabel "double quote string literal")+    parse p "" "\"foo"+      `shouldFailWith` err+        4+        (ueof <> etok '"' <> etok '\\' <> elabel "string character")++  specify "singleQuoteStringLiteral" $ do+    let p = singleQuoteStringLiteral <* eof+    parse p "" "'foo'" `shouldParse` "foo"+    parse p "" "'foo bar'" `shouldParse` "foo bar"+    parse p "" "'\\\"Hello\\'\\n\\\\'" `shouldParse` "\"Hello'\n\\"+    parse p "" "foo"+      `shouldFailWith` err 0 (utok 'f' <> elabel "single quote string literal")+    parse p "" "'foo"+      `shouldFailWith` err+        4+        (ueof <> etok '\'' <> etok '\\' <> elabel "string character")++  forM_ (['\'', '"'] :: [Char]) $ \terminal -> do+    specify ("charactersInStringLiteral " ++ show terminal) $ do+      let p = charactersInStringLiteral terminal <* eof+      parse p "" "foo" `shouldParse` "foo"+      parse p "" "foo bar" `shouldParse` "foo bar"+      parse p "" "\\\"Hello\\'\\n\\\\" `shouldParse` "\"Hello'\n\\"+      parse p "" "\\b\\f\\n\\r\\t\\v\\0" `shouldParse` "\b\f\n\r\t\v\0"+      parse p "" "\\x41\\x42\\x43\\x44" `shouldParse` "ABCD"+      parse p "" "\\u0045\\u0046\\u0047\\u0048" `shouldParse` "EFGH" -- cSpell: disable-line+      parse p "" "\\U00000049\\U0000004A\\U0000004b" `shouldParse` "IJK"+      parse p "" "\\"+        `shouldFailWith` err+          1+          ( (ueof <> etok '"' <> etok '\'' <> etok '0' <> etok 'U' <> etok '\\')+              <> (etok 'b' <> etok 'f' <> etok 'n' <> etok 'r' <> etok 't')+              <> (etok 'u' <> etok 'v' <> etok 'x')+          )+      parse p "" (singleton terminal)+        `shouldFailWith` err+          0+          (utok terminal <> etok '\\' <> eeof <> elabel "string character")++  specify "errorBundlePretty" $ do+    let Left e = parseEnvironmentPredicate "<input>" "invalid"+    errorBundlePretty e+      `shouldBe` "<input>:1:1:\n"+      <> "  |\n"+      <> "1 | invalid\n"+      <> "  | ^^^^^^^\n"+      <> "unexpected \"invalid\"\n"+      <> "expecting expression\n"
+ test/Dojang/Syntax/EnvironmentPredicate/WriterSpec.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}++module Dojang.Syntax.EnvironmentPredicate.WriterSpec (spec) where++import Data.Text (Text, unpack)+import Test.Hspec (Spec, describe, it, specify)+import Test.Hspec.Expectations.Pretty (shouldBe)+import Test.Hspec.Hedgehog (annotateShow, footnote, forAll, hedgehog, (===))++import Dojang.Syntax.EnvironmentPredicate.Parser+  ( errorBundlePretty+  , parseEnvironmentPredicate+  )+import Dojang.Syntax.EnvironmentPredicate.Writer (writeEnvironmentPredicate)+import Dojang.Types.EnvironmentPredicate+  ( EnvironmentPredicate (..)+  , normalizePredicate+  )+import Dojang.Types.Gen qualified as Gen+import Dojang.Types.MonikerName (parseMonikerName)+++write :: EnvironmentPredicate -> Text+write = writeEnvironmentPredicate+++spec :: Spec+spec = do+  describe "writeEnvironmentPredicate" $ do+    specify "simple expressions" $ do+      write Always `shouldBe` "always"+      write (Not Always) `shouldBe` "never"+      write (OperatingSystem "linux") `shouldBe` "os = linux"+      write (Architecture "x86_64")+        `shouldBe` "arch = \"x86_64\""+      let Right fooBar = parseMonikerName "foo-bar"+      write (Moniker fooBar) `shouldBe` "moniker = \"foo-bar\""++    it "escape special characters in string literal" $ do+      write (OperatingSystem "\\'\"\b\f\n\r\t\v\0\x01\xff\xffff")+        `shouldBe` "os = \"\\\\'\\\"\\b\\f\\n\\r\\t\\v\\0\\x01\\xff\\uffff\""+      write (OperatingSystem "\\'\b\f\n\r\t\v\0\x01\xff\xffff")+        `shouldBe` "os = \"\\\\'\\b\\f\\n\\r\\t\\v\\0\\x01\\xff\\uffff\""++    specify "string literal is around by quotes if needed" $ do+      write (OperatingSystem "test") `shouldBe` "os = test"+      write (OperatingSystem "te st") `shouldBe` "os = \"te st\""+      write (OperatingSystem "") `shouldBe` "os = \"\""++    specify "string literal is around by single quotes if it has double quote"+      $ do+        write (OperatingSystem "\"test\"") `shouldBe` "os = '\"test\"'"+        write (OperatingSystem "\"test'") `shouldBe` "os = \"\\\"test'\""++    specify "homogenous predicates in Or are expressed using in operator" $ do+      write (Or [OperatingSystem "linux", OperatingSystem "macos"])+        `shouldBe` "os in (linux, macos)"+      write (Or [Architecture "x86_64", Architecture "aarch64"])+        `shouldBe` "arch in (\"x86_64\", aarch64)"+      let Right foo = parseMonikerName "foo"+      let Right bar = parseMonikerName "bar"+      write (Or [Moniker foo, Moniker bar]) `shouldBe` "moniker in (foo, bar)"++    specify+      ( "homogenous negative predicates in And are expressed using "+          ++ "not in operator"+      )+      $ do+        write+          (And [Not $ OperatingSystem "linux", Not $ OperatingSystem "macos"])+          `shouldBe` "os not in (linux, macos)"+        write (And [Not $ Architecture "x86_64", Not $ Architecture "aarch64"])+          `shouldBe` "arch not in (\"x86_64\", aarch64)"+        let Right foo = parseMonikerName "foo"+        let Right bar = parseMonikerName "bar"+        write (And [Not $ Moniker foo, Not $ Moniker bar])+          `shouldBe` "moniker not in (foo, bar)"++    it "properly wrap sub-expressions with parentheses" $ do+      let Right foo = parseMonikerName "foo"+      let Right bar = parseMonikerName "bar"+      write+        ( And+            [ Or [OperatingSystem "linux", Architecture "aarch64"]+            , Or [Moniker foo, Moniker bar]+            ]+        )+        `shouldBe` "(os = linux || arch = aarch64) && moniker in (foo, bar)"++    specify "yields what parseEnvironmentPredicate can parse" $ hedgehog $ do+      predicate <- normalizePredicate <$> forAll Gen.environmentPredicate+      let predText = write predicate+      annotateShow predText+      let parseResult = parseEnvironmentPredicate "test" predText+      case parseResult of+        Left err -> footnote $ unpack $ errorBundlePretty err+        Right _ -> return ()+      let Right pred' = parseResult+      pred' === predicate
+ test/Dojang/Syntax/FilePathExpression/ParserSpec.hs view
@@ -0,0 +1,304 @@+{-# LANGUAGE OverloadedStrings #-}++module Dojang.Syntax.FilePathExpression.ParserSpec (spec) where++import Control.Monad (forM_)+import Prelude hiding (unlines)++import Data.Text (unlines)+import Test.Hspec (Spec, specify)+import Test.Hspec.Expectations.Pretty (shouldBe)+import Test.Hspec.Megaparsec+  ( eeof+  , elabel+  , err+  , etok+  , etoks+  , shouldFailWith+  , shouldParse+  , ueof+  , utok+  , utoks+  )+import Text.Megaparsec (eof, parse)++import Dojang.Syntax.FilePathExpression.Parser+  ( bareComponent+  , environmentVariable+  , errorBundlePretty+  , filePathExpression+  , filePathExpression'+  , parseFilePathExpression+  , root+  , substitution+  , substitutionConditional+  , substitutionDefault+  , substitutionInBraces+  , substitutionModifierAfterColon+  )+import Dojang.Types.FilePathExpression (FilePathExpression (..), (+/+))+++spec :: Spec+spec = do+  specify "environmentVariable" $ do+    let environmentVariable' = environmentVariable <* eof+    parse environmentVariable' "" "FOO_BAR" `shouldParse` "FOO_BAR"+    parse environmentVariable' "" "foo_bar" `shouldParse` "foo_bar"+    parse environmentVariable "" "_BAR_123" `shouldParse` "_BAR_123"+    parse environmentVariable "" "123_FOO"+      `shouldFailWith` err 0 (utok '1' <> elabel "environment variable")+    parse environmentVariable "" "-FOO"+      `shouldFailWith` err 0 (utok '-' <> elabel "environment variable")+    parse environmentVariable' "" "FOO-BAR"+      `shouldFailWith` err 3 (utok '-' <> eeof)+    parse environmentVariable "" "甲_乙"+      `shouldFailWith` err 0 (utok '甲' <> elabel "environment variable")+    parse environmentVariable' "" "FOO_乙"+      `shouldFailWith` err 4 (utok '乙' <> eeof)+    parse environmentVariable "" ""+      `shouldFailWith` err 0 (ueof <> elabel "environment variable")++  specify "bareComponent" $ do+    let bareComponent' = bareComponent "" <* eof+    parse bareComponent' "" "foo" `shouldParse` BareComponent "foo"+    parse bareComponent' "" "123" `shouldParse` BareComponent "123"+    parse bareComponent' "" "甲" `shouldParse` BareComponent "甲"+    parse bareComponent' "" "123-foo-乙"+      `shouldParse` BareComponent "123-foo-乙"+    parse (bareComponent "") "" "/foo"+      `shouldFailWith` err+        0+        (utok '/' <> elabel "component")+    parse bareComponent' "" "foo/"+      `shouldFailWith` err+        3+        (utok '/' <> elabel "component" <> eeof)+    parse bareComponent' "" ""+      `shouldFailWith` err+        0+        (ueof <> elabel "component")++  specify "root" $ do+    let root' = root <* eof+    parse root' "" "/" `shouldParse` Root Nothing+    parse root' "" "C:\\" `shouldParse` Root (Just 'C')+    parse root' "" "C:/" `shouldParse` Root (Just 'C')+    parse root "" ""+      `shouldFailWith` err 0 (ueof <> etok '/' <> elabel "drive letter")+    parse root "" "C" `shouldFailWith` err 1 (ueof <> etok ':')++  specify "substitution" $ do+    let substitution' = substitution <* eof+    parse substitution' "" "$FOO" `shouldParse` Substitution "FOO"+    parse substitution' "" "$FOO_BAR" `shouldParse` Substitution "FOO_BAR"+    parse substitution "" ""+      `shouldFailWith` err 0 (ueof <> etok '$')+    parse substitution "" "FOO"+      `shouldFailWith` err 0 (utok 'F' <> etok '$')+    parse substitution' "" "$FOO-"+      `shouldFailWith` err 4 (utok '-' <> eeof)++  trueFalse $ \begin -> specify ("substitutionDefault " ++ show begin) $ do+    let substitutionDefault' env = substitutionDefault begin env <* eof+    parse (substitutionDefault' "FOO") "" "-bar"+      `shouldParse` SubstitutionWithDefault "FOO" (BareComponent "bar")+    parse (substitutionDefault' "FOO") "" "-bar${BAZ}qux"+      `shouldParse` SubstitutionWithDefault+        "FOO"+        ( Concatenation+            (Concatenation (BareComponent "bar") (Substitution "BAZ"))+            $ BareComponent "qux"+        )+    parse (substitutionDefault begin "FOO") "" ""+      `shouldFailWith` err 0 (ueof <> etok '-')+    parse (substitutionDefault begin "FOO") "" "+bar"+      `shouldFailWith` err 0 (utok '+' <> etok '-')+    parse (substitutionDefault' "FOO") "" "-$BAR}"+      `shouldFailWith` err+        5+        ( utok '}'+            <> etoks "${"+            <> etok '$'+            <> elabel "component"+            <> eeof+        )+    parse (substitutionDefault' "FOO") "" "-${BAR}}"+      `shouldFailWith` err+        7+        ( utok '}'+            <> etoks "${"+            <> etok '$'+            <> elabel "component"+            <> eeof+        )++  trueFalse $ \begin -> specify ("substitutionConditional " ++ show begin) $ do+    let substitutionConditional' env = substitutionConditional begin env <* eof+    parse (substitutionConditional' "FOO") "" "+bar"+      `shouldParse` ConditionalSubstitution "FOO" (BareComponent "bar")+    parse (substitutionConditional' "FOO") "" "+bar${BAZ}qux"+      `shouldParse` ConditionalSubstitution+        "FOO"+        ( Concatenation+            (Concatenation (BareComponent "bar") (Substitution "BAZ"))+            $ BareComponent "qux"+        )+    parse (substitutionConditional begin "FOO") "" ""+      `shouldFailWith` err 0 (ueof <> etok '+')+    parse (substitutionConditional begin "FOO") "" "-bar"+      `shouldFailWith` err 0 (utok '-' <> etok '+')+    parse (substitutionConditional' "FOO") "" "+$BAR}"+      `shouldFailWith` err+        5+        ( utok '}'+            <> etoks "${"+            <> etok '$'+            <> elabel "component"+            <> eeof+        )+    parse (substitutionConditional' "FOO") "" "+${BAR}}"+      `shouldFailWith` err+        7+        ( utok '}'+            <> etoks "${"+            <> etok '$'+            <> elabel "component"+            <> eeof+        )++  trueFalse $ \begin -> specify+    ("substitutionModifierAfterColon" ++ show begin)+    $ do+      let substitutionModifierAfterColon' env =+            substitutionModifierAfterColon begin env <* eof+      parse (substitutionModifierAfterColon' "FOO") "" "-bar"+        `shouldParse` SubstitutionWithDefault "FOO" (BareComponent "bar")+      parse (substitutionModifierAfterColon' "FOO") "" "+bar"+        `shouldParse` ConditionalSubstitution "FOO" (BareComponent "bar")+      parse (substitutionModifierAfterColon begin "FOO") "" "!bar"+        `shouldFailWith` err 0 (utok '!' <> etok '+' <> etok '-')++  trueFalse $ \begin -> specify ("substitutionInBraces" ++ show begin) $ do+    let substitutionInBraces' = substitutionInBraces begin <* eof+    parse substitutionInBraces' "" "${FOO}"+      `shouldParse` Substitution "FOO"+    parse substitutionInBraces' "" "${FOO:-bar}"+      `shouldParse` SubstitutionWithDefault "FOO" (BareComponent "bar")+    parse substitutionInBraces' "" "${FOO:+bar}"+      `shouldParse` ConditionalSubstitution "FOO" (BareComponent "bar")+    parse (substitutionInBraces begin) "" ""+      `shouldFailWith` err 0 (ueof <> etoks "${")+    parse (substitutionInBraces begin) "" "${FOO-bar}"+      `shouldFailWith` err 5 (utok '-' <> etok ':' <> etok '}')++  specify "filePathExpression' False" $ do+    let filePathExpr' disallowed = filePathExpression' False disallowed <* eof+    parse (filePathExpr' []) "" "foo}"+      `shouldParse` BareComponent "foo}"+    parse (filePathExpr' "}") "" "foo}"+      `shouldFailWith` err+        3+        ( utok '}'+            <> etoks "${"+            <> etok '$'+            <> elabel "component"+            <> eeof+        )+    parse (filePathExpr' []) "" "/foo"+      `shouldFailWith` err+        0+        (utoks "/f" <> etoks "${" <> etok '$' <> elabel "component")+    parse (filePathExpr' []) "" "C:\\foo"+      `shouldParse` PathSeparator+        (BareComponent "C:")+        (BareComponent "foo")+    parse (filePathExpr' []) "" "D:/bar"+      `shouldParse` PathSeparator+        (BareComponent "D:")+        (BareComponent "bar")++  specify "filePathExpression' True" $ do+    let filePathExpr' = filePathExpression' True [] <* eof+    parse filePathExpr' "" "/foo"+      `shouldParse` PathSeparator (Root Nothing) (BareComponent "foo")+    parse filePathExpr' "" "C:\\foo"+      `shouldParse` PathSeparator (Root $ Just 'C') (BareComponent "foo")+    parse filePathExpr' "" "D:/bar"+      `shouldParse` PathSeparator (Root $ Just 'D') (BareComponent "bar")++  specify "filePathExpression" $ do+    let filePathExpr = filePathExpression <* eof+    parse filePathExpr "" "/" `shouldParse` Root (Nothing)+    parse filePathExpr "" "A" `shouldParse` BareComponent "A"+    parse filePathExpr "" "A/" `shouldParse` BareComponent "A"+    parse filePathExpr "" "A:\\" `shouldParse` Root (Just 'A')+    parse filePathExpr "" "A:/" `shouldParse` Root (Just 'A')+    parse filePathExpr "" "foo" `shouldParse` BareComponent "foo"+    parse filePathExpr "" "foo/" `shouldParse` BareComponent "foo"+    parse filePathExpr "" "foo/bar"+      `shouldParse` PathSeparator (BareComponent "foo") (BareComponent "bar")+    parse filePathExpr "" "foo/bar/"+      `shouldParse` PathSeparator (BareComponent "foo") (BareComponent "bar")+    parse filePathExpr "" "foo/bar/baz"+      `shouldParse` PathSeparator+        (PathSeparator (BareComponent "foo") (BareComponent "bar"))+        (BareComponent "baz")+    parse filePathExpr "" "foo${BAR}baz/qux"+      `shouldParse` PathSeparator+        ( Concatenation+            (Concatenation (BareComponent "foo") (Substitution "BAR"))+            $ BareComponent "baz"+        )+        (BareComponent "qux")+    parse filePathExpr "" "foo/bar${BAZ}qux"+      `shouldParse` PathSeparator+        (BareComponent "foo")+        ( Concatenation+            (Concatenation (BareComponent "bar") (Substitution "BAZ"))+            $ BareComponent "qux"+        )+    parse filePathExpr "" "foo/${BAR:-bar}/${BAZ:+baz}"+      `shouldParse` PathSeparator+        ( PathSeparator+            (BareComponent "foo")+            (SubstitutionWithDefault "BAR" (BareComponent "bar"))+        )+        (ConditionalSubstitution "BAZ" (BareComponent "baz"))+    parse filePathExpr "" "/$FOO/bar"+      `shouldParse` PathSeparator+        (PathSeparator (Root Nothing) (Substitution "FOO"))+        (BareComponent "bar")+    parse filePathExpr "" "C:\\D:\\bar"+      `shouldParse` PathSeparator+        (PathSeparator (Root $ Just 'C') (BareComponent "D:"))+        (BareComponent "bar")+    parse filePathExpr "" "${FOO:-C:\\bar}"+      `shouldParse` SubstitutionWithDefault+        "FOO"+        (PathSeparator (Root $ Just 'C') (BareComponent "bar"))++  specify "parseFilePathExpression" $ do+    parseFilePathExpression "" "foo"+      `shouldBe` Right (BareComponent "foo")+    parseFilePathExpression "" "/foo/$BAR"+      `shouldBe` Right (Root Nothing +/+ "foo" +/+ Substitution "BAR")+    parseFilePathExpression "" "C:\\foo\\$BAR"+      `shouldBe` Right (Root (Just 'C') +/+ "foo" +/+ Substitution "BAR")++  specify "errorBundlePretty" $ do+    let Left errorBundle = parseFilePathExpression "" "/foo/${BAR/baz"+    -- FIXME: The error message is not very helpful in this case.+    errorBundlePretty errorBundle+      `shouldBe` unlines+        [ "1:6:"+        , "  |"+        , "1 | /foo/${BAR/baz"+        , "  |      ^"+        , "unexpected '$'"+        , "expecting end of input"+        ]+++trueFalse :: (Monad m) => (Bool -> m a) -> m ()+trueFalse = forM_ [False, True]
+ test/Dojang/Syntax/Manifest/WriterSpec.hs view
@@ -0,0 +1,20 @@+module Dojang.Syntax.Manifest.WriterSpec (spec) where++import Data.Text (unpack)+import Test.Hspec (Spec, specify)+import Test.Hspec.Hedgehog (annotate, annotateShow, forAll, hedgehog, (===))++import Dojang.Syntax.Manifest.Parser (readManifest)+import Dojang.Syntax.Manifest.Writer (writeManifest)+import Dojang.Types.Gen as Gen (manifest)+++spec :: Spec+spec = do+  specify "writeManifest" $ hedgehog $ do+    manifest' <- forAll Gen.manifest+    let toml = writeManifest manifest'+    annotate $ unpack toml+    let Right (parsed, _) = readManifest toml+    annotateShow parsed+    parsed === manifest'
+ test/Dojang/TestUtils.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE LambdaCase #-}++module Dojang.TestUtils (Entry (..), Tree, makeFixtureTree, withTempDir) where++import Control.Monad (forM_, unless, void)++import System.IO.Temp (withSystemTempDirectory)+import System.OsPath (OsPath, encodeFS, (</>))++import Data.ByteString (ByteString)+import Dojang.MonadFileSystem (MonadFileSystem (..))+++withTempDir :: (OsPath -> FilePath -> IO a) -> IO a+withTempDir action = do+  withSystemTempDirectory "dojang-spec-" $ \tmpDir -> do+    tmpDir' <- encodeFS tmpDir+    action tmpDir' tmpDir+++data Entry = F ByteString | D Tree+++type Tree = [(OsPath, Entry)]+++makeFixtureTree+  :: (MonadFileSystem m) => OsPath -> Tree -> m ()+makeFixtureTree path tree = do+  pathExists <- exists path+  unless pathExists $ void $ createDirectories path+  forM_ tree $ \case+    (p, F bytes) -> Dojang.MonadFileSystem.writeFile (path </> p) bytes+    (p, D tree') -> makeFixtureTree (path </> p) tree'
+ test/Dojang/Types/ContextSpec.hs view
@@ -0,0 +1,834 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++module Dojang.Types.ContextSpec (spec) where++import Data.List (isInfixOf, sort, sortOn)+import System.IO.Error+  ( ioeGetErrorString+  , ioeGetErrorType+  , ioeGetFileName+  , ioeGetLocation+  )+import Prelude hiding (readFile, writeFile)++import Data.ByteString qualified (length)+import Data.Map.Strict (Map, fromList)+import System.FilePath (combine)+import System.OsPath (OsPath, encodeFS, (</>))+import Test.Hspec (Spec, describe, it, runIO, specify)+import Test.Hspec.Expectations.Pretty (shouldBe, shouldReturn, shouldThrow)++import Dojang.MonadFileSystem (MonadFileSystem (..))+import Dojang.MonadFileSystem qualified (FileType (..))+import Dojang.Syntax.Manifest.Writer (writeManifestFile)+import Dojang.TestUtils (Entry (..), makeFixtureTree, withTempDir)+import Dojang.Types.Context+  ( Context (..)+  , FileCorrespondence (..)+  , FileDeltaKind (..)+  , FileEntry (..)+  , FileStat (..)+  , RouteState (..)+  , getRouteState+  , listFiles+  , makeCorrespond+  , makeCorrespondBetweenThreeDirs+  , makeCorrespondBetweenThreeFiles+  , makeCorrespondBetweenTwoDirs+  , makeCorrespondWithDestination+  , routePaths+  )+import Dojang.Types.Environment+  ( Architecture (..)+  , Environment (..)+  , Kernel (..)+  , OperatingSystem (..)+  )+import Dojang.Types.EnvironmentPredicate.Evaluate (EvaluationWarning (..))+import Dojang.Types.FilePathExpression (FilePathExpression (..), (+/+))+import Dojang.Types.FileRouteSpec (monikerMap)+import Dojang.Types.Manifest (manifest)+import Dojang.Types.MonikerName (MonikerName, parseMonikerName)+import Dojang.Types.Repository+  ( Repository (..)+  , RouteMapWarning (..)+  , RouteResult (..)+  )+import GHC.IO.Exception (IOErrorType (InappropriateType))+++spec :: Spec+spec = do+  src <- runIO $ encodeFS "src"+  inter <- runIO $ encodeFS "inter"+  dst <- runIO $ encodeFS "dst"+  foo <- runIO $ encodeFS "foo"+  bar <- runIO $ encodeFS "bar"+  baz <- runIO $ encodeFS "baz"+  qux <- runIO $ encodeFS "qux"+  -- cSpell:ignore quux corge+  quux <- runIO $ encodeFS "quux"+  corge <- runIO $ encodeFS "corge"+  intermediateDir <- runIO $ encodeFS ".dojang"+  manifestFilename' <- runIO $ encodeFS "dojang.toml"++  let Right posix = parseMonikerName "posix"+  let Right undefined' = parseMonikerName "undefined"+  let Right windows = parseMonikerName "windows"++  let fileRoutes =+        [+          ( baz+          ,+            [+              ( undefined'+              , Just $ Root Nothing +/+ BareComponent "__dojang_test_baz__"+              )+            , (windows, Just $ Substitution "BAZ")+            ]+          )+        ]+          :: Map OsPath [(MonikerName, Maybe FilePathExpression)]+  let dirRoutes =+        [ (foo, [(posix, Just $ Substitution "FOO"), (windows, Nothing)])+        ,+          ( bar+          ,+            [ (posix, Just $ Substitution "BAR")+            , (windows, Just $ Root $ Just 'B')+            ]+          )+        ]+          :: Map OsPath [(MonikerName, Maybe FilePathExpression)]++  let manifest' =+        Dojang.Types.Manifest.manifest+          monikerMap+          fileRoutes+          dirRoutes+          [(foo, ["ignore-*"])]++  let repositoryFixture repoPath = do+        -- The tree of the repository fixture looks like this:+        -- .+        -- ├── bar/+        -- │   └── foo+        -- ├── baz+        -- ├── dojang.toml+        -- └── foo/+        --     ├── bar/+        --     │   └── foo+        --     ├── baz/+        --     └── foo+        -- Total 4 directories and 5 files+        writeManifestFile manifest' $ repoPath </> manifestFilename'+        createDirectory $ repoPath </> foo+        writeFile (repoPath </> foo </> foo) "asdf"+        createDirectory $ repoPath </> foo </> bar+        writeFile (repoPath </> foo </> bar </> foo) "asdf asdf"+        createDirectory $ repoPath </> foo </> baz+        createDirectory $ repoPath </> bar+        writeFile (repoPath </> bar </> foo) "foobar"+        writeFile (repoPath </> baz) "foo bar baz"+        let repo =+              Repository+                repoPath+                (repoPath </> intermediateDir)+                manifest'+        return repo++  let withContextFixture action = withTempDir $ \tmpDir _ -> do+        createDirectory $ tmpDir </> src+        createDirectory $ tmpDir </> foo+        repo <- repositoryFixture $ tmpDir </> src+        let ctx = Context+              repo+              (Environment Linux X86_64 $ Kernel "Linux" "5.10.0-8")+              $ \e ->+                return $ case e of+                  "FOO" -> Just $ tmpDir </> foo+                  "BAR" -> Just $ tmpDir </> bar+                  "BAZ" -> Just $ tmpDir </> baz+                  _ -> Nothing+        action ctx tmpDir++  specify "routePaths" $ withContextFixture $ \ctx tmpDir -> do+    (results, ws) <- routePaths ctx+    ws `shouldBe` [EnvironmentPredicateWarning $ UndefinedMoniker undefined']+    sortOn (.sourcePath) results+      `shouldBe` [ RouteResult+                    { sourcePath = tmpDir </> src </> bar+                    , routeName = bar+                    , destinationPath = tmpDir </> bar+                    , fileType = Dojang.MonadFileSystem.Directory+                    }+                 , RouteResult+                    { sourcePath = tmpDir </> src </> foo+                    , routeName = foo+                    , destinationPath = tmpDir </> foo+                    , fileType = Dojang.MonadFileSystem.Directory+                    }+                 ]+  specify "makeCorrespondWithDestination"+    $ withContextFixture+    $ \ctx tmpDir -> do+      (correspond, ws) <-+        makeCorrespondWithDestination ctx (tmpDir </> bar </> foo)+      ws `shouldBe` [EnvironmentPredicateWarning $ UndefinedMoniker undefined']+      correspond+        `shouldBe` Just+          ( FileCorrespondence+              { source =+                  FileEntry+                    (tmpDir </> src </> bar </> foo)+                    (File 6)+              , sourceDelta = Added+              , intermediate =+                  FileEntry+                    (tmpDir </> src </> intermediateDir </> bar </> foo)+                    Missing+              , destination = FileEntry (tmpDir </> bar </> foo) Missing+              , destinationDelta = Unchanged+              }+          )+      let ctx' = ctx{environment = ctx.environment{operatingSystem = Windows}}+      (correspond', ws') <-+        makeCorrespondWithDestination ctx' (tmpDir </> baz)+      ws' `shouldBe` [EnvironmentPredicateWarning $ UndefinedMoniker undefined']+      correspond'+        `shouldBe` Just+          ( FileCorrespondence+              { source = FileEntry (tmpDir </> src </> baz) (File 11)+              , sourceDelta = Added+              , intermediate =+                  FileEntry (tmpDir </> src </> intermediateDir </> baz) Missing+              , destination = FileEntry (tmpDir </> baz) Missing+              , destinationDelta = Unchanged+              }+          )+      (correspond'', ws'') <-+        makeCorrespondWithDestination ctx (tmpDir </> corge)+      correspond'' `shouldBe` Nothing+      ws'' `shouldBe` ws++  specify "makeCorrespond" $ withContextFixture $ \ctx tmpDir -> do+    (corresponds, ws) <- makeCorrespond ctx+    ws `shouldBe` [EnvironmentPredicateWarning $ UndefinedMoniker undefined']+    sortOn (.source.path) corresponds+      `shouldBe` [ FileCorrespondence+                    { source =+                        FileEntry+                          (tmpDir </> src </> bar </> foo)+                          (File 6)+                    , sourceDelta = Added+                    , intermediate =+                        FileEntry+                          (tmpDir </> src </> intermediateDir </> bar </> foo)+                          Missing+                    , destination = FileEntry (tmpDir </> bar </> foo) Missing+                    , destinationDelta = Unchanged+                    }+                 , FileCorrespondence+                    { source =+                        FileEntry+                          (tmpDir </> src </> foo </> bar)+                          Directory+                    , sourceDelta = Added+                    , intermediate =+                        FileEntry+                          (tmpDir </> src </> intermediateDir </> foo </> bar)+                          Missing+                    , destination = FileEntry (tmpDir </> foo </> bar) Missing+                    , destinationDelta = Unchanged+                    }+                 , FileCorrespondence+                    { source =+                        FileEntry+                          (tmpDir </> src </> foo </> bar </> foo)+                          (File 9)+                    , sourceDelta = Added+                    , intermediate =+                        FileEntry+                          ( tmpDir+                              </> src+                              </> intermediateDir+                              </> foo+                              </> bar+                              </> foo+                          )+                          Missing+                    , destination =+                        FileEntry (tmpDir </> foo </> bar </> foo) Missing+                    , destinationDelta = Unchanged+                    }+                 , FileCorrespondence+                    { source =+                        FileEntry (tmpDir </> src </> foo </> baz) Directory+                    , sourceDelta = Added+                    , intermediate =+                        FileEntry+                          (tmpDir </> src </> intermediateDir </> foo </> baz)+                          Missing+                    , destination = FileEntry (tmpDir </> foo </> baz) Missing+                    , destinationDelta = Unchanged+                    }+                 , FileCorrespondence+                    { source =+                        FileEntry (tmpDir </> src </> foo </> foo) (File 4)+                    , sourceDelta = Added+                    , intermediate =+                        FileEntry+                          (tmpDir </> src </> intermediateDir </> foo </> foo)+                          Missing+                    , destination = FileEntry (tmpDir </> foo </> foo) Missing+                    , destinationDelta = Unchanged+                    }+                 ]++  describe "listFiles" $ do+    it "lists files recursively" $ withTempDir $ \tmpDir _ -> do+      _ <- repositoryFixture tmpDir+      files <- listFiles tmpDir []+      manifestData <- readFile $ tmpDir </> manifestFilename'+      let manifestSize = toEnum $ Data.ByteString.length manifestData+      sort files+        `shouldBe` [ FileEntry bar Directory+                   , FileEntry (bar </> foo) $ File 6+                   , FileEntry baz $ File 11+                   , FileEntry manifestFilename' $ File manifestSize+                   , FileEntry foo Directory+                   , FileEntry (foo </> bar) Directory+                   , FileEntry (foo </> bar </> foo) $ File 9+                   , FileEntry (foo </> baz) Directory+                   , FileEntry (foo </> foo) $ File 4+                   ]++    it "filters out files by ignorePatterns" $ withTempDir $ \tmpDir _ -> do+      _ <- repositoryFixture tmpDir+      files <- listFiles tmpDir ["foo/b*"]+      manifestData <- readFile $ tmpDir </> manifestFilename'+      let manifestSize = toEnum $ Data.ByteString.length manifestData+      sort files+        `shouldBe` [ FileEntry bar Directory+                   , FileEntry (bar </> foo) $ File 6+                   , FileEntry baz $ File 11+                   , FileEntry manifestFilename' $ File manifestSize+                   , FileEntry foo Directory+                   , FileEntry (foo </> foo) $ File 4+                   ]++    it "only accepts a directory path" $ withTempDir $ \tmpDir tmpDir' -> do+      () <- writeFile (tmpDir </> foo) "foo"+      listFiles (tmpDir </> foo) [] `shouldThrow` \e ->+        (ioeGetErrorType e == InappropriateType)+          && (ioeGetLocation e == "listFiles")+          && (ioeGetFileName e == Just (tmpDir' `combine` "foo"))+          && ("not a directory" `isInfixOf` show e)++  specify "makeCorrespondBetweenThreeFiles" $ withTempDir $ \tmpDir _ -> do+    let makeCorrespond_ =+          makeCorrespondBetweenThreeFiles+            (tmpDir </> inter)+            (tmpDir </> src)+            (tmpDir </> dst)++    writeFile (tmpDir </> inter) "unchanged"+    writeFile (tmpDir </> src) "unchanged"+    writeFile (tmpDir </> dst) "unchanged"+    makeCorrespond_+      `shouldReturn` FileCorrespondence+        { source = FileEntry (tmpDir </> src) $ File 9+        , sourceDelta = Unchanged+        , intermediate = FileEntry (tmpDir </> inter) $ File 9+        , destination = FileEntry (tmpDir </> dst) $ File 9+        , destinationDelta = Unchanged+        }++    writeFile (tmpDir </> src) "modified!"+    writeFile (tmpDir </> dst) "modified"+    makeCorrespond_+      `shouldReturn` FileCorrespondence+        { source = FileEntry (tmpDir </> src) $ File 9+        , sourceDelta = Modified+        , intermediate = FileEntry (tmpDir </> inter) $ File 9+        , destination = FileEntry (tmpDir </> dst) $ File 8+        , destinationDelta = Modified+        }++    removeFile (tmpDir </> inter)+    writeFile (tmpDir </> src) "added"+    writeFile (tmpDir </> dst) "added"+    makeCorrespond_+      `shouldReturn` FileCorrespondence+        { source = FileEntry (tmpDir </> src) $ File 5+        , sourceDelta = Added+        , intermediate = FileEntry (tmpDir </> inter) Missing+        , destination = FileEntry (tmpDir </> dst) $ File 5+        , destinationDelta = Added+        }++    writeFile (tmpDir </> inter) "removed"+    removeFile (tmpDir </> src)+    removeFile (tmpDir </> dst)+    makeCorrespond_+      `shouldReturn` FileCorrespondence+        { source = FileEntry (tmpDir </> src) Missing+        , sourceDelta = Removed+        , intermediate = FileEntry (tmpDir </> inter) $ File 7+        , destination = FileEntry (tmpDir </> dst) Missing+        , destinationDelta = Removed+        }++    writeFile (tmpDir </> inter) "dir is disallowed"+    createDirectory (tmpDir </> src)+    filename <- decodePath $ tmpDir </> src+    makeCorrespond_ `shouldThrow` \e ->+      ( ioeGetErrorString e+          == "makeCorrespondBetweenThreeFiles: "+          ++ "expected a file, but got a directory"+      )+        && (ioeGetFileName e == Just filename)++  specify "makeCorrespondBetweenThreeDirs" $ withTempDir $ \tmpDir _ -> do+    () <-+      makeFixtureTree+        (tmpDir </> foo)+        [ (inter, D [])+        , (src, D [])+        , (dst, D [])+        ]+    emptyCorresponds <-+      makeCorrespondBetweenThreeDirs+        (tmpDir </> foo </> inter)+        (tmpDir </> foo </> src)+        (tmpDir </> foo </> dst)+        []+    sortOn (.source.path) emptyCorresponds `shouldBe` []++    unchanged <- encodePath "unchanged"+    added <- encodePath "added"+    removed <- encodePath "removed"+    modified <- encodePath "modified"+    ignored <- encodePath "ignored"+    () <-+      makeFixtureTree+        (tmpDir </> bar)+        [+          ( inter+          , D+              [ (unchanged, D [(foo, F "foo-unchanged")])+              , (added, D [])+              ,+                ( removed+                , D+                    [ (foo, F "foo-src-removed")+                    , (bar, F "bar-dst-removed")+                    , (baz, F "baz-both-removed")+                    , (qux, D [])+                    ]+                )+              ,+                ( modified+                , D+                    [ (foo, F "foo")+                    , (bar, F "bar")+                    , (baz, F "baz")+                    , (qux, F "qux-file-to-dir")+                    , (quux, D [])+                    , (corge, F "same-size-but-different-content")+                    ]+                )+              ,+                ( ignored+                , D+                    [ (foo, F "foo-ignored-but-tracked")+                    , (baz, F "baz-ignored-but-indexed")+                    ]+                )+              ]+          )+        ,+          ( src+          , D+              [ (unchanged, D [(foo, F "foo-unchanged")])+              ,+                ( added+                , D+                    [ (foo, F "foo-src-added")+                    , (baz, F "baz-both-added")+                    , (qux, D [])+                    ]+                )+              , (removed, D [(bar, F "bar-dst-removed")])+              ,+                ( modified+                , D+                    [ (foo, F "foo-src-modified")+                    , (bar, F "bar")+                    , (baz, F "baz-src-modified")+                    , (qux, D [])+                    , (quux, F "qux-dir-to-file")+                    , (corge, F "same-length-but--different-body")+                    ]+                )+              ,+                ( ignored+                , D+                    [ (foo, F "foo-ignored-but-tracked")+                    , (bar, F "bar-ignored-but-added")+                    ]+                )+              ]+          )+        ,+          ( dst+          , D+              [ (unchanged, D [(foo, F "foo-unchanged")])+              ,+                ( added+                , D+                    [ (bar, F "bar-dst-added")+                    , (baz, F "baz-both-added")+                    , (qux, D [])+                    ]+                )+              , (removed, D [(foo, F "foo-src-removed")])+              ,+                ( modified+                , D+                    [ (foo, F "foo")+                    , (bar, F "bar-dst-modified")+                    , (baz, F "baz-dst-modified")+                    , (qux, F "qux-file-to-dir")+                    , (quux, D [])+                    , (corge, F "equivalent-length-but-different")+                    ]+                )+              ,+                ( ignored+                , D+                    [ (foo, F "foo-ignored-but-tracked")+                    , (bar, F "bar-ignored-but-added")+                    , (baz, F "baz-ignored-but-indexed")+                    ]+                )+              ]+          )+        ]+    corresponds <-+      makeCorrespondBetweenThreeDirs+        (tmpDir </> bar </> inter)+        (tmpDir </> bar </> src)+        (tmpDir </> bar </> dst)+        ["ignored"]+    sortOn (.source.path) corresponds+      `shouldBe` [ FileCorrespondence+                    { source = FileEntry added Directory+                    , sourceDelta = Unchanged+                    , intermediate = FileEntry added Directory+                    , destination = FileEntry added Directory+                    , destinationDelta = Unchanged+                    }+                 , FileCorrespondence+                    { source = FileEntry (added </> bar) Missing+                    , sourceDelta = Unchanged+                    , intermediate = FileEntry (added </> bar) Missing+                    , destination = FileEntry (added </> bar) (File 13)+                    , destinationDelta = Added+                    }+                 , FileCorrespondence+                    { source = FileEntry (added </> baz) (File 14)+                    , sourceDelta = Added+                    , intermediate = FileEntry (added </> baz) Missing+                    , destination = FileEntry (added </> baz) (File 14)+                    , destinationDelta = Added+                    }+                 , FileCorrespondence+                    { source = FileEntry (added </> foo) (File 13)+                    , sourceDelta = Added+                    , intermediate = FileEntry (added </> foo) Missing+                    , destination = FileEntry (added </> foo) Missing+                    , destinationDelta = Unchanged+                    }+                 , FileCorrespondence+                    { source = FileEntry (added </> qux) Directory+                    , sourceDelta = Added+                    , intermediate = FileEntry (added </> qux) Missing+                    , destination = FileEntry (added </> qux) Directory+                    , destinationDelta = Added+                    }+                 , FileCorrespondence+                    { source = FileEntry ignored Directory+                    , sourceDelta = Unchanged+                    , intermediate = FileEntry ignored Directory+                    , destination = FileEntry ignored Directory+                    , destinationDelta = Unchanged+                    }+                 , FileCorrespondence+                    { source = FileEntry (ignored </> bar) (File 21)+                    , sourceDelta = Added+                    , intermediate = FileEntry (ignored </> bar) Missing+                    , destination = FileEntry (ignored </> bar) (File 21)+                    , destinationDelta = Added+                    }+                 , FileCorrespondence+                    { source = FileEntry (ignored </> baz) Missing+                    , sourceDelta = Removed+                    , intermediate = FileEntry (ignored </> baz) (File 23)+                    , destination = FileEntry (ignored </> baz) (File 23)+                    , destinationDelta = Unchanged+                    }+                 , FileCorrespondence+                    { source = FileEntry (ignored </> foo) (File 23)+                    , sourceDelta = Unchanged+                    , intermediate = FileEntry (ignored </> foo) (File 23)+                    , destination = FileEntry (ignored </> foo) (File 23)+                    , destinationDelta = Unchanged+                    }+                 , FileCorrespondence+                    { source = FileEntry modified Directory+                    , sourceDelta = Unchanged+                    , intermediate = FileEntry modified Directory+                    , destination = FileEntry modified Directory+                    , destinationDelta = Unchanged+                    }+                 , FileCorrespondence+                    { source = FileEntry (modified </> bar) (File 3)+                    , sourceDelta = Unchanged+                    , intermediate = FileEntry (modified </> bar) (File 3)+                    , destination = FileEntry (modified </> bar) (File 16)+                    , destinationDelta = Modified+                    }+                 , FileCorrespondence+                    { source = FileEntry (modified </> baz) (File 16)+                    , sourceDelta = Modified+                    , intermediate = FileEntry (modified </> baz) (File 3)+                    , destination = FileEntry (modified </> baz) (File 16)+                    , destinationDelta = Modified+                    }+                 , FileCorrespondence+                    { source = FileEntry (modified </> corge) (File 31)+                    , sourceDelta = Modified+                    , intermediate = FileEntry (modified </> corge) (File 31)+                    , destination = FileEntry (modified </> corge) (File 31)+                    , destinationDelta = Modified+                    }+                 , FileCorrespondence+                    { source = FileEntry (modified </> foo) (File 16)+                    , sourceDelta = Modified+                    , intermediate = FileEntry (modified </> foo) (File 3)+                    , destination = FileEntry (modified </> foo) (File 3)+                    , destinationDelta = Unchanged+                    }+                 , FileCorrespondence+                    { source = FileEntry (modified </> quux) (File 15)+                    , sourceDelta = Modified+                    , intermediate = FileEntry (modified </> quux) Directory+                    , destination = FileEntry (modified </> quux) Directory+                    , destinationDelta = Unchanged+                    }+                 , FileCorrespondence+                    { source = FileEntry (modified </> qux) Directory+                    , sourceDelta = Modified+                    , intermediate = FileEntry (modified </> qux) (File 15)+                    , destination = FileEntry (modified </> qux) (File 15)+                    , destinationDelta = Unchanged+                    }+                 , FileCorrespondence+                    { source = FileEntry removed Directory+                    , sourceDelta = Unchanged+                    , intermediate = FileEntry removed Directory+                    , destination = FileEntry removed Directory+                    , destinationDelta = Unchanged+                    }+                 , FileCorrespondence+                    { source = FileEntry (removed </> bar) (File 15)+                    , sourceDelta = Unchanged+                    , intermediate = FileEntry (removed </> bar) (File 15)+                    , destination = FileEntry (removed </> bar) Missing+                    , destinationDelta = Removed+                    }+                 , FileCorrespondence+                    { source = FileEntry (removed </> baz) Missing+                    , sourceDelta = Removed+                    , intermediate = FileEntry (removed </> baz) (File 16)+                    , destination = FileEntry (removed </> baz) Missing+                    , destinationDelta = Removed+                    }+                 , FileCorrespondence+                    { source = FileEntry (removed </> foo) Missing+                    , sourceDelta = Removed+                    , intermediate = FileEntry (removed </> foo) (File 15)+                    , destination = FileEntry (removed </> foo) (File 15)+                    , destinationDelta = Unchanged+                    }+                 , FileCorrespondence+                    { source = FileEntry (removed </> qux) Missing+                    , sourceDelta = Removed+                    , intermediate = FileEntry (removed </> qux) Directory+                    , destination = FileEntry (removed </> qux) Missing+                    , destinationDelta = Removed+                    }+                 , FileCorrespondence+                    { source = FileEntry unchanged Directory+                    , sourceDelta = Unchanged+                    , intermediate = FileEntry unchanged Directory+                    , destination = FileEntry unchanged Directory+                    , destinationDelta = Unchanged+                    }+                 , FileCorrespondence+                    { source = FileEntry (unchanged </> foo) (File 13)+                    , sourceDelta = Unchanged+                    , intermediate = FileEntry (unchanged </> foo) (File 13)+                    , destination = FileEntry (unchanged </> foo) (File 13)+                    , destinationDelta = Unchanged+                    }+                 ]++  specify "makeCorrespondBetweenTwoDirs" $ withTempDir $ \tmpDir _ -> do+    () <-+      makeFixtureTree+        (tmpDir </> foo)+        [ (foo, F "foo")+        ,+          ( bar+          , D+              [ (foo, F "bar/foo")+              , (bar, F "bar/bar")+              , (baz, D [])+              ]+          )+        , (baz, F "baz")+        ,+          ( qux+          , D+              [ (foo, F "qux/foo")+              , (quux, F "qux/quux")+              ]+          )+        ]+    () <-+      makeFixtureTree+        (tmpDir </> bar)+        [ (foo, F "foo 2")+        ,+          ( bar+          , D+              [ (foo, F "bar/foo")+              , (baz, D [(bar, F "bar/baz/bar")])+              ]+          )+        , (baz, F "baz")+        ,+          ( qux+          , D+              [ (foo, F "qux/foo")+              , (quux, F "qux/quux 2")+              ]+          )+        ]+    makeCorrespondBetweenTwoDirs (tmpDir </> foo) (tmpDir </> bar) []+      `shouldReturn` fromList+        [ (foo, (FileEntry foo $ File 3, FileEntry foo $ File 5))+        , (bar, (FileEntry bar Directory, FileEntry bar Directory))+        ,+          ( bar </> foo+          , (FileEntry (bar </> foo) $ File 7, FileEntry (bar </> foo) $ File 7)+          )+        ,+          ( bar </> bar+          , (FileEntry (bar </> bar) $ File 7, FileEntry (bar </> bar) Missing)+          )+        ,+          ( bar </> baz+          ,+            ( FileEntry (bar </> baz) Directory+            , FileEntry (bar </> baz) Directory+            )+          )+        ,+          ( bar </> baz </> bar+          ,+            ( FileEntry (bar </> baz </> bar) Missing+            , FileEntry (bar </> baz </> bar) $ File 11+            )+          )+        , (baz, (FileEntry baz $ File 3, FileEntry baz $ File 3))+        ,+          ( qux+          , (FileEntry qux Directory, FileEntry qux Directory)+          )+        ,+          ( qux </> foo+          , (FileEntry (qux </> foo) $ File 7, FileEntry (qux </> foo) $ File 7)+          )+        ,+          ( qux </> quux+          ,+            ( FileEntry (qux </> quux) $ File 8+            , FileEntry (qux </> quux) $ File 10+            )+          )+        ]+    makeCorrespondBetweenTwoDirs+      (tmpDir </> baz) -- This dir does not exist+      (tmpDir </> bar)+      []+      `shouldReturn` fromList+        [ (foo, (FileEntry foo Missing, FileEntry foo $ File 5))+        , (bar, (FileEntry bar Missing, FileEntry bar Directory))+        ,+          ( bar </> foo+          ,+            ( FileEntry (bar </> foo) Missing+            , FileEntry (bar </> foo) $ File 7+            )+          )+        ,+          ( bar </> baz+          ,+            ( FileEntry (bar </> baz) Missing+            , FileEntry (bar </> baz) Directory+            )+          )+        ,+          ( bar </> baz </> bar+          ,+            ( FileEntry (bar </> baz </> bar) Missing+            , FileEntry (bar </> baz </> bar) $ File 11+            )+          )+        , (baz, (FileEntry baz Missing, FileEntry baz $ File 3))+        , (qux, (FileEntry qux Missing, FileEntry qux Directory))+        ,+          ( qux </> foo+          , (FileEntry (qux </> foo) Missing, FileEntry (qux </> foo) $ File 7)+          )+        ,+          ( qux </> quux+          ,+            ( FileEntry (qux </> quux) Missing+            , FileEntry (qux </> quux) $ File 10+            )+          )+        ]++  specify "getRouteState" $ withContextFixture $ \ctx tmpDir -> do+    (state, ws) <- getRouteState ctx (tmpDir </> src)+    ws `shouldBe` [EnvironmentPredicateWarning $ UndefinedMoniker undefined']+    state `shouldBe` NotRouted+    (state', ws') <- getRouteState ctx (tmpDir </> foo </> foo)+    ws' `shouldBe` ws+    state' `shouldBe` Routed foo+    ignoreMe <- encodePath "ignore-me"+    (state'', ws'') <- getRouteState ctx (tmpDir </> foo </> ignoreMe)+    ws'' `shouldBe` ws+    state'' `shouldBe` Ignored foo "ignore-*"+    let ctx' = ctx{environment = ctx.environment{operatingSystem = FreeBSD}}+    (stateOnNullRouting, ws''') <- getRouteState ctx' (tmpDir </> src)+    ws''' `shouldBe` ws+    stateOnNullRouting `shouldBe` NotRouted
+ test/Dojang/Types/Environment/CurrentSpec.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++module Dojang.Types.Environment.CurrentSpec (spec) where++import Dojang.Types.Environment+  ( Architecture (..)+  , Environment (..)+  , Kernel (..)+  , OperatingSystem (..)+  )+import Dojang.Types.Environment.Current+  ( currentArchitecture+  , currentEnvironment+  , currentKernel+  , currentOperatingSystem+  , parseArchitecture+  , parseOperatingSystem+  )++import Data.CaseInsensitive (original)+import Data.String (IsString (fromString))+import Data.Text (Text)+import System.Info (arch, os)+import Test.Hspec (Spec, specify)+import Test.Hspec.Expectations.Pretty (shouldBe, shouldSatisfy)+import Text.Regex.TDFA ((=~))+++spec :: Spec+spec = do+  specify "currentOperatingSystem" $ do+    os' <- currentOperatingSystem+    os' `shouldBe` expectedOS++  specify "currentArchitecture" $ do+    arch' <- currentArchitecture+    arch' `shouldBe` expectedArch++  specify "currentKernel" $ do+    kernel <- currentKernel+    expectKernel kernel++  specify "currentEnvironment" $ do+    env <- currentEnvironment+    env.operatingSystem `shouldBe` expectedOS+    env.architecture `shouldBe` expectedArch+    expectKernel env.kernel++  specify "parseOperatingSystem" $ do+    parseOperatingSystem "linux-android" `shouldBe` Android+    parseOperatingSystem "darwin" `shouldBe` MacOS+    parseOperatingSystem "freebsd" `shouldBe` FreeBSD+    parseOperatingSystem "linux" `shouldBe` Linux+    parseOperatingSystem "netbsd" `shouldBe` NetBSD+    parseOperatingSystem "openbsd" `shouldBe` OpenBSD+    parseOperatingSystem "mingw32" `shouldBe` Windows+    parseOperatingSystem "other-os" `shouldBe` OtherOS "other-os"++  specify "parseArchitecture" $ do+    parseArchitecture "aarch64" `shouldBe` AArch64+    parseArchitecture "i386" `shouldBe` X86+    parseArchitecture "x86_64" `shouldBe` X86_64+    parseArchitecture "other-arch" `shouldBe` Etc "other-arch"+++expectedOS :: OperatingSystem+expectedOS = case os of+  "darwin" -> MacOS+  "linux" -> Linux+  "mingw32" -> Windows+  "freebsd" -> FreeBSD+  os' -> OtherOS $ fromString os'+++expectedArch :: Architecture+expectedArch = case arch of+  "aarch64" -> AArch64+  "x86_64" -> X86_64+  arch' -> Etc $ fromString arch'+++expectKernel :: Kernel -> IO ()+expectKernel = case os of+  "darwin" -> expectMacOSKernel+  "linux" -> expectLinuxKernel+  "mingw32" -> expectWindowsKernel+  _ -> \_ -> return ()+++expectMacOSKernel :: Kernel -> IO ()+expectMacOSKernel kernel = do+  original kernel.name `shouldBe` "Darwin"+  original kernel.release+    `shouldSatisfy` (=~ ("^[0-9]+\\.[0-9]+\\.[0-9]+$" :: Text))+++expectLinuxKernel :: Kernel -> IO ()+expectLinuxKernel kernel = do+  original kernel.name `shouldBe` "Linux"+  original kernel.release+    `shouldSatisfy` (=~ ("^[0-9]+\\.[0-9]+\\.?[0-9]+[.-][0-9]+(-|$)" :: Text))+++expectWindowsKernel :: Kernel -> IO ()+expectWindowsKernel kernel = do+  original kernel.name `shouldBe` "Microsoft Windows"+  original kernel.release+    `shouldSatisfy` (=~ ("^[0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+$" :: Text))
+ test/Dojang/Types/EnvironmentPredicate/EvaluateSpec.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}++module Dojang.Types.EnvironmentPredicate.EvaluateSpec (spec) where++import Data.HashMap.Strict (HashMap)+import Test.Hspec (Spec, describe, specify)+import Test.Hspec.Expectations.Pretty (shouldBe)+import Test.Hspec.Hedgehog (forAll, hedgehog, (/==), (===))++import Dojang.Gen qualified as Gen+import Dojang.Types.Environment+  ( Architecture (..)+  , Environment (Environment)+  , Kernel (..)+  , OperatingSystem (..)+  )+import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (..))+import Dojang.Types.EnvironmentPredicate.Evaluate+  ( EvaluationWarning (..)+  , evaluate+  )+import Dojang.Types.MonikerName (MonikerName, parseMonikerName)+++spec :: Spec+spec = do+  describe "EvaluationWarning" $ do+    specify "Eq" $ hedgehog $ do+      warning <- forAll Gen.evaluationWarning+      warning' <- forAll Gen.evaluationWarning+      (warning == warning') /== (warning /= warning')++    specify "Show" $ hedgehog $ do+      warning <- forAll Gen.evaluationWarning+      warning' <- forAll Gen.evaluationWarning+      showList [warning, warning'] ""+        === ("[" ++ show warning ++ "," ++ show warning' ++ "]")++  describe "evaluate" $ do+    let (Right linuxAmd64) = parseMonikerName "linux-amd64"+    let (Right linuxArm64) = parseMonikerName "linux-arm64"+    let (Right macosArm64) = parseMonikerName "macos-arm64"+    let (Right linuxAmd64') = parseMonikerName "linux-amd64-alias"+    let (Right nonExistentMoniker) = parseMonikerName "non-existent"+    let monikerMap =+          [ (linuxAmd64, And [OperatingSystem Linux, Architecture X86_64])+          , (linuxArm64, And [OperatingSystem Linux, Architecture AArch64])+          , (macosArm64, And [OperatingSystem MacOS, Architecture AArch64])+          , (linuxAmd64', Moniker linuxAmd64)+          ]+            :: HashMap MonikerName EnvironmentPredicate+    let kernel = Kernel "Linux" "5.10.0-8"+    let environment = Environment Linux X86_64 kernel+    let eval = evaluate environment monikerMap++    specify "Always"+      $ eval Always+      `shouldBe` (True, [])++    specify "OperatingSystem" $ do+      eval (OperatingSystem Linux) `shouldBe` (True, [])+      eval (OperatingSystem MacOS) `shouldBe` (False, [])+      eval (OperatingSystem $ OtherOS "other")+        `shouldBe` ( False+                   , [UnrecognizedOperatingSystem $ OtherOS "other"]+                   )++    specify "Architecture" $ do+      eval (Architecture X86_64) `shouldBe` (True, [])+      eval (Architecture AArch64) `shouldBe` (False, [])+      eval (Architecture $ Etc "etc")+        `shouldBe` ( False+                   , [UnrecognizedArchitecture $ Etc "etc"]+                   )++    specify "Moniker" $ do+      eval (Moniker linuxAmd64) `shouldBe` (True, [])+      eval (Moniker linuxAmd64') `shouldBe` (True, [])+      eval (Moniker linuxArm64) `shouldBe` (False, [])+      eval (Moniker macosArm64) `shouldBe` (False, [])+      eval (Moniker nonExistentMoniker)+        `shouldBe` (False, [UndefinedMoniker nonExistentMoniker])++    specify "Not" $ do+      eval (Not $ OperatingSystem Linux) `shouldBe` (False, [])+      eval (Not $ Architecture X86_64) `shouldBe` (False, [])+      eval (Not $ Moniker linuxAmd64) `shouldBe` (False, [])+      eval (Not $ Moniker linuxArm64) `shouldBe` (True, [])+      eval (Not $ Moniker linuxAmd64') `shouldBe` (False, [])++    specify "And" $ do+      eval (And [OperatingSystem Linux]) `shouldBe` (True, [])+      eval (And [Architecture X86_64]) `shouldBe` (True, [])+      eval (And [OperatingSystem Linux, Architecture X86_64])+        `shouldBe` (True, [])+      eval+        (And [OperatingSystem Linux, Architecture X86_64, Moniker linuxAmd64])+        `shouldBe` (True, [])+      eval+        (And [OperatingSystem Linux, Architecture AArch64, Moniker linuxArm64])+        `shouldBe` (False, [])+      eval+        ( And+            [ OperatingSystem Linux+            , Architecture X86_64+            , Moniker nonExistentMoniker+            ]+        )+        `shouldBe` (False, [UndefinedMoniker nonExistentMoniker])+      eval+        (And [OperatingSystem Linux, Architecture AArch64])+        `shouldBe` (False, [])+      eval+        (And [OperatingSystem MacOS, Architecture X86_64])+        `shouldBe` (False, [])+      eval+        (And [OperatingSystem MacOS, Architecture AArch64])+        `shouldBe` (False, [])++    specify "Or"+      $ do+        eval (Or [OperatingSystem Linux]) `shouldBe` (True, [])+        eval (Or [Architecture X86_64]) `shouldBe` (True, [])+        eval+          (Or [OperatingSystem Linux, Architecture X86_64])+          `shouldBe` (True, [])+        eval+          (Or [OperatingSystem Linux, Architecture X86_64, Moniker linuxAmd64])+          `shouldBe` (True, [])+        eval+          (Or [OperatingSystem Linux, Architecture AArch64, Moniker linuxArm64])+          `shouldBe` (True, [])+        eval+          ( Or+              [ OperatingSystem Linux+              , Architecture X86_64+              , Moniker nonExistentMoniker+              ]+          )+          `shouldBe` (True, [UndefinedMoniker nonExistentMoniker])
+ test/Dojang/Types/EnvironmentPredicate/SpecificitySpec.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++module Dojang.Types.EnvironmentPredicate.SpecificitySpec (spec) where++import Test.Hspec (Spec, describe, specify)+import Test.Hspec.Expectations.Pretty (shouldBe)+import Test.Hspec.Hedgehog (forAll, hedgehog, (/==), (===))++import Dojang.Types.Environment+  ( Architecture (X86_64)+  , OperatingSystem (Linux)+  )+import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (..))+import Dojang.Types.EnvironmentPredicate.Specificity+  ( Specificity (..)+  , specificity+  )+import Dojang.Types.Gen qualified as Gen+import Dojang.Types.MonikerName (parseMonikerName)+++spec :: Spec+spec = do+  describe "Specificity" $ do+    specify "Eq" $ hedgehog $ do+      specificityA <- forAll Gen.specificity+      specificityB <- forAll Gen.specificity+      (specificityA == specificityB) /== (specificityA /= specificityB)++    describe "Ord" $ do+      specify "examples" $ do+        max (Specificity 0 0) (Specificity 1 0) `shouldBe` Specificity 1 0+        max (Specificity 0 0) (Specificity 0 1) `shouldBe` Specificity 0 0+        min (Specificity 1 0) (Specificity 1 1) `shouldBe` Specificity 1 1++      specify "properties" $ hedgehog $ do+        specificityA <- forAll Gen.specificity+        specificityB <- forAll Gen.specificity+        (specificityA `compare` specificityB)+          === (specificityA.maxPredicates, specificityB.totalPredicates)+          `compare` (specificityB.maxPredicates, specificityA.totalPredicates)+        (specificityA < specificityB) /== (specificityA >= specificityB)+        (specificityA <= specificityB) /== (specificityA > specificityB)+        (specificityA > specificityB) /== (specificityA <= specificityB)+        (specificityA >= specificityB) /== (specificityA < specificityB)++    specify "Read, Show" $ hedgehog $ do+      specificityA <- forAll Gen.specificity+      specificityB <- forAll Gen.specificity+      showList [specificityA, specificityB] ""+        === ("[" ++ show specificityA ++ "," ++ show specificityB ++ "]")+      read (show specificityA) === specificityA+      read (showList [specificityA, specificityB] "")+        === ([specificityA, specificityB] :: [Specificity])++  specify "specificity" $ do+    specificity undefined (Always) `shouldBe` Specificity 0 0+    specificity undefined (OperatingSystem Linux) `shouldBe` Specificity 1 1+    specificity undefined (Architecture X86_64) `shouldBe` Specificity 1 1+    specificity undefined (Not Always) `shouldBe` Specificity 0 0+    specificity undefined (Not (Architecture X86_64)) `shouldBe` Specificity 1 1+    specificity undefined (And [Always, Architecture X86_64])+      `shouldBe` Specificity 1 1+    specificity undefined (And [OperatingSystem Linux, Architecture X86_64])+      `shouldBe` Specificity 2 2+    specificity undefined (Or [Always, Architecture X86_64])+      `shouldBe` Specificity 1 1+    specificity undefined (Or [OperatingSystem Linux, Architecture X86_64])+      `shouldBe` Specificity 1 2+    let Right foo = parseMonikerName "foo"+        Right bar = parseMonikerName "bar"+        Right baz = parseMonikerName "baz"+        Right nonExistent = parseMonikerName "non-existent"+        lookup' m+          | m == foo = Just (OperatingSystem Linux)+          | m == bar = Just (And [OperatingSystem Linux, Architecture X86_64])+          | m == baz = Just (Moniker foo)+          | otherwise = Nothing+    specificity lookup' (Moniker foo) `shouldBe` Specificity 1 1+    specificity lookup' (Moniker nonExistent) `shouldBe` Specificity 0 0+    specificity lookup' (Not $ Moniker foo) `shouldBe` Specificity 1 1+    specificity lookup' (And [Moniker foo, Moniker bar])+      `shouldBe` Specificity 3 3+    specificity lookup' (Or [Moniker foo, Moniker bar])+      `shouldBe` Specificity 2 3+    specificity lookup' (And [Moniker baz, Moniker bar])+      `shouldBe` Specificity 3 3
+ test/Dojang/Types/EnvironmentPredicateSpec.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}++module Dojang.Types.EnvironmentPredicateSpec (spec) where++import Data.Hashable (Hashable (hash, hashWithSalt))+import Test.Hspec (Spec, describe, it, specify)+import Test.Hspec.Expectations.Pretty (shouldBe)+import Test.Hspec.Hedgehog (forAll, hedgehog, (/==), (===))++import Dojang.Types.EnvironmentPredicate+  ( EnvironmentPredicate (..)+  , normalizePredicate+  )+import Dojang.Types.Gen qualified as Gen+import Dojang.Types.MonikerName (parseMonikerName)+++spec :: Spec+spec = do+  describe "EnvironmentPredicate" $ do+    specify "Eq" $ hedgehog $ do+      predicate <- forAll Gen.environmentPredicate+      predicate' <- forAll Gen.environmentPredicate+      (predicate == predicate') /== (predicate /= predicate')+      And [predicate, predicate'] === And [predicate', predicate]+      Or [predicate, predicate'] === Or [predicate', predicate]++    specify "Hashable" $ hedgehog $ do+      predicate <- forAll Gen.environmentPredicate+      predicate' <- forAll Gen.environmentPredicate+      (hash predicate == hash predicate') === (predicate == predicate')+      (hashWithSalt 0 predicate == hashWithSalt 0 predicate')+        === (predicate == predicate')++    specify "Show" $ hedgehog $ do+      predicate <- forAll Gen.environmentPredicate+      predicate' <- forAll Gen.environmentPredicate+      showList [predicate, predicate'] ""+        === ("[" ++ show predicate ++ "," ++ show predicate' ++ "]")++  describe "normalizePredicate" $ do+    it "reduces an unary And/Or to its child" $ do+      normalizePredicate (And [Always]) `shouldBe` Always+      normalizePredicate (Or [Always]) `shouldBe` Always++    it "reduces an And predicate into Not Always if it has any Not Always" $ do+      normalizePredicate (And [Not Always]) `shouldBe` Not Always+      normalizePredicate (And [Always, Not Always]) `shouldBe` Not Always+      normalizePredicate (And [Not Always, OperatingSystem "linux"])+        `shouldBe` Not Always+      normalizePredicate (And [OperatingSystem "linux", Architecture "x86_64"])+        `shouldBe` And [OperatingSystem "linux", Architecture "x86_64"]++    it "reduces an Or predicate into Always if it has any Always" $ do+      normalizePredicate (Or [Always]) `shouldBe` Always+      normalizePredicate (Or [Always, Not Always]) `shouldBe` Always+      normalizePredicate (Or [Always, OperatingSystem "linux"])+        `shouldBe` Always+      normalizePredicate (Or [OperatingSystem "linux", OperatingSystem "macos"])+        `shouldBe` Or [OperatingSystem "linux", OperatingSystem "macos"]++    it "removes all Always predicates in an And predicate" $ do+      normalizePredicate (And [Always, Always, OperatingSystem "linux"])+        `shouldBe` OperatingSystem "linux"+      normalizePredicate+        (And [Always, Always, OperatingSystem "linux", Architecture "x86_64"])+        `shouldBe` And [OperatingSystem "linux", Architecture "x86_64"]+      normalizePredicate (And [Always, Always]) `shouldBe` Always++    it "removes all Not Always predicates in an Or predicate" $ do+      normalizePredicate (Or [Not Always, Not Always, OperatingSystem "linux"])+        `shouldBe` OperatingSystem "linux"+      normalizePredicate+        ( Or+            [ Not Always+            , Not Always+            , OperatingSystem "linux"+            , OperatingSystem "macos"+            ]+        )+        `shouldBe` Or [OperatingSystem "linux", OperatingSystem "macos"]+      normalizePredicate (Or [Not Always, Not Always]) `shouldBe` Not Always++    it+      ( "reduces an And predicate into Not Always if it has two contradicting "+          ++ "predicates"+      )+      $ do+        normalizePredicate+          (And [OperatingSystem "linux", Not $ OperatingSystem "linux"])+          `shouldBe` Not Always+        normalizePredicate (And [OperatingSystem "linux", Architecture "x86_64"])+          `shouldBe` And [OperatingSystem "linux", Architecture "x86_64"]++    it+      ( "reduces an Or predicate into Always if it has two contradicting "+          ++ "predicates"+      )+      $ do+        normalizePredicate+          (Or [OperatingSystem "linux", Not $ OperatingSystem "linux"])+          `shouldBe` Always+        normalizePredicate+          (Or [OperatingSystem "linux", OperatingSystem "macos"])+          `shouldBe` Or [OperatingSystem "linux", OperatingSystem "macos"]++    let Right foo = parseMonikerName "foo"++    it "flattens nested Ands" $ do+      normalizePredicate+        ( And+            [ OperatingSystem "linux"+            , And [Architecture "x86_64", Moniker foo]+            ]+        )+        `shouldBe` And+          [ OperatingSystem "linux"+          , Architecture "x86_64"+          , Moniker foo+          ]++    it "flattens nested Ors" $ do+      normalizePredicate+        ( Or+            [ OperatingSystem "linux"+            , Or [OperatingSystem "macos", Moniker foo]+            ]+        )+        `shouldBe` Or+          [ OperatingSystem "linux"+          , OperatingSystem "macos"+          , Moniker foo+          ]++    it "reduces double negation" $ do+      normalizePredicate (Not $ Not Always) `shouldBe` Always+      normalizePredicate (Not $ Not $ Not Always) `shouldBe` Not Always+      normalizePredicate (Not $ Not $ OperatingSystem "linux")+        `shouldBe` OperatingSystem "linux"++    it "is idempotent" $ hedgehog $ do+      predicate <- forAll Gen.environmentPredicate+      normalizePredicate (normalizePredicate predicate)+        === normalizePredicate predicate
+ test/Dojang/Types/EnvironmentSpec.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# HLINT ignore "Use min" #-}+{-# HLINT ignore "Use max" #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++module Dojang.Types.EnvironmentSpec (spec) where++import Dojang.Types.Environment+  ( Architecture (..)+  , OperatingSystem (..)+  )+import Dojang.Types.Gen qualified as Gen++import Data.CaseInsensitive (original)+import Data.Hashable (Hashable (hash, hashWithSalt))+import Data.String (IsString (fromString))+import Data.Text (unpack)+import Hedgehog.Gen (unicodeAll)+import Hedgehog.Range (constantFrom)+import Test.Hspec (Spec, describe, specify)+import Test.Hspec.Expectations.Pretty (shouldBe)+import Test.Hspec.Hedgehog (forAll, hedgehog, (/==), (===))+++spec :: Spec+spec = do+  describe "OperatingSystem" $ do+    specify "HasField \"identifier\"" $ do+      (Linux).identifier `shouldBe` "linux"+      (OtherOS "other-os").identifier `shouldBe` "other-os"++    specify "IsString" $ do+      fromString "linux" `shouldBe` Linux+      fromString "other-os" `shouldBe` OtherOS "other-os"++    specify "HasField \"identifier\", IsString" $ hedgehog $ do+      os' <- forAll Gen.operatingSystem+      fromString (unpack $ original os'.identifier) === os'++    specify "Eq" $ hedgehog $ do+      os <- forAll Gen.operatingSystem+      os' <- forAll Gen.operatingSystem+      (os == os') /== (os /= os')++    specify "Ord" $ do+      hedgehog $ do+        os <- forAll Gen.operatingSystem+        os' <- forAll Gen.operatingSystem+        (os <= os') /== (os > os')+        (os < os') /== (os >= os')+        (os <= os) === True+        (os >= os) === True+      hedgehog $ do+        a <- forAll $ Gen.ciText (constantFrom 0 0 256) unicodeAll+        b <- forAll $ Gen.ciText (constantFrom 0 0 256) unicodeAll+        compare (OtherOS a) (OtherOS b) === compare a b+        min (OtherOS a) (OtherOS b) === OtherOS (min a b)+        max (OtherOS a) (OtherOS b) === OtherOS (max a b)++    specify "Read, Show" $ hedgehog $ do+      os <- forAll Gen.operatingSystem+      read (show os) === os+      read (showList [os] "") === [os]++    specify "Hashable" $ hedgehog $ do+      os <- forAll Gen.operatingSystem+      os' <- forAll Gen.operatingSystem+      (hashWithSalt 0 os == hashWithSalt 0 os') === (os == os')++  describe "Architecture" $ do+    specify "HasField \"identifier\"" $ do+      (X86_64).identifier `shouldBe` "x86_64"+      (Etc "etc").identifier `shouldBe` "etc"++    specify "IsString" $ do+      fromString "x86_64" `shouldBe` X86_64+      fromString "etc" `shouldBe` Etc "etc"++    specify "HasField \"identifier\", IsString" $ hedgehog $ do+      arch <- forAll Gen.architecture+      fromString (unpack $ original arch.identifier) === arch++    specify "Eq" $ hedgehog $ do+      arch <- forAll Gen.architecture+      arch' <- forAll Gen.architecture+      (arch == arch') /== (arch /= arch')++    specify "Ord" $ do+      hedgehog $ do+        arch <- forAll Gen.architecture+        arch' <- forAll Gen.architecture+        (arch <= arch') /== (arch > arch')+        (arch < arch') /== (arch >= arch')+        (arch <= arch) === True+        (arch >= arch) === True+      hedgehog $ do+        a <- forAll $ Gen.ciText (constantFrom 0 0 256) unicodeAll+        b <- forAll $ Gen.ciText (constantFrom 0 0 256) unicodeAll+        compare (Etc a) (Etc b) === compare a b+        min (Etc a) (Etc b) === Etc (min a b)+        max (Etc a) (Etc b) === Etc (max a b)++    specify "Read, Show" $ hedgehog $ do+      arch <- forAll Gen.architecture+      read (show arch) === arch+      read (showList [arch] "") === [arch]++    specify "Hashable" $ hedgehog $ do+      arch <- forAll Gen.architecture+      arch' <- forAll Gen.architecture+      (hashWithSalt 0 arch == hashWithSalt 0 arch') === (arch == arch')++  describe "Kernel" $ do+    specify "Eq" $ hedgehog $ do+      kernel <- forAll Gen.kernel+      kernel' <- forAll Gen.kernel+      (kernel == kernel') /== (kernel /= kernel')++    specify "Ord" $ hedgehog $ do+      kernel <- forAll Gen.kernel+      kernel' <- forAll Gen.kernel+      (kernel <= kernel') /== (kernel > kernel')+      (kernel < kernel') /== (kernel >= kernel')+      (kernel <= kernel) === True+      (kernel >= kernel) === True+      min kernel kernel' === if kernel <= kernel' then kernel else kernel'+      max kernel kernel' === if kernel >= kernel' then kernel else kernel'++    specify "Read, Show" $ hedgehog $ do+      kernel <- forAll Gen.kernel+      read (show kernel) === kernel+      read (showList [kernel] "") === [kernel]++    specify "Hashable" $ hedgehog $ do+      kernel <- forAll Gen.kernel+      kernel' <- forAll Gen.kernel+      (hashWithSalt 0 kernel == hashWithSalt 0 kernel') === (kernel == kernel')++  describe "Environment" $ do+    specify "Eq" $ hedgehog $ do+      env <- forAll Gen.environment+      env' <- forAll Gen.environment+      (env == env') /== (env /= env')++    specify "Ord" $ hedgehog $ do+      env <- forAll Gen.environment+      env' <- forAll Gen.environment+      (env <= env') /== (env > env')+      (env < env') /== (env >= env')+      (env <= env) === True+      (env >= env) === True+      min env env' === if env <= env' then env else env'+      max env env' === if env >= env' then env else env'++    specify "Read, Show" $ hedgehog $ do+      env <- forAll Gen.environment+      read (show env) === env+      read (showList [env] "") === [env]++    specify "Hashable" $ hedgehog $ do+      env <- forAll Gen.environment+      env' <- forAll Gen.environment+      (hash env == hash env') === (env == env')+      (hashWithSalt 0 env == hashWithSalt 0 env') === (env == env')
+ test/Dojang/Types/FilePathExpression/ExpansionSpec.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Dojang.Types.FilePathExpression.ExpansionSpec (spec) where++import Dojang.Types.FilePathExpression (FilePathExpression (..), (++), (+/+))+import Dojang.Types.FilePathExpression.Expansion+  ( ExpansionWarning (..)+  , expandFilePath+  )++import Data.Text (Text, unpack)+import GHC.IO.Unsafe (unsafePerformIO)+import System.OsPath (pathSeparator, (</>))+import System.OsString (OsString, encodeUtf, pack)+import Test.Hspec (Spec, describe, specify)+import Test.Hspec.Expectations.Pretty (shouldBe)++import Prelude hiding ((++))+++encode :: Text -> IO OsString+encode = encodeUtf . unpack+++os :: String -> OsString+os = unsafePerformIO . encodeUtf+++spec :: Spec+spec = do+  describe "expandFilePath" $ do+    specify "BareComponent" $ do+      expanded <- expandFilePath (BareComponent "foo") undefined encode+      expanded `shouldBe` (os "foo", [])++    specify "Root" $ do+      expanded <- expandFilePath (Root Nothing) undefined undefined+      expanded `shouldBe` (pack [pathSeparator], [])+      expanded' <- expandFilePath (Root $ Just 'C') undefined undefined+      expanded' `shouldBe` (os "C:" <> pack [pathSeparator], [])+      expandedAbs <-+        expandFilePath+          (Root Nothing +/+ BareComponent "foo" +/+ BareComponent "bar")+          undefined+          encode+      expandedAbs+        `shouldBe` (pack [pathSeparator] </> os "foo" </> os "bar", [])+      expandedAbs' <-+        expandFilePath+          (Root (Just 'C') +/+ BareComponent "foo" +/+ BareComponent "bar")+          undefined+          encode+      expandedAbs'+        `shouldBe` ( os "C:" <> pack [pathSeparator] </> os "foo" </> os "bar"+                   , []+                   )++    specify "Concatenation" $ do+      expanded <-+        expandFilePath+          (Substitution "FOO" ++ BareComponent "bar")+          (\e -> return $ if e == "FOO" then Just (os "baz") else Nothing)+          encode+      expanded `shouldBe` (os "baz" <> os "bar", [])+      expanded' <-+        expandFilePath+          (BareComponent "foo" ++ Substitution "BAR")+          (\e -> return $ if e == "BAR" then Just (os "qux") else Nothing)+          encode+      expanded' `shouldBe` (os "foo" <> os "qux", [])++    specify "PathSeparator" $ do+      expanded <-+        expandFilePath+          (Substitution "FOO" +/+ BareComponent "bar")+          (\e -> return $ if e == "FOO" then Just (os "baz") else Nothing)+          encode+      expanded `shouldBe` (os "baz" </> os "bar", [])+      expanded' <-+        expandFilePath+          (BareComponent "foo" +/+ Substitution "BAR")+          (\e -> return $ if e == "BAR" then Just (os "qux") else Nothing)+          encode+      expanded' `shouldBe` (os "foo" </> os "qux", [])++    specify "Substitution" $ do+      expanded <-+        expandFilePath+          (Substitution "FOO")+          (\e -> return $ if e == "FOO" then Just (os "bar") else Nothing)+          encode+      expanded `shouldBe` (os "bar", [])+      notFound <-+        expandFilePath+          (Substitution "FOO")+          (const $ return Nothing)+          encode+      notFound `shouldBe` (mempty, [UndefinedEnvironmentVariable "FOO"])++    specify "SubstitutionWithDefault" $ do+      expanded <-+        expandFilePath+          (SubstitutionWithDefault "FOO" (BareComponent "baz"))+          (\e -> return $ if e == "FOO" then Just (os "bar") else Nothing)+          encode+      expanded `shouldBe` (os "bar", [])+      empty <-+        expandFilePath+          (SubstitutionWithDefault "FOO" (Substitution "BAR"))+          (\e -> return $ Just $ if e == "FOO" then mempty else os "qux")+          encode+      empty `shouldBe` (os "qux", [])+      notFound <-+        expandFilePath+          (SubstitutionWithDefault "FOO" (BareComponent "bar"))+          (\e -> return $ if e == "FOO" then Nothing else Just $ os "qux")+          encode+      notFound `shouldBe` (os "bar", [])++    specify "ConditionalSubstitution" $ do+      expanded <-+        expandFilePath+          (ConditionalSubstitution "FOO" (BareComponent "baz"))+          (\e -> return $ if e == "FOO" then Just (os "bar") else Nothing)+          encode+      expanded `shouldBe` (os "baz", [])+      expanded' <-+        expandFilePath+          (ConditionalSubstitution "FOO" (Substitution "BAZ"))+          ( return . \case+              "FOO" -> Just (os "bar")+              "BAZ" -> Just (os "qux")+              _ -> Nothing+          )+          encode+      expanded' `shouldBe` (os "qux", [])+      empty <-+        expandFilePath+          (ConditionalSubstitution "FOO" (BareComponent "baz"))+          (const $ return $ Just mempty)+          encode+      empty `shouldBe` (mempty, [])+      notFound <-+        expandFilePath+          (ConditionalSubstitution "FOO" (BareComponent "baz"))+          (const $ return Nothing)+          encode+      notFound `shouldBe` (mempty, [])
+ test/Dojang/Types/FilePathExpressionSpec.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}++module Dojang.Types.FilePathExpressionSpec (spec) where++import Data.Hashable (hash)+import Data.Text (unpack)+import Test.Hspec (Spec, describe, it, specify)+import Test.Hspec.Expectations.Pretty (shouldBe)+import Test.Hspec.Hedgehog (annotateShow, footnote, forAll, hedgehog, (===))++import Dojang.Syntax.FilePathExpression.Parser+  ( errorBundlePretty+  , parseFilePathExpression+  )+import Dojang.Types.FilePathExpression (FilePathExpression (Root), toPathText)+import Dojang.Types.Gen qualified as Gen+++spec :: Spec+spec = do+  describe "FilePathExpression" $ do+    specify "Eq" $ hedgehog $ do+      x <- forAll Gen.filePathExpression+      y <- forAll Gen.filePathExpression+      (x == y) === (y == x)+      (x /= y) === (y /= x)++    specify "Hashable" $ hedgehog $ do+      x <- forAll Gen.filePathExpression+      y <- forAll Gen.filePathExpression+      (x == y) === (hash x == hash y)+      (x /= y) === (hash x /= hash y)++    specify "Show" $ hedgehog $ do+      x <- forAll Gen.filePathExpression+      y <- forAll Gen.filePathExpression+      showList [x, y] "" === ("[" ++ show x ++ "," ++ show y ++ "]")++  describe "toPathText" $ do+    it "ends with a slash for a single Root expression" $ do+      toPathText (Root Nothing) `shouldBe` "/"+      toPathText (Root $ Just 'C') `shouldBe` "C:/"++    it "yields what parseFilePathExpression can parse" $ hedgehog $ do+      expr <- forAll Gen.filePathExpression+      let exprText = toPathText expr+      annotateShow exprText+      let parseResult = parseFilePathExpression "test" exprText+      case parseResult of+        Left err -> footnote $ unpack $ errorBundlePretty err+        Right _ -> return ()+      let Right expr' = parseResult+      expr' === expr
+ test/Dojang/Types/FileRouteMap/EvaluateSpec.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}++module Dojang.Types.FileRouteMap.EvaluateSpec (spec) where++import Data.Map.Strict (Map)+import System.OsPath (OsPath, encodeFS)+import Test.Hspec (Spec, runIO, specify)+import Test.Hspec.Expectations.Pretty (shouldBe)++import Dojang.MonadFileSystem (FileType (..))+import Dojang.Types.Environment+  ( Architecture (..)+  , Environment (Environment)+  , Kernel (..)+  , OperatingSystem (..)+  )+import Dojang.Types.EnvironmentPredicate.Evaluate (EvaluationWarning (..))+import Dojang.Types.FilePathExpression (FilePathExpression (..))+import Dojang.Types.FileRoute (FileRoute, fileRoute)+import Dojang.Types.FileRouteMap.Evaluate+  ( evaluateRoutes+  , evaluateRoutesWithFileTypes+  )+import Dojang.Types.FileRouteSpec (monikerMap)+import Dojang.Types.MonikerName (parseMonikerName)+++spec :: Spec+spec = do+  foo <- runIO $ encodeFS "foo"+  bar <- runIO $ encodeFS "bar"+  baz <- runIO $ encodeFS "baz"++  let Right posix = parseMonikerName "posix"+  let Right undefined' = parseMonikerName "undefined"+  let Right windows = parseMonikerName "windows"++  let route = fileRoute monikerMap+  let routes =+        [+          ( foo+          , route+              [(posix, Just $ Substitution "FOO"), (windows, Nothing)]+              Directory+          )+        ,+          ( bar+          , route+              [ (posix, Just $ Substitution "BAR")+              , (windows, Just $ Root $ Just 'B')+              ]+              Directory+          )+        ,+          ( baz+          , route+              [ (undefined', Just $ BareComponent "baz")+              , (windows, Just $ Substitution "BAZ")+              ]+              File+          )+        ]+          :: Map OsPath FileRoute++  specify "evaluateRoutes" $ do+    evaluateRoutes [] (Environment Linux X86_64 $ Kernel "Linux" "5.10.0-8")+      `shouldBe` ([], [])+    evaluateRoutes+      routes+      ( Environment Windows X86_64+          $ Kernel "Microsoft Windows" "10.0.23585.1001"+      )+      `shouldBe` (+                   [ (bar, Root $ Just 'B')+                   , (baz, Substitution "BAZ")+                   ]+                 , [UndefinedMoniker undefined']+                 )+    evaluateRoutes+      routes+      (Environment Linux AArch64 $ Kernel "Linux" "6.5.9-300.fc35.aarch64")+      `shouldBe` (+                   [ (foo, Substitution "FOO")+                   , (bar, Substitution "BAR")+                   ]+                 , []+                 )++  specify "evaluateRoutesWithFileTypes" $ do+    let eval = evaluateRoutesWithFileTypes+    eval [] (Environment Linux X86_64 $ Kernel "Linux" "5.10.0-8")+      `shouldBe` ([], [])+    eval+      routes+      ( Environment Windows X86_64+          $ Kernel "Microsoft Windows" "10.0.23585.1001"+      )+      `shouldBe` (+                   [ (bar, (Root $ Just 'B', Directory))+                   , (baz, (Substitution "BAZ", File))+                   ]+                 , [UndefinedMoniker undefined']+                 )+    eval+      routes+      (Environment Linux AArch64 $ Kernel "Linux" "6.5.9-300.fc35.aarch64")+      `shouldBe` (+                   [ (foo, (Substitution "FOO", Directory))+                   , (bar, (Substitution "BAR", Directory))+                   ]+                 , []+                 )
+ test/Dojang/Types/FileRouteSpec.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++module Dojang.Types.FileRouteSpec (monikerMap, paths, spec) where++import Data.HashMap.Strict (HashMap, fromList)+import Data.Text (Text)+import System.OsPath (encodeFS)+import Test.Hspec (Spec, describe, specify)+import Test.Hspec.Expectations.Pretty (shouldBe, shouldNotBe, shouldReturn)+import Test.Hspec.Hedgehog (forAll, hedgehog, (===))++import Dojang.MonadFileSystem (FileType (..))+import Dojang.Types.Environment (Environment (Environment), Kernel (Kernel))+import Dojang.Types.EnvironmentPredicate+  ( EnvironmentPredicate (Moniker, OperatingSystem, Or)+  )+import Dojang.Types.EnvironmentPredicate.Evaluate (EvaluationWarning (..))+import Dojang.Types.FilePathExpression (FilePathExpression (Root, Substitution))+import Dojang.Types.FilePathExpression.Expansion (ExpansionWarning (..))+import Dojang.Types.FileRoute+  ( FileRoute (monikerResolver, predicates)+  , RouteWarning (..)+  , dispatch+  , fileRoute+  , fileRoute'+  , routePath+  )+import Dojang.Types.Gen qualified as Gen+import Dojang.Types.MonikerName (MonikerName, parseMonikerName)+++moniker :: Text -> MonikerName+moniker name = case parseMonikerName name of+  Right monikerName -> monikerName+  Left _ -> error "Invalid moniker name"+++monikerMap :: HashMap MonikerName EnvironmentPredicate+monikerMap =+  fromList+    [ (moniker "linux", OperatingSystem "linux")+    , (moniker "macos", OperatingSystem "macos")+    , (moniker "windows", OperatingSystem "windows")+    ,+      ( moniker "posix"+      , Or [Moniker $ moniker "linux", Moniker $ moniker "macos"]+      )+    ]+++paths :: [(MonikerName, Maybe FilePathExpression)]+paths =+  [ (moniker "posix", Just $ Substitution "HOME")+  ,+    ( moniker "windows"+    , Just $ Substitution "USERPROFILE" -- cSpell:disable-line+    )+  ]+++spec :: Spec+spec = do+  let route = fileRoute monikerMap paths Directory+  describe "FileRoute" $ do+    specify "monikerResolver" $ do+      route.monikerResolver (moniker "linux")+        `shouldBe` Just (OperatingSystem "linux")+      route.monikerResolver (moniker "non-existent") `shouldBe` Nothing++    describe "Eq" $ do+      specify "properties" $ hedgehog $ do+        x <- forAll Gen.fileRoute+        y <- forAll Gen.fileRoute+        (x == x) === True+        (x == y) === (y == x)+        (x /= y) === (y /= x)++      specify "examples" $ do+        route `shouldBe` route+        route+          `shouldBe` fileRoute+            monikerMap+            [ (moniker "posix", Just $ Substitution "HOME")+            ,+              ( moniker "windows"+              , Just $ Substitution "USERPROFILE" -- cSpell:disable-line+              )+            ]+            Directory+        route+          `shouldNotBe` fileRoute+            monikerMap+            [ (moniker "posix", Just $ Substitution "HOME")+            , (moniker "windows", Just $ Substitution "HOME")+            ]+            Directory+        route+          `shouldNotBe` fileRoute'+            (const Nothing)+            [ (Moniker $ moniker "posix", Just $ Substitution "HOME")+            ,+              ( Moniker $ moniker "windows"+              , Just $ Substitution "USERPROFILE" -- cSpell:disable-line+              )+            ]+            Directory++    specify "predicates" $ do+      route.predicates+        `shouldBe` ( [+                       ( Moniker $ moniker "windows"+                       , Just $ Substitution "USERPROFILE" -- cSpell:disable-line+                       )+                     , (Moniker $ moniker "posix", Just $ Substitution "HOME")+                     ]+                      :: [(EnvironmentPredicate, Maybe FilePathExpression)]+                   )++    specify "Show" $ do+      show route+        `shouldBe` ("FileRoute " ++ show (route.predicates) ++ " Directory")+      showList [route] ""+        `shouldBe` ("[FileRoute " ++ show (route.predicates) ++ " Directory]")++  specify "dispatch" $ do+    dispatch (Environment "linux" "x86_64" $ Kernel "Linux" "5.10.0-8") route+      `shouldBe` ([Just $ Substitution "HOME"], [])+    dispatch (Environment "macos" "aarch64" $ Kernel "Darwin" "23.1.0") route+      `shouldBe` ([Just $ Substitution "HOME"], [])+    dispatch+      ( Environment "windows" "x86_64"+          $ Kernel "Microsoft Windows" "10.0.23585.1001"+      )+      route+      `shouldBe` ([Just $ Substitution "USERPROFILE"], []) -- cSpell:disable-line+    dispatch+      ( Environment "windows" "x86_64"+          $ Kernel "Microsoft Windows" "10.0.23585.1001"+      )+      route+      `shouldBe` ([Just $ Substitution "USERPROFILE"], []) -- cSpell:disable-line+    let withWarnings =+          fileRoute+            monikerMap+            (paths ++ [(moniker "non-existent", Just $ Root Nothing)])+            Directory+    dispatch+      (Environment "linux" "x86_64" $ Kernel "Linux" "5.10.0-8")+      withWarnings+      `shouldBe` ( [Just $ Substitution "HOME"]+                 , [UndefinedMoniker (moniker "non-existent")]+                 )++  specify "routePath" $ do+    routePath+      route+      (Environment "freebsd" "x86_64" $ Kernel "FreeBSD" "13.2-RELEASE-p4")+      (const $ return Nothing)+      `shouldReturn` (Nothing, [])+    routePath+      route+      (Environment "linux" "x86_64" $ Kernel "Linux" "5.10.0-8")+      (const $ return Nothing)+      `shouldReturn` ( Just mempty+                     ,+                       [ FilePathExpressionWarning+                          (UndefinedEnvironmentVariable "HOME")+                       ]+                     )+    home <- encodeFS "/home/hong"+    routePath+      route+      (Environment "linux" "aarch64" $ Kernel "Linux" "5.10.0-8")+      (const $ return $ Just $ home)+      `shouldReturn` (Just home, [])
+ test/Dojang/Types/Gen.hs view
@@ -0,0 +1,410 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Dojang.Types.Gen+  ( architecture+  , ciText+  , fileRoute+  , fileRoute'+  , fileRouteMap+  , emptyMonikerNameText+  , environment+  , environmentPredicate+  , environmentVariable+  , filePathExpression+  , invalidMonikerNameText+  , kernel+  , manifest+  , manifest'+  , monikerMap+  , monikerMap'+  , monikerName+  , monikerNameText+  , monikerNameTextHavingInvalidCharacterWithIndex+  , monikerNameTextStartingWithNonLetter+  , monikerNameWithCIText+  , monikerNameError+  , operatingSystem+  , osPath+  , osString+  , specificity+  ) where++import Data.Char (isAlpha, isAlphaNum, isAscii, isControl, toUpper)+import Data.List (nub)+import System.IO.Unsafe (unsafePerformIO)+import Prelude hiding (lookup)++import Data.CaseInsensitive (CI, mk)+import Data.HashMap.Strict (HashMap, fromList, keys, lookup)+import Data.Map.Strict (empty)+import Data.Text (Text, cons, length, pack)+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range (Range, constant, constantFrom, singleton)+import System.OsPath (OsPath, joinPath)+import System.OsString (OsString, encodeFS)+import Test.Hspec.Hedgehog (MonadGen)++import Dojang.MonadFileSystem (FileType (..))+import Dojang.Types.Environment+  ( Architecture (..)+  , Environment (Environment)+  , Kernel (..)+  , OperatingSystem (..)+  )+import Dojang.Types.EnvironmentPredicate+  ( EnvironmentPredicate (..)+  , normalizePredicate+  )+import Dojang.Types.EnvironmentPredicate.Specificity (Specificity (..))+import Dojang.Types.FilePathExpression+  ( EnvironmentVariable+  , FilePathExpression (..)+  )+import Dojang.Types.FileRoute qualified as FileRoute+import Dojang.Types.FileRouteMap (FileRouteMap)+import Dojang.Types.Manifest (Manifest (..))+import Dojang.Types.MonikerMap (MonikerMap)+import Dojang.Types.MonikerName+  ( MonikerName+  , MonikerNameError (..)+  , parseMonikerName+  )+++ciText :: (MonadGen m) => Range Int -> m Char -> m (CI Text)+ciText range char = mk <$> Gen.text range char+++monikerNameText :: (MonadGen m) => m Text+monikerNameText = do+  firstChar <- Gen.text (constant 1 1) Gen.alpha+  rest <- Gen.text (constantFrom 0 0 256) Gen.alphaNum+  return $ firstChar <> rest+++monikerNameWithCIText :: (MonadGen m) => m (MonikerName, CI Text)+monikerNameWithCIText = do+  name <- monikerNameText+  let Right monikerName' = parseMonikerName name+  return (monikerName', mk name)+++monikerName :: (MonadGen m) => m MonikerName+monikerName = fst <$> monikerNameWithCIText+++invalidMonikerNameText :: (MonadGen m) => m Text+invalidMonikerNameText =+  Gen.choice+    [ emptyMonikerNameText+    , monikerNameTextStartingWithNonLetter+    , fst <$> monikerNameTextHavingInvalidCharacterWithIndex+    ]+++emptyMonikerNameText :: (MonadGen m) => m Text+emptyMonikerNameText = Gen.text (constant 0 0) Gen.unicodeAll+++monikerNameTextStartingWithNonLetter :: (MonadGen m) => m Text+monikerNameTextStartingWithNonLetter = do+  firstChar <- Gen.text (constant 1 1) Gen.digit+  rest <- Gen.text (constantFrom 0 0 256) Gen.unicodeAll+  return $ firstChar <> rest+++monikerNameTextHavingInvalidCharacterWithIndex :: (MonadGen m) => m (Text, Int)+monikerNameTextHavingInvalidCharacterWithIndex = do+  a <- Gen.text (constantFrom 1 1 256) Gen.alpha+  b <-+    Gen.text (constant 1 1)+      $ Gen.filterT (\c -> c /= '-' && c /= '_' && not (isAlphaNum c)) Gen.unicodeAll+  c <- Gen.text (constantFrom 0 0 256) Gen.alphaNum+  return (a <> b <> c, Data.Text.length a)+++monikerNameError :: (MonadGen m) => m MonikerNameError+monikerNameError =+  Gen.choice+    [ return Empty+    , return StartingWithNonLetter+    , HavingInvalidCharacter <$> Gen.integral (constantFrom 0 0 256)+    ]+++operatingSystem :: (MonadGen m) => m OperatingSystem+operatingSystem =+  Gen.choice+    [ return Android+    , return FreeBSD+    , return Linux+    , return MacOS+    , return NetBSD+    , return OpenBSD+    , return Windows+    , OtherOS <$> ciText (constant 0 256) Gen.unicodeAll+    ]+++architecture :: (MonadGen m) => m Architecture+architecture =+  Gen.choice+    [ return AArch64+    , return X86+    , return X86_64+    , Etc <$> ciText (constant 0 256) Gen.unicodeAll+    ]+++kernelName :: (MonadGen m) => m (CI Text)+kernelName = ciText (constant 1 50) Gen.unicodeAll+++kernelRelease :: (MonadGen m) => m (CI Text)+kernelRelease = ciText (constant 1 50) Gen.unicodeAll+++kernel :: (MonadGen m) => m Kernel+kernel = Kernel <$> kernelName <*> kernelRelease+++environment :: (MonadGen m) => m Environment+environment = Environment <$> operatingSystem <*> architecture <*> kernel+++environmentPredicate :: (MonadGen m) => m EnvironmentPredicate+environmentPredicate = environmentPredicate' 5+++environmentPredicate' :: (MonadGen m) => Int -> m EnvironmentPredicate+environmentPredicate' maxDepth =+  Gen.choice+    $ [ return Always+      , Moniker <$> monikerName+      , OperatingSystem <$> operatingSystem+      , Architecture <$> architecture+      , KernelName <$> kernelName+      , KernelRelease <$> kernelRelease+      , KernelReleasePrefix <$> (ciText (constant 0 50) Gen.unicodeAll)+      , KernelReleaseSuffix <$> (ciText (constant 0 50) Gen.unicodeAll)+      ]+    ++ if maxDepth < 1+      then []+      else+        [ Not <$> environmentPredicate' nextMaxDepth+        , And+            <$> Gen.nonEmpty+              (constant 0 nextMaxDepth)+              (environmentPredicate' nextMaxDepth)+        , Or+            <$> Gen.nonEmpty+              (constant 0 nextMaxDepth)+              (environmentPredicate' nextMaxDepth)+        ]+ where+  nextMaxDepth :: Int+  nextMaxDepth = maxDepth - 1+++specificity :: (MonadGen m) => m Specificity+specificity =+  Specificity+    <$> Gen.integral (constantFrom 0 0 8)+    <*> Gen.integral (constantFrom 0 0 8)+++osChar :: (MonadGen m) => m Char+osChar =+  Gen.filterT (not . isControl)+    $ Gen.frequency [(5, Gen.alphaNum), (3, Gen.latin1), (2, Gen.unicode)]+++environmentVariable :: (MonadGen m) => m EnvironmentVariable+environmentVariable =+  Gen.frequency+    [ (8, typicalEnvVar)+    , (2, Gen.text (constantFrom 1 1 256) osChar)+    ]+ where+  typicalEnvVar :: (MonadGen m) => m EnvironmentVariable+  typicalEnvVar = do+    firstChar <- Gen.upper+    rest <-+      Gen.text+        (constantFrom 1 1 50)+        $ Gen.frequency [(8, Gen.upper), (1, Gen.digit), (1, return '_')]+    return $ cons firstChar rest+++filePathExpression :: (MonadGen m) => m FilePathExpression+filePathExpression = filePathExpression' 5+++filePathExpression' :: (MonadGen m) => Int -> m FilePathExpression+filePathExpression' maxDepth =+  Gen.choice+    $ [ bareComponent+      , root+      , substitution+      ]+    ++ if maxDepth > 0+      then+        [ concatenation+        , pathSeparator+        , substitutionWithDefault+        , conditionalSubstitution+        ]+      else []+ where+  filePathExpr :: (MonadGen m) => m FilePathExpression+  filePathExpr = filePathExpression' (maxDepth - 1)+  bareComponent :: (MonadGen m) => m FilePathExpression+  bareComponent =+    BareComponent+      <$> Gen.text+        (constantFrom 1 1 256)+        ( Gen.filterT+            (`notElem` ['/', '\\', '$', '{', '}', ':', '\r', '\n'])+            osChar+        )+  root :: (MonadGen m) => m FilePathExpression+  root = Root . fmap toUpper <$> Gen.maybe Gen.alpha+  concatenation :: (MonadGen m) => m FilePathExpression+  concatenation =+    Gen.filterT+      ( \case+          Concatenation (Concatenation _ _) _ -> False+          Concatenation _ (Concatenation _ _) -> False+          Concatenation (PathSeparator _ _) _ -> False+          Concatenation _ (PathSeparator _ _) -> False+          c@(Concatenation (BareComponent _) b) ->+            not (startsWithBareComponent b) && not (containsRoot c)+          c -> not $ containsRoot c+      )+      $ Concatenation+      <$> filePathExpr+      <*> filePathExpr+  pathSeparator :: (MonadGen m) => m FilePathExpression+  pathSeparator =+    PathSeparator+      <$> filePathExpr+      <*> Gen.filterT+        (\case PathSeparator _ _ -> False; e -> not $ containsRoot e)+        filePathExpr+  envVar :: (MonadGen m) => m EnvironmentVariable+  envVar = do+    first <- Gen.filterT (\c -> isAscii c && isAlpha c || c == '_') osChar+    rest <-+      Gen.text (constantFrom 0 0 256)+        $ Gen.filterT (\c -> isAscii c && isAlphaNum c || c == '_') osChar+    return $ first `cons` rest+  substitution :: (MonadGen m) => m FilePathExpression+  substitution = Substitution <$> envVar+  substitutionWithDefault :: (MonadGen m) => m FilePathExpression+  substitutionWithDefault =+    SubstitutionWithDefault+      <$> envVar+      <*> Gen.filterT (\case Root _ -> False; _ -> True) filePathExpr+  conditionalSubstitution :: (MonadGen m) => m FilePathExpression+  conditionalSubstitution =+    ConditionalSubstitution+      <$> envVar+      <*> Gen.filterT (\case Root _ -> False; _ -> True) filePathExpr+  startsWithBareComponent :: FilePathExpression -> Bool+  startsWithBareComponent (BareComponent _) = True+  startsWithBareComponent (Concatenation a _) = startsWithBareComponent a+  startsWithBareComponent (PathSeparator a _) = startsWithBareComponent a+  startsWithBareComponent _ = False+  containsRoot :: FilePathExpression -> Bool+  containsRoot (Root _) = True+  containsRoot (Concatenation a b) = containsRoot a || containsRoot b+  containsRoot (PathSeparator a b) = containsRoot a || containsRoot b+  containsRoot (SubstitutionWithDefault _ expr) = containsRoot expr+  containsRoot (ConditionalSubstitution _ expr) = containsRoot expr+  containsRoot _ = False+++monikerMap :: (MonadGen m) => m (HashMap MonikerName EnvironmentPredicate)+monikerMap = monikerMap' (constantFrom 0 0 10)+++monikerMap'+  :: (MonadGen m) => Range Int -> m (HashMap MonikerName EnvironmentPredicate)+monikerMap' sizeRange = do+  keys' <- Gen.list sizeRange monikerName+  let cardinality = Prelude.length keys'+  values <-+    Gen.list (constant cardinality cardinality)+      $ normalizePredicate+      <$> environmentPredicate+  return $ fromList $ zip keys' values+++fileRoute :: (MonadGen m) => m FileRoute.FileRoute+fileRoute = do+  mm <- monikerMap' (constant 0 5)+  fileRoute' (constant 0 5) mm environmentPredicate+++fileRoute'+  :: (MonadGen m)+  => Range Int+  -> MonikerMap+  -> m EnvironmentPredicate+  -> m FileRoute.FileRoute+fileRoute' predicatesNumberRange mm predGen = do+  predicates <-+    nub . map normalizePredicate <$> Gen.list predicatesNumberRange predGen+  let cardinality = Prelude.length predicates+  paths <-+    Gen.list (constant cardinality cardinality) $ Gen.maybe filePathExpression+  fileOrDir <- Gen.element [File, Directory]+  return $ FileRoute.fileRoute' (`lookup` mm) (predicates `zip` paths) fileOrDir+++osString :: (MonadGen m) => Range Int -> m Char -> m OsString+osString range = fmap (unsafePerformIO . encodeFS) . Gen.string range+++osPath :: (MonadGen m) => Range Int -> m OsPath+osPath range =+  joinPath+    <$> Gen.list+      range+      ( osString+          (constant 1 100)+          ( Gen.filterT+              (\c -> c `notElem` "/\\:" && not (isControl c))+              Gen.unicode+          )+      )+++fileRouteMap :: (MonadGen m) => Range Int -> MonikerMap -> m FileRouteMap+fileRouteMap range monikers =+  Gen.map range $ do+    key <- osPath (singleton 1)+    value <-+      fileRoute' (constant 0 5) monikers+        $ Gen.choice+        $ map return+        $ fmap Moniker+        $ case keys monikers of+          [] ->+            let Right undefined' = parseMonikerName $ pack "undefined"+            in [undefined']+          names -> names+    return (key, value)+++manifest' :: forall m. (MonadGen m) => Range Int -> Range Int -> m Manifest+manifest' monikerMapRange fileRouteMapRange = do+  monikers <- monikerMap' monikerMapRange+  fileRoutes <- fileRouteMap fileRouteMapRange monikers+  return $ Manifest monikers fileRoutes Data.Map.Strict.empty+++manifest :: (MonadGen m) => m Manifest+manifest = manifest' (constantFrom 0 0 5) (constantFrom 0 0 5)
+ test/Dojang/Types/MonikerNameSpec.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++module Dojang.Types.MonikerNameSpec (spec) where++import Dojang.Types.Gen+  ( emptyMonikerNameText+  , invalidMonikerNameText+  , monikerName+  , monikerNameError+  , monikerNameText+  , monikerNameTextHavingInvalidCharacterWithIndex+  , monikerNameTextStartingWithNonLetter+  , monikerNameWithCIText+  )+import Dojang.Types.MonikerName+  ( MonikerNameError (Empty, HavingInvalidCharacter, StartingWithNonLetter)+  , parseMonikerName+  )++import Data.CaseInsensitive (foldCase, mk)+import Data.Either (isLeft)+import Data.Hashable (Hashable (hashWithSalt))+import Test.Hspec (Spec, describe, specify)+import Test.Hspec.Expectations.Pretty (shouldBe)+import Test.Hspec.Hedgehog+  ( assert+  , forAll+  , hedgehog+  , (===)+  )+++spec :: Spec+spec = do+  describe "parseMonikerName" $ do+    specify "examples" $ do+      let Right a = parseMonikerName "foo-bar"+      a.name `shouldBe` "foo-bar"+      let Right b = parseMonikerName "甲乙_丙丁"+      b.name `shouldBe` "甲乙_丙丁"+      parseMonikerName "" `shouldBe` Left Empty+      parseMonikerName "1" `shouldBe` Left StartingWithNonLetter+      parseMonikerName "*" `shouldBe` Left StartingWithNonLetter+      parseMonikerName "$foo" `shouldBe` Left StartingWithNonLetter+      parseMonikerName "foo\tbar" `shouldBe` Left (HavingInvalidCharacter 3)++    specify "properties" $ hedgehog $ do+      forAll monikerNameText >>= \name ->+        let Right parsed = parseMonikerName name+        in parsed.name === mk name+      forAll invalidMonikerNameText >>= \name ->+        assert $ isLeft $ parseMonikerName name+      forAll emptyMonikerNameText >>= \name ->+        parseMonikerName name === Left Empty+      forAll monikerNameTextStartingWithNonLetter >>= \name ->+        parseMonikerName name === Left StartingWithNonLetter+      forAll monikerNameTextHavingInvalidCharacterWithIndex >>= \(name, idx) ->+        parseMonikerName name === Left (HavingInvalidCharacter idx)++  describe "MonikerName" $ do+    specify "Eq" $ hedgehog $ do+      name <- forAll monikerName+      name' <- forAll monikerName+      (name == name') === (foldCase name.name == foldCase name'.name)+      (name /= name') === (foldCase name.name /= foldCase name'.name)++    specify "Ord" $ hedgehog $ do+      name <- forAll monikerName+      name' <- forAll monikerName+      let foldedName = foldCase name.name+      let foldedName' = foldCase name'.name+      name `compare` name' === foldedName `compare` foldedName'+      (name < name') === (foldedName < foldedName')+      (name <= name') === (foldedName <= foldedName')+      (name > name') === (foldedName > foldedName')+      (name >= name') === (foldedName >= foldedName')+      (min name name').name === min foldedName foldedName'+      (max name name').name === max foldedName foldedName'++    specify "Hashable" $ hedgehog $ do+      (name, nameText) <- forAll monikerNameWithCIText+      hashWithSalt 0 name === hashWithSalt 0 (foldCase nameText)++    specify "HasField \"name\"" $ hedgehog $ do+      (name, nameText) <- forAll monikerNameWithCIText+      name.name === nameText++    specify "Show" $ hedgehog $ do+      (name, nameText) <- forAll monikerNameWithCIText+      show name === "MonikerName " ++ show nameText+      shows name "" === "MonikerName " ++ shows nameText ""+      showList [name] "" === "[MonikerName " ++ show nameText ++ "]"++  describe "MonikerNameError" $ do+    specify "Eq" $ hedgehog $ do+      e <- forAll monikerNameError+      e' <- forAll monikerNameError+      (e == e') === (show e == show e')+      (e /= e') === (show e /= show e')++    specify "Show" $ hedgehog $ do+      e <- forAll monikerNameError+      read (show e) === e+      read (shows e "") === e+      read (showList [e] "") === [e]
+ test/Dojang/Types/RepositorySpec.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}++module Dojang.Types.RepositorySpec (spec) where++import System.Info (os)++import System.OsPath (encodeFS, (</>))+import Test.Hspec (Spec, runIO, specify)+import Test.Hspec.Expectations.Pretty+  ( shouldBe+  , shouldNotSatisfy+  , shouldReturn+  , shouldSatisfy+  )++import Dojang.MonadFileSystem (FileType (..))+import Dojang.Types.Environment (Environment (..), Kernel (..))+import Dojang.Types.EnvironmentPredicate (EnvironmentPredicate (Always))+import Dojang.Types.FileRoute (fileRoute)+import Dojang.Types.Manifest (Manifest (..))+import Dojang.Types.MonikerMap (MonikerMap)+import Dojang.Types.MonikerName (parseMonikerName)+import Dojang.Types.Repository+  ( Repository (..)+  , RouteMapWarning (OverlapDestinationPathsWarning)+  , RouteResult (..)+  , findOverlappingRouteResults+  , overlaps+  , routePaths+  )+++win :: Bool+win = os == "mingw32"+++spec :: Spec+spec = do+  root <- runIO $ encodeFS $ if win then "C:\\" else "/"+  foo <- runIO $ encodeFS "foo"+  bar <- runIO $ encodeFS "bar"+  baz <- runIO $ encodeFS "baz"+  qux <- runIO $ encodeFS "qux"+  src <- runIO $ encodeFS "src"+  dst <- runIO $ encodeFS "dst"+  inter <- runIO $ encodeFS ".dojang"++  specify "routePaths" $ do+    let Right any' = parseMonikerName "any"+    let monikers = [(any', Always)] :: MonikerMap+    let dirRoute expr = fileRoute monikers [(any', Just expr)] Directory+    let manifest =+          Manifest+            { monikers = monikers+            , fileRoutes =+                [ (foo, dirRoute $ if win then "C:\\dst\\foo" else "/dst/foo")+                ,+                  ( bar+                  , dirRoute+                      $ if win then "C:\\dst\\foo\\bar" else "/dst/foo/bar"+                  )+                ,+                  ( baz+                  , dirRoute+                      $ if win+                        then "C:\\dst\\foo\\bar\\baz"+                        else "/dst/foo/bar/baz"+                  )+                ,+                  ( qux+                  , dirRoute+                      $ if win then "C:\\dst\\foo\\qux" else "/dst/foo/qux"+                  )+                ]+            , ignorePatterns =+                [ (foo, ["bar"])+                ]+            }+    let repo =+          Repository+            { sourcePath = root </> src+            , intermediatePath = root </> src </> inter+            , manifest = manifest+            }+    let env = Environment "linux" "x86_64" $ Kernel "Linux" "4.19.0-16-amd64"+    routePaths repo env (const $ return Nothing)+      `shouldReturn` (+                       [ RouteResult+                          (root </> src </> bar)+                          bar+                          (root </> dst </> foo </> bar)+                          Directory+                       , RouteResult+                          (root </> src </> baz)+                          baz+                          (root </> dst </> foo </> bar </> baz)+                          Directory+                       , RouteResult+                          (root </> src </> foo)+                          foo+                          (root </> dst </> foo)+                          Directory+                       , RouteResult+                          (root </> src </> qux)+                          qux+                          (root </> dst </> foo </> qux)+                          Directory+                       ]+                     ,+                       [ OverlapDestinationPathsWarning+                          bar+                          (root </> dst </> foo </> bar)+                          [(baz, root </> dst </> foo </> bar </> baz)]+                       , OverlapDestinationPathsWarning+                          foo+                          (root </> dst </> foo)+                          [(qux, root </> dst </> foo </> qux)]+                       ]+                     )++  specify "findOverlappingRouteResults" $ do+    findOverlappingRouteResults+      [ RouteResult (root </> src </> foo) foo (root </> foo) Directory+      , RouteResult (root </> src </> bar) bar (root </> bar) Directory+      , RouteResult (root </> src </> baz) baz (root </> foo </> baz) Directory+      , RouteResult+          (root </> src </> qux)+          qux+          (root </> foo </> baz </> qux)+          File+      ]+      `shouldBe` [+                   ( (baz, root </> foo </> baz)+                   , [(qux, root </> foo </> baz </> qux)]+                   )+                 ,+                   ( (foo, root </> foo)+                   ,+                     [ (baz, root </> foo </> baz)+                     , (qux, root </> foo </> baz </> qux)+                     ]+                   )+                 ]++  specify "overlaps" $ do+    foo `shouldSatisfy` overlaps foo+    foo `shouldSatisfy` (`overlaps` (foo </> bar))+    foo `shouldSatisfy` (`overlaps` (foo </> bar </> baz))+    foo `shouldNotSatisfy` (`overlaps` bar)+    foo `shouldNotSatisfy` (`overlaps` (bar </> foo))+    (foo </> bar) `shouldNotSatisfy` (`overlaps` foo)+    (foo </> bar) `shouldSatisfy` (`overlaps` (foo </> bar))+    (foo </> bar) `shouldSatisfy` (`overlaps` (foo </> bar </> baz))+    (foo </> bar) `shouldNotSatisfy` (`overlaps` (foo </> baz))
+ test/Main.hs view
@@ -0,0 +1,13 @@+module Main where++import qualified Spec++import Test.Hspec.Formatters (specdoc)+import Test.Hspec.JUnit (hspecJUnitWith)+import Test.Hspec.Runner (configFormatter, defaultConfig)+++main :: IO ()+main = hspecJUnitWith defaultConfig{configFormatter = Just specdoc} Spec.spec++-- cSpell:ignore specdoc
+ test/Spec.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}+
+ test/SpecHook.hs view
@@ -0,0 +1,7 @@+module SpecHook where++import Test.Hspec (Spec, parallel)+++hook :: Spec -> Spec+hook = parallel